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