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