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