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