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