?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Make argv const char ** in read_md_files etc
[official-gcc.git] / gcc / fortran / dump-parse-tree.c
blob8d50d75fcf657c8af1e531f7b11a88f71728baef
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 gfc_association_list *alist;
1777
1778 if (c->ext.block.assoc)
1779 blocktype = "ASSOCIATE";
1780 else
1781 blocktype = "BLOCK";
1782 show_indent ();
1783 fprintf (dumpfile, "%s ", blocktype);
1784 for (alist = c->ext.block.assoc; alist; alist = alist->next)
1785 {
1786 fprintf (dumpfile, " %s = ", alist->name);
1787 show_expr (alist->target);
1788 }
1789
1790 ++show_level;
1791 ns = c->ext.block.ns;
1792 saved_ns = gfc_current_ns;
1793 gfc_current_ns = ns;
1794 gfc_traverse_symtree (ns->sym_root, show_symtree);
1795 gfc_current_ns = saved_ns;
1796 show_code (show_level, ns->code);
1797 --show_level;
1798 show_indent ();
1799 fprintf (dumpfile, "END %s ", blocktype);
1800 break;
1801 }
1802
1803 case EXEC_END_BLOCK:
1804 /* Only come here when there is a label on an
1805 END ASSOCIATE construct. */
1806 break;
1807
1808 case EXEC_SELECT:
1809 d = c->block;
1810 fputs ("SELECT CASE ", dumpfile);
1811 show_expr (c->expr1);
1812 fputc ('\n', dumpfile);
1813
1814 for (; d; d = d->block)
1815 {
1816 code_indent (level, 0);
1817
1818 fputs ("CASE ", dumpfile);
1819 for (cp = d->ext.block.case_list; cp; cp = cp->next)
1820 {
1821 fputc ('(', dumpfile);
1822 show_expr (cp->low);
1823 fputc (' ', dumpfile);
1824 show_expr (cp->high);
1825 fputc (')', dumpfile);
1826 fputc (' ', dumpfile);
1827 }
1828 fputc ('\n', dumpfile);
1829
1830 show_code (level + 1, d->next);
1831 }
1832
1833 code_indent (level, c->label1);
1834 fputs ("END SELECT", dumpfile);
1835 break;
1836
1837 case EXEC_WHERE:
1838 fputs ("WHERE ", dumpfile);
1839
1840 d = c->block;
1841 show_expr (d->expr1);
1842 fputc ('\n', dumpfile);
1843
1844 show_code (level + 1, d->next);
1845
1846 for (d = d->block; d; d = d->block)
1847 {
1848 code_indent (level, 0);
1849 fputs ("ELSE WHERE ", dumpfile);
1850 show_expr (d->expr1);
1851 fputc ('\n', dumpfile);
1852 show_code (level + 1, d->next);
1853 }
1854
1855 code_indent (level, 0);
1856 fputs ("END WHERE", dumpfile);
1857 break;
1858
1859
1860 case EXEC_FORALL:
1861 fputs ("FORALL ", dumpfile);
1862 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1863 {
1864 show_expr (fa->var);
1865 fputc (' ', dumpfile);
1866 show_expr (fa->start);
1867 fputc (':', dumpfile);
1868 show_expr (fa->end);
1869 fputc (':', dumpfile);
1870 show_expr (fa->stride);
1871
1872 if (fa->next != NULL)
1873 fputc (',', dumpfile);
1874 }
1875
1876 if (c->expr1 != NULL)
1877 {
1878 fputc (',', dumpfile);
1879 show_expr (c->expr1);
1880 }
1881 fputc ('\n', dumpfile);
1882
1883 show_code (level + 1, c->block->next);
1884
1885 code_indent (level, 0);
1886 fputs ("END FORALL", dumpfile);
1887 break;
1888
1889 case EXEC_CRITICAL:
1890 fputs ("CRITICAL\n", dumpfile);
1891 show_code (level + 1, c->block->next);
1892 code_indent (level, 0);
1893 fputs ("END CRITICAL", dumpfile);
1894 break;
1895
1896 case EXEC_DO:
1897 fputs ("DO ", dumpfile);
1898 if (c->label1)
1899 fprintf (dumpfile, " %-5d ", c->label1->value);
1900
1901 show_expr (c->ext.iterator->var);
1902 fputc ('=', dumpfile);
1903 show_expr (c->ext.iterator->start);
1904 fputc (' ', dumpfile);
1905 show_expr (c->ext.iterator->end);
1906 fputc (' ', dumpfile);
1907 show_expr (c->ext.iterator->step);
1908
1909 ++show_level;
1910 show_code (level + 1, c->block->next);
1911 --show_level;
1912
1913 if (c->label1)
1914 break;
1915
1916 show_indent ();
1917 fputs ("END DO", dumpfile);
1918 break;
1919
1920 case EXEC_DO_CONCURRENT:
1921 fputs ("DO CONCURRENT ", dumpfile);
1922 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1923 {
1924 show_expr (fa->var);
1925 fputc (' ', dumpfile);
1926 show_expr (fa->start);
1927 fputc (':', dumpfile);
1928 show_expr (fa->end);
1929 fputc (':', dumpfile);
1930 show_expr (fa->stride);
1931
1932 if (fa->next != NULL)
1933 fputc (',', dumpfile);
1934 }
1935 show_expr (c->expr1);
1936
1937 show_code (level + 1, c->block->next);
1938 code_indent (level, c->label1);
1939 fputs ("END DO", dumpfile);
1940 break;
1941
1942 case EXEC_DO_WHILE:
1943 fputs ("DO WHILE ", dumpfile);
1944 show_expr (c->expr1);
1945 fputc ('\n', dumpfile);
1946
1947 show_code (level + 1, c->block->next);
1948
1949 code_indent (level, c->label1);
1950 fputs ("END DO", dumpfile);
1951 break;
1952
1953 case EXEC_CYCLE:
1954 fputs ("CYCLE", dumpfile);
1955 if (c->symtree)
1956 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1957 break;
1958
1959 case EXEC_EXIT:
1960 fputs ("EXIT", dumpfile);
1961 if (c->symtree)
1962 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1963 break;
1964
1965 case EXEC_ALLOCATE:
1966 fputs ("ALLOCATE ", dumpfile);
1967 if (c->expr1)
1968 {
1969 fputs (" STAT=", dumpfile);
1970 show_expr (c->expr1);
1971 }
1972
1973 if (c->expr2)
1974 {
1975 fputs (" ERRMSG=", dumpfile);
1976 show_expr (c->expr2);
1977 }
1978
1979 if (c->expr3)
1980 {
1981 if (c->expr3->mold)
1982 fputs (" MOLD=", dumpfile);
1983 else
1984 fputs (" SOURCE=", dumpfile);
1985 show_expr (c->expr3);
1986 }
1987
1988 for (a = c->ext.alloc.list; a; a = a->next)
1989 {
1990 fputc (' ', dumpfile);
1991 show_expr (a->expr);
1992 }
1993
1994 break;
1995
1996 case EXEC_DEALLOCATE:
1997 fputs ("DEALLOCATE ", dumpfile);
1998 if (c->expr1)
1999 {
2000 fputs (" STAT=", dumpfile);
2001 show_expr (c->expr1);
2002 }
2003
2004 if (c->expr2)
2005 {
2006 fputs (" ERRMSG=", dumpfile);
2007 show_expr (c->expr2);
2008 }
2009
2010 for (a = c->ext.alloc.list; a; a = a->next)
2011 {
2012 fputc (' ', dumpfile);
2013 show_expr (a->expr);
2014 }
2015
2016 break;
2017
2018 case EXEC_OPEN:
2019 fputs ("OPEN", dumpfile);
2020 open = c->ext.open;
2021
2022 if (open->unit)
2023 {
2024 fputs (" UNIT=", dumpfile);
2025 show_expr (open->unit);
2026 }
2027 if (open->iomsg)
2028 {
2029 fputs (" IOMSG=", dumpfile);
2030 show_expr (open->iomsg);
2031 }
2032 if (open->iostat)
2033 {
2034 fputs (" IOSTAT=", dumpfile);
2035 show_expr (open->iostat);
2036 }
2037 if (open->file)
2038 {
2039 fputs (" FILE=", dumpfile);
2040 show_expr (open->file);
2041 }
2042 if (open->status)
2043 {
2044 fputs (" STATUS=", dumpfile);
2045 show_expr (open->status);
2046 }
2047 if (open->access)
2048 {
2049 fputs (" ACCESS=", dumpfile);
2050 show_expr (open->access);
2051 }
2052 if (open->form)
2053 {
2054 fputs (" FORM=", dumpfile);
2055 show_expr (open->form);
2056 }
2057 if (open->recl)
2058 {
2059 fputs (" RECL=", dumpfile);
2060 show_expr (open->recl);
2061 }
2062 if (open->blank)
2063 {
2064 fputs (" BLANK=", dumpfile);
2065 show_expr (open->blank);
2066 }
2067 if (open->position)
2068 {
2069 fputs (" POSITION=", dumpfile);
2070 show_expr (open->position);
2071 }
2072 if (open->action)
2073 {
2074 fputs (" ACTION=", dumpfile);
2075 show_expr (open->action);
2076 }
2077 if (open->delim)
2078 {
2079 fputs (" DELIM=", dumpfile);
2080 show_expr (open->delim);
2081 }
2082 if (open->pad)
2083 {
2084 fputs (" PAD=", dumpfile);
2085 show_expr (open->pad);
2086 }
2087 if (open->decimal)
2088 {
2089 fputs (" DECIMAL=", dumpfile);
2090 show_expr (open->decimal);
2091 }
2092 if (open->encoding)
2093 {
2094 fputs (" ENCODING=", dumpfile);
2095 show_expr (open->encoding);
2096 }
2097 if (open->round)
2098 {
2099 fputs (" ROUND=", dumpfile);
2100 show_expr (open->round);
2101 }
2102 if (open->sign)
2103 {
2104 fputs (" SIGN=", dumpfile);
2105 show_expr (open->sign);
2106 }
2107 if (open->convert)
2108 {
2109 fputs (" CONVERT=", dumpfile);
2110 show_expr (open->convert);
2111 }
2112 if (open->asynchronous)
2113 {
2114 fputs (" ASYNCHRONOUS=", dumpfile);
2115 show_expr (open->asynchronous);
2116 }
2117 if (open->err != NULL)
2118 fprintf (dumpfile, " ERR=%d", open->err->value);
2119
2120 break;
2121
2122 case EXEC_CLOSE:
2123 fputs ("CLOSE", dumpfile);
2124 close = c->ext.close;
2125
2126 if (close->unit)
2127 {
2128 fputs (" UNIT=", dumpfile);
2129 show_expr (close->unit);
2130 }
2131 if (close->iomsg)
2132 {
2133 fputs (" IOMSG=", dumpfile);
2134 show_expr (close->iomsg);
2135 }
2136 if (close->iostat)
2137 {
2138 fputs (" IOSTAT=", dumpfile);
2139 show_expr (close->iostat);
2140 }
2141 if (close->status)
2142 {
2143 fputs (" STATUS=", dumpfile);
2144 show_expr (close->status);
2145 }
2146 if (close->err != NULL)
2147 fprintf (dumpfile, " ERR=%d", close->err->value);
2148 break;
2149
2150 case EXEC_BACKSPACE:
2151 fputs ("BACKSPACE", dumpfile);
2152 goto show_filepos;
2153
2154 case EXEC_ENDFILE:
2155 fputs ("ENDFILE", dumpfile);
2156 goto show_filepos;
2157
2158 case EXEC_REWIND:
2159 fputs ("REWIND", dumpfile);
2160 goto show_filepos;
2161
2162 case EXEC_FLUSH:
2163 fputs ("FLUSH", dumpfile);
2164
2165 show_filepos:
2166 fp = c->ext.filepos;
2167
2168 if (fp->unit)
2169 {
2170 fputs (" UNIT=", dumpfile);
2171 show_expr (fp->unit);
2172 }
2173 if (fp->iomsg)
2174 {
2175 fputs (" IOMSG=", dumpfile);
2176 show_expr (fp->iomsg);
2177 }
2178 if (fp->iostat)
2179 {
2180 fputs (" IOSTAT=", dumpfile);
2181 show_expr (fp->iostat);
2182 }
2183 if (fp->err != NULL)
2184 fprintf (dumpfile, " ERR=%d", fp->err->value);
2185 break;
2186
2187 case EXEC_INQUIRE:
2188 fputs ("INQUIRE", dumpfile);
2189 i = c->ext.inquire;
2190
2191 if (i->unit)
2192 {
2193 fputs (" UNIT=", dumpfile);
2194 show_expr (i->unit);
2195 }
2196 if (i->file)
2197 {
2198 fputs (" FILE=", dumpfile);
2199 show_expr (i->file);
2200 }
2201
2202 if (i->iomsg)
2203 {
2204 fputs (" IOMSG=", dumpfile);
2205 show_expr (i->iomsg);
2206 }
2207 if (i->iostat)
2208 {
2209 fputs (" IOSTAT=", dumpfile);
2210 show_expr (i->iostat);
2211 }
2212 if (i->exist)
2213 {
2214 fputs (" EXIST=", dumpfile);
2215 show_expr (i->exist);
2216 }
2217 if (i->opened)
2218 {
2219 fputs (" OPENED=", dumpfile);
2220 show_expr (i->opened);
2221 }
2222 if (i->number)
2223 {
2224 fputs (" NUMBER=", dumpfile);
2225 show_expr (i->number);
2226 }
2227 if (i->named)
2228 {
2229 fputs (" NAMED=", dumpfile);
2230 show_expr (i->named);
2231 }
2232 if (i->name)
2233 {
2234 fputs (" NAME=", dumpfile);
2235 show_expr (i->name);
2236 }
2237 if (i->access)
2238 {
2239 fputs (" ACCESS=", dumpfile);
2240 show_expr (i->access);
2241 }
2242 if (i->sequential)
2243 {
2244 fputs (" SEQUENTIAL=", dumpfile);
2245 show_expr (i->sequential);
2246 }
2247
2248 if (i->direct)
2249 {
2250 fputs (" DIRECT=", dumpfile);
2251 show_expr (i->direct);
2252 }
2253 if (i->form)
2254 {
2255 fputs (" FORM=", dumpfile);
2256 show_expr (i->form);
2257 }
2258 if (i->formatted)
2259 {
2260 fputs (" FORMATTED", dumpfile);
2261 show_expr (i->formatted);
2262 }
2263 if (i->unformatted)
2264 {
2265 fputs (" UNFORMATTED=", dumpfile);
2266 show_expr (i->unformatted);
2267 }
2268 if (i->recl)
2269 {
2270 fputs (" RECL=", dumpfile);
2271 show_expr (i->recl);
2272 }
2273 if (i->nextrec)
2274 {
2275 fputs (" NEXTREC=", dumpfile);
2276 show_expr (i->nextrec);
2277 }
2278 if (i->blank)
2279 {
2280 fputs (" BLANK=", dumpfile);
2281 show_expr (i->blank);
2282 }
2283 if (i->position)
2284 {
2285 fputs (" POSITION=", dumpfile);
2286 show_expr (i->position);
2287 }
2288 if (i->action)
2289 {
2290 fputs (" ACTION=", dumpfile);
2291 show_expr (i->action);
2292 }
2293 if (i->read)
2294 {
2295 fputs (" READ=", dumpfile);
2296 show_expr (i->read);
2297 }
2298 if (i->write)
2299 {
2300 fputs (" WRITE=", dumpfile);
2301 show_expr (i->write);
2302 }
2303 if (i->readwrite)
2304 {
2305 fputs (" READWRITE=", dumpfile);
2306 show_expr (i->readwrite);
2307 }
2308 if (i->delim)
2309 {
2310 fputs (" DELIM=", dumpfile);
2311 show_expr (i->delim);
2312 }
2313 if (i->pad)
2314 {
2315 fputs (" PAD=", dumpfile);
2316 show_expr (i->pad);
2317 }
2318 if (i->convert)
2319 {
2320 fputs (" CONVERT=", dumpfile);
2321 show_expr (i->convert);
2322 }
2323 if (i->asynchronous)
2324 {
2325 fputs (" ASYNCHRONOUS=", dumpfile);
2326 show_expr (i->asynchronous);
2327 }
2328 if (i->decimal)
2329 {
2330 fputs (" DECIMAL=", dumpfile);
2331 show_expr (i->decimal);
2332 }
2333 if (i->encoding)
2334 {
2335 fputs (" ENCODING=", dumpfile);
2336 show_expr (i->encoding);
2337 }
2338 if (i->pending)
2339 {
2340 fputs (" PENDING=", dumpfile);
2341 show_expr (i->pending);
2342 }
2343 if (i->round)
2344 {
2345 fputs (" ROUND=", dumpfile);
2346 show_expr (i->round);
2347 }
2348 if (i->sign)
2349 {
2350 fputs (" SIGN=", dumpfile);
2351 show_expr (i->sign);
2352 }
2353 if (i->size)
2354 {
2355 fputs (" SIZE=", dumpfile);
2356 show_expr (i->size);
2357 }
2358 if (i->id)
2359 {
2360 fputs (" ID=", dumpfile);
2361 show_expr (i->id);
2362 }
2363
2364 if (i->err != NULL)
2365 fprintf (dumpfile, " ERR=%d", i->err->value);
2366 break;
2367
2368 case EXEC_IOLENGTH:
2369 fputs ("IOLENGTH ", dumpfile);
2370 show_expr (c->expr1);
2371 goto show_dt_code;
2372 break;
2373
2374 case EXEC_READ:
2375 fputs ("READ", dumpfile);
2376 goto show_dt;
2377
2378 case EXEC_WRITE:
2379 fputs ("WRITE", dumpfile);
2380
2381 show_dt:
2382 dt = c->ext.dt;
2383 if (dt->io_unit)
2384 {
2385 fputs (" UNIT=", dumpfile);
2386 show_expr (dt->io_unit);
2387 }
2388
2389 if (dt->format_expr)
2390 {
2391 fputs (" FMT=", dumpfile);
2392 show_expr (dt->format_expr);
2393 }
2394
2395 if (dt->format_label != NULL)
2396 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
2397 if (dt->namelist)
2398 fprintf (dumpfile, " NML=%s", dt->namelist->name);
2399
2400 if (dt->iomsg)
2401 {
2402 fputs (" IOMSG=", dumpfile);
2403 show_expr (dt->iomsg);
2404 }
2405 if (dt->iostat)
2406 {
2407 fputs (" IOSTAT=", dumpfile);
2408 show_expr (dt->iostat);
2409 }
2410 if (dt->size)
2411 {
2412 fputs (" SIZE=", dumpfile);
2413 show_expr (dt->size);
2414 }
2415 if (dt->rec)
2416 {
2417 fputs (" REC=", dumpfile);
2418 show_expr (dt->rec);
2419 }
2420 if (dt->advance)
2421 {
2422 fputs (" ADVANCE=", dumpfile);
2423 show_expr (dt->advance);
2424 }
2425 if (dt->id)
2426 {
2427 fputs (" ID=", dumpfile);
2428 show_expr (dt->id);
2429 }
2430 if (dt->pos)
2431 {
2432 fputs (" POS=", dumpfile);
2433 show_expr (dt->pos);
2434 }
2435 if (dt->asynchronous)
2436 {
2437 fputs (" ASYNCHRONOUS=", dumpfile);
2438 show_expr (dt->asynchronous);
2439 }
2440 if (dt->blank)
2441 {
2442 fputs (" BLANK=", dumpfile);
2443 show_expr (dt->blank);
2444 }
2445 if (dt->decimal)
2446 {
2447 fputs (" DECIMAL=", dumpfile);
2448 show_expr (dt->decimal);
2449 }
2450 if (dt->delim)
2451 {
2452 fputs (" DELIM=", dumpfile);
2453 show_expr (dt->delim);
2454 }
2455 if (dt->pad)
2456 {
2457 fputs (" PAD=", dumpfile);
2458 show_expr (dt->pad);
2459 }
2460 if (dt->round)
2461 {
2462 fputs (" ROUND=", dumpfile);
2463 show_expr (dt->round);
2464 }
2465 if (dt->sign)
2466 {
2467 fputs (" SIGN=", dumpfile);
2468 show_expr (dt->sign);
2469 }
2470
2471 show_dt_code:
2472 for (c = c->block->next; c; c = c->next)
2473 show_code_node (level + (c->next != NULL), c);
2474 return;
2475
2476 case EXEC_TRANSFER:
2477 fputs ("TRANSFER ", dumpfile);
2478 show_expr (c->expr1);
2479 break;
2480
2481 case EXEC_DT_END:
2482 fputs ("DT_END", dumpfile);
2483 dt = c->ext.dt;
2484
2485 if (dt->err != NULL)
2486 fprintf (dumpfile, " ERR=%d", dt->err->value);
2487 if (dt->end != NULL)
2488 fprintf (dumpfile, " END=%d", dt->end->value);
2489 if (dt->eor != NULL)
2490 fprintf (dumpfile, " EOR=%d", dt->eor->value);
2491 break;
2492
2493 case EXEC_OACC_PARALLEL_LOOP:
2494 case EXEC_OACC_PARALLEL:
2495 case EXEC_OACC_KERNELS_LOOP:
2496 case EXEC_OACC_KERNELS:
2497 case EXEC_OACC_DATA:
2498 case EXEC_OACC_HOST_DATA:
2499 case EXEC_OACC_LOOP:
2500 case EXEC_OACC_UPDATE:
2501 case EXEC_OACC_WAIT:
2502 case EXEC_OACC_CACHE:
2503 case EXEC_OACC_ENTER_DATA:
2504 case EXEC_OACC_EXIT_DATA:
2505 case EXEC_OMP_ATOMIC:
2506 case EXEC_OMP_CANCEL:
2507 case EXEC_OMP_CANCELLATION_POINT:
2508 case EXEC_OMP_BARRIER:
2509 case EXEC_OMP_CRITICAL:
2510 case EXEC_OMP_FLUSH:
2511 case EXEC_OMP_DO:
2512 case EXEC_OMP_DO_SIMD:
2513 case EXEC_OMP_MASTER:
2514 case EXEC_OMP_ORDERED:
2515 case EXEC_OMP_PARALLEL:
2516 case EXEC_OMP_PARALLEL_DO:
2517 case EXEC_OMP_PARALLEL_DO_SIMD:
2518 case EXEC_OMP_PARALLEL_SECTIONS:
2519 case EXEC_OMP_PARALLEL_WORKSHARE:
2520 case EXEC_OMP_SECTIONS:
2521 case EXEC_OMP_SIMD:
2522 case EXEC_OMP_SINGLE:
2523 case EXEC_OMP_TASK:
2524 case EXEC_OMP_TASKGROUP:
2525 case EXEC_OMP_TASKWAIT:
2526 case EXEC_OMP_TASKYIELD:
2527 case EXEC_OMP_WORKSHARE:
2528 show_omp_node (level, c);
2529 break;
2530
2531 default:
2532 gfc_internal_error ("show_code_node(): Bad statement code");
2533 }
2534 }
2535
2536
2537 /* Show an equivalence chain. */
2538
2539 static void
2540 show_equiv (gfc_equiv *eq)
2541 {
2542 show_indent ();
2543 fputs ("Equivalence: ", dumpfile);
2544 while (eq)
2545 {
2546 show_expr (eq->expr);
2547 eq = eq->eq;
2548 if (eq)
2549 fputs (", ", dumpfile);
2550 }
2551 }
2552
2553
2554 /* Show a freakin' whole namespace. */
2555
2556 static void
2557 show_namespace (gfc_namespace *ns)
2558 {
2559 gfc_interface *intr;
2560 gfc_namespace *save;
2561 int op;
2562 gfc_equiv *eq;
2563 int i;
2564
2565 gcc_assert (ns);
2566 save = gfc_current_ns;
2567
2568 show_indent ();
2569 fputs ("Namespace:", dumpfile);
2570
2571 i = 0;
2572 do
2573 {
2574 int l = i;
2575 while (i < GFC_LETTERS - 1
2576 && gfc_compare_types (&ns->default_type[i+1],
2577 &ns->default_type[l]))
2578 i++;
2579
2580 if (i > l)
2581 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2582 else
2583 fprintf (dumpfile, " %c: ", l+'A');
2584
2585 show_typespec(&ns->default_type[l]);
2586 i++;
2587 } while (i < GFC_LETTERS);
2588
2589 if (ns->proc_name != NULL)
2590 {
2591 show_indent ();
2592 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2593 }
2594
2595 ++show_level;
2596 gfc_current_ns = ns;
2597 gfc_traverse_symtree (ns->common_root, show_common);
2598
2599 gfc_traverse_symtree (ns->sym_root, show_symtree);
2600
2601 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2602 {
2603 /* User operator interfaces */
2604 intr = ns->op[op];
2605 if (intr == NULL)
2606 continue;
2607
2608 show_indent ();
2609 fprintf (dumpfile, "Operator interfaces for %s:",
2610 gfc_op2string ((gfc_intrinsic_op) op));
2611
2612 for (; intr; intr = intr->next)
2613 fprintf (dumpfile, " %s", intr->sym->name);
2614 }
2615
2616 if (ns->uop_root != NULL)
2617 {
2618 show_indent ();
2619 fputs ("User operators:\n", dumpfile);
2620 gfc_traverse_user_op (ns, show_uop);
2621 }
2622
2623 for (eq = ns->equiv; eq; eq = eq->next)
2624 show_equiv (eq);
2625
2626 if (ns->oacc_declare)
2627 {
2628 struct gfc_oacc_declare *decl;
2629 /* Dump !$ACC DECLARE clauses. */
2630 for (decl = ns->oacc_declare; decl; decl = decl->next)
2631 {
2632 show_indent ();
2633 fprintf (dumpfile, "!$ACC DECLARE");
2634 show_omp_clauses (decl->clauses);
2635 }
2636 }
2637
2638 fputc ('\n', dumpfile);
2639 show_indent ();
2640 fputs ("code:", dumpfile);
2641 show_code (show_level, ns->code);
2642 --show_level;
2643
2644 for (ns = ns->contained; ns; ns = ns->sibling)
2645 {
2646 fputs ("\nCONTAINS\n", dumpfile);
2647 ++show_level;
2648 show_namespace (ns);
2649 --show_level;
2650 }
2651
2652 fputc ('\n', dumpfile);
2653 gfc_current_ns = save;
2654 }
2655
2656
2657 /* Main function for dumping a parse tree. */
2658
2659 void
2660 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2661 {
2662 dumpfile = file;
2663 show_namespace (ns);
2664 }
2665
Mirror of the offical gcc git repository hosted at gcc.gnu.org