]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/dump-parse-tree.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
re PR fortran/32669 ("Actual argument contains too few elements for dummy argument...
[thirdparty/gcc.git] / gcc / fortran / dump-parse-tree.c
CommitLineData
6de9cd9a 1/* Parse tree dumper
636dff67
SK		 2 Copyright (C) 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
6de9cd9a
DN		 4 Contributed by Steven Bosscher
5
9fc4d79b 6This file is part of GCC.
6de9cd9a 7
9fc4d79b
TS		 8GCC is free software; you can redistribute it and/or modify it under
9the terms of the GNU General Public License as published by the Free
10Software Foundation; either version 2, or (at your option) any later
11version.
6de9cd9a 12
9fc4d79b
TS		 13GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14WARRANTY; without even the implied warranty of MERCHANTABILITY or
15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16for more details.
6de9cd9a
DN		 17
18You should have received a copy of the GNU General Public License
9fc4d79b 19along with GCC; see the file COPYING. If not, write to the Free
ab57747b
KC		 20Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
2102110-1301, USA. */
6de9cd9a
DN		 22
23
24/* Actually this is just a collection of routines that used to be
25 scattered around the sources. Now that they are all in a single
26 file, almost all of them can be static, and the other files don't
27 have this mess in them.
28
29 As a nice side-effect, this file can act as documentation of the
30 gfc_code and gfc_expr structures and all their friends and
31 relatives.
32
33 TODO: Dump DATA. */
34
35#include "config.h"
36#include "gfortran.h"
37
38/* Keep track of indentation for symbol tree dumps. */
39static int show_level = 0;
40
6de9cd9a
DN		 41/* Do indentation for a specific level. */
42
43static inline void
636dff67 44code_indent (int level, gfc_st_label *label)
6de9cd9a
DN		 45{
46 int i;
47
48 if (label != NULL)
49 gfc_status ("%-5d ", label->value);
50 else
51 gfc_status (" ");
52
53 for (i = 0; i < 2 * level; i++)
54 gfc_status_char (' ');
55}
56
57
58/* Simple indentation at the current level. This one
59 is used to show symbols. */
30c05595 60
6de9cd9a
DN		 61static inline void
62show_indent (void)
63{
64 gfc_status ("\n");
65 code_indent (show_level, NULL);
66}
67
68
69/* Show type-specific information. */
30c05595 70
c4632147 71void
636dff67 72gfc_show_typespec (gfc_typespec *ts)
6de9cd9a 73{
6de9cd9a
DN		 74 gfc_status ("(%s ", gfc_basic_typename (ts->type));
75
76 switch (ts->type)
77 {
78 case BT_DERIVED:
79 gfc_status ("%s", ts->derived->name);
80 break;
81
82 case BT_CHARACTER:
83 gfc_show_expr (ts->cl->length);
84 break;
85
86 default:
87 gfc_status ("%d", ts->kind);
88 break;
89 }
90
91 gfc_status (")");
92}
93
94
95/* Show an actual argument list. */
96
c4632147 97void
636dff67 98gfc_show_actual_arglist (gfc_actual_arglist *a)
6de9cd9a 99{
6de9cd9a
DN		 100 gfc_status ("(");
101
102 for (; a; a = a->next)
103 {
104 gfc_status_char ('(');
cb9e4f55 105 if (a->name != NULL)
6de9cd9a
DN		 106 gfc_status ("%s = ", a->name);
107 if (a->expr != NULL)
108 gfc_show_expr (a->expr);
109 else
110 gfc_status ("(arg not-present)");
111
112 gfc_status_char (')');
113 if (a->next != NULL)
114 gfc_status (" ");
115 }
116
117 gfc_status (")");
118}
119
120
49de9e73 121/* Show a gfc_array_spec array specification structure. */
6de9cd9a 122
c4632147 123void
636dff67 124gfc_show_array_spec (gfc_array_spec *as)
6de9cd9a
DN		 125{
126 const char *c;
127 int i;
128
129 if (as == NULL)
130 {
131 gfc_status ("()");
132 return;
133 }
134
135 gfc_status ("(%d", as->rank);
136
137 if (as->rank != 0)
138 {
139 switch (as->type)
140 {
141 case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
142 case AS_DEFERRED: c = "AS_DEFERRED"; break;
143 case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
144 case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
145 default:
636dff67
SK		 146 gfc_internal_error ("gfc_show_array_spec(): Unhandled array shape "
147 "type.");
6de9cd9a
DN		 148 }
149 gfc_status (" %s ", c);
150
151 for (i = 0; i < as->rank; i++)
152 {
153 gfc_show_expr (as->lower[i]);
154 gfc_status_char (' ');
155 gfc_show_expr (as->upper[i]);
156 gfc_status_char (' ');
157 }
158 }
159
160 gfc_status (")");
161}
162
163
49de9e73 164/* Show a gfc_array_ref array reference structure. */
6de9cd9a 165
c4632147 166void
6de9cd9a
DN		 167gfc_show_array_ref (gfc_array_ref * ar)
168{
169 int i;
170
171 gfc_status_char ('(');
172
173 switch (ar->type)
174 {
175 case AR_FULL:
176 gfc_status ("FULL");
177 break;
178
179 case AR_SECTION:
180 for (i = 0; i < ar->dimen; i++)
181 {
fb89e8bd
TS		 182 /* There are two types of array sections: either the
183 elements are identified by an integer array ('vector'),
184 or by an index range. In the former case we only have to
185 print the start expression which contains the vector, in
186 the latter case we have to print any of lower and upper
187 bound and the stride, if they're present. */
188
6de9cd9a
DN		 189 if (ar->start[i] != NULL)
190 gfc_show_expr (ar->start[i]);
191
fb89e8bd 192 if (ar->dimen_type[i] == DIMEN_RANGE)
6de9cd9a
DN		 193 {
194 gfc_status_char (':');
fb89e8bd
TS		 195
196 if (ar->end[i] != NULL)
197 gfc_show_expr (ar->end[i]);
198
199 if (ar->stride[i] != NULL)
200 {
201 gfc_status_char (':');
202 gfc_show_expr (ar->stride[i]);
203 }
6de9cd9a
DN		 204 }
205
206 if (i != ar->dimen - 1)
207 gfc_status (" , ");
208 }
209 break;
210
211 case AR_ELEMENT:
212 for (i = 0; i < ar->dimen; i++)
213 {
214 gfc_show_expr (ar->start[i]);
215 if (i != ar->dimen - 1)
216 gfc_status (" , ");
217 }
218 break;
219
220 case AR_UNKNOWN:
221 gfc_status ("UNKNOWN");
222 break;
223
224 default:
225 gfc_internal_error ("gfc_show_array_ref(): Unknown array reference");
226 }
227
228 gfc_status_char (')');
229}
230
231
232/* Show a list of gfc_ref structures. */
233
c4632147 234void
636dff67 235gfc_show_ref (gfc_ref *p)
6de9cd9a 236{
6de9cd9a
DN		 237 for (; p; p = p->next)
238 switch (p->type)
239 {
240 case REF_ARRAY:
241 gfc_show_array_ref (&p->u.ar);
242 break;
243
244 case REF_COMPONENT:
245 gfc_status (" %% %s", p->u.c.component->name);
246 break;
247
248 case REF_SUBSTRING:
249 gfc_status_char ('(');
250 gfc_show_expr (p->u.ss.start);
251 gfc_status_char (':');
252 gfc_show_expr (p->u.ss.end);
253 gfc_status_char (')');
254 break;
255
256 default:
257 gfc_internal_error ("gfc_show_ref(): Bad component code");
258 }
259}
260
261
262/* Display a constructor. Works recursively for array constructors. */
263
c4632147 264void
636dff67 265gfc_show_constructor (gfc_constructor *c)
6de9cd9a 266{
6de9cd9a
DN		 267 for (; c; c = c->next)
268 {
269 if (c->iterator == NULL)
270 gfc_show_expr (c->expr);
271 else
272 {
273 gfc_status_char ('(');
274 gfc_show_expr (c->expr);
275
276 gfc_status_char (' ');
277 gfc_show_expr (c->iterator->var);
278 gfc_status_char ('=');
279 gfc_show_expr (c->iterator->start);
280 gfc_status_char (',');
281 gfc_show_expr (c->iterator->end);
282 gfc_status_char (',');
283 gfc_show_expr (c->iterator->step);
284
285 gfc_status_char (')');
286 }
287
288 if (c->next != NULL)
289 gfc_status (" , ");
290 }
291}
292
293
294/* Show an expression. */
295
c4632147 296void
636dff67 297gfc_show_expr (gfc_expr *p)
6de9cd9a
DN		 298{
299 const char *c;
300 int i;
301
302 if (p == NULL)
303 {
304 gfc_status ("()");
305 return;
306 }
307
308 switch (p->expr_type)
309 {
310 case EXPR_SUBSTRING:
311 c = p->value.character.string;
312
313 for (i = 0; i < p->value.character.length; i++, c++)
314 {
315 if (*c == '\'')
316 gfc_status ("''");
317 else
318 gfc_status ("%c", *c);
319 }
320
321 gfc_show_ref (p->ref);
322 break;
323
324 case EXPR_STRUCTURE:
325 gfc_status ("%s(", p->ts.derived->name);
326 gfc_show_constructor (p->value.constructor);
327 gfc_status_char (')');
328 break;
329
330 case EXPR_ARRAY:
331 gfc_status ("(/ ");
332 gfc_show_constructor (p->value.constructor);
333 gfc_status (" /)");
334
335 gfc_show_ref (p->ref);
336 break;
337
338 case EXPR_NULL:
339 gfc_status ("NULL()");
340 break;
341
342 case EXPR_CONSTANT:
343 switch (p->ts.type)
344 {
345 case BT_INTEGER:
346 mpz_out_str (stdout, 10, p->value.integer);
347
9d64df18 348 if (p->ts.kind != gfc_default_integer_kind)
6de9cd9a
DN		 349 gfc_status ("_%d", p->ts.kind);
350 break;
351
352 case BT_LOGICAL:
353 if (p->value.logical)
354 gfc_status (".true.");
355 else
356 gfc_status (".false.");
357 break;
358
359 case BT_REAL:
f8e566e5 360 mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
9d64df18 361 if (p->ts.kind != gfc_default_real_kind)
6de9cd9a
DN		 362 gfc_status ("_%d", p->ts.kind);
363 break;
364
365 case BT_CHARACTER:
366 c = p->value.character.string;
367
368 gfc_status_char ('\'');
369
370 for (i = 0; i < p->value.character.length; i++, c++)
371 {
372 if (*c == '\'')
373 gfc_status ("''");
374 else
375 gfc_status_char (*c);
376 }
377
378 gfc_status_char ('\'');
379
380 break;
381
382 case BT_COMPLEX:
383 gfc_status ("(complex ");
384
f8e566e5 385 mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
9d64df18 386 if (p->ts.kind != gfc_default_complex_kind)
6de9cd9a
DN		 387 gfc_status ("_%d", p->ts.kind);
388
389 gfc_status (" ");
390
f8e566e5 391 mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE);
9d64df18 392 if (p->ts.kind != gfc_default_complex_kind)
6de9cd9a
DN		 393 gfc_status ("_%d", p->ts.kind);
394
395 gfc_status (")");
396 break;
397
20585ad6
BM		 398 case BT_HOLLERITH:
399 gfc_status ("%dH", p->representation.length);
400 c = p->representation.string;
401 for (i = 0; i < p->representation.length; i++, c++)
402 {
403 gfc_status_char (*c);
404 }
405 break;
406
6de9cd9a
DN		 407 default:
408 gfc_status ("???");
409 break;
410 }
411
20585ad6
BM		 412 if (p->representation.string)
413 {
414 gfc_status (" {");
415 c = p->representation.string;
416 for (i = 0; i < p->representation.length; i++, c++)
417 {
418 gfc_status ("%.2x", (unsigned int) *c);
419 if (i < p->representation.length - 1)
420 gfc_status_char (',');
421 }
422 gfc_status_char ('}');
423 }
424
6de9cd9a
DN		 425 break;
426
427 case EXPR_VARIABLE:
9439ae41
TS		 428 if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
429 gfc_status ("%s:", p->symtree->n.sym->ns->proc_name->name);
6de9cd9a
DN		 430 gfc_status ("%s", p->symtree->n.sym->name);
431 gfc_show_ref (p->ref);
432 break;
433
434 case EXPR_OP:
435 gfc_status ("(");
58b03ab2 436 switch (p->value.op.operator)
6de9cd9a
DN		 437 {
438 case INTRINSIC_UPLUS:
439 gfc_status ("U+ ");
440 break;
441 case INTRINSIC_UMINUS:
442 gfc_status ("U- ");
443 break;
444 case INTRINSIC_PLUS:
445 gfc_status ("+ ");
446 break;
447 case INTRINSIC_MINUS:
448 gfc_status ("- ");
449 break;
450 case INTRINSIC_TIMES:
451 gfc_status ("* ");
452 break;
453 case INTRINSIC_DIVIDE:
454 gfc_status ("/ ");
455 break;
456 case INTRINSIC_POWER:
457 gfc_status ("** ");
458 break;
459 case INTRINSIC_CONCAT:
460 gfc_status ("// ");
461 break;
462 case INTRINSIC_AND:
463 gfc_status ("AND ");
464 break;
465 case INTRINSIC_OR:
466 gfc_status ("OR ");
467 break;
468 case INTRINSIC_EQV:
469 gfc_status ("EQV ");
470 break;
471 case INTRINSIC_NEQV:
472 gfc_status ("NEQV ");
473 break;
474 case INTRINSIC_EQ:
475 gfc_status ("= ");
476 break;
477 case INTRINSIC_NE:
478 gfc_status ("<> ");
479 break;
480 case INTRINSIC_GT:
481 gfc_status ("> ");
482 break;
483 case INTRINSIC_GE:
484 gfc_status (">= ");
485 break;
486 case INTRINSIC_LT:
487 gfc_status ("< ");
488 break;
489 case INTRINSIC_LE:
490 gfc_status ("<= ");
491 break;
492 case INTRINSIC_NOT:
493 gfc_status ("NOT ");
494 break;
2414e1d6
TS		 495 case INTRINSIC_PARENTHESES:
496 gfc_status ("parens");
497 break;
6de9cd9a
DN		 498
499 default:
500 gfc_internal_error
501 ("gfc_show_expr(): Bad intrinsic in expression!");
502 }
503
58b03ab2 504 gfc_show_expr (p->value.op.op1);
6de9cd9a 505
58b03ab2 506 if (p->value.op.op2)
6de9cd9a
DN		 507 {
508 gfc_status (" ");
58b03ab2 509 gfc_show_expr (p->value.op.op2);
6de9cd9a
DN		 510 }
511
512 gfc_status (")");
513 break;
514
515 case EXPR_FUNCTION:
516 if (p->value.function.name == NULL)
517 {
518 gfc_status ("%s[", p->symtree->n.sym->name);
519 gfc_show_actual_arglist (p->value.function.actual);
520 gfc_status_char (']');
521 }
522 else
523 {
524 gfc_status ("%s[[", p->value.function.name);
525 gfc_show_actual_arglist (p->value.function.actual);
526 gfc_status_char (']');
527 gfc_status_char (']');
528 }
529
530 break;
531
532 default:
533 gfc_internal_error ("gfc_show_expr(): Don't know how to show expr");
534 }
535}
536
537
538/* Show symbol attributes. The flavor and intent are followed by
539 whatever single bit attributes are present. */
540
c4632147 541void
636dff67 542gfc_show_attr (symbol_attribute *attr)
6de9cd9a
DN		 543{
544
ef7236d2 545 gfc_status ("(%s %s %s %s %s", gfc_code2string (flavors, attr->flavor),
6de9cd9a
DN		 546 gfc_intent_string (attr->intent),
547 gfc_code2string (access_types, attr->access),
ef7236d2
DF		 548 gfc_code2string (procedures, attr->proc),
549 gfc_code2string (save_status, attr->save));
6de9cd9a
DN		 550
551 if (attr->allocatable)
552 gfc_status (" ALLOCATABLE");
553 if (attr->dimension)
554 gfc_status (" DIMENSION");
555 if (attr->external)
556 gfc_status (" EXTERNAL");
557 if (attr->intrinsic)
558 gfc_status (" INTRINSIC");
559 if (attr->optional)
560 gfc_status (" OPTIONAL");
561 if (attr->pointer)
562 gfc_status (" POINTER");
ee7e677f
TB		 563 if (attr->protected)
564 gfc_status (" PROTECTED");
06469efd
PT		 565 if (attr->value)
566 gfc_status (" VALUE");
775e6c3a
TB		 567 if (attr->volatile_)
568 gfc_status (" VOLATILE");
6c7a4dfd
JJ		 569 if (attr->threadprivate)
570 gfc_status (" THREADPRIVATE");
6de9cd9a
DN		 571 if (attr->target)
572 gfc_status (" TARGET");
573 if (attr->dummy)
574 gfc_status (" DUMMY");
6de9cd9a
DN		 575 if (attr->result)
576 gfc_status (" RESULT");
577 if (attr->entry)
578 gfc_status (" ENTRY");
579
580 if (attr->data)
581 gfc_status (" DATA");
582 if (attr->use_assoc)
583 gfc_status (" USE-ASSOC");
584 if (attr->in_namelist)
585 gfc_status (" IN-NAMELIST");
586 if (attr->in_common)
587 gfc_status (" IN-COMMON");
6de9cd9a
DN		 588
589 if (attr->function)
590 gfc_status (" FUNCTION");
591 if (attr->subroutine)
592 gfc_status (" SUBROUTINE");
593 if (attr->implicit_type)
594 gfc_status (" IMPLICIT-TYPE");
595
596 if (attr->sequence)
597 gfc_status (" SEQUENCE");
598 if (attr->elemental)
599 gfc_status (" ELEMENTAL");
600 if (attr->pure)
601 gfc_status (" PURE");
602 if (attr->recursive)
603 gfc_status (" RECURSIVE");
604
605 gfc_status (")");
606}
607
608
609/* Show components of a derived type. */
610
c4632147 611void
636dff67 612gfc_show_components (gfc_symbol *sym)
6de9cd9a
DN		 613{
614 gfc_component *c;
615
616 for (c = sym->components; c; c = c->next)
617 {
618 gfc_status ("(%s ", c->name);
619 gfc_show_typespec (&c->ts);
620 if (c->pointer)
621 gfc_status (" POINTER");
622 if (c->dimension)
623 gfc_status (" DIMENSION");
624 gfc_status_char (' ');
625 gfc_show_array_spec (c->as);
2eae3dc7
TB		 626 if (c->access)
627 gfc_status (" %s", gfc_code2string (access_types, c->access));
6de9cd9a
DN		 628 gfc_status (")");
629 if (c->next != NULL)
630 gfc_status_char (' ');
631 }
632}
633
634
635/* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
636 show the interface. Information needed to reconstruct the list of
637 specific interfaces associated with a generic symbol is done within
638 that symbol. */
639
c4632147 640void
636dff67 641gfc_show_symbol (gfc_symbol *sym)
6de9cd9a
DN		 642{
643 gfc_formal_arglist *formal;
644 gfc_interface *intr;
6de9cd9a
DN		 645
646 if (sym == NULL)
647 return;
648
649 show_indent ();
650
651 gfc_status ("symbol %s ", sym->name);
652 gfc_show_typespec (&sym->ts);
653 gfc_show_attr (&sym->attr);
654
655 if (sym->value)
656 {
657 show_indent ();
658 gfc_status ("value: ");
659 gfc_show_expr (sym->value);
660 }
661
662 if (sym->as)
663 {
664 show_indent ();
665 gfc_status ("Array spec:");
666 gfc_show_array_spec (sym->as);
667 }
668
669 if (sym->generic)
670 {
671 show_indent ();
672 gfc_status ("Generic interfaces:");
673 for (intr = sym->generic; intr; intr = intr->next)
674 gfc_status (" %s", intr->sym->name);
675 }
676
6de9cd9a
DN		 677 if (sym->result)
678 {
679 show_indent ();
680 gfc_status ("result: %s", sym->result->name);
681 }
682
683 if (sym->components)
684 {
685 show_indent ();
686 gfc_status ("components: ");
687 gfc_show_components (sym);
688 }
689
690 if (sym->formal)
691 {
692 show_indent ();
693 gfc_status ("Formal arglist:");
694
695 for (formal = sym->formal; formal; formal = formal->next)
636dff67
SK		 696 {
697 if (formal->sym != NULL)
698 gfc_status (" %s", formal->sym->name);
699 else
700 gfc_status (" [Alt Return]");
701 }
6de9cd9a
DN		 702 }
703
704 if (sym->formal_ns)
705 {
706 show_indent ();
707 gfc_status ("Formal namespace");
708 gfc_show_namespace (sym->formal_ns);
709 }
710
711 gfc_status_char ('\n');
712}
713
714
715/* Show a user-defined operator. Just prints an operator
716 and the name of the associated subroutine, really. */
30c05595 717
6de9cd9a 718static void
636dff67 719show_uop (gfc_user_op *uop)
6de9cd9a
DN		 720{
721 gfc_interface *intr;
722
723 show_indent ();
724 gfc_status ("%s:", uop->name);
725
726 for (intr = uop->operator; intr; intr = intr->next)
727 gfc_status (" %s", intr->sym->name);
728}
729
730
731/* Workhorse function for traversing the user operator symtree. */
732
733static void
636dff67 734traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
6de9cd9a 735{
6de9cd9a
DN		 736 if (st == NULL)
737 return;
738
739 (*func) (st->n.uop);
740
741 traverse_uop (st->left, func);
742 traverse_uop (st->right, func);
743}
744
745
746/* Traverse the tree of user operator nodes. */
747
748void
636dff67 749gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
6de9cd9a 750{
6de9cd9a
DN		 751 traverse_uop (ns->uop_root, func);
752}
753
754
fbc9b453
TS		 755/* Function to display a common block. */
756
757static void
636dff67 758show_common (gfc_symtree *st)
fbc9b453
TS		 759{
760 gfc_symbol *s;
761
762 show_indent ();
763 gfc_status ("common: /%s/ ", st->name);
764
765 s = st->n.common->head;
766 while (s)
767 {
768 gfc_status ("%s", s->name);
769 s = s->common_next;
770 if (s)
771 gfc_status (", ");
772 }
773 gfc_status_char ('\n');
774}
775
30c05595 776
6de9cd9a
DN		 777/* Worker function to display the symbol tree. */
778
779static void
636dff67 780show_symtree (gfc_symtree *st)
6de9cd9a 781{
6de9cd9a
DN		 782 show_indent ();
783 gfc_status ("symtree: %s Ambig %d", st->name, st->ambiguous);
784
785 if (st->n.sym->ns != gfc_current_ns)
2e71c2a0 786 gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
6de9cd9a
DN		 787 else
788 gfc_show_symbol (st->n.sym);
789}
790
791
792/******************* Show gfc_code structures **************/
793
794
795
636dff67 796static void gfc_show_code_node (int, gfc_code *);
6de9cd9a
DN		 797
798/* Show a list of code structures. Mutually recursive with
799 gfc_show_code_node(). */
800
c4632147 801void
636dff67 802gfc_show_code (int level, gfc_code *c)
6de9cd9a 803{
6de9cd9a
DN		 804 for (; c; c = c->next)
805 gfc_show_code_node (level, c);
806}
807
c4632147 808void
6c7a4dfd
JJ		 809gfc_show_namelist (gfc_namelist *n)
810{
811 for (; n->next; n = n->next)
812 gfc_status ("%s,", n->sym->name);
813 gfc_status ("%s", n->sym->name);
814}
815
816/* Show a single OpenMP directive node and everything underneath it
817 if necessary. */
818
819static void
636dff67 820gfc_show_omp_node (int level, gfc_code *c)
6c7a4dfd
JJ		 821{
822 gfc_omp_clauses *omp_clauses = NULL;
823 const char *name = NULL;
824
825 switch (c->op)
826 {
827 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
828 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
829 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
830 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
831 case EXEC_OMP_DO: name = "DO"; break;
832 case EXEC_OMP_MASTER: name = "MASTER"; break;
833 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
834 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
835 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
836 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
837 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
838 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
839 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
840 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
841 default:
842 gcc_unreachable ();
843 }
844 gfc_status ("!$OMP %s", name);
845 switch (c->op)
846 {
847 case EXEC_OMP_DO:
848 case EXEC_OMP_PARALLEL:
849 case EXEC_OMP_PARALLEL_DO:
850 case EXEC_OMP_PARALLEL_SECTIONS:
851 case EXEC_OMP_SECTIONS:
852 case EXEC_OMP_SINGLE:
853 case EXEC_OMP_WORKSHARE:
854 case EXEC_OMP_PARALLEL_WORKSHARE:
855 omp_clauses = c->ext.omp_clauses;
856 break;
857 case EXEC_OMP_CRITICAL:
858 if (c->ext.omp_name)
859 gfc_status (" (%s)", c->ext.omp_name);
860 break;
861 case EXEC_OMP_FLUSH:
862 if (c->ext.omp_namelist)
863 {
864 gfc_status (" (");
865 gfc_show_namelist (c->ext.omp_namelist);
866 gfc_status_char (')');
867 }
868 return;
869 case EXEC_OMP_BARRIER:
870 return;
871 default:
872 break;
873 }
874 if (omp_clauses)
875 {
876 int list_type;
877
878 if (omp_clauses->if_expr)
879 {
880 gfc_status (" IF(");
881 gfc_show_expr (omp_clauses->if_expr);
882 gfc_status_char (')');
883 }
884 if (omp_clauses->num_threads)
885 {
886 gfc_status (" NUM_THREADS(");
887 gfc_show_expr (omp_clauses->num_threads);
888 gfc_status_char (')');
889 }
890 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
891 {
892 const char *type;
893 switch (omp_clauses->sched_kind)
894 {
895 case OMP_SCHED_STATIC: type = "STATIC"; break;
896 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
897 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
898 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
899 default:
900 gcc_unreachable ();
901 }
902 gfc_status (" SCHEDULE (%s", type);
903 if (omp_clauses->chunk_size)
904 {
905 gfc_status_char (',');
906 gfc_show_expr (omp_clauses->chunk_size);
907 }
908 gfc_status_char (')');
909 }
910 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
911 {
912 const char *type;
913 switch (omp_clauses->default_sharing)
914 {
915 case OMP_DEFAULT_NONE: type = "NONE"; break;
916 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
917 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
918 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
919 default:
920 gcc_unreachable ();
921 }
922 gfc_status (" DEFAULT(%s)", type);
923 }
924 if (omp_clauses->ordered)
925 gfc_status (" ORDERED");
926 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
927 if (omp_clauses->lists[list_type] != NULL
928 && list_type != OMP_LIST_COPYPRIVATE)
929 {
930 const char *type;
931 if (list_type >= OMP_LIST_REDUCTION_FIRST)
932 {
933 switch (list_type)
934 {
935 case OMP_LIST_PLUS: type = "+"; break;
936 case OMP_LIST_MULT: type = "*"; break;
937 case OMP_LIST_SUB: type = "-"; break;
938 case OMP_LIST_AND: type = ".AND."; break;
939 case OMP_LIST_OR: type = ".OR."; break;
940 case OMP_LIST_EQV: type = ".EQV."; break;
941 case OMP_LIST_NEQV: type = ".NEQV."; break;
942 case OMP_LIST_MAX: type = "MAX"; break;
943 case OMP_LIST_MIN: type = "MIN"; break;
944 case OMP_LIST_IAND: type = "IAND"; break;
945 case OMP_LIST_IOR: type = "IOR"; break;
946 case OMP_LIST_IEOR: type = "IEOR"; break;
947 default:
948 gcc_unreachable ();
949 }
950 gfc_status (" REDUCTION(%s:", type);
951 }
952 else
953 {
954 switch (list_type)
955 {
956 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
957 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
958 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
959 case OMP_LIST_SHARED: type = "SHARED"; break;
960 case OMP_LIST_COPYIN: type = "COPYIN"; break;
961 default:
962 gcc_unreachable ();
963 }
964 gfc_status (" %s(", type);
965 }
966 gfc_show_namelist (omp_clauses->lists[list_type]);
967 gfc_status_char (')');
968 }
969 }
970 gfc_status_char ('\n');
971 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
972 {
973 gfc_code *d = c->block;
974 while (d != NULL)
975 {
976 gfc_show_code (level + 1, d->next);
977 if (d->block == NULL)
978 break;
979 code_indent (level, 0);
980 gfc_status ("!$OMP SECTION\n");
981 d = d->block;
982 }
983 }
984 else
985 gfc_show_code (level + 1, c->block->next);
986 if (c->op == EXEC_OMP_ATOMIC)
987 return;
988 code_indent (level, 0);
989 gfc_status ("!$OMP END %s", name);
990 if (omp_clauses != NULL)
991 {
992 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
993 {
994 gfc_status (" COPYPRIVATE(");
995 gfc_show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
996 gfc_status_char (')');
997 }
998 else if (omp_clauses->nowait)
999 gfc_status (" NOWAIT");
1000 }
1001 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1002 gfc_status (" (%s)", c->ext.omp_name);
1003}
6de9cd9a 1004
636dff67 1005
6de9cd9a
DN		 1006/* Show a single code node and everything underneath it if necessary. */
1007
1008static void
636dff67 1009gfc_show_code_node (int level, gfc_code *c)
6de9cd9a
DN		 1010{
1011 gfc_forall_iterator *fa;
1012 gfc_open *open;
1013 gfc_case *cp;
1014 gfc_alloc *a;
1015 gfc_code *d;
1016 gfc_close *close;
1017 gfc_filepos *fp;
1018 gfc_inquire *i;
1019 gfc_dt *dt;
1020
1021 code_indent (level, c->here);
1022
1023 switch (c->op)
1024 {
1025 case EXEC_NOP:
1026 gfc_status ("NOP");
1027 break;
1028
1029 case EXEC_CONTINUE:
1030 gfc_status ("CONTINUE");
1031 break;
1032
3d79abbd
PB		 1033 case EXEC_ENTRY:
1034 gfc_status ("ENTRY %s", c->ext.entry->sym->name);
1035 break;
1036
6b591ec0 1037 case EXEC_INIT_ASSIGN:
6de9cd9a
DN		 1038 case EXEC_ASSIGN:
1039 gfc_status ("ASSIGN ");
1040 gfc_show_expr (c->expr);
1041 gfc_status_char (' ');
1042 gfc_show_expr (c->expr2);
1043 break;
3d79abbd 1044
6de9cd9a
DN		 1045 case EXEC_LABEL_ASSIGN:
1046 gfc_status ("LABEL ASSIGN ");
1047 gfc_show_expr (c->expr);
1048 gfc_status (" %d", c->label->value);
1049 break;
1050
1051 case EXEC_POINTER_ASSIGN:
1052 gfc_status ("POINTER ASSIGN ");
1053 gfc_show_expr (c->expr);
1054 gfc_status_char (' ');
1055 gfc_show_expr (c->expr2);
1056 break;
1057
1058 case EXEC_GOTO:
1059 gfc_status ("GOTO ");
1060 if (c->label)
636dff67 1061 gfc_status ("%d", c->label->value);
6de9cd9a 1062 else
636dff67
SK		 1063 {
1064 gfc_show_expr (c->expr);
1065 d = c->block;
1066 if (d != NULL)
1067 {
1068 gfc_status (", (");
1069 for (; d; d = d ->block)
1070 {
1071 code_indent (level, d->label);
1072 if (d->block != NULL)
1073 gfc_status_char (',');
1074 else
1075 gfc_status_char (')');
1076 }
1077 }
1078 }
6de9cd9a
DN		 1079 break;
1080
1081 case EXEC_CALL:
bfaacea7
FXC		 1082 if (c->resolved_sym)
1083 gfc_status ("CALL %s ", c->resolved_sym->name);
1084 else if (c->symtree)
1085 gfc_status ("CALL %s ", c->symtree->name);
1086 else
1087 gfc_status ("CALL ?? ");
1088
6de9cd9a
DN		 1089 gfc_show_actual_arglist (c->ext.actual);
1090 break;
1091
1092 case EXEC_RETURN:
1093 gfc_status ("RETURN ");
1094 if (c->expr)
1095 gfc_show_expr (c->expr);
1096 break;
1097
1098 case EXEC_PAUSE:
1099 gfc_status ("PAUSE ");
1100
1101 if (c->expr != NULL)
636dff67 1102 gfc_show_expr (c->expr);
6de9cd9a 1103 else
636dff67 1104 gfc_status ("%d", c->ext.stop_code);
6de9cd9a
DN		 1105
1106 break;
1107
1108 case EXEC_STOP:
1109 gfc_status ("STOP ");
1110
1111 if (c->expr != NULL)
636dff67 1112 gfc_show_expr (c->expr);
6de9cd9a 1113 else
636dff67 1114 gfc_status ("%d", c->ext.stop_code);
6de9cd9a
DN		 1115
1116 break;
1117
1118 case EXEC_ARITHMETIC_IF:
1119 gfc_status ("IF ");
1120 gfc_show_expr (c->expr);
1121 gfc_status (" %d, %d, %d",
1122 c->label->value, c->label2->value, c->label3->value);
1123 break;
1124
1125 case EXEC_IF:
1126 d = c->block;
1127 gfc_status ("IF ");
1128 gfc_show_expr (d->expr);
1129 gfc_status_char ('\n');
1130 gfc_show_code (level + 1, d->next);
1131
1132 d = d->block;
1133 for (; d; d = d->block)
1134 {
1135 code_indent (level, 0);
1136
1137 if (d->expr == NULL)
1138 gfc_status ("ELSE\n");
1139 else
1140 {
1141 gfc_status ("ELSE IF ");
1142 gfc_show_expr (d->expr);
1143 gfc_status_char ('\n');
1144 }
1145
1146 gfc_show_code (level + 1, d->next);
1147 }
1148
1149 code_indent (level, c->label);
1150
1151 gfc_status ("ENDIF");
1152 break;
1153
1154 case EXEC_SELECT:
1155 d = c->block;
1156 gfc_status ("SELECT CASE ");
1157 gfc_show_expr (c->expr);
1158 gfc_status_char ('\n');
1159
1160 for (; d; d = d->block)
1161 {
1162 code_indent (level, 0);
1163
1164 gfc_status ("CASE ");
1165 for (cp = d->ext.case_list; cp; cp = cp->next)
1166 {
1167 gfc_status_char ('(');
1168 gfc_show_expr (cp->low);
1169 gfc_status_char (' ');
1170 gfc_show_expr (cp->high);
1171 gfc_status_char (')');
1172 gfc_status_char (' ');
1173 }
1174 gfc_status_char ('\n');
1175
1176 gfc_show_code (level + 1, d->next);
1177 }
1178
1179 code_indent (level, c->label);
1180 gfc_status ("END SELECT");
1181 break;
1182
1183 case EXEC_WHERE:
1184 gfc_status ("WHERE ");
1185
1186 d = c->block;
1187 gfc_show_expr (d->expr);
1188 gfc_status_char ('\n');
1189
1190 gfc_show_code (level + 1, d->next);
1191
1192 for (d = d->block; d; d = d->block)
1193 {
1194 code_indent (level, 0);
1195 gfc_status ("ELSE WHERE ");
1196 gfc_show_expr (d->expr);
1197 gfc_status_char ('\n');
1198 gfc_show_code (level + 1, d->next);
1199 }
1200
1201 code_indent (level, 0);
1202 gfc_status ("END WHERE");
1203 break;
1204
1205
1206 case EXEC_FORALL:
1207 gfc_status ("FORALL ");
1208 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1209 {
1210 gfc_show_expr (fa->var);
1211 gfc_status_char (' ');
1212 gfc_show_expr (fa->start);
1213 gfc_status_char (':');
1214 gfc_show_expr (fa->end);
1215 gfc_status_char (':');
1216 gfc_show_expr (fa->stride);
1217
1218 if (fa->next != NULL)
1219 gfc_status_char (',');
1220 }
1221
1222 if (c->expr != NULL)
1223 {
1224 gfc_status_char (',');
1225 gfc_show_expr (c->expr);
1226 }
1227 gfc_status_char ('\n');
1228
1229 gfc_show_code (level + 1, c->block->next);
1230
1231 code_indent (level, 0);
1232 gfc_status ("END FORALL");
1233 break;
1234
1235 case EXEC_DO:
1236 gfc_status ("DO ");
1237
1238 gfc_show_expr (c->ext.iterator->var);
1239 gfc_status_char ('=');
1240 gfc_show_expr (c->ext.iterator->start);
1241 gfc_status_char (' ');
1242 gfc_show_expr (c->ext.iterator->end);
1243 gfc_status_char (' ');
1244 gfc_show_expr (c->ext.iterator->step);
1245 gfc_status_char ('\n');
1246
1247 gfc_show_code (level + 1, c->block->next);
1248
1249 code_indent (level, 0);
1250 gfc_status ("END DO");
1251 break;
1252
1253 case EXEC_DO_WHILE:
1254 gfc_status ("DO WHILE ");
1255 gfc_show_expr (c->expr);
1256 gfc_status_char ('\n');
1257
1258 gfc_show_code (level + 1, c->block->next);
1259
1260 code_indent (level, c->label);
1261 gfc_status ("END DO");
1262 break;
1263
1264 case EXEC_CYCLE:
1265 gfc_status ("CYCLE");
1266 if (c->symtree)
1267 gfc_status (" %s", c->symtree->n.sym->name);
1268 break;
1269
1270 case EXEC_EXIT:
1271 gfc_status ("EXIT");
1272 if (c->symtree)
1273 gfc_status (" %s", c->symtree->n.sym->name);
1274 break;
1275
1276 case EXEC_ALLOCATE:
1277 gfc_status ("ALLOCATE ");
1278 if (c->expr)
1279 {
1280 gfc_status (" STAT=");
1281 gfc_show_expr (c->expr);
1282 }
1283
1284 for (a = c->ext.alloc_list; a; a = a->next)
1285 {
1286 gfc_status_char (' ');
1287 gfc_show_expr (a->expr);
1288 }
1289
1290 break;
1291
1292 case EXEC_DEALLOCATE:
1293 gfc_status ("DEALLOCATE ");
1294 if (c->expr)
1295 {
1296 gfc_status (" STAT=");
1297 gfc_show_expr (c->expr);
1298 }
1299
1300 for (a = c->ext.alloc_list; a; a = a->next)
1301 {
1302 gfc_status_char (' ');
1303 gfc_show_expr (a->expr);
1304 }
1305
1306 break;
1307
1308 case EXEC_OPEN:
1309 gfc_status ("OPEN");
1310 open = c->ext.open;
1311
1312 if (open->unit)
1313 {
1314 gfc_status (" UNIT=");
1315 gfc_show_expr (open->unit);
1316 }
7aba8abe
TK		 1317 if (open->iomsg)
1318 {
1319 gfc_status (" IOMSG=");
1320 gfc_show_expr (open->iomsg);
1321 }
6de9cd9a
DN		 1322 if (open->iostat)
1323 {
1324 gfc_status (" IOSTAT=");
1325 gfc_show_expr (open->iostat);
1326 }
1327 if (open->file)
1328 {
1329 gfc_status (" FILE=");
1330 gfc_show_expr (open->file);
1331 }
1332 if (open->status)
1333 {
1334 gfc_status (" STATUS=");
1335 gfc_show_expr (open->status);
1336 }
1337 if (open->access)
1338 {
1339 gfc_status (" ACCESS=");
1340 gfc_show_expr (open->access);
1341 }
1342 if (open->form)
1343 {
1344 gfc_status (" FORM=");
1345 gfc_show_expr (open->form);
1346 }
1347 if (open->recl)
1348 {
1349 gfc_status (" RECL=");
1350 gfc_show_expr (open->recl);
1351 }
1352 if (open->blank)
1353 {
1354 gfc_status (" BLANK=");
1355 gfc_show_expr (open->blank);
1356 }
1357 if (open->position)
1358 {
1359 gfc_status (" POSITION=");
1360 gfc_show_expr (open->position);
1361 }
1362 if (open->action)
1363 {
1364 gfc_status (" ACTION=");
1365 gfc_show_expr (open->action);
1366 }
1367 if (open->delim)
1368 {
1369 gfc_status (" DELIM=");
1370 gfc_show_expr (open->delim);
1371 }
1372 if (open->pad)
1373 {
1374 gfc_status (" PAD=");
1375 gfc_show_expr (open->pad);
1376 }
181c9f4a
TK		 1377 if (open->convert)
1378 {
1379 gfc_status (" CONVERT=");
1380 gfc_show_expr (open->convert);
1381 }
6de9cd9a
DN		 1382 if (open->err != NULL)
1383 gfc_status (" ERR=%d", open->err->value);
1384
1385 break;
1386
1387 case EXEC_CLOSE:
1388 gfc_status ("CLOSE");
1389 close = c->ext.close;
1390
1391 if (close->unit)
1392 {
1393 gfc_status (" UNIT=");
1394 gfc_show_expr (close->unit);
1395 }
7aba8abe
TK		 1396 if (close->iomsg)
1397 {
1398 gfc_status (" IOMSG=");
1399 gfc_show_expr (close->iomsg);
1400 }
6de9cd9a
DN		 1401 if (close->iostat)
1402 {
1403 gfc_status (" IOSTAT=");
1404 gfc_show_expr (close->iostat);
1405 }
1406 if (close->status)
1407 {
1408 gfc_status (" STATUS=");
1409 gfc_show_expr (close->status);
1410 }
1411 if (close->err != NULL)
1412 gfc_status (" ERR=%d", close->err->value);
1413 break;
1414
1415 case EXEC_BACKSPACE:
1416 gfc_status ("BACKSPACE");
1417 goto show_filepos;
1418
1419 case EXEC_ENDFILE:
1420 gfc_status ("ENDFILE");
1421 goto show_filepos;
1422
1423 case EXEC_REWIND:
1424 gfc_status ("REWIND");
6403ec5f
JB		 1425 goto show_filepos;
1426
1427 case EXEC_FLUSH:
1428 gfc_status ("FLUSH");
6de9cd9a
DN		 1429
1430 show_filepos:
1431 fp = c->ext.filepos;
1432
1433 if (fp->unit)
1434 {
1435 gfc_status (" UNIT=");
1436 gfc_show_expr (fp->unit);
1437 }
7aba8abe
TK		 1438 if (fp->iomsg)
1439 {
1440 gfc_status (" IOMSG=");
1441 gfc_show_expr (fp->iomsg);
1442 }
6de9cd9a
DN		 1443 if (fp->iostat)
1444 {
1445 gfc_status (" IOSTAT=");
1446 gfc_show_expr (fp->iostat);
1447 }
1448 if (fp->err != NULL)
1449 gfc_status (" ERR=%d", fp->err->value);
1450 break;
1451
1452 case EXEC_INQUIRE:
1453 gfc_status ("INQUIRE");
1454 i = c->ext.inquire;
1455
1456 if (i->unit)
1457 {
1458 gfc_status (" UNIT=");
1459 gfc_show_expr (i->unit);
1460 }
1461 if (i->file)
1462 {
1463 gfc_status (" FILE=");
1464 gfc_show_expr (i->file);
1465 }
1466
7aba8abe
TK		 1467 if (i->iomsg)
1468 {
1469 gfc_status (" IOMSG=");
1470 gfc_show_expr (i->iomsg);
1471 }
6de9cd9a
DN		 1472 if (i->iostat)
1473 {
1474 gfc_status (" IOSTAT=");
1475 gfc_show_expr (i->iostat);
1476 }
1477 if (i->exist)
1478 {
1479 gfc_status (" EXIST=");
1480 gfc_show_expr (i->exist);
1481 }
1482 if (i->opened)
1483 {
1484 gfc_status (" OPENED=");
1485 gfc_show_expr (i->opened);
1486 }
1487 if (i->number)
1488 {
1489 gfc_status (" NUMBER=");
1490 gfc_show_expr (i->number);
1491 }
1492 if (i->named)
1493 {
1494 gfc_status (" NAMED=");
1495 gfc_show_expr (i->named);
1496 }
1497 if (i->name)
1498 {
1499 gfc_status (" NAME=");
1500 gfc_show_expr (i->name);
1501 }
1502 if (i->access)
1503 {
1504 gfc_status (" ACCESS=");
1505 gfc_show_expr (i->access);
1506 }
1507 if (i->sequential)
1508 {
1509 gfc_status (" SEQUENTIAL=");
1510 gfc_show_expr (i->sequential);
1511 }
1512
1513 if (i->direct)
1514 {
1515 gfc_status (" DIRECT=");
1516 gfc_show_expr (i->direct);
1517 }
1518 if (i->form)
1519 {
1520 gfc_status (" FORM=");
1521 gfc_show_expr (i->form);
1522 }
1523 if (i->formatted)
1524 {
1525 gfc_status (" FORMATTED");
1526 gfc_show_expr (i->formatted);
1527 }
1528 if (i->unformatted)
1529 {
1530 gfc_status (" UNFORMATTED=");
1531 gfc_show_expr (i->unformatted);
1532 }
1533 if (i->recl)
1534 {
1535 gfc_status (" RECL=");
1536 gfc_show_expr (i->recl);
1537 }
1538 if (i->nextrec)
1539 {
1540 gfc_status (" NEXTREC=");
1541 gfc_show_expr (i->nextrec);
1542 }
1543 if (i->blank)
1544 {
1545 gfc_status (" BLANK=");
1546 gfc_show_expr (i->blank);
1547 }
1548 if (i->position)
1549 {
1550 gfc_status (" POSITION=");
1551 gfc_show_expr (i->position);
1552 }
1553 if (i->action)
1554 {
1555 gfc_status (" ACTION=");
1556 gfc_show_expr (i->action);
1557 }
1558 if (i->read)
1559 {
1560 gfc_status (" READ=");
1561 gfc_show_expr (i->read);
1562 }
1563 if (i->write)
1564 {
1565 gfc_status (" WRITE=");
1566 gfc_show_expr (i->write);
1567 }
1568 if (i->readwrite)
1569 {
1570 gfc_status (" READWRITE=");
1571 gfc_show_expr (i->readwrite);
1572 }
1573 if (i->delim)
1574 {
1575 gfc_status (" DELIM=");
1576 gfc_show_expr (i->delim);
1577 }
1578 if (i->pad)
1579 {
1580 gfc_status (" PAD=");
1581 gfc_show_expr (i->pad);
1582 }
181c9f4a
TK		 1583 if (i->convert)
1584 {
1585 gfc_status (" CONVERT=");
1586 gfc_show_expr (i->convert);
1587 }
6de9cd9a
DN		 1588
1589 if (i->err != NULL)
1590 gfc_status (" ERR=%d", i->err->value);
1591 break;
1592
1593 case EXEC_IOLENGTH:
1594 gfc_status ("IOLENGTH ");
1595 gfc_show_expr (c->expr);
5e805e44 1596 goto show_dt_code;
6de9cd9a
DN		 1597 break;
1598
1599 case EXEC_READ:
1600 gfc_status ("READ");
1601 goto show_dt;
1602
1603 case EXEC_WRITE:
1604 gfc_status ("WRITE");
1605
1606 show_dt:
1607 dt = c->ext.dt;
1608 if (dt->io_unit)
1609 {
1610 gfc_status (" UNIT=");
1611 gfc_show_expr (dt->io_unit);
1612 }
1613
1614 if (dt->format_expr)
1615 {
1616 gfc_status (" FMT=");
1617 gfc_show_expr (dt->format_expr);
1618 }
1619
1620 if (dt->format_label != NULL)
1621 gfc_status (" FMT=%d", dt->format_label->value);
1622 if (dt->namelist)
1623 gfc_status (" NML=%s", dt->namelist->name);
7aba8abe
TK		 1624
1625 if (dt->iomsg)
1626 {
1627 gfc_status (" IOMSG=");
1628 gfc_show_expr (dt->iomsg);
1629 }
6de9cd9a
DN		 1630 if (dt->iostat)
1631 {
1632 gfc_status (" IOSTAT=");
1633 gfc_show_expr (dt->iostat);
1634 }
1635 if (dt->size)
1636 {
1637 gfc_status (" SIZE=");
1638 gfc_show_expr (dt->size);
1639 }
1640 if (dt->rec)
1641 {
1642 gfc_status (" REC=");
1643 gfc_show_expr (dt->rec);
1644 }
1645 if (dt->advance)
1646 {
1647 gfc_status (" ADVANCE=");
1648 gfc_show_expr (dt->advance);
1649 }
1650
5e805e44
JJ		 1651 show_dt_code:
1652 gfc_status_char ('\n');
1653 for (c = c->block->next; c; c = c->next)
1654 gfc_show_code_node (level + (c->next != NULL), c);
1655 return;
6de9cd9a
DN		 1656
1657 case EXEC_TRANSFER:
1658 gfc_status ("TRANSFER ");
1659 gfc_show_expr (c->expr);
1660 break;
1661
1662 case EXEC_DT_END:
1663 gfc_status ("DT_END");
1664 dt = c->ext.dt;
1665
1666 if (dt->err != NULL)
1667 gfc_status (" ERR=%d", dt->err->value);
1668 if (dt->end != NULL)
1669 gfc_status (" END=%d", dt->end->value);
1670 if (dt->eor != NULL)
1671 gfc_status (" EOR=%d", dt->eor->value);
1672 break;
1673
6c7a4dfd
JJ		 1674 case EXEC_OMP_ATOMIC:
1675 case EXEC_OMP_BARRIER:
1676 case EXEC_OMP_CRITICAL:
1677 case EXEC_OMP_FLUSH:
1678 case EXEC_OMP_DO:
1679 case EXEC_OMP_MASTER:
1680 case EXEC_OMP_ORDERED:
1681 case EXEC_OMP_PARALLEL:
1682 case EXEC_OMP_PARALLEL_DO:
1683 case EXEC_OMP_PARALLEL_SECTIONS:
1684 case EXEC_OMP_PARALLEL_WORKSHARE:
1685 case EXEC_OMP_SECTIONS:
1686 case EXEC_OMP_SINGLE:
1687 case EXEC_OMP_WORKSHARE:
1688 gfc_show_omp_node (level, c);
1689 break;
1690
6de9cd9a
DN		 1691 default:
1692 gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1693 }
1694
1695 gfc_status_char ('\n');
1696}
1697
1698
30c05595 1699/* Show an equivalence chain. */
1854117e 1700
c4632147 1701void
1854117e
PB		 1702gfc_show_equiv (gfc_equiv *eq)
1703{
1704 show_indent ();
1705 gfc_status ("Equivalence: ");
1706 while (eq)
1707 {
1708 gfc_show_expr (eq->expr);
1709 eq = eq->eq;
1710 if (eq)
1711 gfc_status (", ");
1712 }
1713}
1714
1715
6de9cd9a
DN		 1716/* Show a freakin' whole namespace. */
1717
1718void
636dff67 1719gfc_show_namespace (gfc_namespace *ns)
6de9cd9a
DN		 1720{
1721 gfc_interface *intr;
1722 gfc_namespace *save;
1723 gfc_intrinsic_op op;
1854117e 1724 gfc_equiv *eq;
6de9cd9a
DN		 1725 int i;
1726
1727 save = gfc_current_ns;
1728 show_level++;
1729
1730 show_indent ();
1731 gfc_status ("Namespace:");
1732
1733 if (ns != NULL)
1734 {
1735 i = 0;
1736 do
1737 {
1738 int l = i;
1739 while (i < GFC_LETTERS - 1
1740 && gfc_compare_types(&ns->default_type[i+1],
1741 &ns->default_type[l]))
1742 i++;
1743
1744 if (i > l)
1745 gfc_status(" %c-%c: ", l+'A', i+'A');
1746 else
1747 gfc_status(" %c: ", l+'A');
1748
1749 gfc_show_typespec(&ns->default_type[l]);
1750 i++;
1751 } while (i < GFC_LETTERS);
1752
1753 if (ns->proc_name != NULL)
1754 {
1755 show_indent ();
1756 gfc_status ("procedure name = %s", ns->proc_name->name);
1757 }
1758
1759 gfc_current_ns = ns;
fbc9b453
TS		 1760 gfc_traverse_symtree (ns->common_root, show_common);
1761
9056bd70 1762 gfc_traverse_symtree (ns->sym_root, show_symtree);
6de9cd9a
DN		 1763
1764 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1765 {
1766 /* User operator interfaces */
1767 intr = ns->operator[op];
1768 if (intr == NULL)
1769 continue;
1770
1771 show_indent ();
1772 gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
1773
1774 for (; intr; intr = intr->next)
1775 gfc_status (" %s", intr->sym->name);
1776 }
1777
1778 if (ns->uop_root != NULL)
1779 {
1780 show_indent ();
1781 gfc_status ("User operators:\n");
1782 gfc_traverse_user_op (ns, show_uop);
1783 }
1784 }
1854117e
PB		 1785
1786 for (eq = ns->equiv; eq; eq = eq->next)
1787 gfc_show_equiv (eq);
6de9cd9a
DN		 1788
1789 gfc_status_char ('\n');
1790 gfc_status_char ('\n');
1791
1792 gfc_show_code (0, ns->code);
1793
1794 for (ns = ns->contained; ns; ns = ns->sibling)
1795 {
1796 show_indent ();
1797 gfc_status ("CONTAINS\n");
1798 gfc_show_namespace (ns);
1799 }
1800
1801 show_level--;
1802 gfc_status_char ('\n');
1803 gfc_current_ns = save;
1804}
Mirror of https://gcc.gnu.org/git/gcc.git