?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2014-07-12 Paul Thomas <pault@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / dump-parse-tree.c
blob19f83a9eff8f267632cf899f342344db868f52b1
1 /* Parse tree dumper
2 Copyright (C) 2003-2014 Free Software Foundation, Inc.
3 Contributed by Steven Bosscher
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21
22 /* Actually this is just a collection of routines that used to be
23 scattered around the sources. Now that they are all in a single
24 file, almost all of them can be static, and the other files don't
25 have this mess in them.
26
27 As a nice side-effect, this file can act as documentation of the
28 gfc_code and gfc_expr structures and all their friends and
29 relatives.
30
31 TODO: Dump DATA. */
32
33 #include "config.h"
34 #include "system.h"
35 #include "coretypes.h"
36 #include "gfortran.h"
37 #include "constructor.h"
38
39 /* Keep track of indentation for symbol tree dumps. */
40 static int show_level = 0;
41
42 /* The file handle we're dumping to is kept in a static variable. This
43 is not too cool, but it avoids a lot of passing it around. */
44 static FILE *dumpfile;
45
46 /* Forward declaration of some of the functions. */
47 static void show_expr (gfc_expr *p);
48 static void show_code_node (int, gfc_code *);
49 static void show_namespace (gfc_namespace *ns);
50
51
52 /* Allow dumping of an expression in the debugger. */
53 void gfc_debug_expr (gfc_expr *);
54
55 void
56 gfc_debug_expr (gfc_expr *e)
57 {
58 FILE *tmp = dumpfile;
59 dumpfile = stderr;
60 show_expr (e);
61 fputc ('\n', dumpfile);
62 dumpfile = tmp;
63 }
64
65
66 /* Do indentation for a specific level. */
67
68 static inline void
69 code_indent (int level, gfc_st_label *label)
70 {
71 int i;
72
73 if (label != NULL)
74 fprintf (dumpfile, "%-5d ", label->value);
75
76 for (i = 0; i < (2 * level - (label ? 6 : 0)); i++)
77 fputc (' ', dumpfile);
78 }
79
80
81 /* Simple indentation at the current level. This one
82 is used to show symbols. */
83
84 static inline void
85 show_indent (void)
86 {
87 fputc ('\n', dumpfile);
88 code_indent (show_level, NULL);
89 }
90
91
92 /* Show type-specific information. */
93
94 static void
95 show_typespec (gfc_typespec *ts)
96 {
97 if (ts->type == BT_ASSUMED)
98 {
99 fputs ("(TYPE(*))", dumpfile);
100 return;
101 }
102
103 fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
104
105 switch (ts->type)
106 {
107 case BT_DERIVED:
108 case BT_CLASS:
109 fprintf (dumpfile, "%s", ts->u.derived->name);
110 break;
111
112 case BT_CHARACTER:
113 if (ts->u.cl)
114 show_expr (ts->u.cl->length);
115 fprintf(dumpfile, " %d", ts->kind);
116 break;
117
118 default:
119 fprintf (dumpfile, "%d", ts->kind);
120 break;
121 }
122
123 fputc (')', dumpfile);
124 }
125
126
127 /* Show an actual argument list. */
128
129 static void
130 show_actual_arglist (gfc_actual_arglist *a)
131 {
132 fputc ('(', dumpfile);
133
134 for (; a; a = a->next)
135 {
136 fputc ('(', dumpfile);
137 if (a->name != NULL)
138 fprintf (dumpfile, "%s = ", a->name);
139 if (a->expr != NULL)
140 show_expr (a->expr);
141 else
142 fputs ("(arg not-present)", dumpfile);
143
144 fputc (')', dumpfile);
145 if (a->next != NULL)
146 fputc (' ', dumpfile);
147 }
148
149 fputc (')', dumpfile);
150 }
151
152
153 /* Show a gfc_array_spec array specification structure. */
154
155 static void
156 show_array_spec (gfc_array_spec *as)
157 {
158 const char *c;
159 int i;
160
161 if (as == NULL)
162 {
163 fputs ("()", dumpfile);
164 return;
165 }
166
167 fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
168
169 if (as->rank + as->corank > 0 || as->rank == -1)
170 {
171 switch (as->type)
172 {
173 case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
174 case AS_DEFERRED: c = "AS_DEFERRED"; break;
175 case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
176 case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
177 case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break;
178 default:
179 gfc_internal_error ("show_array_spec(): Unhandled array shape "
180 "type.");
181 }
182 fprintf (dumpfile, " %s ", c);
183
184 for (i = 0; i < as->rank + as->corank; i++)
185 {
186 show_expr (as->lower[i]);
187 fputc (' ', dumpfile);
188 show_expr (as->upper[i]);
189 fputc (' ', dumpfile);
190 }
191 }
192
193 fputc (')', dumpfile);
194 }
195
196
197 /* Show a gfc_array_ref array reference structure. */
198
199 static void
200 show_array_ref (gfc_array_ref * ar)
201 {
202 int i;
203
204 fputc ('(', dumpfile);
205
206 switch (ar->type)
207 {
208 case AR_FULL:
209 fputs ("FULL", dumpfile);
210 break;
211
212 case AR_SECTION:
213 for (i = 0; i < ar->dimen; i++)
214 {
215 /* There are two types of array sections: either the
216 elements are identified by an integer array ('vector'),
217 or by an index range. In the former case we only have to
218 print the start expression which contains the vector, in
219 the latter case we have to print any of lower and upper
220 bound and the stride, if they're present. */
221
222 if (ar->start[i] != NULL)
223 show_expr (ar->start[i]);
224
225 if (ar->dimen_type[i] == DIMEN_RANGE)
226 {
227 fputc (':', dumpfile);
228
229 if (ar->end[i] != NULL)
230 show_expr (ar->end[i]);
231
232 if (ar->stride[i] != NULL)
233 {
234 fputc (':', dumpfile);
235 show_expr (ar->stride[i]);
236 }
237 }
238
239 if (i != ar->dimen - 1)
240 fputs (" , ", dumpfile);
241 }
242 break;
243
244 case AR_ELEMENT:
245 for (i = 0; i < ar->dimen; i++)
246 {
247 show_expr (ar->start[i]);
248 if (i != ar->dimen - 1)
249 fputs (" , ", dumpfile);
250 }
251 break;
252
253 case AR_UNKNOWN:
254 fputs ("UNKNOWN", dumpfile);
255 break;
256
257 default:
258 gfc_internal_error ("show_array_ref(): Unknown array reference");
259 }
260
261 fputc (')', dumpfile);
262 }
263
264
265 /* Show a list of gfc_ref structures. */
266
267 static void
268 show_ref (gfc_ref *p)
269 {
270 for (; p; p = p->next)
271 switch (p->type)
272 {
273 case REF_ARRAY:
274 show_array_ref (&p->u.ar);
275 break;
276
277 case REF_COMPONENT:
278 fprintf (dumpfile, " %% %s", p->u.c.component->name);
279 break;
280
281 case REF_SUBSTRING:
282 fputc ('(', dumpfile);
283 show_expr (p->u.ss.start);
284 fputc (':', dumpfile);
285 show_expr (p->u.ss.end);
286 fputc (')', dumpfile);
287 break;
288
289 default:
290 gfc_internal_error ("show_ref(): Bad component code");
291 }
292 }
293
294
295 /* Display a constructor. Works recursively for array constructors. */
296
297 static void
298 show_constructor (gfc_constructor_base base)
299 {
300 gfc_constructor *c;
301 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
302 {
303 if (c->iterator == NULL)
304 show_expr (c->expr);
305 else
306 {
307 fputc ('(', dumpfile);
308 show_expr (c->expr);
309
310 fputc (' ', dumpfile);
311 show_expr (c->iterator->var);
312 fputc ('=', dumpfile);
313 show_expr (c->iterator->start);
314 fputc (',', dumpfile);
315 show_expr (c->iterator->end);
316 fputc (',', dumpfile);
317 show_expr (c->iterator->step);
318
319 fputc (')', dumpfile);
320 }
321
322 if (gfc_constructor_next (c) != NULL)
323 fputs (" , ", dumpfile);
324 }
325 }
326
327
328 static void
329 show_char_const (const gfc_char_t *c, int length)
330 {
331 int i;
332
333 fputc ('\'', dumpfile);
334 for (i = 0; i < length; i++)
335 {
336 if (c[i] == '\'')
337 fputs ("''", dumpfile);
338 else
339 fputs (gfc_print_wide_char (c[i]), dumpfile);
340 }
341 fputc ('\'', dumpfile);
342 }
343
344
345 /* Show a component-call expression. */
346
347 static void
348 show_compcall (gfc_expr* p)
349 {
350 gcc_assert (p->expr_type == EXPR_COMPCALL);
351
352 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
353 show_ref (p->ref);
354 fprintf (dumpfile, "%s", p->value.compcall.name);
355
356 show_actual_arglist (p->value.compcall.actual);
357 }
358
359
360 /* Show an expression. */
361
362 static void
363 show_expr (gfc_expr *p)
364 {
365 const char *c;
366 int i;
367
368 if (p == NULL)
369 {
370 fputs ("()", dumpfile);
371 return;
372 }
373
374 switch (p->expr_type)
375 {
376 case EXPR_SUBSTRING:
377 show_char_const (p->value.character.string, p->value.character.length);
378 show_ref (p->ref);
379 break;
380
381 case EXPR_STRUCTURE:
382 fprintf (dumpfile, "%s(", p->ts.u.derived->name);
383 show_constructor (p->value.constructor);
384 fputc (')', dumpfile);
385 break;
386
387 case EXPR_ARRAY:
388 fputs ("(/ ", dumpfile);
389 show_constructor (p->value.constructor);
390 fputs (" /)", dumpfile);
391
392 show_ref (p->ref);
393 break;
394
395 case EXPR_NULL:
396 fputs ("NULL()", dumpfile);
397 break;
398
399 case EXPR_CONSTANT:
400 switch (p->ts.type)
401 {
402 case BT_INTEGER:
403 mpz_out_str (stdout, 10, p->value.integer);
404
405 if (p->ts.kind != gfc_default_integer_kind)
406 fprintf (dumpfile, "_%d", p->ts.kind);
407 break;
408
409 case BT_LOGICAL:
410 if (p->value.logical)
411 fputs (".true.", dumpfile);
412 else
413 fputs (".false.", dumpfile);
414 break;
415
416 case BT_REAL:
417 mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
418 if (p->ts.kind != gfc_default_real_kind)
419 fprintf (dumpfile, "_%d", p->ts.kind);
420 break;
421
422 case BT_CHARACTER:
423 show_char_const (p->value.character.string,
424 p->value.character.length);
425 break;
426
427 case BT_COMPLEX:
428 fputs ("(complex ", dumpfile);
429
430 mpfr_out_str (stdout, 10, 0, mpc_realref (p->value.complex),
431 GFC_RND_MODE);
432 if (p->ts.kind != gfc_default_complex_kind)
433 fprintf (dumpfile, "_%d", p->ts.kind);
434
435 fputc (' ', dumpfile);
436
437 mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
438 GFC_RND_MODE);
439 if (p->ts.kind != gfc_default_complex_kind)
440 fprintf (dumpfile, "_%d", p->ts.kind);
441
442 fputc (')', dumpfile);
443 break;
444
445 case BT_HOLLERITH:
446 fprintf (dumpfile, "%dH", p->representation.length);
447 c = p->representation.string;
448 for (i = 0; i < p->representation.length; i++, c++)
449 {
450 fputc (*c, dumpfile);
451 }
452 break;
453
454 default:
455 fputs ("???", dumpfile);
456 break;
457 }
458
459 if (p->representation.string)
460 {
461 fputs (" {", dumpfile);
462 c = p->representation.string;
463 for (i = 0; i < p->representation.length; i++, c++)
464 {
465 fprintf (dumpfile, "%.2x", (unsigned int) *c);
466 if (i < p->representation.length - 1)
467 fputc (',', dumpfile);
468 }
469 fputc ('}', dumpfile);
470 }
471
472 break;
473
474 case EXPR_VARIABLE:
475 if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
476 fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
477 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
478 show_ref (p->ref);
479 break;
480
481 case EXPR_OP:
482 fputc ('(', dumpfile);
483 switch (p->value.op.op)
484 {
485 case INTRINSIC_UPLUS:
486 fputs ("U+ ", dumpfile);
487 break;
488 case INTRINSIC_UMINUS:
489 fputs ("U- ", dumpfile);
490 break;
491 case INTRINSIC_PLUS:
492 fputs ("+ ", dumpfile);
493 break;
494 case INTRINSIC_MINUS:
495 fputs ("- ", dumpfile);
496 break;
497 case INTRINSIC_TIMES:
498 fputs ("* ", dumpfile);
499 break;
500 case INTRINSIC_DIVIDE:
501 fputs ("/ ", dumpfile);
502 break;
503 case INTRINSIC_POWER:
504 fputs ("** ", dumpfile);
505 break;
506 case INTRINSIC_CONCAT:
507 fputs ("// ", dumpfile);
508 break;
509 case INTRINSIC_AND:
510 fputs ("AND ", dumpfile);
511 break;
512 case INTRINSIC_OR:
513 fputs ("OR ", dumpfile);
514 break;
515 case INTRINSIC_EQV:
516 fputs ("EQV ", dumpfile);
517 break;
518 case INTRINSIC_NEQV:
519 fputs ("NEQV ", dumpfile);
520 break;
521 case INTRINSIC_EQ:
522 case INTRINSIC_EQ_OS:
523 fputs ("= ", dumpfile);
524 break;
525 case INTRINSIC_NE:
526 case INTRINSIC_NE_OS:
527 fputs ("/= ", dumpfile);
528 break;
529 case INTRINSIC_GT:
530 case INTRINSIC_GT_OS:
531 fputs ("> ", dumpfile);
532 break;
533 case INTRINSIC_GE:
534 case INTRINSIC_GE_OS:
535 fputs (">= ", dumpfile);
536 break;
537 case INTRINSIC_LT:
538 case INTRINSIC_LT_OS:
539 fputs ("< ", dumpfile);
540 break;
541 case INTRINSIC_LE:
542 case INTRINSIC_LE_OS:
543 fputs ("<= ", dumpfile);
544 break;
545 case INTRINSIC_NOT:
546 fputs ("NOT ", dumpfile);
547 break;
548 case INTRINSIC_PARENTHESES:
549 fputs ("parens ", dumpfile);
550 break;
551
552 default:
553 gfc_internal_error
554 ("show_expr(): Bad intrinsic in expression!");
555 }
556
557 show_expr (p->value.op.op1);
558
559 if (p->value.op.op2)
560 {
561 fputc (' ', dumpfile);
562 show_expr (p->value.op.op2);
563 }
564
565 fputc (')', dumpfile);
566 break;
567
568 case EXPR_FUNCTION:
569 if (p->value.function.name == NULL)
570 {
571 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
572 if (gfc_is_proc_ptr_comp (p))
573 show_ref (p->ref);
574 fputc ('[', dumpfile);
575 show_actual_arglist (p->value.function.actual);
576 fputc (']', dumpfile);
577 }
578 else
579 {
580 fprintf (dumpfile, "%s", p->value.function.name);
581 if (gfc_is_proc_ptr_comp (p))
582 show_ref (p->ref);
583 fputc ('[', dumpfile);
584 fputc ('[', dumpfile);
585 show_actual_arglist (p->value.function.actual);
586 fputc (']', dumpfile);
587 fputc (']', dumpfile);
588 }
589
590 break;
591
592 case EXPR_COMPCALL:
593 show_compcall (p);
594 break;
595
596 default:
597 gfc_internal_error ("show_expr(): Don't know how to show expr");
598 }
599 }
600
601 /* Show symbol attributes. The flavor and intent are followed by
602 whatever single bit attributes are present. */
603
604 static void
605 show_attr (symbol_attribute *attr, const char * module)
606 {
607 if (attr->flavor != FL_UNKNOWN)
608 fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor));
609 if (attr->access != ACCESS_UNKNOWN)
610 fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access));
611 if (attr->proc != PROC_UNKNOWN)
612 fprintf (dumpfile, "%s ", gfc_code2string (procedures, attr->proc));
613 if (attr->save != SAVE_NONE)
614 fprintf (dumpfile, "%s", gfc_code2string (save_status, attr->save));
615
616 if (attr->artificial)
617 fputs (" ARTIFICIAL", dumpfile);
618 if (attr->allocatable)
619 fputs (" ALLOCATABLE", dumpfile);
620 if (attr->asynchronous)
621 fputs (" ASYNCHRONOUS", dumpfile);
622 if (attr->codimension)
623 fputs (" CODIMENSION", dumpfile);
624 if (attr->dimension)
625 fputs (" DIMENSION", dumpfile);
626 if (attr->contiguous)
627 fputs (" CONTIGUOUS", dumpfile);
628 if (attr->external)
629 fputs (" EXTERNAL", dumpfile);
630 if (attr->intrinsic)
631 fputs (" INTRINSIC", dumpfile);
632 if (attr->optional)
633 fputs (" OPTIONAL", dumpfile);
634 if (attr->pointer)
635 fputs (" POINTER", dumpfile);
636 if (attr->is_protected)
637 fputs (" PROTECTED", dumpfile);
638 if (attr->value)
639 fputs (" VALUE", dumpfile);
640 if (attr->volatile_)
641 fputs (" VOLATILE", dumpfile);
642 if (attr->threadprivate)
643 fputs (" THREADPRIVATE", dumpfile);
644 if (attr->target)
645 fputs (" TARGET", dumpfile);
646 if (attr->dummy)
647 {
648 fputs (" DUMMY", dumpfile);
649 if (attr->intent != INTENT_UNKNOWN)
650 fprintf (dumpfile, "(%s)", gfc_intent_string (attr->intent));
651 }
652
653 if (attr->result)
654 fputs (" RESULT", dumpfile);
655 if (attr->entry)
656 fputs (" ENTRY", dumpfile);
657 if (attr->is_bind_c)
658 fputs (" BIND(C)", dumpfile);
659
660 if (attr->data)
661 fputs (" DATA", dumpfile);
662 if (attr->use_assoc)
663 {
664 fputs (" USE-ASSOC", dumpfile);
665 if (module != NULL)
666 fprintf (dumpfile, "(%s)", module);
667 }
668
669 if (attr->in_namelist)
670 fputs (" IN-NAMELIST", dumpfile);
671 if (attr->in_common)
672 fputs (" IN-COMMON", dumpfile);
673
674 if (attr->abstract)
675 fputs (" ABSTRACT", dumpfile);
676 if (attr->function)
677 fputs (" FUNCTION", dumpfile);
678 if (attr->subroutine)
679 fputs (" SUBROUTINE", dumpfile);
680 if (attr->implicit_type)
681 fputs (" IMPLICIT-TYPE", dumpfile);
682
683 if (attr->sequence)
684 fputs (" SEQUENCE", dumpfile);
685 if (attr->elemental)
686 fputs (" ELEMENTAL", dumpfile);
687 if (attr->pure)
688 fputs (" PURE", dumpfile);
689 if (attr->recursive)
690 fputs (" RECURSIVE", dumpfile);
691
692 fputc (')', dumpfile);
693 }
694
695
696 /* Show components of a derived type. */
697
698 static void
699 show_components (gfc_symbol *sym)
700 {
701 gfc_component *c;
702
703 for (c = sym->components; c; c = c->next)
704 {
705 fprintf (dumpfile, "(%s ", c->name);
706 show_typespec (&c->ts);
707 if (c->attr.allocatable)
708 fputs (" ALLOCATABLE", dumpfile);
709 if (c->attr.pointer)
710 fputs (" POINTER", dumpfile);
711 if (c->attr.proc_pointer)
712 fputs (" PPC", dumpfile);
713 if (c->attr.dimension)
714 fputs (" DIMENSION", dumpfile);
715 fputc (' ', dumpfile);
716 show_array_spec (c->as);
717 if (c->attr.access)
718 fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
719 fputc (')', dumpfile);
720 if (c->next != NULL)
721 fputc (' ', dumpfile);
722 }
723 }
724
725
726 /* Show the f2k_derived namespace with procedure bindings. */
727
728 static void
729 show_typebound_proc (gfc_typebound_proc* tb, const char* name)
730 {
731 show_indent ();
732
733 if (tb->is_generic)
734 fputs ("GENERIC", dumpfile);
735 else
736 {
737 fputs ("PROCEDURE, ", dumpfile);
738 if (tb->nopass)
739 fputs ("NOPASS", dumpfile);
740 else
741 {
742 if (tb->pass_arg)
743 fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
744 else
745 fputs ("PASS", dumpfile);
746 }
747 if (tb->non_overridable)
748 fputs (", NON_OVERRIDABLE", dumpfile);
749 }
750
751 if (tb->access == ACCESS_PUBLIC)
752 fputs (", PUBLIC", dumpfile);
753 else
754 fputs (", PRIVATE", dumpfile);
755
756 fprintf (dumpfile, " :: %s => ", name);
757
758 if (tb->is_generic)
759 {
760 gfc_tbp_generic* g;
761 for (g = tb->u.generic; g; g = g->next)
762 {
763 fputs (g->specific_st->name, dumpfile);
764 if (g->next)
765 fputs (", ", dumpfile);
766 }
767 }
768 else
769 fputs (tb->u.specific->n.sym->name, dumpfile);
770 }
771
772 static void
773 show_typebound_symtree (gfc_symtree* st)
774 {
775 gcc_assert (st->n.tb);
776 show_typebound_proc (st->n.tb, st->name);
777 }
778
779 static void
780 show_f2k_derived (gfc_namespace* f2k)
781 {
782 gfc_finalizer* f;
783 int op;
784
785 show_indent ();
786 fputs ("Procedure bindings:", dumpfile);
787 ++show_level;
788
789 /* Finalizer bindings. */
790 for (f = f2k->finalizers; f; f = f->next)
791 {
792 show_indent ();
793 fprintf (dumpfile, "FINAL %s", f->proc_tree->n.sym->name);
794 }
795
796 /* Type-bound procedures. */
797 gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
798
799 --show_level;
800
801 show_indent ();
802 fputs ("Operator bindings:", dumpfile);
803 ++show_level;
804
805 /* User-defined operators. */
806 gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
807
808 /* Intrinsic operators. */
809 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
810 if (f2k->tb_op[op])
811 show_typebound_proc (f2k->tb_op[op],
812 gfc_op2string ((gfc_intrinsic_op) op));
813
814 --show_level;
815 }
816
817
818 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
819 show the interface. Information needed to reconstruct the list of
820 specific interfaces associated with a generic symbol is done within
821 that symbol. */
822
823 static void
824 show_symbol (gfc_symbol *sym)
825 {
826 gfc_formal_arglist *formal;
827 gfc_interface *intr;
828 int i,len;
829
830 if (sym == NULL)
831 return;
832
833 fprintf (dumpfile, "|| symbol: '%s' ", sym->name);
834 len = strlen (sym->name);
835 for (i=len; i<12; i++)
836 fputc(' ', dumpfile);
837
838 ++show_level;
839
840 show_indent ();
841 fputs ("type spec : ", dumpfile);
842 show_typespec (&sym->ts);
843
844 show_indent ();
845 fputs ("attributes: ", dumpfile);
846 show_attr (&sym->attr, sym->module);
847
848 if (sym->value)
849 {
850 show_indent ();
851 fputs ("value: ", dumpfile);
852 show_expr (sym->value);
853 }
854
855 if (sym->as)
856 {
857 show_indent ();
858 fputs ("Array spec:", dumpfile);
859 show_array_spec (sym->as);
860 }
861
862 if (sym->generic)
863 {
864 show_indent ();
865 fputs ("Generic interfaces:", dumpfile);
866 for (intr = sym->generic; intr; intr = intr->next)
867 fprintf (dumpfile, " %s", intr->sym->name);
868 }
869
870 if (sym->result)
871 {
872 show_indent ();
873 fprintf (dumpfile, "result: %s", sym->result->name);
874 }
875
876 if (sym->components)
877 {
878 show_indent ();
879 fputs ("components: ", dumpfile);
880 show_components (sym);
881 }
882
883 if (sym->f2k_derived)
884 {
885 show_indent ();
886 if (sym->hash_value)
887 fprintf (dumpfile, "hash: %d", sym->hash_value);
888 show_f2k_derived (sym->f2k_derived);
889 }
890
891 if (sym->formal)
892 {
893 show_indent ();
894 fputs ("Formal arglist:", dumpfile);
895
896 for (formal = sym->formal; formal; formal = formal->next)
897 {
898 if (formal->sym != NULL)
899 fprintf (dumpfile, " %s", formal->sym->name);
900 else
901 fputs (" [Alt Return]", dumpfile);
902 }
903 }
904
905 if (sym->formal_ns && (sym->formal_ns->proc_name != sym)
906 && sym->attr.proc != PROC_ST_FUNCTION
907 && !sym->attr.entry)
908 {
909 show_indent ();
910 fputs ("Formal namespace", dumpfile);
911 show_namespace (sym->formal_ns);
912 }
913 --show_level;
914 }
915
916
917 /* Show a user-defined operator. Just prints an operator
918 and the name of the associated subroutine, really. */
919
920 static void
921 show_uop (gfc_user_op *uop)
922 {
923 gfc_interface *intr;
924
925 show_indent ();
926 fprintf (dumpfile, "%s:", uop->name);
927
928 for (intr = uop->op; intr; intr = intr->next)
929 fprintf (dumpfile, " %s", intr->sym->name);
930 }
931
932
933 /* Workhorse function for traversing the user operator symtree. */
934
935 static void
936 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
937 {
938 if (st == NULL)
939 return;
940
941 (*func) (st->n.uop);
942
943 traverse_uop (st->left, func);
944 traverse_uop (st->right, func);
945 }
946
947
948 /* Traverse the tree of user operator nodes. */
949
950 void
951 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
952 {
953 traverse_uop (ns->uop_root, func);
954 }
955
956
957 /* Function to display a common block. */
958
959 static void
960 show_common (gfc_symtree *st)
961 {
962 gfc_symbol *s;
963
964 show_indent ();
965 fprintf (dumpfile, "common: /%s/ ", st->name);
966
967 s = st->n.common->head;
968 while (s)
969 {
970 fprintf (dumpfile, "%s", s->name);
971 s = s->common_next;
972 if (s)
973 fputs (", ", dumpfile);
974 }
975 fputc ('\n', dumpfile);
976 }
977
978
979 /* Worker function to display the symbol tree. */
980
981 static void
982 show_symtree (gfc_symtree *st)
983 {
984 int len, i;
985
986 show_indent ();
987
988 len = strlen(st->name);
989 fprintf (dumpfile, "symtree: '%s'", st->name);
990
991 for (i=len; i<12; i++)
992 fputc(' ', dumpfile);
993
994 if (st->ambiguous)
995 fputs( " Ambiguous", dumpfile);
996
997 if (st->n.sym->ns != gfc_current_ns)
998 fprintf (dumpfile, "|| symbol: '%s' from namespace '%s'", st->n.sym->name,
999 st->n.sym->ns->proc_name->name);
1000 else
1001 show_symbol (st->n.sym);
1002 }
1003
1004
1005 /******************* Show gfc_code structures **************/
1006
1007
1008 /* Show a list of code structures. Mutually recursive with
1009 show_code_node(). */
1010
1011 static void
1012 show_code (int level, gfc_code *c)
1013 {
1014 for (; c; c = c->next)
1015 show_code_node (level, c);
1016 }
1017
1018 static void
1019 show_omp_namelist (int list_type, gfc_omp_namelist *n)
1020 {
1021 for (; n; n = n->next)
1022 {
1023 if (list_type == OMP_LIST_REDUCTION)
1024 switch (n->u.reduction_op)
1025 {
1026 case OMP_REDUCTION_PLUS:
1027 case OMP_REDUCTION_TIMES:
1028 case OMP_REDUCTION_MINUS:
1029 case OMP_REDUCTION_AND:
1030 case OMP_REDUCTION_OR:
1031 case OMP_REDUCTION_EQV:
1032 case OMP_REDUCTION_NEQV:
1033 fprintf (dumpfile, "%s:",
1034 gfc_op2string ((gfc_intrinsic_op) n->u.reduction_op));
1035 break;
1036 case OMP_REDUCTION_MAX: fputs ("max:", dumpfile); break;
1037 case OMP_REDUCTION_MIN: fputs ("min:", dumpfile); break;
1038 case OMP_REDUCTION_IAND: fputs ("iand:", dumpfile); break;
1039 case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break;
1040 case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break;
1041 case OMP_REDUCTION_USER:
1042 if (n->udr)
1043 fprintf (dumpfile, "%s:", n->udr->udr->name);
1044 break;
1045 default: break;
1046 }
1047 else if (list_type == OMP_LIST_DEPEND)
1048 switch (n->u.depend_op)
1049 {
1050 case OMP_DEPEND_IN: fputs ("in:", dumpfile); break;
1051 case OMP_DEPEND_OUT: fputs ("out:", dumpfile); break;
1052 case OMP_DEPEND_INOUT: fputs ("inout:", dumpfile); break;
1053 default: break;
1054 }
1055 else if (list_type == OMP_LIST_MAP)
1056 switch (n->u.map_op)
1057 {
1058 case OMP_MAP_ALLOC: fputs ("alloc:", dumpfile); break;
1059 case OMP_MAP_TO: fputs ("to:", dumpfile); break;
1060 case OMP_MAP_FROM: fputs ("from:", dumpfile); break;
1061 case OMP_MAP_TOFROM: fputs ("tofrom:", dumpfile); break;
1062 default: break;
1063 }
1064 fprintf (dumpfile, "%s", n->sym->name);
1065 if (n->expr)
1066 {
1067 fputc (':', dumpfile);
1068 show_expr (n->expr);
1069 }
1070 if (n->next)
1071 fputc (',', dumpfile);
1072 }
1073 }
1074
1075 /* Show a single OpenMP directive node and everything underneath it
1076 if necessary. */
1077
1078 static void
1079 show_omp_node (int level, gfc_code *c)
1080 {
1081 gfc_omp_clauses *omp_clauses = NULL;
1082 const char *name = NULL;
1083
1084 switch (c->op)
1085 {
1086 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
1087 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
1088 case EXEC_OMP_CANCEL: name = "CANCEL"; break;
1089 case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break;
1090 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
1091 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
1092 case EXEC_OMP_DO: name = "DO"; break;
1093 case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break;
1094 case EXEC_OMP_MASTER: name = "MASTER"; break;
1095 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
1096 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
1097 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
1098 case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break;
1099 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
1100 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
1101 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
1102 case EXEC_OMP_SIMD: name = "SIMD"; break;
1103 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
1104 case EXEC_OMP_TASK: name = "TASK"; break;
1105 case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break;
1106 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
1107 case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
1108 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
1109 default:
1110 gcc_unreachable ();
1111 }
1112 fprintf (dumpfile, "!$OMP %s", name);
1113 switch (c->op)
1114 {
1115 case EXEC_OMP_CANCEL:
1116 case EXEC_OMP_CANCELLATION_POINT:
1117 case EXEC_OMP_DO:
1118 case EXEC_OMP_DO_SIMD:
1119 case EXEC_OMP_PARALLEL:
1120 case EXEC_OMP_PARALLEL_DO:
1121 case EXEC_OMP_PARALLEL_DO_SIMD:
1122 case EXEC_OMP_PARALLEL_SECTIONS:
1123 case EXEC_OMP_SECTIONS:
1124 case EXEC_OMP_SIMD:
1125 case EXEC_OMP_SINGLE:
1126 case EXEC_OMP_WORKSHARE:
1127 case EXEC_OMP_PARALLEL_WORKSHARE:
1128 case EXEC_OMP_TASK:
1129 omp_clauses = c->ext.omp_clauses;
1130 break;
1131 case EXEC_OMP_CRITICAL:
1132 if (c->ext.omp_name)
1133 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1134 break;
1135 case EXEC_OMP_FLUSH:
1136 if (c->ext.omp_namelist)
1137 {
1138 fputs (" (", dumpfile);
1139 show_omp_namelist (OMP_LIST_NUM, c->ext.omp_namelist);
1140 fputc (')', dumpfile);
1141 }
1142 return;
1143 case EXEC_OMP_BARRIER:
1144 case EXEC_OMP_TASKWAIT:
1145 case EXEC_OMP_TASKYIELD:
1146 return;
1147 default:
1148 break;
1149 }
1150 if (omp_clauses)
1151 {
1152 int list_type;
1153
1154 switch (omp_clauses->cancel)
1155 {
1156 case OMP_CANCEL_UNKNOWN:
1157 break;
1158 case OMP_CANCEL_PARALLEL:
1159 fputs (" PARALLEL", dumpfile);
1160 break;
1161 case OMP_CANCEL_SECTIONS:
1162 fputs (" SECTIONS", dumpfile);
1163 break;
1164 case OMP_CANCEL_DO:
1165 fputs (" DO", dumpfile);
1166 break;
1167 case OMP_CANCEL_TASKGROUP:
1168 fputs (" TASKGROUP", dumpfile);
1169 break;
1170 }
1171 if (omp_clauses->if_expr)
1172 {
1173 fputs (" IF(", dumpfile);
1174 show_expr (omp_clauses->if_expr);
1175 fputc (')', dumpfile);
1176 }
1177 if (omp_clauses->final_expr)
1178 {
1179 fputs (" FINAL(", dumpfile);
1180 show_expr (omp_clauses->final_expr);
1181 fputc (')', dumpfile);
1182 }
1183 if (omp_clauses->num_threads)
1184 {
1185 fputs (" NUM_THREADS(", dumpfile);
1186 show_expr (omp_clauses->num_threads);
1187 fputc (')', dumpfile);
1188 }
1189 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1190 {
1191 const char *type;
1192 switch (omp_clauses->sched_kind)
1193 {
1194 case OMP_SCHED_STATIC: type = "STATIC"; break;
1195 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1196 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1197 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1198 case OMP_SCHED_AUTO: type = "AUTO"; break;
1199 default:
1200 gcc_unreachable ();
1201 }
1202 fprintf (dumpfile, " SCHEDULE (%s", type);
1203 if (omp_clauses->chunk_size)
1204 {
1205 fputc (',', dumpfile);
1206 show_expr (omp_clauses->chunk_size);
1207 }
1208 fputc (')', dumpfile);
1209 }
1210 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1211 {
1212 const char *type;
1213 switch (omp_clauses->default_sharing)
1214 {
1215 case OMP_DEFAULT_NONE: type = "NONE"; break;
1216 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1217 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1218 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1219 default:
1220 gcc_unreachable ();
1221 }
1222 fprintf (dumpfile, " DEFAULT(%s)", type);
1223 }
1224 if (omp_clauses->ordered)
1225 fputs (" ORDERED", dumpfile);
1226 if (omp_clauses->untied)
1227 fputs (" UNTIED", dumpfile);
1228 if (omp_clauses->mergeable)
1229 fputs (" MERGEABLE", dumpfile);
1230 if (omp_clauses->collapse)
1231 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1232 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1233 if (omp_clauses->lists[list_type] != NULL
1234 && list_type != OMP_LIST_COPYPRIVATE)
1235 {
1236 const char *type = NULL;
1237 switch (list_type)
1238 {
1239 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1240 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1241 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1242 case OMP_LIST_SHARED: type = "SHARED"; break;
1243 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1244 case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
1245 case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
1246 case OMP_LIST_LINEAR: type = "LINEAR"; break;
1247 case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
1248 case OMP_LIST_DEPEND: type = "DEPEND"; break;
1249 default:
1250 gcc_unreachable ();
1251 }
1252 fprintf (dumpfile, " %s(", type);
1253 show_omp_namelist (list_type, omp_clauses->lists[list_type]);
1254 fputc (')', dumpfile);
1255 }
1256 if (omp_clauses->safelen_expr)
1257 {
1258 fputs (" SAFELEN(", dumpfile);
1259 show_expr (omp_clauses->safelen_expr);
1260 fputc (')', dumpfile);
1261 }
1262 if (omp_clauses->simdlen_expr)
1263 {
1264 fputs (" SIMDLEN(", dumpfile);
1265 show_expr (omp_clauses->simdlen_expr);
1266 fputc (')', dumpfile);
1267 }
1268 if (omp_clauses->inbranch)
1269 fputs (" INBRANCH", dumpfile);
1270 if (omp_clauses->notinbranch)
1271 fputs (" NOTINBRANCH", dumpfile);
1272 if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
1273 {
1274 const char *type;
1275 switch (omp_clauses->proc_bind)
1276 {
1277 case OMP_PROC_BIND_MASTER: type = "MASTER"; break;
1278 case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break;
1279 case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break;
1280 default:
1281 gcc_unreachable ();
1282 }
1283 fprintf (dumpfile, " PROC_BIND(%s)", type);
1284 }
1285 if (omp_clauses->num_teams)
1286 {
1287 fputs (" NUM_TEAMS(", dumpfile);
1288 show_expr (omp_clauses->num_teams);
1289 fputc (')', dumpfile);
1290 }
1291 if (omp_clauses->device)
1292 {
1293 fputs (" DEVICE(", dumpfile);
1294 show_expr (omp_clauses->device);
1295 fputc (')', dumpfile);
1296 }
1297 if (omp_clauses->thread_limit)
1298 {
1299 fputs (" THREAD_LIMIT(", dumpfile);
1300 show_expr (omp_clauses->thread_limit);
1301 fputc (')', dumpfile);
1302 }
1303 if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE)
1304 {
1305 fprintf (dumpfile, " DIST_SCHEDULE (static");
1306 if (omp_clauses->dist_chunk_size)
1307 {
1308 fputc (',', dumpfile);
1309 show_expr (omp_clauses->dist_chunk_size);
1310 }
1311 fputc (')', dumpfile);
1312 }
1313 }
1314 fputc ('\n', dumpfile);
1315 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1316 {
1317 gfc_code *d = c->block;
1318 while (d != NULL)
1319 {
1320 show_code (level + 1, d->next);
1321 if (d->block == NULL)
1322 break;
1323 code_indent (level, 0);
1324 fputs ("!$OMP SECTION\n", dumpfile);
1325 d = d->block;
1326 }
1327 }
1328 else
1329 show_code (level + 1, c->block->next);
1330 if (c->op == EXEC_OMP_ATOMIC)
1331 return;
1332 fputc ('\n', dumpfile);
1333 code_indent (level, 0);
1334 fprintf (dumpfile, "!$OMP END %s", name);
1335 if (omp_clauses != NULL)
1336 {
1337 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1338 {
1339 fputs (" COPYPRIVATE(", dumpfile);
1340 show_omp_namelist (OMP_LIST_COPYPRIVATE,
1341 omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1342 fputc (')', dumpfile);
1343 }
1344 else if (omp_clauses->nowait)
1345 fputs (" NOWAIT", dumpfile);
1346 }
1347 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1348 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1349 }
1350
1351
1352 /* Show a single code node and everything underneath it if necessary. */
1353
1354 static void
1355 show_code_node (int level, gfc_code *c)
1356 {
1357 gfc_forall_iterator *fa;
1358 gfc_open *open;
1359 gfc_case *cp;
1360 gfc_alloc *a;
1361 gfc_code *d;
1362 gfc_close *close;
1363 gfc_filepos *fp;
1364 gfc_inquire *i;
1365 gfc_dt *dt;
1366 gfc_namespace *ns;
1367
1368 if (c->here)
1369 {
1370 fputc ('\n', dumpfile);
1371 code_indent (level, c->here);
1372 }
1373 else
1374 show_indent ();
1375
1376 switch (c->op)
1377 {
1378 case EXEC_END_PROCEDURE:
1379 break;
1380
1381 case EXEC_NOP:
1382 fputs ("NOP", dumpfile);
1383 break;
1384
1385 case EXEC_CONTINUE:
1386 fputs ("CONTINUE", dumpfile);
1387 break;
1388
1389 case EXEC_ENTRY:
1390 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1391 break;
1392
1393 case EXEC_INIT_ASSIGN:
1394 case EXEC_ASSIGN:
1395 fputs ("ASSIGN ", dumpfile);
1396 show_expr (c->expr1);
1397 fputc (' ', dumpfile);
1398 show_expr (c->expr2);
1399 break;
1400
1401 case EXEC_LABEL_ASSIGN:
1402 fputs ("LABEL ASSIGN ", dumpfile);
1403 show_expr (c->expr1);
1404 fprintf (dumpfile, " %d", c->label1->value);
1405 break;
1406
1407 case EXEC_POINTER_ASSIGN:
1408 fputs ("POINTER ASSIGN ", dumpfile);
1409 show_expr (c->expr1);
1410 fputc (' ', dumpfile);
1411 show_expr (c->expr2);
1412 break;
1413
1414 case EXEC_GOTO:
1415 fputs ("GOTO ", dumpfile);
1416 if (c->label1)
1417 fprintf (dumpfile, "%d", c->label1->value);
1418 else
1419 {
1420 show_expr (c->expr1);
1421 d = c->block;
1422 if (d != NULL)
1423 {
1424 fputs (", (", dumpfile);
1425 for (; d; d = d ->block)
1426 {
1427 code_indent (level, d->label1);
1428 if (d->block != NULL)
1429 fputc (',', dumpfile);
1430 else
1431 fputc (')', dumpfile);
1432 }
1433 }
1434 }
1435 break;
1436
1437 case EXEC_CALL:
1438 case EXEC_ASSIGN_CALL:
1439 if (c->resolved_sym)
1440 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1441 else if (c->symtree)
1442 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1443 else
1444 fputs ("CALL ?? ", dumpfile);
1445
1446 show_actual_arglist (c->ext.actual);
1447 break;
1448
1449 case EXEC_COMPCALL:
1450 fputs ("CALL ", dumpfile);
1451 show_compcall (c->expr1);
1452 break;
1453
1454 case EXEC_CALL_PPC:
1455 fputs ("CALL ", dumpfile);
1456 show_expr (c->expr1);
1457 show_actual_arglist (c->ext.actual);
1458 break;
1459
1460 case EXEC_RETURN:
1461 fputs ("RETURN ", dumpfile);
1462 if (c->expr1)
1463 show_expr (c->expr1);
1464 break;
1465
1466 case EXEC_PAUSE:
1467 fputs ("PAUSE ", dumpfile);
1468
1469 if (c->expr1 != NULL)
1470 show_expr (c->expr1);
1471 else
1472 fprintf (dumpfile, "%d", c->ext.stop_code);
1473
1474 break;
1475
1476 case EXEC_ERROR_STOP:
1477 fputs ("ERROR ", dumpfile);
1478 /* Fall through. */
1479
1480 case EXEC_STOP:
1481 fputs ("STOP ", dumpfile);
1482
1483 if (c->expr1 != NULL)
1484 show_expr (c->expr1);
1485 else
1486 fprintf (dumpfile, "%d", c->ext.stop_code);
1487
1488 break;
1489
1490 case EXEC_SYNC_ALL:
1491 fputs ("SYNC ALL ", dumpfile);
1492 if (c->expr2 != NULL)
1493 {
1494 fputs (" stat=", dumpfile);
1495 show_expr (c->expr2);
1496 }
1497 if (c->expr3 != NULL)
1498 {
1499 fputs (" errmsg=", dumpfile);
1500 show_expr (c->expr3);
1501 }
1502 break;
1503
1504 case EXEC_SYNC_MEMORY:
1505 fputs ("SYNC MEMORY ", dumpfile);
1506 if (c->expr2 != NULL)
1507 {
1508 fputs (" stat=", dumpfile);
1509 show_expr (c->expr2);
1510 }
1511 if (c->expr3 != NULL)
1512 {
1513 fputs (" errmsg=", dumpfile);
1514 show_expr (c->expr3);
1515 }
1516 break;
1517
1518 case EXEC_SYNC_IMAGES:
1519 fputs ("SYNC IMAGES image-set=", dumpfile);
1520 if (c->expr1 != NULL)
1521 show_expr (c->expr1);
1522 else
1523 fputs ("* ", dumpfile);
1524 if (c->expr2 != NULL)
1525 {
1526 fputs (" stat=", dumpfile);
1527 show_expr (c->expr2);
1528 }
1529 if (c->expr3 != NULL)
1530 {
1531 fputs (" errmsg=", dumpfile);
1532 show_expr (c->expr3);
1533 }
1534 break;
1535
1536 case EXEC_LOCK:
1537 case EXEC_UNLOCK:
1538 if (c->op == EXEC_LOCK)
1539 fputs ("LOCK ", dumpfile);
1540 else
1541 fputs ("UNLOCK ", dumpfile);
1542
1543 fputs ("lock-variable=", dumpfile);
1544 if (c->expr1 != NULL)
1545 show_expr (c->expr1);
1546 if (c->expr4 != NULL)
1547 {
1548 fputs (" acquired_lock=", dumpfile);
1549 show_expr (c->expr4);
1550 }
1551 if (c->expr2 != NULL)
1552 {
1553 fputs (" stat=", dumpfile);
1554 show_expr (c->expr2);
1555 }
1556 if (c->expr3 != NULL)
1557 {
1558 fputs (" errmsg=", dumpfile);
1559 show_expr (c->expr3);
1560 }
1561 break;
1562
1563 case EXEC_ARITHMETIC_IF:
1564 fputs ("IF ", dumpfile);
1565 show_expr (c->expr1);
1566 fprintf (dumpfile, " %d, %d, %d",
1567 c->label1->value, c->label2->value, c->label3->value);
1568 break;
1569
1570 case EXEC_IF:
1571 d = c->block;
1572 fputs ("IF ", dumpfile);
1573 show_expr (d->expr1);
1574
1575 ++show_level;
1576 show_code (level + 1, d->next);
1577 --show_level;
1578
1579 d = d->block;
1580 for (; d; d = d->block)
1581 {
1582 code_indent (level, 0);
1583
1584 if (d->expr1 == NULL)
1585 fputs ("ELSE", dumpfile);
1586 else
1587 {
1588 fputs ("ELSE IF ", dumpfile);
1589 show_expr (d->expr1);
1590 }
1591
1592 ++show_level;
1593 show_code (level + 1, d->next);
1594 --show_level;
1595 }
1596
1597 if (c->label1)
1598 code_indent (level, c->label1);
1599 else
1600 show_indent ();
1601
1602 fputs ("ENDIF", dumpfile);
1603 break;
1604
1605 case EXEC_BLOCK:
1606 {
1607 const char* blocktype;
1608 gfc_namespace *saved_ns;
1609
1610 if (c->ext.block.assoc)
1611 blocktype = "ASSOCIATE";
1612 else
1613 blocktype = "BLOCK";
1614 show_indent ();
1615 fprintf (dumpfile, "%s ", blocktype);
1616 ++show_level;
1617 ns = c->ext.block.ns;
1618 saved_ns = gfc_current_ns;
1619 gfc_current_ns = ns;
1620 gfc_traverse_symtree (ns->sym_root, show_symtree);
1621 gfc_current_ns = saved_ns;
1622 show_code (show_level, ns->code);
1623 --show_level;
1624 show_indent ();
1625 fprintf (dumpfile, "END %s ", blocktype);
1626 break;
1627 }
1628
1629 case EXEC_SELECT:
1630 d = c->block;
1631 fputs ("SELECT CASE ", dumpfile);
1632 show_expr (c->expr1);
1633 fputc ('\n', dumpfile);
1634
1635 for (; d; d = d->block)
1636 {
1637 code_indent (level, 0);
1638
1639 fputs ("CASE ", dumpfile);
1640 for (cp = d->ext.block.case_list; cp; cp = cp->next)
1641 {
1642 fputc ('(', dumpfile);
1643 show_expr (cp->low);
1644 fputc (' ', dumpfile);
1645 show_expr (cp->high);
1646 fputc (')', dumpfile);
1647 fputc (' ', dumpfile);
1648 }
1649 fputc ('\n', dumpfile);
1650
1651 show_code (level + 1, d->next);
1652 }
1653
1654 code_indent (level, c->label1);
1655 fputs ("END SELECT", dumpfile);
1656 break;
1657
1658 case EXEC_WHERE:
1659 fputs ("WHERE ", dumpfile);
1660
1661 d = c->block;
1662 show_expr (d->expr1);
1663 fputc ('\n', dumpfile);
1664
1665 show_code (level + 1, d->next);
1666
1667 for (d = d->block; d; d = d->block)
1668 {
1669 code_indent (level, 0);
1670 fputs ("ELSE WHERE ", dumpfile);
1671 show_expr (d->expr1);
1672 fputc ('\n', dumpfile);
1673 show_code (level + 1, d->next);
1674 }
1675
1676 code_indent (level, 0);
1677 fputs ("END WHERE", dumpfile);
1678 break;
1679
1680
1681 case EXEC_FORALL:
1682 fputs ("FORALL ", dumpfile);
1683 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1684 {
1685 show_expr (fa->var);
1686 fputc (' ', dumpfile);
1687 show_expr (fa->start);
1688 fputc (':', dumpfile);
1689 show_expr (fa->end);
1690 fputc (':', dumpfile);
1691 show_expr (fa->stride);
1692
1693 if (fa->next != NULL)
1694 fputc (',', dumpfile);
1695 }
1696
1697 if (c->expr1 != NULL)
1698 {
1699 fputc (',', dumpfile);
1700 show_expr (c->expr1);
1701 }
1702 fputc ('\n', dumpfile);
1703
1704 show_code (level + 1, c->block->next);
1705
1706 code_indent (level, 0);
1707 fputs ("END FORALL", dumpfile);
1708 break;
1709
1710 case EXEC_CRITICAL:
1711 fputs ("CRITICAL\n", dumpfile);
1712 show_code (level + 1, c->block->next);
1713 code_indent (level, 0);
1714 fputs ("END CRITICAL", dumpfile);
1715 break;
1716
1717 case EXEC_DO:
1718 fputs ("DO ", dumpfile);
1719 if (c->label1)
1720 fprintf (dumpfile, " %-5d ", c->label1->value);
1721
1722 show_expr (c->ext.iterator->var);
1723 fputc ('=', dumpfile);
1724 show_expr (c->ext.iterator->start);
1725 fputc (' ', dumpfile);
1726 show_expr (c->ext.iterator->end);
1727 fputc (' ', dumpfile);
1728 show_expr (c->ext.iterator->step);
1729
1730 ++show_level;
1731 show_code (level + 1, c->block->next);
1732 --show_level;
1733
1734 if (c->label1)
1735 break;
1736
1737 show_indent ();
1738 fputs ("END DO", dumpfile);
1739 break;
1740
1741 case EXEC_DO_CONCURRENT:
1742 fputs ("DO CONCURRENT ", dumpfile);
1743 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1744 {
1745 show_expr (fa->var);
1746 fputc (' ', dumpfile);
1747 show_expr (fa->start);
1748 fputc (':', dumpfile);
1749 show_expr (fa->end);
1750 fputc (':', dumpfile);
1751 show_expr (fa->stride);
1752
1753 if (fa->next != NULL)
1754 fputc (',', dumpfile);
1755 }
1756 show_expr (c->expr1);
1757
1758 show_code (level + 1, c->block->next);
1759 code_indent (level, c->label1);
1760 fputs ("END DO", dumpfile);
1761 break;
1762
1763 case EXEC_DO_WHILE:
1764 fputs ("DO WHILE ", dumpfile);
1765 show_expr (c->expr1);
1766 fputc ('\n', dumpfile);
1767
1768 show_code (level + 1, c->block->next);
1769
1770 code_indent (level, c->label1);
1771 fputs ("END DO", dumpfile);
1772 break;
1773
1774 case EXEC_CYCLE:
1775 fputs ("CYCLE", dumpfile);
1776 if (c->symtree)
1777 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1778 break;
1779
1780 case EXEC_EXIT:
1781 fputs ("EXIT", dumpfile);
1782 if (c->symtree)
1783 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1784 break;
1785
1786 case EXEC_ALLOCATE:
1787 fputs ("ALLOCATE ", dumpfile);
1788 if (c->expr1)
1789 {
1790 fputs (" STAT=", dumpfile);
1791 show_expr (c->expr1);
1792 }
1793
1794 if (c->expr2)
1795 {
1796 fputs (" ERRMSG=", dumpfile);
1797 show_expr (c->expr2);
1798 }
1799
1800 if (c->expr3)
1801 {
1802 if (c->expr3->mold)
1803 fputs (" MOLD=", dumpfile);
1804 else
1805 fputs (" SOURCE=", dumpfile);
1806 show_expr (c->expr3);
1807 }
1808
1809 for (a = c->ext.alloc.list; a; a = a->next)
1810 {
1811 fputc (' ', dumpfile);
1812 show_expr (a->expr);
1813 }
1814
1815 break;
1816
1817 case EXEC_DEALLOCATE:
1818 fputs ("DEALLOCATE ", dumpfile);
1819 if (c->expr1)
1820 {
1821 fputs (" STAT=", dumpfile);
1822 show_expr (c->expr1);
1823 }
1824
1825 if (c->expr2)
1826 {
1827 fputs (" ERRMSG=", dumpfile);
1828 show_expr (c->expr2);
1829 }
1830
1831 for (a = c->ext.alloc.list; a; a = a->next)
1832 {
1833 fputc (' ', dumpfile);
1834 show_expr (a->expr);
1835 }
1836
1837 break;
1838
1839 case EXEC_OPEN:
1840 fputs ("OPEN", dumpfile);
1841 open = c->ext.open;
1842
1843 if (open->unit)
1844 {
1845 fputs (" UNIT=", dumpfile);
1846 show_expr (open->unit);
1847 }
1848 if (open->iomsg)
1849 {
1850 fputs (" IOMSG=", dumpfile);
1851 show_expr (open->iomsg);
1852 }
1853 if (open->iostat)
1854 {
1855 fputs (" IOSTAT=", dumpfile);
1856 show_expr (open->iostat);
1857 }
1858 if (open->file)
1859 {
1860 fputs (" FILE=", dumpfile);
1861 show_expr (open->file);
1862 }
1863 if (open->status)
1864 {
1865 fputs (" STATUS=", dumpfile);
1866 show_expr (open->status);
1867 }
1868 if (open->access)
1869 {
1870 fputs (" ACCESS=", dumpfile);
1871 show_expr (open->access);
1872 }
1873 if (open->form)
1874 {
1875 fputs (" FORM=", dumpfile);
1876 show_expr (open->form);
1877 }
1878 if (open->recl)
1879 {
1880 fputs (" RECL=", dumpfile);
1881 show_expr (open->recl);
1882 }
1883 if (open->blank)
1884 {
1885 fputs (" BLANK=", dumpfile);
1886 show_expr (open->blank);
1887 }
1888 if (open->position)
1889 {
1890 fputs (" POSITION=", dumpfile);
1891 show_expr (open->position);
1892 }
1893 if (open->action)
1894 {
1895 fputs (" ACTION=", dumpfile);
1896 show_expr (open->action);
1897 }
1898 if (open->delim)
1899 {
1900 fputs (" DELIM=", dumpfile);
1901 show_expr (open->delim);
1902 }
1903 if (open->pad)
1904 {
1905 fputs (" PAD=", dumpfile);
1906 show_expr (open->pad);
1907 }
1908 if (open->decimal)
1909 {
1910 fputs (" DECIMAL=", dumpfile);
1911 show_expr (open->decimal);
1912 }
1913 if (open->encoding)
1914 {
1915 fputs (" ENCODING=", dumpfile);
1916 show_expr (open->encoding);
1917 }
1918 if (open->round)
1919 {
1920 fputs (" ROUND=", dumpfile);
1921 show_expr (open->round);
1922 }
1923 if (open->sign)
1924 {
1925 fputs (" SIGN=", dumpfile);
1926 show_expr (open->sign);
1927 }
1928 if (open->convert)
1929 {
1930 fputs (" CONVERT=", dumpfile);
1931 show_expr (open->convert);
1932 }
1933 if (open->asynchronous)
1934 {
1935 fputs (" ASYNCHRONOUS=", dumpfile);
1936 show_expr (open->asynchronous);
1937 }
1938 if (open->err != NULL)
1939 fprintf (dumpfile, " ERR=%d", open->err->value);
1940
1941 break;
1942
1943 case EXEC_CLOSE:
1944 fputs ("CLOSE", dumpfile);
1945 close = c->ext.close;
1946
1947 if (close->unit)
1948 {
1949 fputs (" UNIT=", dumpfile);
1950 show_expr (close->unit);
1951 }
1952 if (close->iomsg)
1953 {
1954 fputs (" IOMSG=", dumpfile);
1955 show_expr (close->iomsg);
1956 }
1957 if (close->iostat)
1958 {
1959 fputs (" IOSTAT=", dumpfile);
1960 show_expr (close->iostat);
1961 }
1962 if (close->status)
1963 {
1964 fputs (" STATUS=", dumpfile);
1965 show_expr (close->status);
1966 }
1967 if (close->err != NULL)
1968 fprintf (dumpfile, " ERR=%d", close->err->value);
1969 break;
1970
1971 case EXEC_BACKSPACE:
1972 fputs ("BACKSPACE", dumpfile);
1973 goto show_filepos;
1974
1975 case EXEC_ENDFILE:
1976 fputs ("ENDFILE", dumpfile);
1977 goto show_filepos;
1978
1979 case EXEC_REWIND:
1980 fputs ("REWIND", dumpfile);
1981 goto show_filepos;
1982
1983 case EXEC_FLUSH:
1984 fputs ("FLUSH", dumpfile);
1985
1986 show_filepos:
1987 fp = c->ext.filepos;
1988
1989 if (fp->unit)
1990 {
1991 fputs (" UNIT=", dumpfile);
1992 show_expr (fp->unit);
1993 }
1994 if (fp->iomsg)
1995 {
1996 fputs (" IOMSG=", dumpfile);
1997 show_expr (fp->iomsg);
1998 }
1999 if (fp->iostat)
2000 {
2001 fputs (" IOSTAT=", dumpfile);
2002 show_expr (fp->iostat);
2003 }
2004 if (fp->err != NULL)
2005 fprintf (dumpfile, " ERR=%d", fp->err->value);
2006 break;
2007
2008 case EXEC_INQUIRE:
2009 fputs ("INQUIRE", dumpfile);
2010 i = c->ext.inquire;
2011
2012 if (i->unit)
2013 {
2014 fputs (" UNIT=", dumpfile);
2015 show_expr (i->unit);
2016 }
2017 if (i->file)
2018 {
2019 fputs (" FILE=", dumpfile);
2020 show_expr (i->file);
2021 }
2022
2023 if (i->iomsg)
2024 {
2025 fputs (" IOMSG=", dumpfile);
2026 show_expr (i->iomsg);
2027 }
2028 if (i->iostat)
2029 {
2030 fputs (" IOSTAT=", dumpfile);
2031 show_expr (i->iostat);
2032 }
2033 if (i->exist)
2034 {
2035 fputs (" EXIST=", dumpfile);
2036 show_expr (i->exist);
2037 }
2038 if (i->opened)
2039 {
2040 fputs (" OPENED=", dumpfile);
2041 show_expr (i->opened);
2042 }
2043 if (i->number)
2044 {
2045 fputs (" NUMBER=", dumpfile);
2046 show_expr (i->number);
2047 }
2048 if (i->named)
2049 {
2050 fputs (" NAMED=", dumpfile);
2051 show_expr (i->named);
2052 }
2053 if (i->name)
2054 {
2055 fputs (" NAME=", dumpfile);
2056 show_expr (i->name);
2057 }
2058 if (i->access)
2059 {
2060 fputs (" ACCESS=", dumpfile);
2061 show_expr (i->access);
2062 }
2063 if (i->sequential)
2064 {
2065 fputs (" SEQUENTIAL=", dumpfile);
2066 show_expr (i->sequential);
2067 }
2068
2069 if (i->direct)
2070 {
2071 fputs (" DIRECT=", dumpfile);
2072 show_expr (i->direct);
2073 }
2074 if (i->form)
2075 {
2076 fputs (" FORM=", dumpfile);
2077 show_expr (i->form);
2078 }
2079 if (i->formatted)
2080 {
2081 fputs (" FORMATTED", dumpfile);
2082 show_expr (i->formatted);
2083 }
2084 if (i->unformatted)
2085 {
2086 fputs (" UNFORMATTED=", dumpfile);
2087 show_expr (i->unformatted);
2088 }
2089 if (i->recl)
2090 {
2091 fputs (" RECL=", dumpfile);
2092 show_expr (i->recl);
2093 }
2094 if (i->nextrec)
2095 {
2096 fputs (" NEXTREC=", dumpfile);
2097 show_expr (i->nextrec);
2098 }
2099 if (i->blank)
2100 {
2101 fputs (" BLANK=", dumpfile);
2102 show_expr (i->blank);
2103 }
2104 if (i->position)
2105 {
2106 fputs (" POSITION=", dumpfile);
2107 show_expr (i->position);
2108 }
2109 if (i->action)
2110 {
2111 fputs (" ACTION=", dumpfile);
2112 show_expr (i->action);
2113 }
2114 if (i->read)
2115 {
2116 fputs (" READ=", dumpfile);
2117 show_expr (i->read);
2118 }
2119 if (i->write)
2120 {
2121 fputs (" WRITE=", dumpfile);
2122 show_expr (i->write);
2123 }
2124 if (i->readwrite)
2125 {
2126 fputs (" READWRITE=", dumpfile);
2127 show_expr (i->readwrite);
2128 }
2129 if (i->delim)
2130 {
2131 fputs (" DELIM=", dumpfile);
2132 show_expr (i->delim);
2133 }
2134 if (i->pad)
2135 {
2136 fputs (" PAD=", dumpfile);
2137 show_expr (i->pad);
2138 }
2139 if (i->convert)
2140 {
2141 fputs (" CONVERT=", dumpfile);
2142 show_expr (i->convert);
2143 }
2144 if (i->asynchronous)
2145 {
2146 fputs (" ASYNCHRONOUS=", dumpfile);
2147 show_expr (i->asynchronous);
2148 }
2149 if (i->decimal)
2150 {
2151 fputs (" DECIMAL=", dumpfile);
2152 show_expr (i->decimal);
2153 }
2154 if (i->encoding)
2155 {
2156 fputs (" ENCODING=", dumpfile);
2157 show_expr (i->encoding);
2158 }
2159 if (i->pending)
2160 {
2161 fputs (" PENDING=", dumpfile);
2162 show_expr (i->pending);
2163 }
2164 if (i->round)
2165 {
2166 fputs (" ROUND=", dumpfile);
2167 show_expr (i->round);
2168 }
2169 if (i->sign)
2170 {
2171 fputs (" SIGN=", dumpfile);
2172 show_expr (i->sign);
2173 }
2174 if (i->size)
2175 {
2176 fputs (" SIZE=", dumpfile);
2177 show_expr (i->size);
2178 }
2179 if (i->id)
2180 {
2181 fputs (" ID=", dumpfile);
2182 show_expr (i->id);
2183 }
2184
2185 if (i->err != NULL)
2186 fprintf (dumpfile, " ERR=%d", i->err->value);
2187 break;
2188
2189 case EXEC_IOLENGTH:
2190 fputs ("IOLENGTH ", dumpfile);
2191 show_expr (c->expr1);
2192 goto show_dt_code;
2193 break;
2194
2195 case EXEC_READ:
2196 fputs ("READ", dumpfile);
2197 goto show_dt;
2198
2199 case EXEC_WRITE:
2200 fputs ("WRITE", dumpfile);
2201
2202 show_dt:
2203 dt = c->ext.dt;
2204 if (dt->io_unit)
2205 {
2206 fputs (" UNIT=", dumpfile);
2207 show_expr (dt->io_unit);
2208 }
2209
2210 if (dt->format_expr)
2211 {
2212 fputs (" FMT=", dumpfile);
2213 show_expr (dt->format_expr);
2214 }
2215
2216 if (dt->format_label != NULL)
2217 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
2218 if (dt->namelist)
2219 fprintf (dumpfile, " NML=%s", dt->namelist->name);
2220
2221 if (dt->iomsg)
2222 {
2223 fputs (" IOMSG=", dumpfile);
2224 show_expr (dt->iomsg);
2225 }
2226 if (dt->iostat)
2227 {
2228 fputs (" IOSTAT=", dumpfile);
2229 show_expr (dt->iostat);
2230 }
2231 if (dt->size)
2232 {
2233 fputs (" SIZE=", dumpfile);
2234 show_expr (dt->size);
2235 }
2236 if (dt->rec)
2237 {
2238 fputs (" REC=", dumpfile);
2239 show_expr (dt->rec);
2240 }
2241 if (dt->advance)
2242 {
2243 fputs (" ADVANCE=", dumpfile);
2244 show_expr (dt->advance);
2245 }
2246 if (dt->id)
2247 {
2248 fputs (" ID=", dumpfile);
2249 show_expr (dt->id);
2250 }
2251 if (dt->pos)
2252 {
2253 fputs (" POS=", dumpfile);
2254 show_expr (dt->pos);
2255 }
2256 if (dt->asynchronous)
2257 {
2258 fputs (" ASYNCHRONOUS=", dumpfile);
2259 show_expr (dt->asynchronous);
2260 }
2261 if (dt->blank)
2262 {
2263 fputs (" BLANK=", dumpfile);
2264 show_expr (dt->blank);
2265 }
2266 if (dt->decimal)
2267 {
2268 fputs (" DECIMAL=", dumpfile);
2269 show_expr (dt->decimal);
2270 }
2271 if (dt->delim)
2272 {
2273 fputs (" DELIM=", dumpfile);
2274 show_expr (dt->delim);
2275 }
2276 if (dt->pad)
2277 {
2278 fputs (" PAD=", dumpfile);
2279 show_expr (dt->pad);
2280 }
2281 if (dt->round)
2282 {
2283 fputs (" ROUND=", dumpfile);
2284 show_expr (dt->round);
2285 }
2286 if (dt->sign)
2287 {
2288 fputs (" SIGN=", dumpfile);
2289 show_expr (dt->sign);
2290 }
2291
2292 show_dt_code:
2293 for (c = c->block->next; c; c = c->next)
2294 show_code_node (level + (c->next != NULL), c);
2295 return;
2296
2297 case EXEC_TRANSFER:
2298 fputs ("TRANSFER ", dumpfile);
2299 show_expr (c->expr1);
2300 break;
2301
2302 case EXEC_DT_END:
2303 fputs ("DT_END", dumpfile);
2304 dt = c->ext.dt;
2305
2306 if (dt->err != NULL)
2307 fprintf (dumpfile, " ERR=%d", dt->err->value);
2308 if (dt->end != NULL)
2309 fprintf (dumpfile, " END=%d", dt->end->value);
2310 if (dt->eor != NULL)
2311 fprintf (dumpfile, " EOR=%d", dt->eor->value);
2312 break;
2313
2314 case EXEC_OMP_ATOMIC:
2315 case EXEC_OMP_CANCEL:
2316 case EXEC_OMP_CANCELLATION_POINT:
2317 case EXEC_OMP_BARRIER:
2318 case EXEC_OMP_CRITICAL:
2319 case EXEC_OMP_FLUSH:
2320 case EXEC_OMP_DO:
2321 case EXEC_OMP_DO_SIMD:
2322 case EXEC_OMP_MASTER:
2323 case EXEC_OMP_ORDERED:
2324 case EXEC_OMP_PARALLEL:
2325 case EXEC_OMP_PARALLEL_DO:
2326 case EXEC_OMP_PARALLEL_DO_SIMD:
2327 case EXEC_OMP_PARALLEL_SECTIONS:
2328 case EXEC_OMP_PARALLEL_WORKSHARE:
2329 case EXEC_OMP_SECTIONS:
2330 case EXEC_OMP_SIMD:
2331 case EXEC_OMP_SINGLE:
2332 case EXEC_OMP_TASK:
2333 case EXEC_OMP_TASKGROUP:
2334 case EXEC_OMP_TASKWAIT:
2335 case EXEC_OMP_TASKYIELD:
2336 case EXEC_OMP_WORKSHARE:
2337 show_omp_node (level, c);
2338 break;
2339
2340 default:
2341 gfc_internal_error ("show_code_node(): Bad statement code");
2342 }
2343 }
2344
2345
2346 /* Show an equivalence chain. */
2347
2348 static void
2349 show_equiv (gfc_equiv *eq)
2350 {
2351 show_indent ();
2352 fputs ("Equivalence: ", dumpfile);
2353 while (eq)
2354 {
2355 show_expr (eq->expr);
2356 eq = eq->eq;
2357 if (eq)
2358 fputs (", ", dumpfile);
2359 }
2360 }
2361
2362
2363 /* Show a freakin' whole namespace. */
2364
2365 static void
2366 show_namespace (gfc_namespace *ns)
2367 {
2368 gfc_interface *intr;
2369 gfc_namespace *save;
2370 int op;
2371 gfc_equiv *eq;
2372 int i;
2373
2374 gcc_assert (ns);
2375 save = gfc_current_ns;
2376
2377 show_indent ();
2378 fputs ("Namespace:", dumpfile);
2379
2380 i = 0;
2381 do
2382 {
2383 int l = i;
2384 while (i < GFC_LETTERS - 1
2385 && gfc_compare_types (&ns->default_type[i+1],
2386 &ns->default_type[l]))
2387 i++;
2388
2389 if (i > l)
2390 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2391 else
2392 fprintf (dumpfile, " %c: ", l+'A');
2393
2394 show_typespec(&ns->default_type[l]);
2395 i++;
2396 } while (i < GFC_LETTERS);
2397
2398 if (ns->proc_name != NULL)
2399 {
2400 show_indent ();
2401 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2402 }
2403
2404 ++show_level;
2405 gfc_current_ns = ns;
2406 gfc_traverse_symtree (ns->common_root, show_common);
2407
2408 gfc_traverse_symtree (ns->sym_root, show_symtree);
2409
2410 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2411 {
2412 /* User operator interfaces */
2413 intr = ns->op[op];
2414 if (intr == NULL)
2415 continue;
2416
2417 show_indent ();
2418 fprintf (dumpfile, "Operator interfaces for %s:",
2419 gfc_op2string ((gfc_intrinsic_op) op));
2420
2421 for (; intr; intr = intr->next)
2422 fprintf (dumpfile, " %s", intr->sym->name);
2423 }
2424
2425 if (ns->uop_root != NULL)
2426 {
2427 show_indent ();
2428 fputs ("User operators:\n", dumpfile);
2429 gfc_traverse_user_op (ns, show_uop);
2430 }
2431
2432 for (eq = ns->equiv; eq; eq = eq->next)
2433 show_equiv (eq);
2434
2435 fputc ('\n', dumpfile);
2436 show_indent ();
2437 fputs ("code:", dumpfile);
2438 show_code (show_level, ns->code);
2439 --show_level;
2440
2441 for (ns = ns->contained; ns; ns = ns->sibling)
2442 {
2443 fputs ("\nCONTAINS\n", dumpfile);
2444 ++show_level;
2445 show_namespace (ns);
2446 --show_level;
2447 }
2448
2449 fputc ('\n', dumpfile);
2450 gfc_current_ns = save;
2451 }
2452
2453
2454 /* Main function for dumping a parse tree. */
2455
2456 void
2457 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2458 {
2459 dumpfile = file;
2460 show_namespace (ns);
2461 }
2462
Mirror of the offical gcc git repository hosted at gcc.gnu.org