1 /* Parse tree dumper
2 Copyright (C) 2003-2018 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 static void show_code (int, gfc_code *);
51
52
53 /* Allow dumping of an expression in the debugger. */
54 void gfc_debug_expr (gfc_expr *);
55
56 void
gfc_debug_expr(gfc_expr * e)57 gfc_debug_expr (gfc_expr *e)
58 {
59 FILE *tmp = dumpfile;
60 dumpfile = stderr;
61 show_expr (e);
62 fputc ('\n', dumpfile);
63 dumpfile = tmp;
64 }
65
66 /* Allow for dumping of a piece of code in the debugger. */
67 void gfc_debug_code (gfc_code *c);
68
69 void
gfc_debug_code(gfc_code * c)70 gfc_debug_code (gfc_code *c)
71 {
72 FILE *tmp = dumpfile;
73 dumpfile = stderr;
74 show_code (1, c);
75 fputc ('\n', dumpfile);
76 dumpfile = tmp;
77 }
78
79 /* Do indentation for a specific level. */
80
81 static inline void
code_indent(int level,gfc_st_label * label)82 code_indent (int level, gfc_st_label *label)
83 {
84 int i;
85
86 if (label != NULL)
87 fprintf (dumpfile, "%-5d ", label->value);
88
89 for (i = 0; i < (2 * level - (label ? 6 : 0)); i++)
90 fputc (' ', dumpfile);
91 }
92
93
94 /* Simple indentation at the current level. This one
95 is used to show symbols. */
96
97 static inline void
show_indent(void)98 show_indent (void)
99 {
100 fputc ('\n', dumpfile);
101 code_indent (show_level, NULL);
102 }
103
104
105 /* Show type-specific information. */
106
107 static void
show_typespec(gfc_typespec * ts)108 show_typespec (gfc_typespec *ts)
109 {
110 if (ts->type == BT_ASSUMED)
111 {
112 fputs ("(TYPE(*))", dumpfile);
113 return;
114 }
115
116 fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
117
118 switch (ts->type)
119 {
120 case BT_DERIVED:
121 case BT_CLASS:
122 case BT_UNION:
123 fprintf (dumpfile, "%s", ts->u.derived->name);
124 break;
125
126 case BT_CHARACTER:
127 if (ts->u.cl)
128 show_expr (ts->u.cl->length);
129 fprintf(dumpfile, " %d", ts->kind);
130 break;
131
132 default:
133 fprintf (dumpfile, "%d", ts->kind);
134 break;
135 }
136 if (ts->is_c_interop)
137 fputs (" C_INTEROP", dumpfile);
138
139 if (ts->is_iso_c)
140 fputs (" ISO_C", dumpfile);
141
142 if (ts->deferred)
143 fputs (" DEFERRED", dumpfile);
144
145 fputc (')', dumpfile);
146 }
147
148
149 /* Show an actual argument list. */
150
151 static void
show_actual_arglist(gfc_actual_arglist * a)152 show_actual_arglist (gfc_actual_arglist *a)
153 {
154 fputc ('(', dumpfile);
155
156 for (; a; a = a->next)
157 {
158 fputc ('(', dumpfile);
159 if (a->name != NULL)
160 fprintf (dumpfile, "%s = ", a->name);
161 if (a->expr != NULL)
162 show_expr (a->expr);
163 else
164 fputs ("(arg not-present)", dumpfile);
165
166 fputc (')', dumpfile);
167 if (a->next != NULL)
168 fputc (' ', dumpfile);
169 }
170
171 fputc (')', dumpfile);
172 }
173
174
175 /* Show a gfc_array_spec array specification structure. */
176
177 static void
show_array_spec(gfc_array_spec * as)178 show_array_spec (gfc_array_spec *as)
179 {
180 const char *c;
181 int i;
182
183 if (as == NULL)
184 {
185 fputs ("()", dumpfile);
186 return;
187 }
188
189 fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
190
191 if (as->rank + as->corank > 0 || as->rank == -1)
192 {
193 switch (as->type)
194 {
195 case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
196 case AS_DEFERRED: c = "AS_DEFERRED"; break;
197 case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
198 case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
199 case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break;
200 default:
201 gfc_internal_error ("show_array_spec(): Unhandled array shape "
202 "type.");
203 }
204 fprintf (dumpfile, " %s ", c);
205
206 for (i = 0; i < as->rank + as->corank; i++)
207 {
208 show_expr (as->lower[i]);
209 fputc (' ', dumpfile);
210 show_expr (as->upper[i]);
211 fputc (' ', dumpfile);
212 }
213 }
214
215 fputc (')', dumpfile);
216 }
217
218
219 /* Show a gfc_array_ref array reference structure. */
220
221 static void
show_array_ref(gfc_array_ref * ar)222 show_array_ref (gfc_array_ref * ar)
223 {
224 int i;
225
226 fputc ('(', dumpfile);
227
228 switch (ar->type)
229 {
230 case AR_FULL:
231 fputs ("FULL", dumpfile);
232 break;
233
234 case AR_SECTION:
235 for (i = 0; i < ar->dimen; i++)
236 {
237 /* There are two types of array sections: either the
238 elements are identified by an integer array ('vector'),
239 or by an index range. In the former case we only have to
240 print the start expression which contains the vector, in
241 the latter case we have to print any of lower and upper
242 bound and the stride, if they're present. */
243
244 if (ar->start[i] != NULL)
245 show_expr (ar->start[i]);
246
247 if (ar->dimen_type[i] == DIMEN_RANGE)
248 {
249 fputc (':', dumpfile);
250
251 if (ar->end[i] != NULL)
252 show_expr (ar->end[i]);
253
254 if (ar->stride[i] != NULL)
255 {
256 fputc (':', dumpfile);
257 show_expr (ar->stride[i]);
258 }
259 }
260
261 if (i != ar->dimen - 1)
262 fputs (" , ", dumpfile);
263 }
264 break;
265
266 case AR_ELEMENT:
267 for (i = 0; i < ar->dimen; i++)
268 {
269 show_expr (ar->start[i]);
270 if (i != ar->dimen - 1)
271 fputs (" , ", dumpfile);
272 }
273 break;
274
275 case AR_UNKNOWN:
276 fputs ("UNKNOWN", dumpfile);
277 break;
278
279 default:
280 gfc_internal_error ("show_array_ref(): Unknown array reference");
281 }
282
283 fputc (')', dumpfile);
284 }
285
286
287 /* Show a list of gfc_ref structures. */
288
289 static void
show_ref(gfc_ref * p)290 show_ref (gfc_ref *p)
291 {
292 for (; p; p = p->next)
293 switch (p->type)
294 {
295 case REF_ARRAY:
296 show_array_ref (&p->u.ar);
297 break;
298
299 case REF_COMPONENT:
300 fprintf (dumpfile, " %% %s", p->u.c.component->name);
301 break;
302
303 case REF_SUBSTRING:
304 fputc ('(', dumpfile);
305 show_expr (p->u.ss.start);
306 fputc (':', dumpfile);
307 show_expr (p->u.ss.end);
308 fputc (')', dumpfile);
309 break;
310
311 default:
312 gfc_internal_error ("show_ref(): Bad component code");
313 }
314 }
315
316
317 /* Display a constructor. Works recursively for array constructors. */
318
319 static void
show_constructor(gfc_constructor_base base)320 show_constructor (gfc_constructor_base base)
321 {
322 gfc_constructor *c;
323 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
324 {
325 if (c->iterator == NULL)
326 show_expr (c->expr);
327 else
328 {
329 fputc ('(', dumpfile);
330 show_expr (c->expr);
331
332 fputc (' ', dumpfile);
333 show_expr (c->iterator->var);
334 fputc ('=', dumpfile);
335 show_expr (c->iterator->start);
336 fputc (',', dumpfile);
337 show_expr (c->iterator->end);
338 fputc (',', dumpfile);
339 show_expr (c->iterator->step);
340
341 fputc (')', dumpfile);
342 }
343
344 if (gfc_constructor_next (c) != NULL)
345 fputs (" , ", dumpfile);
346 }
347 }
348
349
350 static void
show_char_const(const gfc_char_t * c,gfc_charlen_t length)351 show_char_const (const gfc_char_t *c, gfc_charlen_t length)
352 {
353 fputc ('\'', dumpfile);
354 for (size_t i = 0; i < (size_t) length; i++)
355 {
356 if (c[i] == '\'')
357 fputs ("''", dumpfile);
358 else
359 fputs (gfc_print_wide_char (c[i]), dumpfile);
360 }
361 fputc ('\'', dumpfile);
362 }
363
364
365 /* Show a component-call expression. */
366
367 static void
show_compcall(gfc_expr * p)368 show_compcall (gfc_expr* p)
369 {
370 gcc_assert (p->expr_type == EXPR_COMPCALL);
371
372 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
373 show_ref (p->ref);
374 fprintf (dumpfile, "%s", p->value.compcall.name);
375
376 show_actual_arglist (p->value.compcall.actual);
377 }
378
379
380 /* Show an expression. */
381
382 static void
show_expr(gfc_expr * p)383 show_expr (gfc_expr *p)
384 {
385 const char *c;
386 int i;
387
388 if (p == NULL)
389 {
390 fputs ("()", dumpfile);
391 return;
392 }
393
394 switch (p->expr_type)
395 {
396 case EXPR_SUBSTRING:
397 show_char_const (p->value.character.string, p->value.character.length);
398 show_ref (p->ref);
399 break;
400
401 case EXPR_STRUCTURE:
402 fprintf (dumpfile, "%s(", p->ts.u.derived->name);
403 show_constructor (p->value.constructor);
404 fputc (')', dumpfile);
405 break;
406
407 case EXPR_ARRAY:
408 fputs ("(/ ", dumpfile);
409 show_constructor (p->value.constructor);
410 fputs (" /)", dumpfile);
411
412 show_ref (p->ref);
413 break;
414
415 case EXPR_NULL:
416 fputs ("NULL()", dumpfile);
417 break;
418
419 case EXPR_CONSTANT:
420 switch (p->ts.type)
421 {
422 case BT_INTEGER:
423 mpz_out_str (dumpfile, 10, p->value.integer);
424
425 if (p->ts.kind != gfc_default_integer_kind)
426 fprintf (dumpfile, "_%d", p->ts.kind);
427 break;
428
429 case BT_LOGICAL:
430 if (p->value.logical)
431 fputs (".true.", dumpfile);
432 else
433 fputs (".false.", dumpfile);
434 break;
435
436 case BT_REAL:
437 mpfr_out_str (dumpfile, 10, 0, p->value.real, GFC_RND_MODE);
438 if (p->ts.kind != gfc_default_real_kind)
439 fprintf (dumpfile, "_%d", p->ts.kind);
440 break;
441
442 case BT_CHARACTER:
443 show_char_const (p->value.character.string,
444 p->value.character.length);
445 break;
446
447 case BT_COMPLEX:
448 fputs ("(complex ", dumpfile);
449
450 mpfr_out_str (dumpfile, 10, 0, mpc_realref (p->value.complex),
451 GFC_RND_MODE);
452 if (p->ts.kind != gfc_default_complex_kind)
453 fprintf (dumpfile, "_%d", p->ts.kind);
454
455 fputc (' ', dumpfile);
456
457 mpfr_out_str (dumpfile, 10, 0, mpc_imagref (p->value.complex),
458 GFC_RND_MODE);
459 if (p->ts.kind != gfc_default_complex_kind)
460 fprintf (dumpfile, "_%d", p->ts.kind);
461
462 fputc (')', dumpfile);
463 break;
464
465 case BT_HOLLERITH:
466 fprintf (dumpfile, HOST_WIDE_INT_PRINT_DEC "H",
467 p->representation.length);
468 c = p->representation.string;
469 for (i = 0; i < p->representation.length; i++, c++)
470 {
471 fputc (*c, dumpfile);
472 }
473 break;
474
475 default:
476 fputs ("???", dumpfile);
477 break;
478 }
479
480 if (p->representation.string)
481 {
482 fputs (" {", dumpfile);
483 c = p->representation.string;
484 for (i = 0; i < p->representation.length; i++, c++)
485 {
486 fprintf (dumpfile, "%.2x", (unsigned int) *c);
487 if (i < p->representation.length - 1)
488 fputc (',', dumpfile);
489 }
490 fputc ('}', dumpfile);
491 }
492
493 break;
494
495 case EXPR_VARIABLE:
496 if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
497 fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
498 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
499 show_ref (p->ref);
500 break;
501
502 case EXPR_OP:
503 fputc ('(', dumpfile);
504 switch (p->value.op.op)
505 {
506 case INTRINSIC_UPLUS:
507 fputs ("U+ ", dumpfile);
508 break;
509 case INTRINSIC_UMINUS:
510 fputs ("U- ", dumpfile);
511 break;
512 case INTRINSIC_PLUS:
513 fputs ("+ ", dumpfile);
514 break;
515 case INTRINSIC_MINUS:
516 fputs ("- ", dumpfile);
517 break;
518 case INTRINSIC_TIMES:
519 fputs ("* ", dumpfile);
520 break;
521 case INTRINSIC_DIVIDE:
522 fputs ("/ ", dumpfile);
523 break;
524 case INTRINSIC_POWER:
525 fputs ("** ", dumpfile);
526 break;
527 case INTRINSIC_CONCAT:
528 fputs ("// ", dumpfile);
529 break;
530 case INTRINSIC_AND:
531 fputs ("AND ", dumpfile);
532 break;
533 case INTRINSIC_OR:
534 fputs ("OR ", dumpfile);
535 break;
536 case INTRINSIC_EQV:
537 fputs ("EQV ", dumpfile);
538 break;
539 case INTRINSIC_NEQV:
540 fputs ("NEQV ", dumpfile);
541 break;
542 case INTRINSIC_EQ:
543 case INTRINSIC_EQ_OS:
544 fputs ("= ", dumpfile);
545 break;
546 case INTRINSIC_NE:
547 case INTRINSIC_NE_OS:
548 fputs ("/= ", dumpfile);
549 break;
550 case INTRINSIC_GT:
551 case INTRINSIC_GT_OS:
552 fputs ("> ", dumpfile);
553 break;
554 case INTRINSIC_GE:
555 case INTRINSIC_GE_OS:
556 fputs (">= ", dumpfile);
557 break;
558 case INTRINSIC_LT:
559 case INTRINSIC_LT_OS:
560 fputs ("< ", dumpfile);
561 break;
562 case INTRINSIC_LE:
563 case INTRINSIC_LE_OS:
564 fputs ("<= ", dumpfile);
565 break;
566 case INTRINSIC_NOT:
567 fputs ("NOT ", dumpfile);
568 break;
569 case INTRINSIC_PARENTHESES:
570 fputs ("parens ", dumpfile);
571 break;
572
573 default:
574 gfc_internal_error
575 ("show_expr(): Bad intrinsic in expression");
576 }
577
578 show_expr (p->value.op.op1);
579
580 if (p->value.op.op2)
581 {
582 fputc (' ', dumpfile);
583 show_expr (p->value.op.op2);
584 }
585
586 fputc (')', dumpfile);
587 break;
588
589 case EXPR_FUNCTION:
590 if (p->value.function.name == NULL)
591 {
592 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
593 if (gfc_is_proc_ptr_comp (p))
594 show_ref (p->ref);
595 fputc ('[', dumpfile);
596 show_actual_arglist (p->value.function.actual);
597 fputc (']', dumpfile);
598 }
599 else
600 {
601 fprintf (dumpfile, "%s", p->value.function.name);
602 if (gfc_is_proc_ptr_comp (p))
603 show_ref (p->ref);
604 fputc ('[', dumpfile);
605 fputc ('[', dumpfile);
606 show_actual_arglist (p->value.function.actual);
607 fputc (']', dumpfile);
608 fputc (']', dumpfile);
609 }
610
611 break;
612
613 case EXPR_COMPCALL:
614 show_compcall (p);
615 break;
616
617 default:
618 gfc_internal_error ("show_expr(): Don't know how to show expr");
619 }
620 }
621
622 /* Show symbol attributes. The flavor and intent are followed by
623 whatever single bit attributes are present. */
624
625 static void
show_attr(symbol_attribute * attr,const char * module)626 show_attr (symbol_attribute *attr, const char * module)
627 {
628 if (attr->flavor != FL_UNKNOWN)
629 {
630 if (attr->flavor == FL_DERIVED && attr->pdt_template)
631 fputs (" (PDT template", dumpfile);
632 else
633 fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor));
634 }
635 if (attr->access != ACCESS_UNKNOWN)
636 fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access));
637 if (attr->proc != PROC_UNKNOWN)
638 fprintf (dumpfile, "%s ", gfc_code2string (procedures, attr->proc));
639 if (attr->save != SAVE_NONE)
640 fprintf (dumpfile, "%s", gfc_code2string (save_status, attr->save));
641
642 if (attr->artificial)
643 fputs (" ARTIFICIAL", dumpfile);
644 if (attr->allocatable)
645 fputs (" ALLOCATABLE", dumpfile);
646 if (attr->asynchronous)
647 fputs (" ASYNCHRONOUS", dumpfile);
648 if (attr->codimension)
649 fputs (" CODIMENSION", dumpfile);
650 if (attr->dimension)
651 fputs (" DIMENSION", dumpfile);
652 if (attr->contiguous)
653 fputs (" CONTIGUOUS", dumpfile);
654 if (attr->external)
655 fputs (" EXTERNAL", dumpfile);
656 if (attr->intrinsic)
657 fputs (" INTRINSIC", dumpfile);
658 if (attr->optional)
659 fputs (" OPTIONAL", dumpfile);
660 if (attr->pdt_kind)
661 fputs (" KIND", dumpfile);
662 if (attr->pdt_len)
663 fputs (" LEN", dumpfile);
664 if (attr->pointer)
665 fputs (" POINTER", dumpfile);
666 if (attr->is_protected)
667 fputs (" PROTECTED", dumpfile);
668 if (attr->value)
669 fputs (" VALUE", dumpfile);
670 if (attr->volatile_)
671 fputs (" VOLATILE", dumpfile);
672 if (attr->threadprivate)
673 fputs (" THREADPRIVATE", dumpfile);
674 if (attr->target)
675 fputs (" TARGET", dumpfile);
676 if (attr->dummy)
677 {
678 fputs (" DUMMY", dumpfile);
679 if (attr->intent != INTENT_UNKNOWN)
680 fprintf (dumpfile, "(%s)", gfc_intent_string (attr->intent));
681 }
682
683 if (attr->result)
684 fputs (" RESULT", dumpfile);
685 if (attr->entry)
686 fputs (" ENTRY", dumpfile);
687 if (attr->is_bind_c)
688 fputs (" BIND(C)", dumpfile);
689
690 if (attr->data)
691 fputs (" DATA", dumpfile);
692 if (attr->use_assoc)
693 {
694 fputs (" USE-ASSOC", dumpfile);
695 if (module != NULL)
696 fprintf (dumpfile, "(%s)", module);
697 }
698
699 if (attr->in_namelist)
700 fputs (" IN-NAMELIST", dumpfile);
701 if (attr->in_common)
702 fputs (" IN-COMMON", dumpfile);
703
704 if (attr->abstract)
705 fputs (" ABSTRACT", dumpfile);
706 if (attr->function)
707 fputs (" FUNCTION", dumpfile);
708 if (attr->subroutine)
709 fputs (" SUBROUTINE", dumpfile);
710 if (attr->implicit_type)
711 fputs (" IMPLICIT-TYPE", dumpfile);
712
713 if (attr->sequence)
714 fputs (" SEQUENCE", dumpfile);
715 if (attr->elemental)
716 fputs (" ELEMENTAL", dumpfile);
717 if (attr->pure)
718 fputs (" PURE", dumpfile);
719 if (attr->recursive)
720 fputs (" RECURSIVE", dumpfile);
721
722 fputc (')', dumpfile);
723 }
724
725
726 /* Show components of a derived type. */
727
728 static void
show_components(gfc_symbol * sym)729 show_components (gfc_symbol *sym)
730 {
731 gfc_component *c;
732
733 for (c = sym->components; c; c = c->next)
734 {
735 show_indent ();
736 fprintf (dumpfile, "(%s ", c->name);
737 show_typespec (&c->ts);
738 if (c->kind_expr)
739 {
740 fputs (" kind_expr: ", dumpfile);
741 show_expr (c->kind_expr);
742 }
743 if (c->param_list)
744 {
745 fputs ("PDT parameters", dumpfile);
746 show_actual_arglist (c->param_list);
747 }
748
749 if (c->attr.allocatable)
750 fputs (" ALLOCATABLE", dumpfile);
751 if (c->attr.pdt_kind)
752 fputs (" KIND", dumpfile);
753 if (c->attr.pdt_len)
754 fputs (" LEN", dumpfile);
755 if (c->attr.pointer)
756 fputs (" POINTER", dumpfile);
757 if (c->attr.proc_pointer)
758 fputs (" PPC", dumpfile);
759 if (c->attr.dimension)
760 fputs (" DIMENSION", dumpfile);
761 fputc (' ', dumpfile);
762 show_array_spec (c->as);
763 if (c->attr.access)
764 fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
765 fputc (')', dumpfile);
766 if (c->next != NULL)
767 fputc (' ', dumpfile);
768 }
769 }
770
771
772 /* Show the f2k_derived namespace with procedure bindings. */
773
774 static void
show_typebound_proc(gfc_typebound_proc * tb,const char * name)775 show_typebound_proc (gfc_typebound_proc* tb, const char* name)
776 {
777 show_indent ();
778
779 if (tb->is_generic)
780 fputs ("GENERIC", dumpfile);
781 else
782 {
783 fputs ("PROCEDURE, ", dumpfile);
784 if (tb->nopass)
785 fputs ("NOPASS", dumpfile);
786 else
787 {
788 if (tb->pass_arg)
789 fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
790 else
791 fputs ("PASS", dumpfile);
792 }
793 if (tb->non_overridable)
794 fputs (", NON_OVERRIDABLE", dumpfile);
795 }
796
797 if (tb->access == ACCESS_PUBLIC)
798 fputs (", PUBLIC", dumpfile);
799 else
800 fputs (", PRIVATE", dumpfile);
801
802 fprintf (dumpfile, " :: %s => ", name);
803
804 if (tb->is_generic)
805 {
806 gfc_tbp_generic* g;
807 for (g = tb->u.generic; g; g = g->next)
808 {
809 fputs (g->specific_st->name, dumpfile);
810 if (g->next)
811 fputs (", ", dumpfile);
812 }
813 }
814 else
815 fputs (tb->u.specific->n.sym->name, dumpfile);
816 }
817
818 static void
show_typebound_symtree(gfc_symtree * st)819 show_typebound_symtree (gfc_symtree* st)
820 {
821 gcc_assert (st->n.tb);
822 show_typebound_proc (st->n.tb, st->name);
823 }
824
825 static void
show_f2k_derived(gfc_namespace * f2k)826 show_f2k_derived (gfc_namespace* f2k)
827 {
828 gfc_finalizer* f;
829 int op;
830
831 show_indent ();
832 fputs ("Procedure bindings:", dumpfile);
833 ++show_level;
834
835 /* Finalizer bindings. */
836 for (f = f2k->finalizers; f; f = f->next)
837 {
838 show_indent ();
839 fprintf (dumpfile, "FINAL %s", f->proc_tree->n.sym->name);
840 }
841
842 /* Type-bound procedures. */
843 gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
844
845 --show_level;
846
847 show_indent ();
848 fputs ("Operator bindings:", dumpfile);
849 ++show_level;
850
851 /* User-defined operators. */
852 gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
853
854 /* Intrinsic operators. */
855 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
856 if (f2k->tb_op[op])
857 show_typebound_proc (f2k->tb_op[op],
858 gfc_op2string ((gfc_intrinsic_op) op));
859
860 --show_level;
861 }
862
863
864 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
865 show the interface. Information needed to reconstruct the list of
866 specific interfaces associated with a generic symbol is done within
867 that symbol. */
868
869 static void
show_symbol(gfc_symbol * sym)870 show_symbol (gfc_symbol *sym)
871 {
872 gfc_formal_arglist *formal;
873 gfc_interface *intr;
874 int i,len;
875
876 if (sym == NULL)
877 return;
878
879 fprintf (dumpfile, "|| symbol: '%s' ", sym->name);
880 len = strlen (sym->name);
881 for (i=len; i<12; i++)
882 fputc(' ', dumpfile);
883
884 if (sym->binding_label)
885 fprintf (dumpfile,"|| binding_label: '%s' ", sym->binding_label);
886
887 ++show_level;
888
889 show_indent ();
890 fputs ("type spec : ", dumpfile);
891 show_typespec (&sym->ts);
892
893 show_indent ();
894 fputs ("attributes: ", dumpfile);
895 show_attr (&sym->attr, sym->module);
896
897 if (sym->value)
898 {
899 show_indent ();
900 fputs ("value: ", dumpfile);
901 show_expr (sym->value);
902 }
903
904 if (sym->as)
905 {
906 show_indent ();
907 fputs ("Array spec:", dumpfile);
908 show_array_spec (sym->as);
909 }
910
911 if (sym->generic)
912 {
913 show_indent ();
914 fputs ("Generic interfaces:", dumpfile);
915 for (intr = sym->generic; intr; intr = intr->next)
916 fprintf (dumpfile, " %s", intr->sym->name);
917 }
918
919 if (sym->result)
920 {
921 show_indent ();
922 fprintf (dumpfile, "result: %s", sym->result->name);
923 }
924
925 if (sym->components)
926 {
927 show_indent ();
928 fputs ("components: ", dumpfile);
929 show_components (sym);
930 }
931
932 if (sym->f2k_derived)
933 {
934 show_indent ();
935 if (sym->hash_value)
936 fprintf (dumpfile, "hash: %d", sym->hash_value);
937 show_f2k_derived (sym->f2k_derived);
938 }
939
940 if (sym->formal)
941 {
942 show_indent ();
943 fputs ("Formal arglist:", dumpfile);
944
945 for (formal = sym->formal; formal; formal = formal->next)
946 {
947 if (formal->sym != NULL)
948 fprintf (dumpfile, " %s", formal->sym->name);
949 else
950 fputs (" [Alt Return]", dumpfile);
951 }
952 }
953
954 if (sym->formal_ns && (sym->formal_ns->proc_name != sym)
955 && sym->attr.proc != PROC_ST_FUNCTION
956 && !sym->attr.entry)
957 {
958 show_indent ();
959 fputs ("Formal namespace", dumpfile);
960 show_namespace (sym->formal_ns);
961 }
962
963 if (sym->attr.flavor == FL_VARIABLE
964 && sym->param_list)
965 {
966 show_indent ();
967 fputs ("PDT parameters", dumpfile);
968 show_actual_arglist (sym->param_list);
969 }
970
971 if (sym->attr.flavor == FL_NAMELIST)
972 {
973 gfc_namelist *nl;
974 show_indent ();
975 fputs ("variables : ", dumpfile);
976 for (nl = sym->namelist; nl; nl = nl->next)
977 fprintf (dumpfile, " %s",nl->sym->name);
978 }
979
980 --show_level;
981 }
982
983
984 /* Show a user-defined operator. Just prints an operator
985 and the name of the associated subroutine, really. */
986
987 static void
show_uop(gfc_user_op * uop)988 show_uop (gfc_user_op *uop)
989 {
990 gfc_interface *intr;
991
992 show_indent ();
993 fprintf (dumpfile, "%s:", uop->name);
994
995 for (intr = uop->op; intr; intr = intr->next)
996 fprintf (dumpfile, " %s", intr->sym->name);
997 }
998
999
1000 /* Workhorse function for traversing the user operator symtree. */
1001
1002 static void
traverse_uop(gfc_symtree * st,void (* func)(gfc_user_op *))1003 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
1004 {
1005 if (st == NULL)
1006 return;
1007
1008 (*func) (st->n.uop);
1009
1010 traverse_uop (st->left, func);
1011 traverse_uop (st->right, func);
1012 }
1013
1014
1015 /* Traverse the tree of user operator nodes. */
1016
1017 void
gfc_traverse_user_op(gfc_namespace * ns,void (* func)(gfc_user_op *))1018 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
1019 {
1020 traverse_uop (ns->uop_root, func);
1021 }
1022
1023
1024 /* Function to display a common block. */
1025
1026 static void
show_common(gfc_symtree * st)1027 show_common (gfc_symtree *st)
1028 {
1029 gfc_symbol *s;
1030
1031 show_indent ();
1032 fprintf (dumpfile, "common: /%s/ ", st->name);
1033
1034 s = st->n.common->head;
1035 while (s)
1036 {
1037 fprintf (dumpfile, "%s", s->name);
1038 s = s->common_next;
1039 if (s)
1040 fputs (", ", dumpfile);
1041 }
1042 fputc ('\n', dumpfile);
1043 }
1044
1045
1046 /* Worker function to display the symbol tree. */
1047
1048 static void
show_symtree(gfc_symtree * st)1049 show_symtree (gfc_symtree *st)
1050 {
1051 int len, i;
1052
1053 show_indent ();
1054
1055 len = strlen(st->name);
1056 fprintf (dumpfile, "symtree: '%s'", st->name);
1057
1058 for (i=len; i<12; i++)
1059 fputc(' ', dumpfile);
1060
1061 if (st->ambiguous)
1062 fputs( " Ambiguous", dumpfile);
1063
1064 if (st->n.sym->ns != gfc_current_ns)
1065 fprintf (dumpfile, "|| symbol: '%s' from namespace '%s'", st->n.sym->name,
1066 st->n.sym->ns->proc_name->name);
1067 else
1068 show_symbol (st->n.sym);
1069 }
1070
1071
1072 /******************* Show gfc_code structures **************/
1073
1074
1075 /* Show a list of code structures. Mutually recursive with
1076 show_code_node(). */
1077
1078 static void
show_code(int level,gfc_code * c)1079 show_code (int level, gfc_code *c)
1080 {
1081 for (; c; c = c->next)
1082 show_code_node (level, c);
1083 }
1084
1085 static void
show_omp_namelist(int list_type,gfc_omp_namelist * n)1086 show_omp_namelist (int list_type, gfc_omp_namelist *n)
1087 {
1088 for (; n; n = n->next)
1089 {
1090 if (list_type == OMP_LIST_REDUCTION)
1091 switch (n->u.reduction_op)
1092 {
1093 case OMP_REDUCTION_PLUS:
1094 case OMP_REDUCTION_TIMES:
1095 case OMP_REDUCTION_MINUS:
1096 case OMP_REDUCTION_AND:
1097 case OMP_REDUCTION_OR:
1098 case OMP_REDUCTION_EQV:
1099 case OMP_REDUCTION_NEQV:
1100 fprintf (dumpfile, "%s:",
1101 gfc_op2string ((gfc_intrinsic_op) n->u.reduction_op));
1102 break;
1103 case OMP_REDUCTION_MAX: fputs ("max:", dumpfile); break;
1104 case OMP_REDUCTION_MIN: fputs ("min:", dumpfile); break;
1105 case OMP_REDUCTION_IAND: fputs ("iand:", dumpfile); break;
1106 case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break;
1107 case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break;
1108 case OMP_REDUCTION_USER:
1109 if (n->udr)
1110 fprintf (dumpfile, "%s:", n->udr->udr->name);
1111 break;
1112 default: break;
1113 }
1114 else if (list_type == OMP_LIST_DEPEND)
1115 switch (n->u.depend_op)
1116 {
1117 case OMP_DEPEND_IN: fputs ("in:", dumpfile); break;
1118 case OMP_DEPEND_OUT: fputs ("out:", dumpfile); break;
1119 case OMP_DEPEND_INOUT: fputs ("inout:", dumpfile); break;
1120 case OMP_DEPEND_SINK_FIRST:
1121 fputs ("sink:", dumpfile);
1122 while (1)
1123 {
1124 fprintf (dumpfile, "%s", n->sym->name);
1125 if (n->expr)
1126 {
1127 fputc ('+', dumpfile);
1128 show_expr (n->expr);
1129 }
1130 if (n->next == NULL)
1131 break;
1132 else if (n->next->u.depend_op != OMP_DEPEND_SINK)
1133 {
1134 fputs (") DEPEND(", dumpfile);
1135 break;
1136 }
1137 fputc (',', dumpfile);
1138 n = n->next;
1139 }
1140 continue;
1141 default: break;
1142 }
1143 else if (list_type == OMP_LIST_MAP)
1144 switch (n->u.map_op)
1145 {
1146 case OMP_MAP_ALLOC: fputs ("alloc:", dumpfile); break;
1147 case OMP_MAP_TO: fputs ("to:", dumpfile); break;
1148 case OMP_MAP_FROM: fputs ("from:", dumpfile); break;
1149 case OMP_MAP_TOFROM: fputs ("tofrom:", dumpfile); break;
1150 default: break;
1151 }
1152 else if (list_type == OMP_LIST_LINEAR)
1153 switch (n->u.linear_op)
1154 {
1155 case OMP_LINEAR_REF: fputs ("ref(", dumpfile); break;
1156 case OMP_LINEAR_VAL: fputs ("val(", dumpfile); break;
1157 case OMP_LINEAR_UVAL: fputs ("uval(", dumpfile); break;
1158 default: break;
1159 }
1160 fprintf (dumpfile, "%s", n->sym->name);
1161 if (list_type == OMP_LIST_LINEAR && n->u.linear_op != OMP_LINEAR_DEFAULT)
1162 fputc (')', dumpfile);
1163 if (n->expr)
1164 {
1165 fputc (':', dumpfile);
1166 show_expr (n->expr);
1167 }
1168 if (n->next)
1169 fputc (',', dumpfile);
1170 }
1171 }
1172
1173
1174 /* Show OpenMP or OpenACC clauses. */
1175
1176 static void
show_omp_clauses(gfc_omp_clauses * omp_clauses)1177 show_omp_clauses (gfc_omp_clauses *omp_clauses)
1178 {
1179 int list_type, i;
1180
1181 switch (omp_clauses->cancel)
1182 {
1183 case OMP_CANCEL_UNKNOWN:
1184 break;
1185 case OMP_CANCEL_PARALLEL:
1186 fputs (" PARALLEL", dumpfile);
1187 break;
1188 case OMP_CANCEL_SECTIONS:
1189 fputs (" SECTIONS", dumpfile);
1190 break;
1191 case OMP_CANCEL_DO:
1192 fputs (" DO", dumpfile);
1193 break;
1194 case OMP_CANCEL_TASKGROUP:
1195 fputs (" TASKGROUP", dumpfile);
1196 break;
1197 }
1198 if (omp_clauses->if_expr)
1199 {
1200 fputs (" IF(", dumpfile);
1201 show_expr (omp_clauses->if_expr);
1202 fputc (')', dumpfile);
1203 }
1204 if (omp_clauses->final_expr)
1205 {
1206 fputs (" FINAL(", dumpfile);
1207 show_expr (omp_clauses->final_expr);
1208 fputc (')', dumpfile);
1209 }
1210 if (omp_clauses->num_threads)
1211 {
1212 fputs (" NUM_THREADS(", dumpfile);
1213 show_expr (omp_clauses->num_threads);
1214 fputc (')', dumpfile);
1215 }
1216 if (omp_clauses->async)
1217 {
1218 fputs (" ASYNC", dumpfile);
1219 if (omp_clauses->async_expr)
1220 {
1221 fputc ('(', dumpfile);
1222 show_expr (omp_clauses->async_expr);
1223 fputc (')', dumpfile);
1224 }
1225 }
1226 if (omp_clauses->num_gangs_expr)
1227 {
1228 fputs (" NUM_GANGS(", dumpfile);
1229 show_expr (omp_clauses->num_gangs_expr);
1230 fputc (')', dumpfile);
1231 }
1232 if (omp_clauses->num_workers_expr)
1233 {
1234 fputs (" NUM_WORKERS(", dumpfile);
1235 show_expr (omp_clauses->num_workers_expr);
1236 fputc (')', dumpfile);
1237 }
1238 if (omp_clauses->vector_length_expr)
1239 {
1240 fputs (" VECTOR_LENGTH(", dumpfile);
1241 show_expr (omp_clauses->vector_length_expr);
1242 fputc (')', dumpfile);
1243 }
1244 if (omp_clauses->gang)
1245 {
1246 fputs (" GANG", dumpfile);
1247 if (omp_clauses->gang_num_expr || omp_clauses->gang_static_expr)
1248 {
1249 fputc ('(', dumpfile);
1250 if (omp_clauses->gang_num_expr)
1251 {
1252 fprintf (dumpfile, "num:");
1253 show_expr (omp_clauses->gang_num_expr);
1254 }
1255 if (omp_clauses->gang_num_expr && omp_clauses->gang_static)
1256 fputc (',', dumpfile);
1257 if (omp_clauses->gang_static)
1258 {
1259 fprintf (dumpfile, "static:");
1260 if (omp_clauses->gang_static_expr)
1261 show_expr (omp_clauses->gang_static_expr);
1262 else
1263 fputc ('*', dumpfile);
1264 }
1265 fputc (')', dumpfile);
1266 }
1267 }
1268 if (omp_clauses->worker)
1269 {
1270 fputs (" WORKER", dumpfile);
1271 if (omp_clauses->worker_expr)
1272 {
1273 fputc ('(', dumpfile);
1274 show_expr (omp_clauses->worker_expr);
1275 fputc (')', dumpfile);
1276 }
1277 }
1278 if (omp_clauses->vector)
1279 {
1280 fputs (" VECTOR", dumpfile);
1281 if (omp_clauses->vector_expr)
1282 {
1283 fputc ('(', dumpfile);
1284 show_expr (omp_clauses->vector_expr);
1285 fputc (')', dumpfile);
1286 }
1287 }
1288 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1289 {
1290 const char *type;
1291 switch (omp_clauses->sched_kind)
1292 {
1293 case OMP_SCHED_STATIC: type = "STATIC"; break;
1294 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1295 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1296 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1297 case OMP_SCHED_AUTO: type = "AUTO"; break;
1298 default:
1299 gcc_unreachable ();
1300 }
1301 fputs (" SCHEDULE (", dumpfile);
1302 if (omp_clauses->sched_simd)
1303 {
1304 if (omp_clauses->sched_monotonic
1305 || omp_clauses->sched_nonmonotonic)
1306 fputs ("SIMD, ", dumpfile);
1307 else
1308 fputs ("SIMD: ", dumpfile);
1309 }
1310 if (omp_clauses->sched_monotonic)
1311 fputs ("MONOTONIC: ", dumpfile);
1312 else if (omp_clauses->sched_nonmonotonic)
1313 fputs ("NONMONOTONIC: ", dumpfile);
1314 fputs (type, dumpfile);
1315 if (omp_clauses->chunk_size)
1316 {
1317 fputc (',', dumpfile);
1318 show_expr (omp_clauses->chunk_size);
1319 }
1320 fputc (')', dumpfile);
1321 }
1322 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1323 {
1324 const char *type;
1325 switch (omp_clauses->default_sharing)
1326 {
1327 case OMP_DEFAULT_NONE: type = "NONE"; break;
1328 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1329 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1330 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1331 case OMP_DEFAULT_PRESENT: type = "PRESENT"; break;
1332 default:
1333 gcc_unreachable ();
1334 }
1335 fprintf (dumpfile, " DEFAULT(%s)", type);
1336 }
1337 if (omp_clauses->tile_list)
1338 {
1339 gfc_expr_list *list;
1340 fputs (" TILE(", dumpfile);
1341 for (list = omp_clauses->tile_list; list; list = list->next)
1342 {
1343 show_expr (list->expr);
1344 if (list->next)
1345 fputs (", ", dumpfile);
1346 }
1347 fputc (')', dumpfile);
1348 }
1349 if (omp_clauses->wait_list)
1350 {
1351 gfc_expr_list *list;
1352 fputs (" WAIT(", dumpfile);
1353 for (list = omp_clauses->wait_list; list; list = list->next)
1354 {
1355 show_expr (list->expr);
1356 if (list->next)
1357 fputs (", ", dumpfile);
1358 }
1359 fputc (')', dumpfile);
1360 }
1361 if (omp_clauses->seq)
1362 fputs (" SEQ", dumpfile);
1363 if (omp_clauses->independent)
1364 fputs (" INDEPENDENT", dumpfile);
1365 if (omp_clauses->ordered)
1366 {
1367 if (omp_clauses->orderedc)
1368 fprintf (dumpfile, " ORDERED(%d)", omp_clauses->orderedc);
1369 else
1370 fputs (" ORDERED", dumpfile);
1371 }
1372 if (omp_clauses->untied)
1373 fputs (" UNTIED", dumpfile);
1374 if (omp_clauses->mergeable)
1375 fputs (" MERGEABLE", dumpfile);
1376 if (omp_clauses->collapse)
1377 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1378 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1379 if (omp_clauses->lists[list_type] != NULL
1380 && list_type != OMP_LIST_COPYPRIVATE)
1381 {
1382 const char *type = NULL;
1383 switch (list_type)
1384 {
1385 case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break;
1386 case OMP_LIST_DEVICE_RESIDENT: type = "USE_DEVICE"; break;
1387 case OMP_LIST_CACHE: type = ""; break;
1388 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1389 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1390 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1391 case OMP_LIST_SHARED: type = "SHARED"; break;
1392 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1393 case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
1394 case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
1395 case OMP_LIST_LINEAR: type = "LINEAR"; break;
1396 case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
1397 case OMP_LIST_IS_DEVICE_PTR: type = "IS_DEVICE_PTR"; break;
1398 case OMP_LIST_USE_DEVICE_PTR: type = "USE_DEVICE_PTR"; break;
1399 case OMP_LIST_DEPEND: type = "DEPEND"; break;
1400 default:
1401 gcc_unreachable ();
1402 }
1403 fprintf (dumpfile, " %s(", type);
1404 show_omp_namelist (list_type, omp_clauses->lists[list_type]);
1405 fputc (')', dumpfile);
1406 }
1407 if (omp_clauses->safelen_expr)
1408 {
1409 fputs (" SAFELEN(", dumpfile);
1410 show_expr (omp_clauses->safelen_expr);
1411 fputc (')', dumpfile);
1412 }
1413 if (omp_clauses->simdlen_expr)
1414 {
1415 fputs (" SIMDLEN(", dumpfile);
1416 show_expr (omp_clauses->simdlen_expr);
1417 fputc (')', dumpfile);
1418 }
1419 if (omp_clauses->inbranch)
1420 fputs (" INBRANCH", dumpfile);
1421 if (omp_clauses->notinbranch)
1422 fputs (" NOTINBRANCH", dumpfile);
1423 if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
1424 {
1425 const char *type;
1426 switch (omp_clauses->proc_bind)
1427 {
1428 case OMP_PROC_BIND_MASTER: type = "MASTER"; break;
1429 case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break;
1430 case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break;
1431 default:
1432 gcc_unreachable ();
1433 }
1434 fprintf (dumpfile, " PROC_BIND(%s)", type);
1435 }
1436 if (omp_clauses->num_teams)
1437 {
1438 fputs (" NUM_TEAMS(", dumpfile);
1439 show_expr (omp_clauses->num_teams);
1440 fputc (')', dumpfile);
1441 }
1442 if (omp_clauses->device)
1443 {
1444 fputs (" DEVICE(", dumpfile);
1445 show_expr (omp_clauses->device);
1446 fputc (')', dumpfile);
1447 }
1448 if (omp_clauses->thread_limit)
1449 {
1450 fputs (" THREAD_LIMIT(", dumpfile);
1451 show_expr (omp_clauses->thread_limit);
1452 fputc (')', dumpfile);
1453 }
1454 if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE)
1455 {
1456 fprintf (dumpfile, " DIST_SCHEDULE (STATIC");
1457 if (omp_clauses->dist_chunk_size)
1458 {
1459 fputc (',', dumpfile);
1460 show_expr (omp_clauses->dist_chunk_size);
1461 }
1462 fputc (')', dumpfile);
1463 }
1464 if (omp_clauses->defaultmap)
1465 fputs (" DEFALTMAP (TOFROM: SCALAR)", dumpfile);
1466 if (omp_clauses->nogroup)
1467 fputs (" NOGROUP", dumpfile);
1468 if (omp_clauses->simd)
1469 fputs (" SIMD", dumpfile);
1470 if (omp_clauses->threads)
1471 fputs (" THREADS", dumpfile);
1472 if (omp_clauses->grainsize)
1473 {
1474 fputs (" GRAINSIZE(", dumpfile);
1475 show_expr (omp_clauses->grainsize);
1476 fputc (')', dumpfile);
1477 }
1478 if (omp_clauses->hint)
1479 {
1480 fputs (" HINT(", dumpfile);
1481 show_expr (omp_clauses->hint);
1482 fputc (')', dumpfile);
1483 }
1484 if (omp_clauses->num_tasks)
1485 {
1486 fputs (" NUM_TASKS(", dumpfile);
1487 show_expr (omp_clauses->num_tasks);
1488 fputc (')', dumpfile);
1489 }
1490 if (omp_clauses->priority)
1491 {
1492 fputs (" PRIORITY(", dumpfile);
1493 show_expr (omp_clauses->priority);
1494 fputc (')', dumpfile);
1495 }
1496 for (i = 0; i < OMP_IF_LAST; i++)
1497 if (omp_clauses->if_exprs[i])
1498 {
1499 static const char *ifs[] = {
1500 "PARALLEL",
1501 "TASK",
1502 "TASKLOOP",
1503 "TARGET",
1504 "TARGET DATA",
1505 "TARGET UPDATE",
1506 "TARGET ENTER DATA",
1507 "TARGET EXIT DATA"
1508 };
1509 fputs (" IF(", dumpfile);
1510 fputs (ifs[i], dumpfile);
1511 fputs (": ", dumpfile);
1512 show_expr (omp_clauses->if_exprs[i]);
1513 fputc (')', dumpfile);
1514 }
1515 if (omp_clauses->depend_source)
1516 fputs (" DEPEND(source)", dumpfile);
1517 }
1518
1519 /* Show a single OpenMP or OpenACC directive node and everything underneath it
1520 if necessary. */
1521
1522 static void
show_omp_node(int level,gfc_code * c)1523 show_omp_node (int level, gfc_code *c)
1524 {
1525 gfc_omp_clauses *omp_clauses = NULL;
1526 const char *name = NULL;
1527 bool is_oacc = false;
1528
1529 switch (c->op)
1530 {
1531 case EXEC_OACC_PARALLEL_LOOP:
1532 name = "PARALLEL LOOP"; is_oacc = true; break;
1533 case EXEC_OACC_PARALLEL: name = "PARALLEL"; is_oacc = true; break;
1534 case EXEC_OACC_KERNELS_LOOP: name = "KERNELS LOOP"; is_oacc = true; break;
1535 case EXEC_OACC_KERNELS: name = "KERNELS"; is_oacc = true; break;
1536 case EXEC_OACC_DATA: name = "DATA"; is_oacc = true; break;
1537 case EXEC_OACC_HOST_DATA: name = "HOST_DATA"; is_oacc = true; break;
1538 case EXEC_OACC_LOOP: name = "LOOP"; is_oacc = true; break;
1539 case EXEC_OACC_UPDATE: name = "UPDATE"; is_oacc = true; break;
1540 case EXEC_OACC_WAIT: name = "WAIT"; is_oacc = true; break;
1541 case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
1542 case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
1543 case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
1544 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
1545 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
1546 case EXEC_OMP_CANCEL: name = "CANCEL"; break;
1547 case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break;
1548 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
1549 case EXEC_OMP_DISTRIBUTE: name = "DISTRIBUTE"; break;
1550 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
1551 name = "DISTRIBUTE PARALLEL DO"; break;
1552 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
1553 name = "DISTRIBUTE PARALLEL DO SIMD"; break;
1554 case EXEC_OMP_DISTRIBUTE_SIMD: name = "DISTRIBUTE SIMD"; break;
1555 case EXEC_OMP_DO: name = "DO"; break;
1556 case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break;
1557 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
1558 case EXEC_OMP_MASTER: name = "MASTER"; break;
1559 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
1560 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
1561 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
1562 case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break;
1563 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
1564 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
1565 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
1566 case EXEC_OMP_SIMD: name = "SIMD"; break;
1567 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
1568 case EXEC_OMP_TARGET: name = "TARGET"; break;
1569 case EXEC_OMP_TARGET_DATA: name = "TARGET DATA"; break;
1570 case EXEC_OMP_TARGET_ENTER_DATA: name = "TARGET ENTER DATA"; break;
1571 case EXEC_OMP_TARGET_EXIT_DATA: name = "TARGET EXIT DATA"; break;
1572 case EXEC_OMP_TARGET_PARALLEL: name = "TARGET PARALLEL"; break;
1573 case EXEC_OMP_TARGET_PARALLEL_DO: name = "TARGET PARALLEL DO"; break;
1574 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
1575 name = "TARGET_PARALLEL_DO_SIMD"; break;
1576 case EXEC_OMP_TARGET_SIMD: name = "TARGET SIMD"; break;
1577 case EXEC_OMP_TARGET_TEAMS: name = "TARGET TEAMS"; break;
1578 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
1579 name = "TARGET TEAMS DISTRIBUTE"; break;
1580 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1581 name = "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break;
1582 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1583 name = "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
1584 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1585 name = "TARGET TEAMS DISTRIBUTE SIMD"; break;
1586 case EXEC_OMP_TARGET_UPDATE: name = "TARGET UPDATE"; break;
1587 case EXEC_OMP_TASK: name = "TASK"; break;
1588 case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break;
1589 case EXEC_OMP_TASKLOOP: name = "TASKLOOP"; break;
1590 case EXEC_OMP_TASKLOOP_SIMD: name = "TASKLOOP SIMD"; break;
1591 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
1592 case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
1593 case EXEC_OMP_TEAMS: name = "TEAMS"; break;
1594 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "TEAMS DISTRIBUTE"; break;
1595 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
1596 name = "TEAMS DISTRIBUTE PARALLEL DO"; break;
1597 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1598 name = "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
1599 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: name = "TEAMS DISTRIBUTE SIMD"; break;
1600 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
1601 default:
1602 gcc_unreachable ();
1603 }
1604 fprintf (dumpfile, "!$%s %s", is_oacc ? "ACC" : "OMP", name);
1605 switch (c->op)
1606 {
1607 case EXEC_OACC_PARALLEL_LOOP:
1608 case EXEC_OACC_PARALLEL:
1609 case EXEC_OACC_KERNELS_LOOP:
1610 case EXEC_OACC_KERNELS:
1611 case EXEC_OACC_DATA:
1612 case EXEC_OACC_HOST_DATA:
1613 case EXEC_OACC_LOOP:
1614 case EXEC_OACC_UPDATE:
1615 case EXEC_OACC_WAIT:
1616 case EXEC_OACC_CACHE:
1617 case EXEC_OACC_ENTER_DATA:
1618 case EXEC_OACC_EXIT_DATA:
1619 case EXEC_OMP_CANCEL:
1620 case EXEC_OMP_CANCELLATION_POINT:
1621 case EXEC_OMP_DISTRIBUTE:
1622 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
1623 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
1624 case EXEC_OMP_DISTRIBUTE_SIMD:
1625 case EXEC_OMP_DO:
1626 case EXEC_OMP_DO_SIMD:
1627 case EXEC_OMP_ORDERED:
1628 case EXEC_OMP_PARALLEL:
1629 case EXEC_OMP_PARALLEL_DO:
1630 case EXEC_OMP_PARALLEL_DO_SIMD:
1631 case EXEC_OMP_PARALLEL_SECTIONS:
1632 case EXEC_OMP_PARALLEL_WORKSHARE:
1633 case EXEC_OMP_SECTIONS:
1634 case EXEC_OMP_SIMD:
1635 case EXEC_OMP_SINGLE:
1636 case EXEC_OMP_TARGET:
1637 case EXEC_OMP_TARGET_DATA:
1638 case EXEC_OMP_TARGET_ENTER_DATA:
1639 case EXEC_OMP_TARGET_EXIT_DATA:
1640 case EXEC_OMP_TARGET_PARALLEL:
1641 case EXEC_OMP_TARGET_PARALLEL_DO:
1642 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
1643 case EXEC_OMP_TARGET_SIMD:
1644 case EXEC_OMP_TARGET_TEAMS:
1645 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
1646 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1647 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1648 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1649 case EXEC_OMP_TARGET_UPDATE:
1650 case EXEC_OMP_TASK:
1651 case EXEC_OMP_TASKLOOP:
1652 case EXEC_OMP_TASKLOOP_SIMD:
1653 case EXEC_OMP_TEAMS:
1654 case EXEC_OMP_TEAMS_DISTRIBUTE:
1655 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
1656 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1657 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
1658 case EXEC_OMP_WORKSHARE:
1659 omp_clauses = c->ext.omp_clauses;
1660 break;
1661 case EXEC_OMP_CRITICAL:
1662 omp_clauses = c->ext.omp_clauses;
1663 if (omp_clauses)
1664 fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name);
1665 break;
1666 case EXEC_OMP_FLUSH:
1667 if (c->ext.omp_namelist)
1668 {
1669 fputs (" (", dumpfile);
1670 show_omp_namelist (OMP_LIST_NUM, c->ext.omp_namelist);
1671 fputc (')', dumpfile);
1672 }
1673 return;
1674 case EXEC_OMP_BARRIER:
1675 case EXEC_OMP_TASKWAIT:
1676 case EXEC_OMP_TASKYIELD:
1677 return;
1678 default:
1679 break;
1680 }
1681 if (omp_clauses)
1682 show_omp_clauses (omp_clauses);
1683 fputc ('\n', dumpfile);
1684
1685 /* OpenMP and OpenACC executable directives don't have associated blocks. */
1686 if (c->op == EXEC_OACC_CACHE || c->op == EXEC_OACC_UPDATE
1687 || c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA
1688 || c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA
1689 || c->op == EXEC_OMP_TARGET_EXIT_DATA
1690 || (c->op == EXEC_OMP_ORDERED && c->block == NULL))
1691 return;
1692 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1693 {
1694 gfc_code *d = c->block;
1695 while (d != NULL)
1696 {
1697 show_code (level + 1, d->next);
1698 if (d->block == NULL)
1699 break;
1700 code_indent (level, 0);
1701 fputs ("!$OMP SECTION\n", dumpfile);
1702 d = d->block;
1703 }
1704 }
1705 else
1706 show_code (level + 1, c->block->next);
1707 if (c->op == EXEC_OMP_ATOMIC)
1708 return;
1709 fputc ('\n', dumpfile);
1710 code_indent (level, 0);
1711 fprintf (dumpfile, "!$%s END %s", is_oacc ? "ACC" : "OMP", name);
1712 if (omp_clauses != NULL)
1713 {
1714 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1715 {
1716 fputs (" COPYPRIVATE(", dumpfile);
1717 show_omp_namelist (OMP_LIST_COPYPRIVATE,
1718 omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1719 fputc (')', dumpfile);
1720 }
1721 else if (omp_clauses->nowait)
1722 fputs (" NOWAIT", dumpfile);
1723 }
1724 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses)
1725 fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name);
1726 }
1727
1728
1729 /* Show a single code node and everything underneath it if necessary. */
1730
1731 static void
show_code_node(int level,gfc_code * c)1732 show_code_node (int level, gfc_code *c)
1733 {
1734 gfc_forall_iterator *fa;
1735 gfc_open *open;
1736 gfc_case *cp;
1737 gfc_alloc *a;
1738 gfc_code *d;
1739 gfc_close *close;
1740 gfc_filepos *fp;
1741 gfc_inquire *i;
1742 gfc_dt *dt;
1743 gfc_namespace *ns;
1744
1745 if (c->here)
1746 {
1747 fputc ('\n', dumpfile);
1748 code_indent (level, c->here);
1749 }
1750 else
1751 show_indent ();
1752
1753 switch (c->op)
1754 {
1755 case EXEC_END_PROCEDURE:
1756 break;
1757
1758 case EXEC_NOP:
1759 fputs ("NOP", dumpfile);
1760 break;
1761
1762 case EXEC_CONTINUE:
1763 fputs ("CONTINUE", dumpfile);
1764 break;
1765
1766 case EXEC_ENTRY:
1767 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1768 break;
1769
1770 case EXEC_INIT_ASSIGN:
1771 case EXEC_ASSIGN:
1772 fputs ("ASSIGN ", dumpfile);
1773 show_expr (c->expr1);
1774 fputc (' ', dumpfile);
1775 show_expr (c->expr2);
1776 break;
1777
1778 case EXEC_LABEL_ASSIGN:
1779 fputs ("LABEL ASSIGN ", dumpfile);
1780 show_expr (c->expr1);
1781 fprintf (dumpfile, " %d", c->label1->value);
1782 break;
1783
1784 case EXEC_POINTER_ASSIGN:
1785 fputs ("POINTER ASSIGN ", dumpfile);
1786 show_expr (c->expr1);
1787 fputc (' ', dumpfile);
1788 show_expr (c->expr2);
1789 break;
1790
1791 case EXEC_GOTO:
1792 fputs ("GOTO ", dumpfile);
1793 if (c->label1)
1794 fprintf (dumpfile, "%d", c->label1->value);
1795 else
1796 {
1797 show_expr (c->expr1);
1798 d = c->block;
1799 if (d != NULL)
1800 {
1801 fputs (", (", dumpfile);
1802 for (; d; d = d ->block)
1803 {
1804 code_indent (level, d->label1);
1805 if (d->block != NULL)
1806 fputc (',', dumpfile);
1807 else
1808 fputc (')', dumpfile);
1809 }
1810 }
1811 }
1812 break;
1813
1814 case EXEC_CALL:
1815 case EXEC_ASSIGN_CALL:
1816 if (c->resolved_sym)
1817 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1818 else if (c->symtree)
1819 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1820 else
1821 fputs ("CALL ?? ", dumpfile);
1822
1823 show_actual_arglist (c->ext.actual);
1824 break;
1825
1826 case EXEC_COMPCALL:
1827 fputs ("CALL ", dumpfile);
1828 show_compcall (c->expr1);
1829 break;
1830
1831 case EXEC_CALL_PPC:
1832 fputs ("CALL ", dumpfile);
1833 show_expr (c->expr1);
1834 show_actual_arglist (c->ext.actual);
1835 break;
1836
1837 case EXEC_RETURN:
1838 fputs ("RETURN ", dumpfile);
1839 if (c->expr1)
1840 show_expr (c->expr1);
1841 break;
1842
1843 case EXEC_PAUSE:
1844 fputs ("PAUSE ", dumpfile);
1845
1846 if (c->expr1 != NULL)
1847 show_expr (c->expr1);
1848 else
1849 fprintf (dumpfile, "%d", c->ext.stop_code);
1850
1851 break;
1852
1853 case EXEC_ERROR_STOP:
1854 fputs ("ERROR ", dumpfile);
1855 /* Fall through. */
1856
1857 case EXEC_STOP:
1858 fputs ("STOP ", dumpfile);
1859
1860 if (c->expr1 != NULL)
1861 show_expr (c->expr1);
1862 else
1863 fprintf (dumpfile, "%d", c->ext.stop_code);
1864
1865 break;
1866
1867 case EXEC_FAIL_IMAGE:
1868 fputs ("FAIL IMAGE ", dumpfile);
1869 break;
1870
1871 case EXEC_CHANGE_TEAM:
1872 fputs ("CHANGE TEAM", dumpfile);
1873 break;
1874
1875 case EXEC_END_TEAM:
1876 fputs ("END TEAM", dumpfile);
1877 break;
1878
1879 case EXEC_FORM_TEAM:
1880 fputs ("FORM TEAM", dumpfile);
1881 break;
1882
1883 case EXEC_SYNC_TEAM:
1884 fputs ("SYNC TEAM", dumpfile);
1885 break;
1886
1887 case EXEC_SYNC_ALL:
1888 fputs ("SYNC ALL ", dumpfile);
1889 if (c->expr2 != NULL)
1890 {
1891 fputs (" stat=", dumpfile);
1892 show_expr (c->expr2);
1893 }
1894 if (c->expr3 != NULL)
1895 {
1896 fputs (" errmsg=", dumpfile);
1897 show_expr (c->expr3);
1898 }
1899 break;
1900
1901 case EXEC_SYNC_MEMORY:
1902 fputs ("SYNC MEMORY ", dumpfile);
1903 if (c->expr2 != NULL)
1904 {
1905 fputs (" stat=", dumpfile);
1906 show_expr (c->expr2);
1907 }
1908 if (c->expr3 != NULL)
1909 {
1910 fputs (" errmsg=", dumpfile);
1911 show_expr (c->expr3);
1912 }
1913 break;
1914
1915 case EXEC_SYNC_IMAGES:
1916 fputs ("SYNC IMAGES image-set=", dumpfile);
1917 if (c->expr1 != NULL)
1918 show_expr (c->expr1);
1919 else
1920 fputs ("* ", dumpfile);
1921 if (c->expr2 != NULL)
1922 {
1923 fputs (" stat=", dumpfile);
1924 show_expr (c->expr2);
1925 }
1926 if (c->expr3 != NULL)
1927 {
1928 fputs (" errmsg=", dumpfile);
1929 show_expr (c->expr3);
1930 }
1931 break;
1932
1933 case EXEC_EVENT_POST:
1934 case EXEC_EVENT_WAIT:
1935 if (c->op == EXEC_EVENT_POST)
1936 fputs ("EVENT POST ", dumpfile);
1937 else
1938 fputs ("EVENT WAIT ", dumpfile);
1939
1940 fputs ("event-variable=", dumpfile);
1941 if (c->expr1 != NULL)
1942 show_expr (c->expr1);
1943 if (c->expr4 != NULL)
1944 {
1945 fputs (" until_count=", dumpfile);
1946 show_expr (c->expr4);
1947 }
1948 if (c->expr2 != NULL)
1949 {
1950 fputs (" stat=", dumpfile);
1951 show_expr (c->expr2);
1952 }
1953 if (c->expr3 != NULL)
1954 {
1955 fputs (" errmsg=", dumpfile);
1956 show_expr (c->expr3);
1957 }
1958 break;
1959
1960 case EXEC_LOCK:
1961 case EXEC_UNLOCK:
1962 if (c->op == EXEC_LOCK)
1963 fputs ("LOCK ", dumpfile);
1964 else
1965 fputs ("UNLOCK ", dumpfile);
1966
1967 fputs ("lock-variable=", dumpfile);
1968 if (c->expr1 != NULL)
1969 show_expr (c->expr1);
1970 if (c->expr4 != NULL)
1971 {
1972 fputs (" acquired_lock=", dumpfile);
1973 show_expr (c->expr4);
1974 }
1975 if (c->expr2 != NULL)
1976 {
1977 fputs (" stat=", dumpfile);
1978 show_expr (c->expr2);
1979 }
1980 if (c->expr3 != NULL)
1981 {
1982 fputs (" errmsg=", dumpfile);
1983 show_expr (c->expr3);
1984 }
1985 break;
1986
1987 case EXEC_ARITHMETIC_IF:
1988 fputs ("IF ", dumpfile);
1989 show_expr (c->expr1);
1990 fprintf (dumpfile, " %d, %d, %d",
1991 c->label1->value, c->label2->value, c->label3->value);
1992 break;
1993
1994 case EXEC_IF:
1995 d = c->block;
1996 fputs ("IF ", dumpfile);
1997 show_expr (d->expr1);
1998
1999 ++show_level;
2000 show_code (level + 1, d->next);
2001 --show_level;
2002
2003 d = d->block;
2004 for (; d; d = d->block)
2005 {
2006 fputs("\n", dumpfile);
2007 code_indent (level, 0);
2008 if (d->expr1 == NULL)
2009 fputs ("ELSE", dumpfile);
2010 else
2011 {
2012 fputs ("ELSE IF ", dumpfile);
2013 show_expr (d->expr1);
2014 }
2015
2016 ++show_level;
2017 show_code (level + 1, d->next);
2018 --show_level;
2019 }
2020
2021 if (c->label1)
2022 code_indent (level, c->label1);
2023 else
2024 show_indent ();
2025
2026 fputs ("ENDIF", dumpfile);
2027 break;
2028
2029 case EXEC_BLOCK:
2030 {
2031 const char* blocktype;
2032 gfc_namespace *saved_ns;
2033 gfc_association_list *alist;
2034
2035 if (c->ext.block.assoc)
2036 blocktype = "ASSOCIATE";
2037 else
2038 blocktype = "BLOCK";
2039 show_indent ();
2040 fprintf (dumpfile, "%s ", blocktype);
2041 for (alist = c->ext.block.assoc; alist; alist = alist->next)
2042 {
2043 fprintf (dumpfile, " %s = ", alist->name);
2044 show_expr (alist->target);
2045 }
2046
2047 ++show_level;
2048 ns = c->ext.block.ns;
2049 saved_ns = gfc_current_ns;
2050 gfc_current_ns = ns;
2051 gfc_traverse_symtree (ns->sym_root, show_symtree);
2052 gfc_current_ns = saved_ns;
2053 show_code (show_level, ns->code);
2054 --show_level;
2055 show_indent ();
2056 fprintf (dumpfile, "END %s ", blocktype);
2057 break;
2058 }
2059
2060 case EXEC_END_BLOCK:
2061 /* Only come here when there is a label on an
2062 END ASSOCIATE construct. */
2063 break;
2064
2065 case EXEC_SELECT:
2066 case EXEC_SELECT_TYPE:
2067 d = c->block;
2068 if (c->op == EXEC_SELECT_TYPE)
2069 fputs ("SELECT TYPE ", dumpfile);
2070 else
2071 fputs ("SELECT CASE ", dumpfile);
2072 show_expr (c->expr1);
2073 fputc ('\n', dumpfile);
2074
2075 for (; d; d = d->block)
2076 {
2077 code_indent (level, 0);
2078
2079 fputs ("CASE ", dumpfile);
2080 for (cp = d->ext.block.case_list; cp; cp = cp->next)
2081 {
2082 fputc ('(', dumpfile);
2083 show_expr (cp->low);
2084 fputc (' ', dumpfile);
2085 show_expr (cp->high);
2086 fputc (')', dumpfile);
2087 fputc (' ', dumpfile);
2088 }
2089 fputc ('\n', dumpfile);
2090
2091 show_code (level + 1, d->next);
2092 }
2093
2094 code_indent (level, c->label1);
2095 fputs ("END SELECT", dumpfile);
2096 break;
2097
2098 case EXEC_WHERE:
2099 fputs ("WHERE ", dumpfile);
2100
2101 d = c->block;
2102 show_expr (d->expr1);
2103 fputc ('\n', dumpfile);
2104
2105 show_code (level + 1, d->next);
2106
2107 for (d = d->block; d; d = d->block)
2108 {
2109 code_indent (level, 0);
2110 fputs ("ELSE WHERE ", dumpfile);
2111 show_expr (d->expr1);
2112 fputc ('\n', dumpfile);
2113 show_code (level + 1, d->next);
2114 }
2115
2116 code_indent (level, 0);
2117 fputs ("END WHERE", dumpfile);
2118 break;
2119
2120
2121 case EXEC_FORALL:
2122 fputs ("FORALL ", dumpfile);
2123 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
2124 {
2125 show_expr (fa->var);
2126 fputc (' ', dumpfile);
2127 show_expr (fa->start);
2128 fputc (':', dumpfile);
2129 show_expr (fa->end);
2130 fputc (':', dumpfile);
2131 show_expr (fa->stride);
2132
2133 if (fa->next != NULL)
2134 fputc (',', dumpfile);
2135 }
2136
2137 if (c->expr1 != NULL)
2138 {
2139 fputc (',', dumpfile);
2140 show_expr (c->expr1);
2141 }
2142 fputc ('\n', dumpfile);
2143
2144 show_code (level + 1, c->block->next);
2145
2146 code_indent (level, 0);
2147 fputs ("END FORALL", dumpfile);
2148 break;
2149
2150 case EXEC_CRITICAL:
2151 fputs ("CRITICAL\n", dumpfile);
2152 show_code (level + 1, c->block->next);
2153 code_indent (level, 0);
2154 fputs ("END CRITICAL", dumpfile);
2155 break;
2156
2157 case EXEC_DO:
2158 fputs ("DO ", dumpfile);
2159 if (c->label1)
2160 fprintf (dumpfile, " %-5d ", c->label1->value);
2161
2162 show_expr (c->ext.iterator->var);
2163 fputc ('=', dumpfile);
2164 show_expr (c->ext.iterator->start);
2165 fputc (' ', dumpfile);
2166 show_expr (c->ext.iterator->end);
2167 fputc (' ', dumpfile);
2168 show_expr (c->ext.iterator->step);
2169
2170 ++show_level;
2171 show_code (level + 1, c->block->next);
2172 --show_level;
2173
2174 if (c->label1)
2175 break;
2176
2177 show_indent ();
2178 fputs ("END DO", dumpfile);
2179 break;
2180
2181 case EXEC_DO_CONCURRENT:
2182 fputs ("DO CONCURRENT ", dumpfile);
2183 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
2184 {
2185 show_expr (fa->var);
2186 fputc (' ', dumpfile);
2187 show_expr (fa->start);
2188 fputc (':', dumpfile);
2189 show_expr (fa->end);
2190 fputc (':', dumpfile);
2191 show_expr (fa->stride);
2192
2193 if (fa->next != NULL)
2194 fputc (',', dumpfile);
2195 }
2196 show_expr (c->expr1);
2197 ++show_level;
2198
2199 show_code (level + 1, c->block->next);
2200 --show_level;
2201 code_indent (level, c->label1);
2202 show_indent ();
2203 fputs ("END DO", dumpfile);
2204 break;
2205
2206 case EXEC_DO_WHILE:
2207 fputs ("DO WHILE ", dumpfile);
2208 show_expr (c->expr1);
2209 fputc ('\n', dumpfile);
2210
2211 show_code (level + 1, c->block->next);
2212
2213 code_indent (level, c->label1);
2214 fputs ("END DO", dumpfile);
2215 break;
2216
2217 case EXEC_CYCLE:
2218 fputs ("CYCLE", dumpfile);
2219 if (c->symtree)
2220 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
2221 break;
2222
2223 case EXEC_EXIT:
2224 fputs ("EXIT", dumpfile);
2225 if (c->symtree)
2226 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
2227 break;
2228
2229 case EXEC_ALLOCATE:
2230 fputs ("ALLOCATE ", dumpfile);
2231 if (c->expr1)
2232 {
2233 fputs (" STAT=", dumpfile);
2234 show_expr (c->expr1);
2235 }
2236
2237 if (c->expr2)
2238 {
2239 fputs (" ERRMSG=", dumpfile);
2240 show_expr (c->expr2);
2241 }
2242
2243 if (c->expr3)
2244 {
2245 if (c->expr3->mold)
2246 fputs (" MOLD=", dumpfile);
2247 else
2248 fputs (" SOURCE=", dumpfile);
2249 show_expr (c->expr3);
2250 }
2251
2252 for (a = c->ext.alloc.list; a; a = a->next)
2253 {
2254 fputc (' ', dumpfile);
2255 show_expr (a->expr);
2256 }
2257
2258 break;
2259
2260 case EXEC_DEALLOCATE:
2261 fputs ("DEALLOCATE ", dumpfile);
2262 if (c->expr1)
2263 {
2264 fputs (" STAT=", dumpfile);
2265 show_expr (c->expr1);
2266 }
2267
2268 if (c->expr2)
2269 {
2270 fputs (" ERRMSG=", dumpfile);
2271 show_expr (c->expr2);
2272 }
2273
2274 for (a = c->ext.alloc.list; a; a = a->next)
2275 {
2276 fputc (' ', dumpfile);
2277 show_expr (a->expr);
2278 }
2279
2280 break;
2281
2282 case EXEC_OPEN:
2283 fputs ("OPEN", dumpfile);
2284 open = c->ext.open;
2285
2286 if (open->unit)
2287 {
2288 fputs (" UNIT=", dumpfile);
2289 show_expr (open->unit);
2290 }
2291 if (open->iomsg)
2292 {
2293 fputs (" IOMSG=", dumpfile);
2294 show_expr (open->iomsg);
2295 }
2296 if (open->iostat)
2297 {
2298 fputs (" IOSTAT=", dumpfile);
2299 show_expr (open->iostat);
2300 }
2301 if (open->file)
2302 {
2303 fputs (" FILE=", dumpfile);
2304 show_expr (open->file);
2305 }
2306 if (open->status)
2307 {
2308 fputs (" STATUS=", dumpfile);
2309 show_expr (open->status);
2310 }
2311 if (open->access)
2312 {
2313 fputs (" ACCESS=", dumpfile);
2314 show_expr (open->access);
2315 }
2316 if (open->form)
2317 {
2318 fputs (" FORM=", dumpfile);
2319 show_expr (open->form);
2320 }
2321 if (open->recl)
2322 {
2323 fputs (" RECL=", dumpfile);
2324 show_expr (open->recl);
2325 }
2326 if (open->blank)
2327 {
2328 fputs (" BLANK=", dumpfile);
2329 show_expr (open->blank);
2330 }
2331 if (open->position)
2332 {
2333 fputs (" POSITION=", dumpfile);
2334 show_expr (open->position);
2335 }
2336 if (open->action)
2337 {
2338 fputs (" ACTION=", dumpfile);
2339 show_expr (open->action);
2340 }
2341 if (open->delim)
2342 {
2343 fputs (" DELIM=", dumpfile);
2344 show_expr (open->delim);
2345 }
2346 if (open->pad)
2347 {
2348 fputs (" PAD=", dumpfile);
2349 show_expr (open->pad);
2350 }
2351 if (open->decimal)
2352 {
2353 fputs (" DECIMAL=", dumpfile);
2354 show_expr (open->decimal);
2355 }
2356 if (open->encoding)
2357 {
2358 fputs (" ENCODING=", dumpfile);
2359 show_expr (open->encoding);
2360 }
2361 if (open->round)
2362 {
2363 fputs (" ROUND=", dumpfile);
2364 show_expr (open->round);
2365 }
2366 if (open->sign)
2367 {
2368 fputs (" SIGN=", dumpfile);
2369 show_expr (open->sign);
2370 }
2371 if (open->convert)
2372 {
2373 fputs (" CONVERT=", dumpfile);
2374 show_expr (open->convert);
2375 }
2376 if (open->asynchronous)
2377 {
2378 fputs (" ASYNCHRONOUS=", dumpfile);
2379 show_expr (open->asynchronous);
2380 }
2381 if (open->err != NULL)
2382 fprintf (dumpfile, " ERR=%d", open->err->value);
2383
2384 break;
2385
2386 case EXEC_CLOSE:
2387 fputs ("CLOSE", dumpfile);
2388 close = c->ext.close;
2389
2390 if (close->unit)
2391 {
2392 fputs (" UNIT=", dumpfile);
2393 show_expr (close->unit);
2394 }
2395 if (close->iomsg)
2396 {
2397 fputs (" IOMSG=", dumpfile);
2398 show_expr (close->iomsg);
2399 }
2400 if (close->iostat)
2401 {
2402 fputs (" IOSTAT=", dumpfile);
2403 show_expr (close->iostat);
2404 }
2405 if (close->status)
2406 {
2407 fputs (" STATUS=", dumpfile);
2408 show_expr (close->status);
2409 }
2410 if (close->err != NULL)
2411 fprintf (dumpfile, " ERR=%d", close->err->value);
2412 break;
2413
2414 case EXEC_BACKSPACE:
2415 fputs ("BACKSPACE", dumpfile);
2416 goto show_filepos;
2417
2418 case EXEC_ENDFILE:
2419 fputs ("ENDFILE", dumpfile);
2420 goto show_filepos;
2421
2422 case EXEC_REWIND:
2423 fputs ("REWIND", dumpfile);
2424 goto show_filepos;
2425
2426 case EXEC_FLUSH:
2427 fputs ("FLUSH", dumpfile);
2428
2429 show_filepos:
2430 fp = c->ext.filepos;
2431
2432 if (fp->unit)
2433 {
2434 fputs (" UNIT=", dumpfile);
2435 show_expr (fp->unit);
2436 }
2437 if (fp->iomsg)
2438 {
2439 fputs (" IOMSG=", dumpfile);
2440 show_expr (fp->iomsg);
2441 }
2442 if (fp->iostat)
2443 {
2444 fputs (" IOSTAT=", dumpfile);
2445 show_expr (fp->iostat);
2446 }
2447 if (fp->err != NULL)
2448 fprintf (dumpfile, " ERR=%d", fp->err->value);
2449 break;
2450
2451 case EXEC_INQUIRE:
2452 fputs ("INQUIRE", dumpfile);
2453 i = c->ext.inquire;
2454
2455 if (i->unit)
2456 {
2457 fputs (" UNIT=", dumpfile);
2458 show_expr (i->unit);
2459 }
2460 if (i->file)
2461 {
2462 fputs (" FILE=", dumpfile);
2463 show_expr (i->file);
2464 }
2465
2466 if (i->iomsg)
2467 {
2468 fputs (" IOMSG=", dumpfile);
2469 show_expr (i->iomsg);
2470 }
2471 if (i->iostat)
2472 {
2473 fputs (" IOSTAT=", dumpfile);
2474 show_expr (i->iostat);
2475 }
2476 if (i->exist)
2477 {
2478 fputs (" EXIST=", dumpfile);
2479 show_expr (i->exist);
2480 }
2481 if (i->opened)
2482 {
2483 fputs (" OPENED=", dumpfile);
2484 show_expr (i->opened);
2485 }
2486 if (i->number)
2487 {
2488 fputs (" NUMBER=", dumpfile);
2489 show_expr (i->number);
2490 }
2491 if (i->named)
2492 {
2493 fputs (" NAMED=", dumpfile);
2494 show_expr (i->named);
2495 }
2496 if (i->name)
2497 {
2498 fputs (" NAME=", dumpfile);
2499 show_expr (i->name);
2500 }
2501 if (i->access)
2502 {
2503 fputs (" ACCESS=", dumpfile);
2504 show_expr (i->access);
2505 }
2506 if (i->sequential)
2507 {
2508 fputs (" SEQUENTIAL=", dumpfile);
2509 show_expr (i->sequential);
2510 }
2511
2512 if (i->direct)
2513 {
2514 fputs (" DIRECT=", dumpfile);
2515 show_expr (i->direct);
2516 }
2517 if (i->form)
2518 {
2519 fputs (" FORM=", dumpfile);
2520 show_expr (i->form);
2521 }
2522 if (i->formatted)
2523 {
2524 fputs (" FORMATTED", dumpfile);
2525 show_expr (i->formatted);
2526 }
2527 if (i->unformatted)
2528 {
2529 fputs (" UNFORMATTED=", dumpfile);
2530 show_expr (i->unformatted);
2531 }
2532 if (i->recl)
2533 {
2534 fputs (" RECL=", dumpfile);
2535 show_expr (i->recl);
2536 }
2537 if (i->nextrec)
2538 {
2539 fputs (" NEXTREC=", dumpfile);
2540 show_expr (i->nextrec);
2541 }
2542 if (i->blank)
2543 {
2544 fputs (" BLANK=", dumpfile);
2545 show_expr (i->blank);
2546 }
2547 if (i->position)
2548 {
2549 fputs (" POSITION=", dumpfile);
2550 show_expr (i->position);
2551 }
2552 if (i->action)
2553 {
2554 fputs (" ACTION=", dumpfile);
2555 show_expr (i->action);
2556 }
2557 if (i->read)
2558 {
2559 fputs (" READ=", dumpfile);
2560 show_expr (i->read);
2561 }
2562 if (i->write)
2563 {
2564 fputs (" WRITE=", dumpfile);
2565 show_expr (i->write);
2566 }
2567 if (i->readwrite)
2568 {
2569 fputs (" READWRITE=", dumpfile);
2570 show_expr (i->readwrite);
2571 }
2572 if (i->delim)
2573 {
2574 fputs (" DELIM=", dumpfile);
2575 show_expr (i->delim);
2576 }
2577 if (i->pad)
2578 {
2579 fputs (" PAD=", dumpfile);
2580 show_expr (i->pad);
2581 }
2582 if (i->convert)
2583 {
2584 fputs (" CONVERT=", dumpfile);
2585 show_expr (i->convert);
2586 }
2587 if (i->asynchronous)
2588 {
2589 fputs (" ASYNCHRONOUS=", dumpfile);
2590 show_expr (i->asynchronous);
2591 }
2592 if (i->decimal)
2593 {
2594 fputs (" DECIMAL=", dumpfile);
2595 show_expr (i->decimal);
2596 }
2597 if (i->encoding)
2598 {
2599 fputs (" ENCODING=", dumpfile);
2600 show_expr (i->encoding);
2601 }
2602 if (i->pending)
2603 {
2604 fputs (" PENDING=", dumpfile);
2605 show_expr (i->pending);
2606 }
2607 if (i->round)
2608 {
2609 fputs (" ROUND=", dumpfile);
2610 show_expr (i->round);
2611 }
2612 if (i->sign)
2613 {
2614 fputs (" SIGN=", dumpfile);
2615 show_expr (i->sign);
2616 }
2617 if (i->size)
2618 {
2619 fputs (" SIZE=", dumpfile);
2620 show_expr (i->size);
2621 }
2622 if (i->id)
2623 {
2624 fputs (" ID=", dumpfile);
2625 show_expr (i->id);
2626 }
2627
2628 if (i->err != NULL)
2629 fprintf (dumpfile, " ERR=%d", i->err->value);
2630 break;
2631
2632 case EXEC_IOLENGTH:
2633 fputs ("IOLENGTH ", dumpfile);
2634 show_expr (c->expr1);
2635 goto show_dt_code;
2636 break;
2637
2638 case EXEC_READ:
2639 fputs ("READ", dumpfile);
2640 goto show_dt;
2641
2642 case EXEC_WRITE:
2643 fputs ("WRITE", dumpfile);
2644
2645 show_dt:
2646 dt = c->ext.dt;
2647 if (dt->io_unit)
2648 {
2649 fputs (" UNIT=", dumpfile);
2650 show_expr (dt->io_unit);
2651 }
2652
2653 if (dt->format_expr)
2654 {
2655 fputs (" FMT=", dumpfile);
2656 show_expr (dt->format_expr);
2657 }
2658
2659 if (dt->format_label != NULL)
2660 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
2661 if (dt->namelist)
2662 fprintf (dumpfile, " NML=%s", dt->namelist->name);
2663
2664 if (dt->iomsg)
2665 {
2666 fputs (" IOMSG=", dumpfile);
2667 show_expr (dt->iomsg);
2668 }
2669 if (dt->iostat)
2670 {
2671 fputs (" IOSTAT=", dumpfile);
2672 show_expr (dt->iostat);
2673 }
2674 if (dt->size)
2675 {
2676 fputs (" SIZE=", dumpfile);
2677 show_expr (dt->size);
2678 }
2679 if (dt->rec)
2680 {
2681 fputs (" REC=", dumpfile);
2682 show_expr (dt->rec);
2683 }
2684 if (dt->advance)
2685 {
2686 fputs (" ADVANCE=", dumpfile);
2687 show_expr (dt->advance);
2688 }
2689 if (dt->id)
2690 {
2691 fputs (" ID=", dumpfile);
2692 show_expr (dt->id);
2693 }
2694 if (dt->pos)
2695 {
2696 fputs (" POS=", dumpfile);
2697 show_expr (dt->pos);
2698 }
2699 if (dt->asynchronous)
2700 {
2701 fputs (" ASYNCHRONOUS=", dumpfile);
2702 show_expr (dt->asynchronous);
2703 }
2704 if (dt->blank)
2705 {
2706 fputs (" BLANK=", dumpfile);
2707 show_expr (dt->blank);
2708 }
2709 if (dt->decimal)
2710 {
2711 fputs (" DECIMAL=", dumpfile);
2712 show_expr (dt->decimal);
2713 }
2714 if (dt->delim)
2715 {
2716 fputs (" DELIM=", dumpfile);
2717 show_expr (dt->delim);
2718 }
2719 if (dt->pad)
2720 {
2721 fputs (" PAD=", dumpfile);
2722 show_expr (dt->pad);
2723 }
2724 if (dt->round)
2725 {
2726 fputs (" ROUND=", dumpfile);
2727 show_expr (dt->round);
2728 }
2729 if (dt->sign)
2730 {
2731 fputs (" SIGN=", dumpfile);
2732 show_expr (dt->sign);
2733 }
2734
2735 show_dt_code:
2736 for (c = c->block->next; c; c = c->next)
2737 show_code_node (level + (c->next != NULL), c);
2738 return;
2739
2740 case EXEC_TRANSFER:
2741 fputs ("TRANSFER ", dumpfile);
2742 show_expr (c->expr1);
2743 break;
2744
2745 case EXEC_DT_END:
2746 fputs ("DT_END", dumpfile);
2747 dt = c->ext.dt;
2748
2749 if (dt->err != NULL)
2750 fprintf (dumpfile, " ERR=%d", dt->err->value);
2751 if (dt->end != NULL)
2752 fprintf (dumpfile, " END=%d", dt->end->value);
2753 if (dt->eor != NULL)
2754 fprintf (dumpfile, " EOR=%d", dt->eor->value);
2755 break;
2756
2757 case EXEC_WAIT:
2758 fputs ("WAIT", dumpfile);
2759
2760 if (c->ext.wait != NULL)
2761 {
2762 gfc_wait *wait = c->ext.wait;
2763 if (wait->unit)
2764 {
2765 fputs (" UNIT=", dumpfile);
2766 show_expr (wait->unit);
2767 }
2768 if (wait->iostat)
2769 {
2770 fputs (" IOSTAT=", dumpfile);
2771 show_expr (wait->iostat);
2772 }
2773 if (wait->iomsg)
2774 {
2775 fputs (" IOMSG=", dumpfile);
2776 show_expr (wait->iomsg);
2777 }
2778 if (wait->id)
2779 {
2780 fputs (" ID=", dumpfile);
2781 show_expr (wait->id);
2782 }
2783 if (wait->err)
2784 fprintf (dumpfile, " ERR=%d", wait->err->value);
2785 if (wait->end)
2786 fprintf (dumpfile, " END=%d", wait->end->value);
2787 if (wait->eor)
2788 fprintf (dumpfile, " EOR=%d", wait->eor->value);
2789 }
2790 break;
2791
2792 case EXEC_OACC_PARALLEL_LOOP:
2793 case EXEC_OACC_PARALLEL:
2794 case EXEC_OACC_KERNELS_LOOP:
2795 case EXEC_OACC_KERNELS:
2796 case EXEC_OACC_DATA:
2797 case EXEC_OACC_HOST_DATA:
2798 case EXEC_OACC_LOOP:
2799 case EXEC_OACC_UPDATE:
2800 case EXEC_OACC_WAIT:
2801 case EXEC_OACC_CACHE:
2802 case EXEC_OACC_ENTER_DATA:
2803 case EXEC_OACC_EXIT_DATA:
2804 case EXEC_OMP_ATOMIC:
2805 case EXEC_OMP_CANCEL:
2806 case EXEC_OMP_CANCELLATION_POINT:
2807 case EXEC_OMP_BARRIER:
2808 case EXEC_OMP_CRITICAL:
2809 case EXEC_OMP_DISTRIBUTE:
2810 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2811 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2812 case EXEC_OMP_DISTRIBUTE_SIMD:
2813 case EXEC_OMP_DO:
2814 case EXEC_OMP_DO_SIMD:
2815 case EXEC_OMP_FLUSH:
2816 case EXEC_OMP_MASTER:
2817 case EXEC_OMP_ORDERED:
2818 case EXEC_OMP_PARALLEL:
2819 case EXEC_OMP_PARALLEL_DO:
2820 case EXEC_OMP_PARALLEL_DO_SIMD:
2821 case EXEC_OMP_PARALLEL_SECTIONS:
2822 case EXEC_OMP_PARALLEL_WORKSHARE:
2823 case EXEC_OMP_SECTIONS:
2824 case EXEC_OMP_SIMD:
2825 case EXEC_OMP_SINGLE:
2826 case EXEC_OMP_TARGET:
2827 case EXEC_OMP_TARGET_DATA:
2828 case EXEC_OMP_TARGET_ENTER_DATA:
2829 case EXEC_OMP_TARGET_EXIT_DATA:
2830 case EXEC_OMP_TARGET_PARALLEL:
2831 case EXEC_OMP_TARGET_PARALLEL_DO:
2832 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2833 case EXEC_OMP_TARGET_SIMD:
2834 case EXEC_OMP_TARGET_TEAMS:
2835 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2836 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2837 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2838 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2839 case EXEC_OMP_TARGET_UPDATE:
2840 case EXEC_OMP_TASK:
2841 case EXEC_OMP_TASKGROUP:
2842 case EXEC_OMP_TASKLOOP:
2843 case EXEC_OMP_TASKLOOP_SIMD:
2844 case EXEC_OMP_TASKWAIT:
2845 case EXEC_OMP_TASKYIELD:
2846 case EXEC_OMP_TEAMS:
2847 case EXEC_OMP_TEAMS_DISTRIBUTE:
2848 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2849 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2850 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2851 case EXEC_OMP_WORKSHARE:
2852 show_omp_node (level, c);
2853 break;
2854
2855 default:
2856 gfc_internal_error ("show_code_node(): Bad statement code");
2857 }
2858 }
2859
2860
2861 /* Show an equivalence chain. */
2862
2863 static void
show_equiv(gfc_equiv * eq)2864 show_equiv (gfc_equiv *eq)
2865 {
2866 show_indent ();
2867 fputs ("Equivalence: ", dumpfile);
2868 while (eq)
2869 {
2870 show_expr (eq->expr);
2871 eq = eq->eq;
2872 if (eq)
2873 fputs (", ", dumpfile);
2874 }
2875 }
2876
2877
2878 /* Show a freakin' whole namespace. */
2879
2880 static void
show_namespace(gfc_namespace * ns)2881 show_namespace (gfc_namespace *ns)
2882 {
2883 gfc_interface *intr;
2884 gfc_namespace *save;
2885 int op;
2886 gfc_equiv *eq;
2887 int i;
2888
2889 gcc_assert (ns);
2890 save = gfc_current_ns;
2891
2892 show_indent ();
2893 fputs ("Namespace:", dumpfile);
2894
2895 i = 0;
2896 do
2897 {
2898 int l = i;
2899 while (i < GFC_LETTERS - 1
2900 && gfc_compare_types (&ns->default_type[i+1],
2901 &ns->default_type[l]))
2902 i++;
2903
2904 if (i > l)
2905 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2906 else
2907 fprintf (dumpfile, " %c: ", l+'A');
2908
2909 show_typespec(&ns->default_type[l]);
2910 i++;
2911 } while (i < GFC_LETTERS);
2912
2913 if (ns->proc_name != NULL)
2914 {
2915 show_indent ();
2916 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2917 }
2918
2919 ++show_level;
2920 gfc_current_ns = ns;
2921 gfc_traverse_symtree (ns->common_root, show_common);
2922
2923 gfc_traverse_symtree (ns->sym_root, show_symtree);
2924
2925 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2926 {
2927 /* User operator interfaces */
2928 intr = ns->op[op];
2929 if (intr == NULL)
2930 continue;
2931
2932 show_indent ();
2933 fprintf (dumpfile, "Operator interfaces for %s:",
2934 gfc_op2string ((gfc_intrinsic_op) op));
2935
2936 for (; intr; intr = intr->next)
2937 fprintf (dumpfile, " %s", intr->sym->name);
2938 }
2939
2940 if (ns->uop_root != NULL)
2941 {
2942 show_indent ();
2943 fputs ("User operators:\n", dumpfile);
2944 gfc_traverse_user_op (ns, show_uop);
2945 }
2946
2947 for (eq = ns->equiv; eq; eq = eq->next)
2948 show_equiv (eq);
2949
2950 if (ns->oacc_declare)
2951 {
2952 struct gfc_oacc_declare *decl;
2953 /* Dump !$ACC DECLARE clauses. */
2954 for (decl = ns->oacc_declare; decl; decl = decl->next)
2955 {
2956 show_indent ();
2957 fprintf (dumpfile, "!$ACC DECLARE");
2958 show_omp_clauses (decl->clauses);
2959 }
2960 }
2961
2962 fputc ('\n', dumpfile);
2963 show_indent ();
2964 fputs ("code:", dumpfile);
2965 show_code (show_level, ns->code);
2966 --show_level;
2967
2968 for (ns = ns->contained; ns; ns = ns->sibling)
2969 {
2970 fputs ("\nCONTAINS\n", dumpfile);
2971 ++show_level;
2972 show_namespace (ns);
2973 --show_level;
2974 }
2975
2976 fputc ('\n', dumpfile);
2977 gfc_current_ns = save;
2978 }
2979
2980
2981 /* Main function for dumping a parse tree. */
2982
2983 void
gfc_dump_parse_tree(gfc_namespace * ns,FILE * file)2984 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2985 {
2986 dumpfile = file;
2987 show_namespace (ns);
2988 }
2989
2990 /* This part writes BIND(C) definition for use in external C programs. */
2991
2992 static void write_interop_decl (gfc_symbol *);
2993
2994 void
gfc_dump_c_prototypes(gfc_namespace * ns,FILE * file)2995 gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file)
2996 {
2997 int error_count;
2998 gfc_get_errors (NULL, &error_count);
2999 if (error_count != 0)
3000 return;
3001 dumpfile = file;
3002 gfc_traverse_ns (ns, write_interop_decl);
3003 }
3004
3005 enum type_return { T_OK=0, T_WARN, T_ERROR };
3006
3007 /* Return the name of the type for later output. Both function pointers and
3008 void pointers will be mapped to void *. */
3009
3010 static enum type_return
get_c_type_name(gfc_typespec * ts,gfc_array_spec * as,const char ** pre,const char ** type_name,bool * asterisk,const char ** post,bool func_ret)3011 get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
3012 const char **type_name, bool *asterisk, const char **post,
3013 bool func_ret)
3014 {
3015 static char post_buffer[40];
3016 enum type_return ret;
3017 ret = T_ERROR;
3018
3019 *pre = " ";
3020 *asterisk = false;
3021 *post = "";
3022 *type_name = "<error>";
3023 if (ts->type == BT_REAL || ts->type == BT_INTEGER)
3024 {
3025 if (ts->is_c_interop && ts->interop_kind)
3026 {
3027 *type_name = ts->interop_kind->name + 2;
3028 if (strcmp (*type_name, "signed_char") == 0)
3029 *type_name = "signed char";
3030 else if (strcmp (*type_name, "size_t") == 0)
3031 *type_name = "ssize_t";
3032
3033 ret = T_OK;
3034 }
3035 else
3036 {
3037 /* The user did not specify a C interop type. Let's look through
3038 the available table and use the first one, but warn. */
3039 for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3040 {
3041 if (c_interop_kinds_table[i].f90_type == ts->type
3042 && c_interop_kinds_table[i].value == ts->kind)
3043 {
3044 *type_name = c_interop_kinds_table[i].name + 2;
3045 if (strcmp (*type_name, "signed_char") == 0)
3046 *type_name = "signed char";
3047 else if (strcmp (*type_name, "size_t") == 0)
3048 *type_name = "ssize_t";
3049
3050 ret = T_WARN;
3051 break;
3052 }
3053 }
3054 }
3055 }
3056 else if (ts->type == BT_LOGICAL)
3057 {
3058 if (ts->is_c_interop && ts->interop_kind)
3059 {
3060 *type_name = "_Bool";
3061 ret = T_OK;
3062 }
3063 else
3064 {
3065 /* Let's select an appropriate int, with a warning. */
3066 for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3067 {
3068 if (c_interop_kinds_table[i].f90_type == BT_INTEGER
3069 && c_interop_kinds_table[i].value == ts->kind)
3070 {
3071 *type_name = c_interop_kinds_table[i].name + 2;
3072 ret = T_WARN;
3073 }
3074 }
3075 }
3076 }
3077 else if (ts->type == BT_CHARACTER)
3078 {
3079 if (ts->is_c_interop)
3080 {
3081 *type_name = "char";
3082 ret = T_OK;
3083 }
3084 else
3085 {
3086 /* Let's select an appropriate int, with a warning. */
3087 for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3088 {
3089 if (c_interop_kinds_table[i].f90_type == BT_INTEGER
3090 && c_interop_kinds_table[i].value == ts->kind)
3091 {
3092 *type_name = c_interop_kinds_table[i].name + 2;
3093 ret = T_WARN;
3094 }
3095 }
3096 }
3097 }
3098 else if (ts->type == BT_DERIVED)
3099 {
3100 if (ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
3101 {
3102 if (strcmp (ts->u.derived->name, "c_ptr") == 0)
3103 *type_name = "void";
3104 else if (strcmp (ts->u.derived->name, "c_funptr") == 0)
3105 {
3106 *type_name = "int ";
3107 if (func_ret)
3108 {
3109 *pre = "(";
3110 *post = "())";
3111 }
3112 else
3113 {
3114 *pre = "(";
3115 *post = ")()";
3116 }
3117 }
3118 *asterisk = true;
3119 }
3120 else
3121 *type_name = ts->u.derived->name;
3122
3123 ret = T_OK;
3124 }
3125 if (ret != T_ERROR && as)
3126 {
3127 mpz_t sz;
3128 bool size_ok;
3129 size_ok = spec_size (as, &sz);
3130 gcc_assert (size_ok == true);
3131 gmp_snprintf (post_buffer, sizeof(post_buffer), "[%Zd]", sz);
3132 *post = post_buffer;
3133 mpz_clear (sz);
3134 }
3135 return ret;
3136 }
3137
3138 /* Write out a declaration. */
3139 static void
write_decl(gfc_typespec * ts,gfc_array_spec * as,const char * sym_name,bool func_ret,locus * where)3140 write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
3141 bool func_ret, locus *where)
3142 {
3143 const char *pre, *type_name, *post;
3144 bool asterisk;
3145 enum type_return rok;
3146
3147 rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret);
3148 if (rok == T_ERROR)
3149 {
3150 gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3151 gfc_typename (ts), where);
3152 fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */",
3153 gfc_typename (ts));
3154 return;
3155 }
3156 fputs (type_name, dumpfile);
3157 fputs (pre, dumpfile);
3158 if (asterisk)
3159 fputs ("*", dumpfile);
3160
3161 fputs (sym_name, dumpfile);
3162 fputs (post, dumpfile);
3163
3164 if (rok == T_WARN)
3165 fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
3166 gfc_typename (ts));
3167 }
3168
3169 /* Write out an interoperable type. It will be written as a typedef
3170 for a struct. */
3171
3172 static void
write_type(gfc_symbol * sym)3173 write_type (gfc_symbol *sym)
3174 {
3175 gfc_component *c;
3176
3177 fprintf (dumpfile, "typedef struct %s {\n", sym->name);
3178 for (c = sym->components; c; c = c->next)
3179 {
3180 fputs (" ", dumpfile);
3181 write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at);
3182 fputs (";\n", dumpfile);
3183 }
3184
3185 fprintf (dumpfile, "} %s;\n", sym->name);
3186 }
3187
3188 /* Write out a variable. */
3189
3190 static void
write_variable(gfc_symbol * sym)3191 write_variable (gfc_symbol *sym)
3192 {
3193 const char *sym_name;
3194
3195 gcc_assert (sym->attr.flavor == FL_VARIABLE);
3196
3197 if (sym->binding_label)
3198 sym_name = sym->binding_label;
3199 else
3200 sym_name = sym->name;
3201
3202 fputs ("extern ", dumpfile);
3203 write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at);
3204 fputs (";\n", dumpfile);
3205 }
3206
3207
3208 /* Write out a procedure, including its arguments. */
3209 static void
write_proc(gfc_symbol * sym)3210 write_proc (gfc_symbol *sym)
3211 {
3212 const char *pre, *type_name, *post;
3213 bool asterisk;
3214 enum type_return rok;
3215 gfc_formal_arglist *f;
3216 const char *sym_name;
3217 const char *intent_in;
3218
3219 if (sym->binding_label)
3220 sym_name = sym->binding_label;
3221 else
3222 sym_name = sym->name;
3223
3224 if (sym->ts.type == BT_UNKNOWN)
3225 {
3226 fprintf (dumpfile, "void ");
3227 fputs (sym_name, dumpfile);
3228 }
3229 else
3230 write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at);
3231
3232 fputs (" (", dumpfile);
3233
3234 for (f = sym->formal; f; f = f->next)
3235 {
3236 gfc_symbol *s;
3237 s = f->sym;
3238 rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk,
3239 &post, false);
3240 if (rok == T_ERROR)
3241 {
3242 gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3243 gfc_typename (&s->ts), &s->declared_at);
3244 fprintf (stderr, "/* Cannot convert '%s' to interoperable type */",
3245 gfc_typename (&s->ts));
3246 return;
3247 }
3248
3249 if (!s->attr.value)
3250 asterisk = true;
3251
3252 if (s->attr.intent == INTENT_IN && !s->attr.value)
3253 intent_in = "const ";
3254 else
3255 intent_in = "";
3256
3257 fputs (intent_in, dumpfile);
3258 fputs (type_name, dumpfile);
3259 fputs (pre, dumpfile);
3260 if (asterisk)
3261 fputs ("*", dumpfile);
3262
3263 fputs (s->name, dumpfile);
3264 fputs (post, dumpfile);
3265 if (rok == T_WARN)
3266 fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile);
3267
3268 if (f->next)
3269 fputs(", ", dumpfile);
3270 }
3271 fputs (");\n", dumpfile);
3272 }
3273
3274
3275 /* Write a C-interoperable declaration as a C prototype or extern
3276 declaration. */
3277
3278 static void
write_interop_decl(gfc_symbol * sym)3279 write_interop_decl (gfc_symbol *sym)
3280 {
3281 /* Only dump bind(c) entities. */
3282 if (!sym->attr.is_bind_c)
3283 return;
3284
3285 /* Don't dump our iso c module. */
3286 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
3287 return;
3288
3289 if (sym->attr.flavor == FL_VARIABLE)
3290 write_variable (sym);
3291 else if (sym->attr.flavor == FL_DERIVED)
3292 write_type (sym);
3293 else if (sym->attr.flavor == FL_PROCEDURE)
3294 write_proc (sym);
3295 }
3296