?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2015-01-20 Jeff Law <law@redhat.com>
[official-gcc.git] / gcc / fortran / dump-parse-tree.c
blob83ecbaa3d823696c800840f287c88b03ccc7d1de
1 /* Parse tree dumper
2 Copyright (C) 2003-2015 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_expr)
1150 {
1151 fputc ('(', dumpfile);
1152 show_expr (omp_clauses->gang_expr);
1153 fputc (')', dumpfile);
1154 }
1155 }
1156 if (omp_clauses->worker)
1157 {
1158 fputs (" WORKER", dumpfile);
1159 if (omp_clauses->worker_expr)
1160 {
1161 fputc ('(', dumpfile);
1162 show_expr (omp_clauses->worker_expr);
1163 fputc (')', dumpfile);
1164 }
1165 }
1166 if (omp_clauses->vector)
1167 {
1168 fputs (" VECTOR", dumpfile);
1169 if (omp_clauses->vector_expr)
1170 {
1171 fputc ('(', dumpfile);
1172 show_expr (omp_clauses->vector_expr);
1173 fputc (')', dumpfile);
1174 }
1175 }
1176 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1177 {
1178 const char *type;
1179 switch (omp_clauses->sched_kind)
1180 {
1181 case OMP_SCHED_STATIC: type = "STATIC"; break;
1182 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1183 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1184 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1185 case OMP_SCHED_AUTO: type = "AUTO"; break;
1186 default:
1187 gcc_unreachable ();
1188 }
1189 fprintf (dumpfile, " SCHEDULE (%s", type);
1190 if (omp_clauses->chunk_size)
1191 {
1192 fputc (',', dumpfile);
1193 show_expr (omp_clauses->chunk_size);
1194 }
1195 fputc (')', dumpfile);
1196 }
1197 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1198 {
1199 const char *type;
1200 switch (omp_clauses->default_sharing)
1201 {
1202 case OMP_DEFAULT_NONE: type = "NONE"; break;
1203 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1204 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1205 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1206 default:
1207 gcc_unreachable ();
1208 }
1209 fprintf (dumpfile, " DEFAULT(%s)", type);
1210 }
1211 if (omp_clauses->tile_list)
1212 {
1213 gfc_expr_list *list;
1214 fputs (" TILE(", dumpfile);
1215 for (list = omp_clauses->tile_list; list; list = list->next)
1216 {
1217 show_expr (list->expr);
1218 if (list->next)
1219 fputs (", ", dumpfile);
1220 }
1221 fputc (')', dumpfile);
1222 }
1223 if (omp_clauses->wait_list)
1224 {
1225 gfc_expr_list *list;
1226 fputs (" WAIT(", dumpfile);
1227 for (list = omp_clauses->wait_list; list; list = list->next)
1228 {
1229 show_expr (list->expr);
1230 if (list->next)
1231 fputs (", ", dumpfile);
1232 }
1233 fputc (')', dumpfile);
1234 }
1235 if (omp_clauses->seq)
1236 fputs (" SEQ", dumpfile);
1237 if (omp_clauses->independent)
1238 fputs (" INDEPENDENT", dumpfile);
1239 if (omp_clauses->ordered)
1240 fputs (" ORDERED", dumpfile);
1241 if (omp_clauses->untied)
1242 fputs (" UNTIED", dumpfile);
1243 if (omp_clauses->mergeable)
1244 fputs (" MERGEABLE", dumpfile);
1245 if (omp_clauses->collapse)
1246 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1247 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1248 if (omp_clauses->lists[list_type] != NULL
1249 && list_type != OMP_LIST_COPYPRIVATE)
1250 {
1251 const char *type = NULL;
1252 switch (list_type)
1253 {
1254 case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break;
1255 case OMP_LIST_DEVICE_RESIDENT: type = "USE_DEVICE"; break;
1256 case OMP_LIST_CACHE: type = ""; break;
1257 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1258 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1259 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1260 case OMP_LIST_SHARED: type = "SHARED"; break;
1261 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1262 case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
1263 case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
1264 case OMP_LIST_LINEAR: type = "LINEAR"; break;
1265 case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
1266 case OMP_LIST_DEPEND: type = "DEPEND"; break;
1267 default:
1268 gcc_unreachable ();
1269 }
1270 fprintf (dumpfile, " %s(", type);
1271 show_omp_namelist (list_type, omp_clauses->lists[list_type]);
1272 fputc (')', dumpfile);
1273 }
1274 if (omp_clauses->safelen_expr)
1275 {
1276 fputs (" SAFELEN(", dumpfile);
1277 show_expr (omp_clauses->safelen_expr);
1278 fputc (')', dumpfile);
1279 }
1280 if (omp_clauses->simdlen_expr)
1281 {
1282 fputs (" SIMDLEN(", dumpfile);
1283 show_expr (omp_clauses->simdlen_expr);
1284 fputc (')', dumpfile);
1285 }
1286 if (omp_clauses->inbranch)
1287 fputs (" INBRANCH", dumpfile);
1288 if (omp_clauses->notinbranch)
1289 fputs (" NOTINBRANCH", dumpfile);
1290 if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
1291 {
1292 const char *type;
1293 switch (omp_clauses->proc_bind)
1294 {
1295 case OMP_PROC_BIND_MASTER: type = "MASTER"; break;
1296 case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break;
1297 case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break;
1298 default:
1299 gcc_unreachable ();
1300 }
1301 fprintf (dumpfile, " PROC_BIND(%s)", type);
1302 }
1303 if (omp_clauses->num_teams)
1304 {
1305 fputs (" NUM_TEAMS(", dumpfile);
1306 show_expr (omp_clauses->num_teams);
1307 fputc (')', dumpfile);
1308 }
1309 if (omp_clauses->device)
1310 {
1311 fputs (" DEVICE(", dumpfile);
1312 show_expr (omp_clauses->device);
1313 fputc (')', dumpfile);
1314 }
1315 if (omp_clauses->thread_limit)
1316 {
1317 fputs (" THREAD_LIMIT(", dumpfile);
1318 show_expr (omp_clauses->thread_limit);
1319 fputc (')', dumpfile);
1320 }
1321 if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE)
1322 {
1323 fprintf (dumpfile, " DIST_SCHEDULE (static");
1324 if (omp_clauses->dist_chunk_size)
1325 {
1326 fputc (',', dumpfile);
1327 show_expr (omp_clauses->dist_chunk_size);
1328 }
1329 fputc (')', dumpfile);
1330 }
1331 }
1332
1333 /* Show a single OpenMP or OpenACC directive node and everything underneath it
1334 if necessary. */
1335
1336 static void
1337 show_omp_node (int level, gfc_code *c)
1338 {
1339 gfc_omp_clauses *omp_clauses = NULL;
1340 const char *name = NULL;
1341 bool is_oacc = false;
1342
1343 switch (c->op)
1344 {
1345 case EXEC_OACC_PARALLEL_LOOP: name = "PARALLEL LOOP"; is_oacc = true; break;
1346 case EXEC_OACC_PARALLEL: name = "PARALLEL"; is_oacc = true; break;
1347 case EXEC_OACC_KERNELS_LOOP: name = "KERNELS LOOP"; is_oacc = true; break;
1348 case EXEC_OACC_KERNELS: name = "KERNELS"; is_oacc = true; break;
1349 case EXEC_OACC_DATA: name = "DATA"; is_oacc = true; break;
1350 case EXEC_OACC_HOST_DATA: name = "HOST_DATA"; is_oacc = true; break;
1351 case EXEC_OACC_LOOP: name = "LOOP"; is_oacc = true; break;
1352 case EXEC_OACC_UPDATE: name = "UPDATE"; is_oacc = true; break;
1353 case EXEC_OACC_WAIT: name = "WAIT"; is_oacc = true; break;
1354 case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
1355 case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
1356 case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
1357 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
1358 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
1359 case EXEC_OMP_CANCEL: name = "CANCEL"; break;
1360 case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break;
1361 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
1362 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
1363 case EXEC_OMP_DO: name = "DO"; break;
1364 case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break;
1365 case EXEC_OMP_MASTER: name = "MASTER"; break;
1366 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
1367 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
1368 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
1369 case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break;
1370 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
1371 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
1372 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
1373 case EXEC_OMP_SIMD: name = "SIMD"; break;
1374 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
1375 case EXEC_OMP_TASK: name = "TASK"; break;
1376 case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break;
1377 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
1378 case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
1379 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
1380 default:
1381 gcc_unreachable ();
1382 }
1383 fprintf (dumpfile, "!$%s %s", is_oacc ? "ACC" : "OMP", name);
1384 switch (c->op)
1385 {
1386 case EXEC_OACC_PARALLEL_LOOP:
1387 case EXEC_OACC_PARALLEL:
1388 case EXEC_OACC_KERNELS_LOOP:
1389 case EXEC_OACC_KERNELS:
1390 case EXEC_OACC_DATA:
1391 case EXEC_OACC_HOST_DATA:
1392 case EXEC_OACC_LOOP:
1393 case EXEC_OACC_UPDATE:
1394 case EXEC_OACC_WAIT:
1395 case EXEC_OACC_CACHE:
1396 case EXEC_OACC_ENTER_DATA:
1397 case EXEC_OACC_EXIT_DATA:
1398 case EXEC_OMP_CANCEL:
1399 case EXEC_OMP_CANCELLATION_POINT:
1400 case EXEC_OMP_DO:
1401 case EXEC_OMP_DO_SIMD:
1402 case EXEC_OMP_PARALLEL:
1403 case EXEC_OMP_PARALLEL_DO:
1404 case EXEC_OMP_PARALLEL_DO_SIMD:
1405 case EXEC_OMP_PARALLEL_SECTIONS:
1406 case EXEC_OMP_SECTIONS:
1407 case EXEC_OMP_SIMD:
1408 case EXEC_OMP_SINGLE:
1409 case EXEC_OMP_WORKSHARE:
1410 case EXEC_OMP_PARALLEL_WORKSHARE:
1411 case EXEC_OMP_TASK:
1412 omp_clauses = c->ext.omp_clauses;
1413 break;
1414 case EXEC_OMP_CRITICAL:
1415 if (c->ext.omp_name)
1416 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1417 break;
1418 case EXEC_OMP_FLUSH:
1419 if (c->ext.omp_namelist)
1420 {
1421 fputs (" (", dumpfile);
1422 show_omp_namelist (OMP_LIST_NUM, c->ext.omp_namelist);
1423 fputc (')', dumpfile);
1424 }
1425 return;
1426 case EXEC_OMP_BARRIER:
1427 case EXEC_OMP_TASKWAIT:
1428 case EXEC_OMP_TASKYIELD:
1429 return;
1430 default:
1431 break;
1432 }
1433 if (omp_clauses)
1434 show_omp_clauses (omp_clauses);
1435 fputc ('\n', dumpfile);
1436
1437 /* OpenACC executable directives don't have associated blocks. */
1438 if (c->op == EXEC_OACC_CACHE || c->op == EXEC_OACC_UPDATE
1439 || c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA)
1440 return;
1441 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1442 {
1443 gfc_code *d = c->block;
1444 while (d != NULL)
1445 {
1446 show_code (level + 1, d->next);
1447 if (d->block == NULL)
1448 break;
1449 code_indent (level, 0);
1450 fputs ("!$OMP SECTION\n", dumpfile);
1451 d = d->block;
1452 }
1453 }
1454 else
1455 show_code (level + 1, c->block->next);
1456 if (c->op == EXEC_OMP_ATOMIC)
1457 return;
1458 fputc ('\n', dumpfile);
1459 code_indent (level, 0);
1460 fprintf (dumpfile, "!$%s END %s", is_oacc ? "ACC" : "OMP", name);
1461 if (omp_clauses != NULL)
1462 {
1463 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1464 {
1465 fputs (" COPYPRIVATE(", dumpfile);
1466 show_omp_namelist (OMP_LIST_COPYPRIVATE,
1467 omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1468 fputc (')', dumpfile);
1469 }
1470 else if (omp_clauses->nowait)
1471 fputs (" NOWAIT", dumpfile);
1472 }
1473 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1474 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1475 }
1476
1477
1478 /* Show a single code node and everything underneath it if necessary. */
1479
1480 static void
1481 show_code_node (int level, gfc_code *c)
1482 {
1483 gfc_forall_iterator *fa;
1484 gfc_open *open;
1485 gfc_case *cp;
1486 gfc_alloc *a;
1487 gfc_code *d;
1488 gfc_close *close;
1489 gfc_filepos *fp;
1490 gfc_inquire *i;
1491 gfc_dt *dt;
1492 gfc_namespace *ns;
1493
1494 if (c->here)
1495 {
1496 fputc ('\n', dumpfile);
1497 code_indent (level, c->here);
1498 }
1499 else
1500 show_indent ();
1501
1502 switch (c->op)
1503 {
1504 case EXEC_END_PROCEDURE:
1505 break;
1506
1507 case EXEC_NOP:
1508 fputs ("NOP", dumpfile);
1509 break;
1510
1511 case EXEC_CONTINUE:
1512 fputs ("CONTINUE", dumpfile);
1513 break;
1514
1515 case EXEC_ENTRY:
1516 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1517 break;
1518
1519 case EXEC_INIT_ASSIGN:
1520 case EXEC_ASSIGN:
1521 fputs ("ASSIGN ", dumpfile);
1522 show_expr (c->expr1);
1523 fputc (' ', dumpfile);
1524 show_expr (c->expr2);
1525 break;
1526
1527 case EXEC_LABEL_ASSIGN:
1528 fputs ("LABEL ASSIGN ", dumpfile);
1529 show_expr (c->expr1);
1530 fprintf (dumpfile, " %d", c->label1->value);
1531 break;
1532
1533 case EXEC_POINTER_ASSIGN:
1534 fputs ("POINTER ASSIGN ", dumpfile);
1535 show_expr (c->expr1);
1536 fputc (' ', dumpfile);
1537 show_expr (c->expr2);
1538 break;
1539
1540 case EXEC_GOTO:
1541 fputs ("GOTO ", dumpfile);
1542 if (c->label1)
1543 fprintf (dumpfile, "%d", c->label1->value);
1544 else
1545 {
1546 show_expr (c->expr1);
1547 d = c->block;
1548 if (d != NULL)
1549 {
1550 fputs (", (", dumpfile);
1551 for (; d; d = d ->block)
1552 {
1553 code_indent (level, d->label1);
1554 if (d->block != NULL)
1555 fputc (',', dumpfile);
1556 else
1557 fputc (')', dumpfile);
1558 }
1559 }
1560 }
1561 break;
1562
1563 case EXEC_CALL:
1564 case EXEC_ASSIGN_CALL:
1565 if (c->resolved_sym)
1566 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1567 else if (c->symtree)
1568 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1569 else
1570 fputs ("CALL ?? ", dumpfile);
1571
1572 show_actual_arglist (c->ext.actual);
1573 break;
1574
1575 case EXEC_COMPCALL:
1576 fputs ("CALL ", dumpfile);
1577 show_compcall (c->expr1);
1578 break;
1579
1580 case EXEC_CALL_PPC:
1581 fputs ("CALL ", dumpfile);
1582 show_expr (c->expr1);
1583 show_actual_arglist (c->ext.actual);
1584 break;
1585
1586 case EXEC_RETURN:
1587 fputs ("RETURN ", dumpfile);
1588 if (c->expr1)
1589 show_expr (c->expr1);
1590 break;
1591
1592 case EXEC_PAUSE:
1593 fputs ("PAUSE ", dumpfile);
1594
1595 if (c->expr1 != NULL)
1596 show_expr (c->expr1);
1597 else
1598 fprintf (dumpfile, "%d", c->ext.stop_code);
1599
1600 break;
1601
1602 case EXEC_ERROR_STOP:
1603 fputs ("ERROR ", dumpfile);
1604 /* Fall through. */
1605
1606 case EXEC_STOP:
1607 fputs ("STOP ", 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_SYNC_ALL:
1617 fputs ("SYNC ALL ", dumpfile);
1618 if (c->expr2 != NULL)
1619 {
1620 fputs (" stat=", dumpfile);
1621 show_expr (c->expr2);
1622 }
1623 if (c->expr3 != NULL)
1624 {
1625 fputs (" errmsg=", dumpfile);
1626 show_expr (c->expr3);
1627 }
1628 break;
1629
1630 case EXEC_SYNC_MEMORY:
1631 fputs ("SYNC MEMORY ", 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_IMAGES:
1645 fputs ("SYNC IMAGES image-set=", dumpfile);
1646 if (c->expr1 != NULL)
1647 show_expr (c->expr1);
1648 else
1649 fputs ("* ", dumpfile);
1650 if (c->expr2 != NULL)
1651 {
1652 fputs (" stat=", dumpfile);
1653 show_expr (c->expr2);
1654 }
1655 if (c->expr3 != NULL)
1656 {
1657 fputs (" errmsg=", dumpfile);
1658 show_expr (c->expr3);
1659 }
1660 break;
1661
1662 case EXEC_LOCK:
1663 case EXEC_UNLOCK:
1664 if (c->op == EXEC_LOCK)
1665 fputs ("LOCK ", dumpfile);
1666 else
1667 fputs ("UNLOCK ", dumpfile);
1668
1669 fputs ("lock-variable=", dumpfile);
1670 if (c->expr1 != NULL)
1671 show_expr (c->expr1);
1672 if (c->expr4 != NULL)
1673 {
1674 fputs (" acquired_lock=", dumpfile);
1675 show_expr (c->expr4);
1676 }
1677 if (c->expr2 != NULL)
1678 {
1679 fputs (" stat=", dumpfile);
1680 show_expr (c->expr2);
1681 }
1682 if (c->expr3 != NULL)
1683 {
1684 fputs (" errmsg=", dumpfile);
1685 show_expr (c->expr3);
1686 }
1687 break;
1688
1689 case EXEC_ARITHMETIC_IF:
1690 fputs ("IF ", dumpfile);
1691 show_expr (c->expr1);
1692 fprintf (dumpfile, " %d, %d, %d",
1693 c->label1->value, c->label2->value, c->label3->value);
1694 break;
1695
1696 case EXEC_IF:
1697 d = c->block;
1698 fputs ("IF ", dumpfile);
1699 show_expr (d->expr1);
1700
1701 ++show_level;
1702 show_code (level + 1, d->next);
1703 --show_level;
1704
1705 d = d->block;
1706 for (; d; d = d->block)
1707 {
1708 code_indent (level, 0);
1709
1710 if (d->expr1 == NULL)
1711 fputs ("ELSE", dumpfile);
1712 else
1713 {
1714 fputs ("ELSE IF ", dumpfile);
1715 show_expr (d->expr1);
1716 }
1717
1718 ++show_level;
1719 show_code (level + 1, d->next);
1720 --show_level;
1721 }
1722
1723 if (c->label1)
1724 code_indent (level, c->label1);
1725 else
1726 show_indent ();
1727
1728 fputs ("ENDIF", dumpfile);
1729 break;
1730
1731 case EXEC_BLOCK:
1732 {
1733 const char* blocktype;
1734 gfc_namespace *saved_ns;
1735
1736 if (c->ext.block.assoc)
1737 blocktype = "ASSOCIATE";
1738 else
1739 blocktype = "BLOCK";
1740 show_indent ();
1741 fprintf (dumpfile, "%s ", blocktype);
1742 ++show_level;
1743 ns = c->ext.block.ns;
1744 saved_ns = gfc_current_ns;
1745 gfc_current_ns = ns;
1746 gfc_traverse_symtree (ns->sym_root, show_symtree);
1747 gfc_current_ns = saved_ns;
1748 show_code (show_level, ns->code);
1749 --show_level;
1750 show_indent ();
1751 fprintf (dumpfile, "END %s ", blocktype);
1752 break;
1753 }
1754
1755 case EXEC_SELECT:
1756 d = c->block;
1757 fputs ("SELECT CASE ", dumpfile);
1758 show_expr (c->expr1);
1759 fputc ('\n', dumpfile);
1760
1761 for (; d; d = d->block)
1762 {
1763 code_indent (level, 0);
1764
1765 fputs ("CASE ", dumpfile);
1766 for (cp = d->ext.block.case_list; cp; cp = cp->next)
1767 {
1768 fputc ('(', dumpfile);
1769 show_expr (cp->low);
1770 fputc (' ', dumpfile);
1771 show_expr (cp->high);
1772 fputc (')', dumpfile);
1773 fputc (' ', dumpfile);
1774 }
1775 fputc ('\n', dumpfile);
1776
1777 show_code (level + 1, d->next);
1778 }
1779
1780 code_indent (level, c->label1);
1781 fputs ("END SELECT", dumpfile);
1782 break;
1783
1784 case EXEC_WHERE:
1785 fputs ("WHERE ", dumpfile);
1786
1787 d = c->block;
1788 show_expr (d->expr1);
1789 fputc ('\n', dumpfile);
1790
1791 show_code (level + 1, d->next);
1792
1793 for (d = d->block; d; d = d->block)
1794 {
1795 code_indent (level, 0);
1796 fputs ("ELSE WHERE ", dumpfile);
1797 show_expr (d->expr1);
1798 fputc ('\n', dumpfile);
1799 show_code (level + 1, d->next);
1800 }
1801
1802 code_indent (level, 0);
1803 fputs ("END WHERE", dumpfile);
1804 break;
1805
1806
1807 case EXEC_FORALL:
1808 fputs ("FORALL ", dumpfile);
1809 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1810 {
1811 show_expr (fa->var);
1812 fputc (' ', dumpfile);
1813 show_expr (fa->start);
1814 fputc (':', dumpfile);
1815 show_expr (fa->end);
1816 fputc (':', dumpfile);
1817 show_expr (fa->stride);
1818
1819 if (fa->next != NULL)
1820 fputc (',', dumpfile);
1821 }
1822
1823 if (c->expr1 != NULL)
1824 {
1825 fputc (',', dumpfile);
1826 show_expr (c->expr1);
1827 }
1828 fputc ('\n', dumpfile);
1829
1830 show_code (level + 1, c->block->next);
1831
1832 code_indent (level, 0);
1833 fputs ("END FORALL", dumpfile);
1834 break;
1835
1836 case EXEC_CRITICAL:
1837 fputs ("CRITICAL\n", dumpfile);
1838 show_code (level + 1, c->block->next);
1839 code_indent (level, 0);
1840 fputs ("END CRITICAL", dumpfile);
1841 break;
1842
1843 case EXEC_DO:
1844 fputs ("DO ", dumpfile);
1845 if (c->label1)
1846 fprintf (dumpfile, " %-5d ", c->label1->value);
1847
1848 show_expr (c->ext.iterator->var);
1849 fputc ('=', dumpfile);
1850 show_expr (c->ext.iterator->start);
1851 fputc (' ', dumpfile);
1852 show_expr (c->ext.iterator->end);
1853 fputc (' ', dumpfile);
1854 show_expr (c->ext.iterator->step);
1855
1856 ++show_level;
1857 show_code (level + 1, c->block->next);
1858 --show_level;
1859
1860 if (c->label1)
1861 break;
1862
1863 show_indent ();
1864 fputs ("END DO", dumpfile);
1865 break;
1866
1867 case EXEC_DO_CONCURRENT:
1868 fputs ("DO CONCURRENT ", dumpfile);
1869 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1870 {
1871 show_expr (fa->var);
1872 fputc (' ', dumpfile);
1873 show_expr (fa->start);
1874 fputc (':', dumpfile);
1875 show_expr (fa->end);
1876 fputc (':', dumpfile);
1877 show_expr (fa->stride);
1878
1879 if (fa->next != NULL)
1880 fputc (',', dumpfile);
1881 }
1882 show_expr (c->expr1);
1883
1884 show_code (level + 1, c->block->next);
1885 code_indent (level, c->label1);
1886 fputs ("END DO", dumpfile);
1887 break;
1888
1889 case EXEC_DO_WHILE:
1890 fputs ("DO WHILE ", dumpfile);
1891 show_expr (c->expr1);
1892 fputc ('\n', dumpfile);
1893
1894 show_code (level + 1, c->block->next);
1895
1896 code_indent (level, c->label1);
1897 fputs ("END DO", dumpfile);
1898 break;
1899
1900 case EXEC_CYCLE:
1901 fputs ("CYCLE", dumpfile);
1902 if (c->symtree)
1903 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1904 break;
1905
1906 case EXEC_EXIT:
1907 fputs ("EXIT", dumpfile);
1908 if (c->symtree)
1909 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1910 break;
1911
1912 case EXEC_ALLOCATE:
1913 fputs ("ALLOCATE ", dumpfile);
1914 if (c->expr1)
1915 {
1916 fputs (" STAT=", dumpfile);
1917 show_expr (c->expr1);
1918 }
1919
1920 if (c->expr2)
1921 {
1922 fputs (" ERRMSG=", dumpfile);
1923 show_expr (c->expr2);
1924 }
1925
1926 if (c->expr3)
1927 {
1928 if (c->expr3->mold)
1929 fputs (" MOLD=", dumpfile);
1930 else
1931 fputs (" SOURCE=", dumpfile);
1932 show_expr (c->expr3);
1933 }
1934
1935 for (a = c->ext.alloc.list; a; a = a->next)
1936 {
1937 fputc (' ', dumpfile);
1938 show_expr (a->expr);
1939 }
1940
1941 break;
1942
1943 case EXEC_DEALLOCATE:
1944 fputs ("DEALLOCATE ", dumpfile);
1945 if (c->expr1)
1946 {
1947 fputs (" STAT=", dumpfile);
1948 show_expr (c->expr1);
1949 }
1950
1951 if (c->expr2)
1952 {
1953 fputs (" ERRMSG=", dumpfile);
1954 show_expr (c->expr2);
1955 }
1956
1957 for (a = c->ext.alloc.list; a; a = a->next)
1958 {
1959 fputc (' ', dumpfile);
1960 show_expr (a->expr);
1961 }
1962
1963 break;
1964
1965 case EXEC_OPEN:
1966 fputs ("OPEN", dumpfile);
1967 open = c->ext.open;
1968
1969 if (open->unit)
1970 {
1971 fputs (" UNIT=", dumpfile);
1972 show_expr (open->unit);
1973 }
1974 if (open->iomsg)
1975 {
1976 fputs (" IOMSG=", dumpfile);
1977 show_expr (open->iomsg);
1978 }
1979 if (open->iostat)
1980 {
1981 fputs (" IOSTAT=", dumpfile);
1982 show_expr (open->iostat);
1983 }
1984 if (open->file)
1985 {
1986 fputs (" FILE=", dumpfile);
1987 show_expr (open->file);
1988 }
1989 if (open->status)
1990 {
1991 fputs (" STATUS=", dumpfile);
1992 show_expr (open->status);
1993 }
1994 if (open->access)
1995 {
1996 fputs (" ACCESS=", dumpfile);
1997 show_expr (open->access);
1998 }
1999 if (open->form)
2000 {
2001 fputs (" FORM=", dumpfile);
2002 show_expr (open->form);
2003 }
2004 if (open->recl)
2005 {
2006 fputs (" RECL=", dumpfile);
2007 show_expr (open->recl);
2008 }
2009 if (open->blank)
2010 {
2011 fputs (" BLANK=", dumpfile);
2012 show_expr (open->blank);
2013 }
2014 if (open->position)
2015 {
2016 fputs (" POSITION=", dumpfile);
2017 show_expr (open->position);
2018 }
2019 if (open->action)
2020 {
2021 fputs (" ACTION=", dumpfile);
2022 show_expr (open->action);
2023 }
2024 if (open->delim)
2025 {
2026 fputs (" DELIM=", dumpfile);
2027 show_expr (open->delim);
2028 }
2029 if (open->pad)
2030 {
2031 fputs (" PAD=", dumpfile);
2032 show_expr (open->pad);
2033 }
2034 if (open->decimal)
2035 {
2036 fputs (" DECIMAL=", dumpfile);
2037 show_expr (open->decimal);
2038 }
2039 if (open->encoding)
2040 {
2041 fputs (" ENCODING=", dumpfile);
2042 show_expr (open->encoding);
2043 }
2044 if (open->round)
2045 {
2046 fputs (" ROUND=", dumpfile);
2047 show_expr (open->round);
2048 }
2049 if (open->sign)
2050 {
2051 fputs (" SIGN=", dumpfile);
2052 show_expr (open->sign);
2053 }
2054 if (open->convert)
2055 {
2056 fputs (" CONVERT=", dumpfile);
2057 show_expr (open->convert);
2058 }
2059 if (open->asynchronous)
2060 {
2061 fputs (" ASYNCHRONOUS=", dumpfile);
2062 show_expr (open->asynchronous);
2063 }
2064 if (open->err != NULL)
2065 fprintf (dumpfile, " ERR=%d", open->err->value);
2066
2067 break;
2068
2069 case EXEC_CLOSE:
2070 fputs ("CLOSE", dumpfile);
2071 close = c->ext.close;
2072
2073 if (close->unit)
2074 {
2075 fputs (" UNIT=", dumpfile);
2076 show_expr (close->unit);
2077 }
2078 if (close->iomsg)
2079 {
2080 fputs (" IOMSG=", dumpfile);
2081 show_expr (close->iomsg);
2082 }
2083 if (close->iostat)
2084 {
2085 fputs (" IOSTAT=", dumpfile);
2086 show_expr (close->iostat);
2087 }
2088 if (close->status)
2089 {
2090 fputs (" STATUS=", dumpfile);
2091 show_expr (close->status);
2092 }
2093 if (close->err != NULL)
2094 fprintf (dumpfile, " ERR=%d", close->err->value);
2095 break;
2096
2097 case EXEC_BACKSPACE:
2098 fputs ("BACKSPACE", dumpfile);
2099 goto show_filepos;
2100
2101 case EXEC_ENDFILE:
2102 fputs ("ENDFILE", dumpfile);
2103 goto show_filepos;
2104
2105 case EXEC_REWIND:
2106 fputs ("REWIND", dumpfile);
2107 goto show_filepos;
2108
2109 case EXEC_FLUSH:
2110 fputs ("FLUSH", dumpfile);
2111
2112 show_filepos:
2113 fp = c->ext.filepos;
2114
2115 if (fp->unit)
2116 {
2117 fputs (" UNIT=", dumpfile);
2118 show_expr (fp->unit);
2119 }
2120 if (fp->iomsg)
2121 {
2122 fputs (" IOMSG=", dumpfile);
2123 show_expr (fp->iomsg);
2124 }
2125 if (fp->iostat)
2126 {
2127 fputs (" IOSTAT=", dumpfile);
2128 show_expr (fp->iostat);
2129 }
2130 if (fp->err != NULL)
2131 fprintf (dumpfile, " ERR=%d", fp->err->value);
2132 break;
2133
2134 case EXEC_INQUIRE:
2135 fputs ("INQUIRE", dumpfile);
2136 i = c->ext.inquire;
2137
2138 if (i->unit)
2139 {
2140 fputs (" UNIT=", dumpfile);
2141 show_expr (i->unit);
2142 }
2143 if (i->file)
2144 {
2145 fputs (" FILE=", dumpfile);
2146 show_expr (i->file);
2147 }
2148
2149 if (i->iomsg)
2150 {
2151 fputs (" IOMSG=", dumpfile);
2152 show_expr (i->iomsg);
2153 }
2154 if (i->iostat)
2155 {
2156 fputs (" IOSTAT=", dumpfile);
2157 show_expr (i->iostat);
2158 }
2159 if (i->exist)
2160 {
2161 fputs (" EXIST=", dumpfile);
2162 show_expr (i->exist);
2163 }
2164 if (i->opened)
2165 {
2166 fputs (" OPENED=", dumpfile);
2167 show_expr (i->opened);
2168 }
2169 if (i->number)
2170 {
2171 fputs (" NUMBER=", dumpfile);
2172 show_expr (i->number);
2173 }
2174 if (i->named)
2175 {
2176 fputs (" NAMED=", dumpfile);
2177 show_expr (i->named);
2178 }
2179 if (i->name)
2180 {
2181 fputs (" NAME=", dumpfile);
2182 show_expr (i->name);
2183 }
2184 if (i->access)
2185 {
2186 fputs (" ACCESS=", dumpfile);
2187 show_expr (i->access);
2188 }
2189 if (i->sequential)
2190 {
2191 fputs (" SEQUENTIAL=", dumpfile);
2192 show_expr (i->sequential);
2193 }
2194
2195 if (i->direct)
2196 {
2197 fputs (" DIRECT=", dumpfile);
2198 show_expr (i->direct);
2199 }
2200 if (i->form)
2201 {
2202 fputs (" FORM=", dumpfile);
2203 show_expr (i->form);
2204 }
2205 if (i->formatted)
2206 {
2207 fputs (" FORMATTED", dumpfile);
2208 show_expr (i->formatted);
2209 }
2210 if (i->unformatted)
2211 {
2212 fputs (" UNFORMATTED=", dumpfile);
2213 show_expr (i->unformatted);
2214 }
2215 if (i->recl)
2216 {
2217 fputs (" RECL=", dumpfile);
2218 show_expr (i->recl);
2219 }
2220 if (i->nextrec)
2221 {
2222 fputs (" NEXTREC=", dumpfile);
2223 show_expr (i->nextrec);
2224 }
2225 if (i->blank)
2226 {
2227 fputs (" BLANK=", dumpfile);
2228 show_expr (i->blank);
2229 }
2230 if (i->position)
2231 {
2232 fputs (" POSITION=", dumpfile);
2233 show_expr (i->position);
2234 }
2235 if (i->action)
2236 {
2237 fputs (" ACTION=", dumpfile);
2238 show_expr (i->action);
2239 }
2240 if (i->read)
2241 {
2242 fputs (" READ=", dumpfile);
2243 show_expr (i->read);
2244 }
2245 if (i->write)
2246 {
2247 fputs (" WRITE=", dumpfile);
2248 show_expr (i->write);
2249 }
2250 if (i->readwrite)
2251 {
2252 fputs (" READWRITE=", dumpfile);
2253 show_expr (i->readwrite);
2254 }
2255 if (i->delim)
2256 {
2257 fputs (" DELIM=", dumpfile);
2258 show_expr (i->delim);
2259 }
2260 if (i->pad)
2261 {
2262 fputs (" PAD=", dumpfile);
2263 show_expr (i->pad);
2264 }
2265 if (i->convert)
2266 {
2267 fputs (" CONVERT=", dumpfile);
2268 show_expr (i->convert);
2269 }
2270 if (i->asynchronous)
2271 {
2272 fputs (" ASYNCHRONOUS=", dumpfile);
2273 show_expr (i->asynchronous);
2274 }
2275 if (i->decimal)
2276 {
2277 fputs (" DECIMAL=", dumpfile);
2278 show_expr (i->decimal);
2279 }
2280 if (i->encoding)
2281 {
2282 fputs (" ENCODING=", dumpfile);
2283 show_expr (i->encoding);
2284 }
2285 if (i->pending)
2286 {
2287 fputs (" PENDING=", dumpfile);
2288 show_expr (i->pending);
2289 }
2290 if (i->round)
2291 {
2292 fputs (" ROUND=", dumpfile);
2293 show_expr (i->round);
2294 }
2295 if (i->sign)
2296 {
2297 fputs (" SIGN=", dumpfile);
2298 show_expr (i->sign);
2299 }
2300 if (i->size)
2301 {
2302 fputs (" SIZE=", dumpfile);
2303 show_expr (i->size);
2304 }
2305 if (i->id)
2306 {
2307 fputs (" ID=", dumpfile);
2308 show_expr (i->id);
2309 }
2310
2311 if (i->err != NULL)
2312 fprintf (dumpfile, " ERR=%d", i->err->value);
2313 break;
2314
2315 case EXEC_IOLENGTH:
2316 fputs ("IOLENGTH ", dumpfile);
2317 show_expr (c->expr1);
2318 goto show_dt_code;
2319 break;
2320
2321 case EXEC_READ:
2322 fputs ("READ", dumpfile);
2323 goto show_dt;
2324
2325 case EXEC_WRITE:
2326 fputs ("WRITE", dumpfile);
2327
2328 show_dt:
2329 dt = c->ext.dt;
2330 if (dt->io_unit)
2331 {
2332 fputs (" UNIT=", dumpfile);
2333 show_expr (dt->io_unit);
2334 }
2335
2336 if (dt->format_expr)
2337 {
2338 fputs (" FMT=", dumpfile);
2339 show_expr (dt->format_expr);
2340 }
2341
2342 if (dt->format_label != NULL)
2343 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
2344 if (dt->namelist)
2345 fprintf (dumpfile, " NML=%s", dt->namelist->name);
2346
2347 if (dt->iomsg)
2348 {
2349 fputs (" IOMSG=", dumpfile);
2350 show_expr (dt->iomsg);
2351 }
2352 if (dt->iostat)
2353 {
2354 fputs (" IOSTAT=", dumpfile);
2355 show_expr (dt->iostat);
2356 }
2357 if (dt->size)
2358 {
2359 fputs (" SIZE=", dumpfile);
2360 show_expr (dt->size);
2361 }
2362 if (dt->rec)
2363 {
2364 fputs (" REC=", dumpfile);
2365 show_expr (dt->rec);
2366 }
2367 if (dt->advance)
2368 {
2369 fputs (" ADVANCE=", dumpfile);
2370 show_expr (dt->advance);
2371 }
2372 if (dt->id)
2373 {
2374 fputs (" ID=", dumpfile);
2375 show_expr (dt->id);
2376 }
2377 if (dt->pos)
2378 {
2379 fputs (" POS=", dumpfile);
2380 show_expr (dt->pos);
2381 }
2382 if (dt->asynchronous)
2383 {
2384 fputs (" ASYNCHRONOUS=", dumpfile);
2385 show_expr (dt->asynchronous);
2386 }
2387 if (dt->blank)
2388 {
2389 fputs (" BLANK=", dumpfile);
2390 show_expr (dt->blank);
2391 }
2392 if (dt->decimal)
2393 {
2394 fputs (" DECIMAL=", dumpfile);
2395 show_expr (dt->decimal);
2396 }
2397 if (dt->delim)
2398 {
2399 fputs (" DELIM=", dumpfile);
2400 show_expr (dt->delim);
2401 }
2402 if (dt->pad)
2403 {
2404 fputs (" PAD=", dumpfile);
2405 show_expr (dt->pad);
2406 }
2407 if (dt->round)
2408 {
2409 fputs (" ROUND=", dumpfile);
2410 show_expr (dt->round);
2411 }
2412 if (dt->sign)
2413 {
2414 fputs (" SIGN=", dumpfile);
2415 show_expr (dt->sign);
2416 }
2417
2418 show_dt_code:
2419 for (c = c->block->next; c; c = c->next)
2420 show_code_node (level + (c->next != NULL), c);
2421 return;
2422
2423 case EXEC_TRANSFER:
2424 fputs ("TRANSFER ", dumpfile);
2425 show_expr (c->expr1);
2426 break;
2427
2428 case EXEC_DT_END:
2429 fputs ("DT_END", dumpfile);
2430 dt = c->ext.dt;
2431
2432 if (dt->err != NULL)
2433 fprintf (dumpfile, " ERR=%d", dt->err->value);
2434 if (dt->end != NULL)
2435 fprintf (dumpfile, " END=%d", dt->end->value);
2436 if (dt->eor != NULL)
2437 fprintf (dumpfile, " EOR=%d", dt->eor->value);
2438 break;
2439
2440 case EXEC_OACC_PARALLEL_LOOP:
2441 case EXEC_OACC_PARALLEL:
2442 case EXEC_OACC_KERNELS_LOOP:
2443 case EXEC_OACC_KERNELS:
2444 case EXEC_OACC_DATA:
2445 case EXEC_OACC_HOST_DATA:
2446 case EXEC_OACC_LOOP:
2447 case EXEC_OACC_UPDATE:
2448 case EXEC_OACC_WAIT:
2449 case EXEC_OACC_CACHE:
2450 case EXEC_OACC_ENTER_DATA:
2451 case EXEC_OACC_EXIT_DATA:
2452 case EXEC_OMP_ATOMIC:
2453 case EXEC_OMP_CANCEL:
2454 case EXEC_OMP_CANCELLATION_POINT:
2455 case EXEC_OMP_BARRIER:
2456 case EXEC_OMP_CRITICAL:
2457 case EXEC_OMP_FLUSH:
2458 case EXEC_OMP_DO:
2459 case EXEC_OMP_DO_SIMD:
2460 case EXEC_OMP_MASTER:
2461 case EXEC_OMP_ORDERED:
2462 case EXEC_OMP_PARALLEL:
2463 case EXEC_OMP_PARALLEL_DO:
2464 case EXEC_OMP_PARALLEL_DO_SIMD:
2465 case EXEC_OMP_PARALLEL_SECTIONS:
2466 case EXEC_OMP_PARALLEL_WORKSHARE:
2467 case EXEC_OMP_SECTIONS:
2468 case EXEC_OMP_SIMD:
2469 case EXEC_OMP_SINGLE:
2470 case EXEC_OMP_TASK:
2471 case EXEC_OMP_TASKGROUP:
2472 case EXEC_OMP_TASKWAIT:
2473 case EXEC_OMP_TASKYIELD:
2474 case EXEC_OMP_WORKSHARE:
2475 show_omp_node (level, c);
2476 break;
2477
2478 default:
2479 gfc_internal_error ("show_code_node(): Bad statement code");
2480 }
2481 }
2482
2483
2484 /* Show an equivalence chain. */
2485
2486 static void
2487 show_equiv (gfc_equiv *eq)
2488 {
2489 show_indent ();
2490 fputs ("Equivalence: ", dumpfile);
2491 while (eq)
2492 {
2493 show_expr (eq->expr);
2494 eq = eq->eq;
2495 if (eq)
2496 fputs (", ", dumpfile);
2497 }
2498 }
2499
2500
2501 /* Show a freakin' whole namespace. */
2502
2503 static void
2504 show_namespace (gfc_namespace *ns)
2505 {
2506 gfc_interface *intr;
2507 gfc_namespace *save;
2508 int op;
2509 gfc_equiv *eq;
2510 int i;
2511
2512 gcc_assert (ns);
2513 save = gfc_current_ns;
2514
2515 show_indent ();
2516 fputs ("Namespace:", dumpfile);
2517
2518 i = 0;
2519 do
2520 {
2521 int l = i;
2522 while (i < GFC_LETTERS - 1
2523 && gfc_compare_types (&ns->default_type[i+1],
2524 &ns->default_type[l]))
2525 i++;
2526
2527 if (i > l)
2528 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2529 else
2530 fprintf (dumpfile, " %c: ", l+'A');
2531
2532 show_typespec(&ns->default_type[l]);
2533 i++;
2534 } while (i < GFC_LETTERS);
2535
2536 if (ns->proc_name != NULL)
2537 {
2538 show_indent ();
2539 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2540 }
2541
2542 ++show_level;
2543 gfc_current_ns = ns;
2544 gfc_traverse_symtree (ns->common_root, show_common);
2545
2546 gfc_traverse_symtree (ns->sym_root, show_symtree);
2547
2548 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2549 {
2550 /* User operator interfaces */
2551 intr = ns->op[op];
2552 if (intr == NULL)
2553 continue;
2554
2555 show_indent ();
2556 fprintf (dumpfile, "Operator interfaces for %s:",
2557 gfc_op2string ((gfc_intrinsic_op) op));
2558
2559 for (; intr; intr = intr->next)
2560 fprintf (dumpfile, " %s", intr->sym->name);
2561 }
2562
2563 if (ns->uop_root != NULL)
2564 {
2565 show_indent ();
2566 fputs ("User operators:\n", dumpfile);
2567 gfc_traverse_user_op (ns, show_uop);
2568 }
2569
2570 for (eq = ns->equiv; eq; eq = eq->next)
2571 show_equiv (eq);
2572
2573 if (ns->oacc_declare_clauses)
2574 {
2575 /* Dump !$ACC DECLARE clauses. */
2576 show_indent ();
2577 fprintf (dumpfile, "!$ACC DECLARE");
2578 show_omp_clauses (ns->oacc_declare_clauses);
2579 }
2580
2581 fputc ('\n', dumpfile);
2582 show_indent ();
2583 fputs ("code:", dumpfile);
2584 show_code (show_level, ns->code);
2585 --show_level;
2586
2587 for (ns = ns->contained; ns; ns = ns->sibling)
2588 {
2589 fputs ("\nCONTAINS\n", dumpfile);
2590 ++show_level;
2591 show_namespace (ns);
2592 --show_level;
2593 }
2594
2595 fputc ('\n', dumpfile);
2596 gfc_current_ns = save;
2597 }
2598
2599
2600 /* Main function for dumping a parse tree. */
2601
2602 void
2603 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2604 {
2605 dumpfile = file;
2606 show_namespace (ns);
2607 }
2608
Mirror of the offical gcc git repository hosted at gcc.gnu.org