1 /* Parse tree dumper
2 Copyright (C) 2003-2022 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->omp_affinity_iterators; sym; sym = sym->tlink)
1306 {
1307 gfc_constructor *c;
1308 if (sym != ns->omp_affinity_iterators)
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_HAS_DEVICE_ADDR: type = "HAS_DEVICE_ADDR"; break;
1687 case OMP_LIST_USE_DEVICE_ADDR: type = "USE_DEVICE_ADDR"; break;
1688 case OMP_LIST_NONTEMPORAL: type = "NONTEMPORAL"; break;
1689 case OMP_LIST_ALLOCATE: type = "ALLOCATE"; break;
1690 case OMP_LIST_SCAN_IN: type = "INCLUSIVE"; break;
1691 case OMP_LIST_SCAN_EX: type = "EXCLUSIVE"; break;
1692 default:
1693 gcc_unreachable ();
1694 }
1695 fprintf (dumpfile, " %s(", type);
1696 if (list_type == OMP_LIST_REDUCTION_INSCAN)
1697 fputs ("inscan, ", dumpfile);
1698 if (list_type == OMP_LIST_REDUCTION_TASK)
1699 fputs ("task, ", dumpfile);
1700 show_omp_namelist (list_type, omp_clauses->lists[list_type]);
1701 fputc (')', dumpfile);
1702 }
1703 if (omp_clauses->safelen_expr)
1704 {
1705 fputs (" SAFELEN(", dumpfile);
1706 show_expr (omp_clauses->safelen_expr);
1707 fputc (')', dumpfile);
1708 }
1709 if (omp_clauses->simdlen_expr)
1710 {
1711 fputs (" SIMDLEN(", dumpfile);
1712 show_expr (omp_clauses->simdlen_expr);
1713 fputc (')', dumpfile);
1714 }
1715 if (omp_clauses->inbranch)
1716 fputs (" INBRANCH", dumpfile);
1717 if (omp_clauses->notinbranch)
1718 fputs (" NOTINBRANCH", dumpfile);
1719 if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
1720 {
1721 const char *type;
1722 switch (omp_clauses->proc_bind)
1723 {
1724 case OMP_PROC_BIND_PRIMARY: type = "PRIMARY"; break;
1725 case OMP_PROC_BIND_MASTER: type = "MASTER"; break;
1726 case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break;
1727 case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break;
1728 default:
1729 gcc_unreachable ();
1730 }
1731 fprintf (dumpfile, " PROC_BIND(%s)", type);
1732 }
1733 if (omp_clauses->bind != OMP_BIND_UNSET)
1734 {
1735 const char *type;
1736 switch (omp_clauses->bind)
1737 {
1738 case OMP_BIND_TEAMS: type = "TEAMS"; break;
1739 case OMP_BIND_PARALLEL: type = "PARALLEL"; break;
1740 case OMP_BIND_THREAD: type = "THREAD"; break;
1741 default:
1742 gcc_unreachable ();
1743 }
1744 fprintf (dumpfile, " BIND(%s)", type);
1745 }
1746 if (omp_clauses->num_teams_upper)
1747 {
1748 fputs (" NUM_TEAMS(", dumpfile);
1749 if (omp_clauses->num_teams_lower)
1750 {
1751 show_expr (omp_clauses->num_teams_lower);
1752 fputc (':', dumpfile);
1753 }
1754 show_expr (omp_clauses->num_teams_upper);
1755 fputc (')', dumpfile);
1756 }
1757 if (omp_clauses->device)
1758 {
1759 fputs (" DEVICE(", dumpfile);
1760 if (omp_clauses->ancestor)
1761 fputs ("ANCESTOR:", dumpfile);
1762 show_expr (omp_clauses->device);
1763 fputc (')', dumpfile);
1764 }
1765 if (omp_clauses->thread_limit)
1766 {
1767 fputs (" THREAD_LIMIT(", dumpfile);
1768 show_expr (omp_clauses->thread_limit);
1769 fputc (')', dumpfile);
1770 }
1771 if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE)
1772 {
1773 fputs (" DIST_SCHEDULE (STATIC", dumpfile);
1774 if (omp_clauses->dist_chunk_size)
1775 {
1776 fputc (',', dumpfile);
1777 show_expr (omp_clauses->dist_chunk_size);
1778 }
1779 fputc (')', dumpfile);
1780 }
1781 for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
1782 {
1783 const char *dfltmap;
1784 if (omp_clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET)
1785 continue;
1786 fputs (" DEFAULTMAP (", dumpfile);
1787 switch (omp_clauses->defaultmap[i])
1788 {
1789 case OMP_DEFAULTMAP_ALLOC: dfltmap = "ALLOC"; break;
1790 case OMP_DEFAULTMAP_TO: dfltmap = "TO"; break;
1791 case OMP_DEFAULTMAP_FROM: dfltmap = "FROM"; break;
1792 case OMP_DEFAULTMAP_TOFROM: dfltmap = "TOFROM"; break;
1793 case OMP_DEFAULTMAP_FIRSTPRIVATE: dfltmap = "FIRSTPRIVATE"; break;
1794 case OMP_DEFAULTMAP_NONE: dfltmap = "NONE"; break;
1795 case OMP_DEFAULTMAP_DEFAULT: dfltmap = "DEFAULT"; break;
1796 case OMP_DEFAULTMAP_PRESENT: dfltmap = "PRESENT"; break;
1797 default: gcc_unreachable ();
1798 }
1799 fputs (dfltmap, dumpfile);
1800 if (i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
1801 {
1802 fputc (':', dumpfile);
1803 switch ((enum gfc_omp_defaultmap_category) i)
1804 {
1805 case OMP_DEFAULTMAP_CAT_SCALAR: dfltmap = "SCALAR"; break;
1806 case OMP_DEFAULTMAP_CAT_AGGREGATE: dfltmap = "AGGREGATE"; break;
1807 case OMP_DEFAULTMAP_CAT_ALLOCATABLE: dfltmap = "ALLOCATABLE"; break;
1808 case OMP_DEFAULTMAP_CAT_POINTER: dfltmap = "POINTER"; break;
1809 default: gcc_unreachable ();
1810 }
1811 fputs (dfltmap, dumpfile);
1812 }
1813 fputc (')', dumpfile);
1814 }
1815 if (omp_clauses->weak)
1816 fputs (" WEAK", dumpfile);
1817 if (omp_clauses->compare)
1818 fputs (" COMPARE", dumpfile);
1819 if (omp_clauses->nogroup)
1820 fputs (" NOGROUP", dumpfile);
1821 if (omp_clauses->simd)
1822 fputs (" SIMD", dumpfile);
1823 if (omp_clauses->threads)
1824 fputs (" THREADS", dumpfile);
1825 if (omp_clauses->grainsize)
1826 {
1827 fputs (" GRAINSIZE(", dumpfile);
1828 if (omp_clauses->grainsize_strict)
1829 fputs ("strict: ", dumpfile);
1830 show_expr (omp_clauses->grainsize);
1831 fputc (')', dumpfile);
1832 }
1833 if (omp_clauses->filter)
1834 {
1835 fputs (" FILTER(", dumpfile);
1836 show_expr (omp_clauses->filter);
1837 fputc (')', dumpfile);
1838 }
1839 if (omp_clauses->hint)
1840 {
1841 fputs (" HINT(", dumpfile);
1842 show_expr (omp_clauses->hint);
1843 fputc (')', dumpfile);
1844 }
1845 if (omp_clauses->num_tasks)
1846 {
1847 fputs (" NUM_TASKS(", dumpfile);
1848 if (omp_clauses->num_tasks_strict)
1849 fputs ("strict: ", dumpfile);
1850 show_expr (omp_clauses->num_tasks);
1851 fputc (')', dumpfile);
1852 }
1853 if (omp_clauses->priority)
1854 {
1855 fputs (" PRIORITY(", dumpfile);
1856 show_expr (omp_clauses->priority);
1857 fputc (')', dumpfile);
1858 }
1859 if (omp_clauses->detach)
1860 {
1861 fputs (" DETACH(", dumpfile);
1862 show_expr (omp_clauses->detach);
1863 fputc (')', dumpfile);
1864 }
1865 for (i = 0; i < OMP_IF_LAST; i++)
1866 if (omp_clauses->if_exprs[i])
1867 {
1868 static const char *ifs[] = {
1869 "CANCEL",
1870 "PARALLEL",
1871 "SIMD",
1872 "TASK",
1873 "TASKLOOP",
1874 "TARGET",
1875 "TARGET DATA",
1876 "TARGET UPDATE",
1877 "TARGET ENTER DATA",
1878 "TARGET EXIT DATA"
1879 };
1880 fputs (" IF(", dumpfile);
1881 fputs (ifs[i], dumpfile);
1882 fputs (": ", dumpfile);
1883 show_expr (omp_clauses->if_exprs[i]);
1884 fputc (')', dumpfile);
1885 }
1886 if (omp_clauses->destroy)
1887 fputs (" DESTROY", dumpfile);
1888 if (omp_clauses->depend_source)
1889 fputs (" DEPEND(source)", dumpfile);
1890 if (omp_clauses->capture)
1891 fputs (" CAPTURE", dumpfile);
1892 if (omp_clauses->depobj_update != OMP_DEPEND_UNSET)
1893 {
1894 const char *deptype;
1895 fputs (" UPDATE(", dumpfile);
1896 switch (omp_clauses->depobj_update)
1897 {
1898 case OMP_DEPEND_IN: deptype = "IN"; break;
1899 case OMP_DEPEND_OUT: deptype = "OUT"; break;
1900 case OMP_DEPEND_INOUT: deptype = "INOUT"; break;
1901 case OMP_DEPEND_MUTEXINOUTSET: deptype = "MUTEXINOUTSET"; break;
1902 default: gcc_unreachable ();
1903 }
1904 fputs (deptype, dumpfile);
1905 fputc (')', dumpfile);
1906 }
1907 if (omp_clauses->atomic_op != GFC_OMP_ATOMIC_UNSET)
1908 {
1909 const char *atomic_op;
1910 switch (omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
1911 {
1912 case GFC_OMP_ATOMIC_READ: atomic_op = "READ"; break;
1913 case GFC_OMP_ATOMIC_WRITE: atomic_op = "WRITE"; break;
1914 case GFC_OMP_ATOMIC_UPDATE: atomic_op = "UPDATE"; break;
1915 default: gcc_unreachable ();
1916 }
1917 fputc (' ', dumpfile);
1918 fputs (atomic_op, dumpfile);
1919 }
1920 if (omp_clauses->memorder != OMP_MEMORDER_UNSET)
1921 {
1922 const char *memorder;
1923 switch (omp_clauses->memorder)
1924 {
1925 case OMP_MEMORDER_ACQ_REL: memorder = "ACQ_REL"; break;
1926 case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break;
1927 case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break;
1928 case OMP_MEMORDER_RELEASE: memorder = "RELEASE"; break;
1929 case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break;
1930 default: gcc_unreachable ();
1931 }
1932 fputc (' ', dumpfile);
1933 fputs (memorder, dumpfile);
1934 }
1935 if (omp_clauses->fail != OMP_MEMORDER_UNSET)
1936 {
1937 const char *memorder;
1938 switch (omp_clauses->fail)
1939 {
1940 case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break;
1941 case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break;
1942 case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break;
1943 default: gcc_unreachable ();
1944 }
1945 fputs (" FAIL(", dumpfile);
1946 fputs (memorder, dumpfile);
1947 putc (')', dumpfile);
1948 }
1949 if (omp_clauses->at != OMP_AT_UNSET)
1950 {
1951 if (omp_clauses->at != OMP_AT_COMPILATION)
1952 fputs (" AT (COMPILATION)", dumpfile);
1953 else
1954 fputs (" AT (EXECUTION)", dumpfile);
1955 }
1956 if (omp_clauses->severity != OMP_SEVERITY_UNSET)
1957 {
1958 if (omp_clauses->severity != OMP_SEVERITY_FATAL)
1959 fputs (" SEVERITY (FATAL)", dumpfile);
1960 else
1961 fputs (" SEVERITY (WARNING)", dumpfile);
1962 }
1963 if (omp_clauses->message)
1964 {
1965 fputs (" ERROR (", dumpfile);
1966 show_expr (omp_clauses->message);
1967 fputc (')', dumpfile);
1968 }
1969 }
1970
1971 /* Show a single OpenMP or OpenACC directive node and everything underneath it
1972 if necessary. */
1973
1974 static void
show_omp_node(int level,gfc_code * c)1975 show_omp_node (int level, gfc_code *c)
1976 {
1977 gfc_omp_clauses *omp_clauses = NULL;
1978 const char *name = NULL;
1979 bool is_oacc = false;
1980
1981 switch (c->op)
1982 {
1983 case EXEC_OACC_PARALLEL_LOOP:
1984 name = "PARALLEL LOOP"; is_oacc = true; break;
1985 case EXEC_OACC_PARALLEL: name = "PARALLEL"; is_oacc = true; break;
1986 case EXEC_OACC_KERNELS_LOOP: name = "KERNELS LOOP"; is_oacc = true; break;
1987 case EXEC_OACC_KERNELS: name = "KERNELS"; is_oacc = true; break;
1988 case EXEC_OACC_SERIAL_LOOP: name = "SERIAL LOOP"; is_oacc = true; break;
1989 case EXEC_OACC_SERIAL: name = "SERIAL"; is_oacc = true; break;
1990 case EXEC_OACC_DATA: name = "DATA"; is_oacc = true; break;
1991 case EXEC_OACC_HOST_DATA: name = "HOST_DATA"; is_oacc = true; break;
1992 case EXEC_OACC_LOOP: name = "LOOP"; is_oacc = true; break;
1993 case EXEC_OACC_UPDATE: name = "UPDATE"; is_oacc = true; break;
1994 case EXEC_OACC_WAIT: name = "WAIT"; is_oacc = true; break;
1995 case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
1996 case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
1997 case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
1998 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
1999 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
2000 case EXEC_OMP_CANCEL: name = "CANCEL"; break;
2001 case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break;
2002 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
2003 case EXEC_OMP_DISTRIBUTE: name = "DISTRIBUTE"; break;
2004 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2005 name = "DISTRIBUTE PARALLEL DO"; break;
2006 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2007 name = "DISTRIBUTE PARALLEL DO SIMD"; break;
2008 case EXEC_OMP_DISTRIBUTE_SIMD: name = "DISTRIBUTE SIMD"; break;
2009 case EXEC_OMP_DO: name = "DO"; break;
2010 case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break;
2011 case EXEC_OMP_ERROR: name = "ERROR"; break;
2012 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
2013 case EXEC_OMP_LOOP: name = "LOOP"; break;
2014 case EXEC_OMP_MASKED: name = "MASKED"; break;
2015 case EXEC_OMP_MASKED_TASKLOOP: name = "MASKED TASKLOOP"; break;
2016 case EXEC_OMP_MASKED_TASKLOOP_SIMD: name = "MASKED TASKLOOP SIMD"; break;
2017 case EXEC_OMP_MASTER: name = "MASTER"; break;
2018 case EXEC_OMP_MASTER_TASKLOOP: name = "MASTER TASKLOOP"; break;
2019 case EXEC_OMP_MASTER_TASKLOOP_SIMD: name = "MASTER TASKLOOP SIMD"; break;
2020 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
2021 case EXEC_OMP_DEPOBJ: name = "DEPOBJ"; break;
2022 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
2023 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
2024 case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break;
2025 case EXEC_OMP_PARALLEL_LOOP: name = "PARALLEL LOOP"; break;
2026 case EXEC_OMP_PARALLEL_MASTER: name = "PARALLEL MASTER"; break;
2027 case EXEC_OMP_PARALLEL_MASKED: name = "PARALLEL MASK"; break;
2028 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
2029 name = "PARALLEL MASK TASKLOOP"; break;
2030 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2031 name = "PARALLEL MASK TASKLOOP SIMD"; break;
2032 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
2033 name = "PARALLEL MASTER TASKLOOP"; break;
2034 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2035 name = "PARALLEL MASTER TASKLOOP SIMD"; break;
2036 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
2037 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
2038 case EXEC_OMP_SCAN: name = "SCAN"; break;
2039 case EXEC_OMP_SCOPE: name = "SCOPE"; break;
2040 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
2041 case EXEC_OMP_SIMD: name = "SIMD"; break;
2042 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
2043 case EXEC_OMP_TARGET: name = "TARGET"; break;
2044 case EXEC_OMP_TARGET_DATA: name = "TARGET DATA"; break;
2045 case EXEC_OMP_TARGET_ENTER_DATA: name = "TARGET ENTER DATA"; break;
2046 case EXEC_OMP_TARGET_EXIT_DATA: name = "TARGET EXIT DATA"; break;
2047 case EXEC_OMP_TARGET_PARALLEL: name = "TARGET PARALLEL"; break;
2048 case EXEC_OMP_TARGET_PARALLEL_DO: name = "TARGET PARALLEL DO"; break;
2049 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2050 name = "TARGET_PARALLEL_DO_SIMD"; break;
2051 case EXEC_OMP_TARGET_PARALLEL_LOOP: name = "TARGET PARALLEL LOOP"; break;
2052 case EXEC_OMP_TARGET_SIMD: name = "TARGET SIMD"; break;
2053 case EXEC_OMP_TARGET_TEAMS: name = "TARGET TEAMS"; break;
2054 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2055 name = "TARGET TEAMS DISTRIBUTE"; break;
2056 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2057 name = "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break;
2058 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2059 name = "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
2060 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2061 name = "TARGET TEAMS DISTRIBUTE SIMD"; break;
2062 case EXEC_OMP_TARGET_TEAMS_LOOP: name = "TARGET TEAMS LOOP"; break;
2063 case EXEC_OMP_TARGET_UPDATE: name = "TARGET UPDATE"; break;
2064 case EXEC_OMP_TASK: name = "TASK"; break;
2065 case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break;
2066 case EXEC_OMP_TASKLOOP: name = "TASKLOOP"; break;
2067 case EXEC_OMP_TASKLOOP_SIMD: name = "TASKLOOP SIMD"; break;
2068 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
2069 case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
2070 case EXEC_OMP_TEAMS: name = "TEAMS"; break;
2071 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "TEAMS DISTRIBUTE"; break;
2072 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2073 name = "TEAMS DISTRIBUTE PARALLEL DO"; break;
2074 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2075 name = "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
2076 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: name = "TEAMS DISTRIBUTE SIMD"; break;
2077 case EXEC_OMP_TEAMS_LOOP: name = "TEAMS LOOP"; break;
2078 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
2079 default:
2080 gcc_unreachable ();
2081 }
2082 fprintf (dumpfile, "!$%s %s", is_oacc ? "ACC" : "OMP", name);
2083 switch (c->op)
2084 {
2085 case EXEC_OACC_PARALLEL_LOOP:
2086 case EXEC_OACC_PARALLEL:
2087 case EXEC_OACC_KERNELS_LOOP:
2088 case EXEC_OACC_KERNELS:
2089 case EXEC_OACC_SERIAL_LOOP:
2090 case EXEC_OACC_SERIAL:
2091 case EXEC_OACC_DATA:
2092 case EXEC_OACC_HOST_DATA:
2093 case EXEC_OACC_LOOP:
2094 case EXEC_OACC_UPDATE:
2095 case EXEC_OACC_WAIT:
2096 case EXEC_OACC_CACHE:
2097 case EXEC_OACC_ENTER_DATA:
2098 case EXEC_OACC_EXIT_DATA:
2099 case EXEC_OMP_CANCEL:
2100 case EXEC_OMP_CANCELLATION_POINT:
2101 case EXEC_OMP_DISTRIBUTE:
2102 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2103 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2104 case EXEC_OMP_DISTRIBUTE_SIMD:
2105 case EXEC_OMP_DO:
2106 case EXEC_OMP_DO_SIMD:
2107 case EXEC_OMP_ERROR:
2108 case EXEC_OMP_LOOP:
2109 case EXEC_OMP_ORDERED:
2110 case EXEC_OMP_MASKED:
2111 case EXEC_OMP_PARALLEL:
2112 case EXEC_OMP_PARALLEL_DO:
2113 case EXEC_OMP_PARALLEL_DO_SIMD:
2114 case EXEC_OMP_PARALLEL_LOOP:
2115 case EXEC_OMP_PARALLEL_MASKED:
2116 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
2117 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2118 case EXEC_OMP_PARALLEL_MASTER:
2119 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
2120 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2121 case EXEC_OMP_PARALLEL_SECTIONS:
2122 case EXEC_OMP_PARALLEL_WORKSHARE:
2123 case EXEC_OMP_SCAN:
2124 case EXEC_OMP_SCOPE:
2125 case EXEC_OMP_SECTIONS:
2126 case EXEC_OMP_SIMD:
2127 case EXEC_OMP_SINGLE:
2128 case EXEC_OMP_TARGET:
2129 case EXEC_OMP_TARGET_DATA:
2130 case EXEC_OMP_TARGET_ENTER_DATA:
2131 case EXEC_OMP_TARGET_EXIT_DATA:
2132 case EXEC_OMP_TARGET_PARALLEL:
2133 case EXEC_OMP_TARGET_PARALLEL_DO:
2134 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2135 case EXEC_OMP_TARGET_PARALLEL_LOOP:
2136 case EXEC_OMP_TARGET_SIMD:
2137 case EXEC_OMP_TARGET_TEAMS:
2138 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2139 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2140 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2141 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2142 case EXEC_OMP_TARGET_TEAMS_LOOP:
2143 case EXEC_OMP_TARGET_UPDATE:
2144 case EXEC_OMP_TASK:
2145 case EXEC_OMP_TASKLOOP:
2146 case EXEC_OMP_TASKLOOP_SIMD:
2147 case EXEC_OMP_TEAMS:
2148 case EXEC_OMP_TEAMS_DISTRIBUTE:
2149 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2150 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2151 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2152 case EXEC_OMP_TEAMS_LOOP:
2153 case EXEC_OMP_WORKSHARE:
2154 omp_clauses = c->ext.omp_clauses;
2155 break;
2156 case EXEC_OMP_CRITICAL:
2157 omp_clauses = c->ext.omp_clauses;
2158 if (omp_clauses)
2159 fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name);
2160 break;
2161 case EXEC_OMP_DEPOBJ:
2162 omp_clauses = c->ext.omp_clauses;
2163 if (omp_clauses)
2164 {
2165 fputc ('(', dumpfile);
2166 show_expr (c->ext.omp_clauses->depobj);
2167 fputc (')', dumpfile);
2168 }
2169 break;
2170 case EXEC_OMP_FLUSH:
2171 if (c->ext.omp_namelist)
2172 {
2173 fputs (" (", dumpfile);
2174 show_omp_namelist (OMP_LIST_NUM, c->ext.omp_namelist);
2175 fputc (')', dumpfile);
2176 }
2177 return;
2178 case EXEC_OMP_BARRIER:
2179 case EXEC_OMP_TASKWAIT:
2180 case EXEC_OMP_TASKYIELD:
2181 return;
2182 case EXEC_OACC_ATOMIC:
2183 case EXEC_OMP_ATOMIC:
2184 omp_clauses = c->block ? c->block->ext.omp_clauses : NULL;
2185 break;
2186 default:
2187 break;
2188 }
2189 if (omp_clauses)
2190 show_omp_clauses (omp_clauses);
2191 fputc ('\n', dumpfile);
2192
2193 /* OpenMP and OpenACC executable directives don't have associated blocks. */
2194 if (c->op == EXEC_OACC_CACHE || c->op == EXEC_OACC_UPDATE
2195 || c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA
2196 || c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA
2197 || c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN
2198 || c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR
2199 || (c->op == EXEC_OMP_ORDERED && c->block == NULL))
2200 return;
2201 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
2202 {
2203 gfc_code *d = c->block;
2204 while (d != NULL)
2205 {
2206 show_code (level + 1, d->next);
2207 if (d->block == NULL)
2208 break;
2209 code_indent (level, 0);
2210 fputs ("!$OMP SECTION\n", dumpfile);
2211 d = d->block;
2212 }
2213 }
2214 else
2215 show_code (level + 1, c->block->next);
2216 if (c->op == EXEC_OMP_ATOMIC)
2217 return;
2218 fputc ('\n', dumpfile);
2219 code_indent (level, 0);
2220 fprintf (dumpfile, "!$%s END %s", is_oacc ? "ACC" : "OMP", name);
2221 if (omp_clauses != NULL)
2222 {
2223 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
2224 {
2225 fputs (" COPYPRIVATE(", dumpfile);
2226 show_omp_namelist (OMP_LIST_COPYPRIVATE,
2227 omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
2228 fputc (')', dumpfile);
2229 }
2230 else if (omp_clauses->nowait)
2231 fputs (" NOWAIT", dumpfile);
2232 }
2233 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses)
2234 fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name);
2235 }
2236
2237
2238 /* Show a single code node and everything underneath it if necessary. */
2239
2240 static void
show_code_node(int level,gfc_code * c)2241 show_code_node (int level, gfc_code *c)
2242 {
2243 gfc_forall_iterator *fa;
2244 gfc_open *open;
2245 gfc_case *cp;
2246 gfc_alloc *a;
2247 gfc_code *d;
2248 gfc_close *close;
2249 gfc_filepos *fp;
2250 gfc_inquire *i;
2251 gfc_dt *dt;
2252 gfc_namespace *ns;
2253
2254 if (c->here)
2255 {
2256 fputc ('\n', dumpfile);
2257 code_indent (level, c->here);
2258 }
2259 else
2260 show_indent ();
2261
2262 switch (c->op)
2263 {
2264 case EXEC_END_PROCEDURE:
2265 break;
2266
2267 case EXEC_NOP:
2268 fputs ("NOP", dumpfile);
2269 break;
2270
2271 case EXEC_CONTINUE:
2272 fputs ("CONTINUE", dumpfile);
2273 break;
2274
2275 case EXEC_ENTRY:
2276 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
2277 break;
2278
2279 case EXEC_INIT_ASSIGN:
2280 case EXEC_ASSIGN:
2281 fputs ("ASSIGN ", dumpfile);
2282 show_expr (c->expr1);
2283 fputc (' ', dumpfile);
2284 show_expr (c->expr2);
2285 break;
2286
2287 case EXEC_LABEL_ASSIGN:
2288 fputs ("LABEL ASSIGN ", dumpfile);
2289 show_expr (c->expr1);
2290 fprintf (dumpfile, " %d", c->label1->value);
2291 break;
2292
2293 case EXEC_POINTER_ASSIGN:
2294 fputs ("POINTER ASSIGN ", dumpfile);
2295 show_expr (c->expr1);
2296 fputc (' ', dumpfile);
2297 show_expr (c->expr2);
2298 break;
2299
2300 case EXEC_GOTO:
2301 fputs ("GOTO ", dumpfile);
2302 if (c->label1)
2303 fprintf (dumpfile, "%d", c->label1->value);
2304 else
2305 {
2306 show_expr (c->expr1);
2307 d = c->block;
2308 if (d != NULL)
2309 {
2310 fputs (", (", dumpfile);
2311 for (; d; d = d ->block)
2312 {
2313 code_indent (level, d->label1);
2314 if (d->block != NULL)
2315 fputc (',', dumpfile);
2316 else
2317 fputc (')', dumpfile);
2318 }
2319 }
2320 }
2321 break;
2322
2323 case EXEC_CALL:
2324 case EXEC_ASSIGN_CALL:
2325 if (c->resolved_sym)
2326 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
2327 else if (c->symtree)
2328 fprintf (dumpfile, "CALL %s ", c->symtree->name);
2329 else
2330 fputs ("CALL ?? ", dumpfile);
2331
2332 show_actual_arglist (c->ext.actual);
2333 break;
2334
2335 case EXEC_COMPCALL:
2336 fputs ("CALL ", dumpfile);
2337 show_compcall (c->expr1);
2338 break;
2339
2340 case EXEC_CALL_PPC:
2341 fputs ("CALL ", dumpfile);
2342 show_expr (c->expr1);
2343 show_actual_arglist (c->ext.actual);
2344 break;
2345
2346 case EXEC_RETURN:
2347 fputs ("RETURN ", dumpfile);
2348 if (c->expr1)
2349 show_expr (c->expr1);
2350 break;
2351
2352 case EXEC_PAUSE:
2353 fputs ("PAUSE ", dumpfile);
2354
2355 if (c->expr1 != NULL)
2356 show_expr (c->expr1);
2357 else
2358 fprintf (dumpfile, "%d", c->ext.stop_code);
2359
2360 break;
2361
2362 case EXEC_ERROR_STOP:
2363 fputs ("ERROR ", dumpfile);
2364 /* Fall through. */
2365
2366 case EXEC_STOP:
2367 fputs ("STOP ", dumpfile);
2368
2369 if (c->expr1 != NULL)
2370 show_expr (c->expr1);
2371 else
2372 fprintf (dumpfile, "%d", c->ext.stop_code);
2373 if (c->expr2 != NULL)
2374 {
2375 fputs (" QUIET=", dumpfile);
2376 show_expr (c->expr2);
2377 }
2378
2379 break;
2380
2381 case EXEC_FAIL_IMAGE:
2382 fputs ("FAIL IMAGE ", dumpfile);
2383 break;
2384
2385 case EXEC_CHANGE_TEAM:
2386 fputs ("CHANGE TEAM", dumpfile);
2387 break;
2388
2389 case EXEC_END_TEAM:
2390 fputs ("END TEAM", dumpfile);
2391 break;
2392
2393 case EXEC_FORM_TEAM:
2394 fputs ("FORM TEAM", dumpfile);
2395 break;
2396
2397 case EXEC_SYNC_TEAM:
2398 fputs ("SYNC TEAM", dumpfile);
2399 break;
2400
2401 case EXEC_SYNC_ALL:
2402 fputs ("SYNC ALL ", dumpfile);
2403 if (c->expr2 != NULL)
2404 {
2405 fputs (" stat=", dumpfile);
2406 show_expr (c->expr2);
2407 }
2408 if (c->expr3 != NULL)
2409 {
2410 fputs (" errmsg=", dumpfile);
2411 show_expr (c->expr3);
2412 }
2413 break;
2414
2415 case EXEC_SYNC_MEMORY:
2416 fputs ("SYNC MEMORY ", dumpfile);
2417 if (c->expr2 != NULL)
2418 {
2419 fputs (" stat=", dumpfile);
2420 show_expr (c->expr2);
2421 }
2422 if (c->expr3 != NULL)
2423 {
2424 fputs (" errmsg=", dumpfile);
2425 show_expr (c->expr3);
2426 }
2427 break;
2428
2429 case EXEC_SYNC_IMAGES:
2430 fputs ("SYNC IMAGES image-set=", dumpfile);
2431 if (c->expr1 != NULL)
2432 show_expr (c->expr1);
2433 else
2434 fputs ("* ", dumpfile);
2435 if (c->expr2 != NULL)
2436 {
2437 fputs (" stat=", dumpfile);
2438 show_expr (c->expr2);
2439 }
2440 if (c->expr3 != NULL)
2441 {
2442 fputs (" errmsg=", dumpfile);
2443 show_expr (c->expr3);
2444 }
2445 break;
2446
2447 case EXEC_EVENT_POST:
2448 case EXEC_EVENT_WAIT:
2449 if (c->op == EXEC_EVENT_POST)
2450 fputs ("EVENT POST ", dumpfile);
2451 else
2452 fputs ("EVENT WAIT ", dumpfile);
2453
2454 fputs ("event-variable=", dumpfile);
2455 if (c->expr1 != NULL)
2456 show_expr (c->expr1);
2457 if (c->expr4 != NULL)
2458 {
2459 fputs (" until_count=", dumpfile);
2460 show_expr (c->expr4);
2461 }
2462 if (c->expr2 != NULL)
2463 {
2464 fputs (" stat=", dumpfile);
2465 show_expr (c->expr2);
2466 }
2467 if (c->expr3 != NULL)
2468 {
2469 fputs (" errmsg=", dumpfile);
2470 show_expr (c->expr3);
2471 }
2472 break;
2473
2474 case EXEC_LOCK:
2475 case EXEC_UNLOCK:
2476 if (c->op == EXEC_LOCK)
2477 fputs ("LOCK ", dumpfile);
2478 else
2479 fputs ("UNLOCK ", dumpfile);
2480
2481 fputs ("lock-variable=", dumpfile);
2482 if (c->expr1 != NULL)
2483 show_expr (c->expr1);
2484 if (c->expr4 != NULL)
2485 {
2486 fputs (" acquired_lock=", dumpfile);
2487 show_expr (c->expr4);
2488 }
2489 if (c->expr2 != NULL)
2490 {
2491 fputs (" stat=", dumpfile);
2492 show_expr (c->expr2);
2493 }
2494 if (c->expr3 != NULL)
2495 {
2496 fputs (" errmsg=", dumpfile);
2497 show_expr (c->expr3);
2498 }
2499 break;
2500
2501 case EXEC_ARITHMETIC_IF:
2502 fputs ("IF ", dumpfile);
2503 show_expr (c->expr1);
2504 fprintf (dumpfile, " %d, %d, %d",
2505 c->label1->value, c->label2->value, c->label3->value);
2506 break;
2507
2508 case EXEC_IF:
2509 d = c->block;
2510 fputs ("IF ", dumpfile);
2511 show_expr (d->expr1);
2512
2513 ++show_level;
2514 show_code (level + 1, d->next);
2515 --show_level;
2516
2517 d = d->block;
2518 for (; d; d = d->block)
2519 {
2520 fputs("\n", dumpfile);
2521 code_indent (level, 0);
2522 if (d->expr1 == NULL)
2523 fputs ("ELSE", dumpfile);
2524 else
2525 {
2526 fputs ("ELSE IF ", dumpfile);
2527 show_expr (d->expr1);
2528 }
2529
2530 ++show_level;
2531 show_code (level + 1, d->next);
2532 --show_level;
2533 }
2534
2535 if (c->label1)
2536 code_indent (level, c->label1);
2537 else
2538 show_indent ();
2539
2540 fputs ("ENDIF", dumpfile);
2541 break;
2542
2543 case EXEC_BLOCK:
2544 {
2545 const char* blocktype;
2546 gfc_namespace *saved_ns;
2547 gfc_association_list *alist;
2548
2549 if (c->ext.block.assoc)
2550 blocktype = "ASSOCIATE";
2551 else
2552 blocktype = "BLOCK";
2553 show_indent ();
2554 fprintf (dumpfile, "%s ", blocktype);
2555 for (alist = c->ext.block.assoc; alist; alist = alist->next)
2556 {
2557 fprintf (dumpfile, " %s = ", alist->name);
2558 show_expr (alist->target);
2559 }
2560
2561 ++show_level;
2562 ns = c->ext.block.ns;
2563 saved_ns = gfc_current_ns;
2564 gfc_current_ns = ns;
2565 gfc_traverse_symtree (ns->sym_root, show_symtree);
2566 gfc_current_ns = saved_ns;
2567 show_code (show_level, ns->code);
2568 --show_level;
2569 show_indent ();
2570 fprintf (dumpfile, "END %s ", blocktype);
2571 break;
2572 }
2573
2574 case EXEC_END_BLOCK:
2575 /* Only come here when there is a label on an
2576 END ASSOCIATE construct. */
2577 break;
2578
2579 case EXEC_SELECT:
2580 case EXEC_SELECT_TYPE:
2581 case EXEC_SELECT_RANK:
2582 d = c->block;
2583 fputc ('\n', dumpfile);
2584 code_indent (level, 0);
2585 if (c->op == EXEC_SELECT_RANK)
2586 fputs ("SELECT RANK ", dumpfile);
2587 else if (c->op == EXEC_SELECT_TYPE)
2588 fputs ("SELECT TYPE ", dumpfile);
2589 else
2590 fputs ("SELECT CASE ", dumpfile);
2591 show_expr (c->expr1);
2592
2593 for (; d; d = d->block)
2594 {
2595 fputc ('\n', dumpfile);
2596 code_indent (level, 0);
2597 fputs ("CASE ", dumpfile);
2598 for (cp = d->ext.block.case_list; cp; cp = cp->next)
2599 {
2600 fputc ('(', dumpfile);
2601 show_expr (cp->low);
2602 fputc (' ', dumpfile);
2603 show_expr (cp->high);
2604 fputc (')', dumpfile);
2605 fputc (' ', dumpfile);
2606 }
2607
2608 show_code (level + 1, d->next);
2609 fputc ('\n', dumpfile);
2610 }
2611
2612 code_indent (level, c->label1);
2613 fputs ("END SELECT", dumpfile);
2614 break;
2615
2616 case EXEC_WHERE:
2617 fputs ("WHERE ", dumpfile);
2618
2619 d = c->block;
2620 show_expr (d->expr1);
2621 fputc ('\n', dumpfile);
2622
2623 show_code (level + 1, d->next);
2624
2625 for (d = d->block; d; d = d->block)
2626 {
2627 code_indent (level, 0);
2628 fputs ("ELSE WHERE ", dumpfile);
2629 show_expr (d->expr1);
2630 fputc ('\n', dumpfile);
2631 show_code (level + 1, d->next);
2632 }
2633
2634 code_indent (level, 0);
2635 fputs ("END WHERE", dumpfile);
2636 break;
2637
2638
2639 case EXEC_FORALL:
2640 fputs ("FORALL ", dumpfile);
2641 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
2642 {
2643 show_expr (fa->var);
2644 fputc (' ', dumpfile);
2645 show_expr (fa->start);
2646 fputc (':', dumpfile);
2647 show_expr (fa->end);
2648 fputc (':', dumpfile);
2649 show_expr (fa->stride);
2650
2651 if (fa->next != NULL)
2652 fputc (',', dumpfile);
2653 }
2654
2655 if (c->expr1 != NULL)
2656 {
2657 fputc (',', dumpfile);
2658 show_expr (c->expr1);
2659 }
2660 fputc ('\n', dumpfile);
2661
2662 show_code (level + 1, c->block->next);
2663
2664 code_indent (level, 0);
2665 fputs ("END FORALL", dumpfile);
2666 break;
2667
2668 case EXEC_CRITICAL:
2669 fputs ("CRITICAL\n", dumpfile);
2670 show_code (level + 1, c->block->next);
2671 code_indent (level, 0);
2672 fputs ("END CRITICAL", dumpfile);
2673 break;
2674
2675 case EXEC_DO:
2676 fputs ("DO ", dumpfile);
2677 if (c->label1)
2678 fprintf (dumpfile, " %-5d ", c->label1->value);
2679
2680 show_expr (c->ext.iterator->var);
2681 fputc ('=', dumpfile);
2682 show_expr (c->ext.iterator->start);
2683 fputc (' ', dumpfile);
2684 show_expr (c->ext.iterator->end);
2685 fputc (' ', dumpfile);
2686 show_expr (c->ext.iterator->step);
2687
2688 ++show_level;
2689 show_code (level + 1, c->block->next);
2690 --show_level;
2691
2692 if (c->label1)
2693 break;
2694
2695 show_indent ();
2696 fputs ("END DO", dumpfile);
2697 break;
2698
2699 case EXEC_DO_CONCURRENT:
2700 fputs ("DO CONCURRENT ", dumpfile);
2701 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
2702 {
2703 show_expr (fa->var);
2704 fputc (' ', dumpfile);
2705 show_expr (fa->start);
2706 fputc (':', dumpfile);
2707 show_expr (fa->end);
2708 fputc (':', dumpfile);
2709 show_expr (fa->stride);
2710
2711 if (fa->next != NULL)
2712 fputc (',', dumpfile);
2713 }
2714 show_expr (c->expr1);
2715 ++show_level;
2716
2717 show_code (level + 1, c->block->next);
2718 --show_level;
2719 code_indent (level, c->label1);
2720 show_indent ();
2721 fputs ("END DO", dumpfile);
2722 break;
2723
2724 case EXEC_DO_WHILE:
2725 fputs ("DO WHILE ", dumpfile);
2726 show_expr (c->expr1);
2727 fputc ('\n', dumpfile);
2728
2729 show_code (level + 1, c->block->next);
2730
2731 code_indent (level, c->label1);
2732 fputs ("END DO", dumpfile);
2733 break;
2734
2735 case EXEC_CYCLE:
2736 fputs ("CYCLE", dumpfile);
2737 if (c->symtree)
2738 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
2739 break;
2740
2741 case EXEC_EXIT:
2742 fputs ("EXIT", dumpfile);
2743 if (c->symtree)
2744 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
2745 break;
2746
2747 case EXEC_ALLOCATE:
2748 fputs ("ALLOCATE ", dumpfile);
2749 if (c->expr1)
2750 {
2751 fputs (" STAT=", dumpfile);
2752 show_expr (c->expr1);
2753 }
2754
2755 if (c->expr2)
2756 {
2757 fputs (" ERRMSG=", dumpfile);
2758 show_expr (c->expr2);
2759 }
2760
2761 if (c->expr3)
2762 {
2763 if (c->expr3->mold)
2764 fputs (" MOLD=", dumpfile);
2765 else
2766 fputs (" SOURCE=", dumpfile);
2767 show_expr (c->expr3);
2768 }
2769
2770 for (a = c->ext.alloc.list; a; a = a->next)
2771 {
2772 fputc (' ', dumpfile);
2773 show_expr (a->expr);
2774 }
2775
2776 break;
2777
2778 case EXEC_DEALLOCATE:
2779 fputs ("DEALLOCATE ", dumpfile);
2780 if (c->expr1)
2781 {
2782 fputs (" STAT=", dumpfile);
2783 show_expr (c->expr1);
2784 }
2785
2786 if (c->expr2)
2787 {
2788 fputs (" ERRMSG=", dumpfile);
2789 show_expr (c->expr2);
2790 }
2791
2792 for (a = c->ext.alloc.list; a; a = a->next)
2793 {
2794 fputc (' ', dumpfile);
2795 show_expr (a->expr);
2796 }
2797
2798 break;
2799
2800 case EXEC_OPEN:
2801 fputs ("OPEN", dumpfile);
2802 open = c->ext.open;
2803
2804 if (open->unit)
2805 {
2806 fputs (" UNIT=", dumpfile);
2807 show_expr (open->unit);
2808 }
2809 if (open->iomsg)
2810 {
2811 fputs (" IOMSG=", dumpfile);
2812 show_expr (open->iomsg);
2813 }
2814 if (open->iostat)
2815 {
2816 fputs (" IOSTAT=", dumpfile);
2817 show_expr (open->iostat);
2818 }
2819 if (open->file)
2820 {
2821 fputs (" FILE=", dumpfile);
2822 show_expr (open->file);
2823 }
2824 if (open->status)
2825 {
2826 fputs (" STATUS=", dumpfile);
2827 show_expr (open->status);
2828 }
2829 if (open->access)
2830 {
2831 fputs (" ACCESS=", dumpfile);
2832 show_expr (open->access);
2833 }
2834 if (open->form)
2835 {
2836 fputs (" FORM=", dumpfile);
2837 show_expr (open->form);
2838 }
2839 if (open->recl)
2840 {
2841 fputs (" RECL=", dumpfile);
2842 show_expr (open->recl);
2843 }
2844 if (open->blank)
2845 {
2846 fputs (" BLANK=", dumpfile);
2847 show_expr (open->blank);
2848 }
2849 if (open->position)
2850 {
2851 fputs (" POSITION=", dumpfile);
2852 show_expr (open->position);
2853 }
2854 if (open->action)
2855 {
2856 fputs (" ACTION=", dumpfile);
2857 show_expr (open->action);
2858 }
2859 if (open->delim)
2860 {
2861 fputs (" DELIM=", dumpfile);
2862 show_expr (open->delim);
2863 }
2864 if (open->pad)
2865 {
2866 fputs (" PAD=", dumpfile);
2867 show_expr (open->pad);
2868 }
2869 if (open->decimal)
2870 {
2871 fputs (" DECIMAL=", dumpfile);
2872 show_expr (open->decimal);
2873 }
2874 if (open->encoding)
2875 {
2876 fputs (" ENCODING=", dumpfile);
2877 show_expr (open->encoding);
2878 }
2879 if (open->round)
2880 {
2881 fputs (" ROUND=", dumpfile);
2882 show_expr (open->round);
2883 }
2884 if (open->sign)
2885 {
2886 fputs (" SIGN=", dumpfile);
2887 show_expr (open->sign);
2888 }
2889 if (open->convert)
2890 {
2891 fputs (" CONVERT=", dumpfile);
2892 show_expr (open->convert);
2893 }
2894 if (open->asynchronous)
2895 {
2896 fputs (" ASYNCHRONOUS=", dumpfile);
2897 show_expr (open->asynchronous);
2898 }
2899 if (open->err != NULL)
2900 fprintf (dumpfile, " ERR=%d", open->err->value);
2901
2902 break;
2903
2904 case EXEC_CLOSE:
2905 fputs ("CLOSE", dumpfile);
2906 close = c->ext.close;
2907
2908 if (close->unit)
2909 {
2910 fputs (" UNIT=", dumpfile);
2911 show_expr (close->unit);
2912 }
2913 if (close->iomsg)
2914 {
2915 fputs (" IOMSG=", dumpfile);
2916 show_expr (close->iomsg);
2917 }
2918 if (close->iostat)
2919 {
2920 fputs (" IOSTAT=", dumpfile);
2921 show_expr (close->iostat);
2922 }
2923 if (close->status)
2924 {
2925 fputs (" STATUS=", dumpfile);
2926 show_expr (close->status);
2927 }
2928 if (close->err != NULL)
2929 fprintf (dumpfile, " ERR=%d", close->err->value);
2930 break;
2931
2932 case EXEC_BACKSPACE:
2933 fputs ("BACKSPACE", dumpfile);
2934 goto show_filepos;
2935
2936 case EXEC_ENDFILE:
2937 fputs ("ENDFILE", dumpfile);
2938 goto show_filepos;
2939
2940 case EXEC_REWIND:
2941 fputs ("REWIND", dumpfile);
2942 goto show_filepos;
2943
2944 case EXEC_FLUSH:
2945 fputs ("FLUSH", dumpfile);
2946
2947 show_filepos:
2948 fp = c->ext.filepos;
2949
2950 if (fp->unit)
2951 {
2952 fputs (" UNIT=", dumpfile);
2953 show_expr (fp->unit);
2954 }
2955 if (fp->iomsg)
2956 {
2957 fputs (" IOMSG=", dumpfile);
2958 show_expr (fp->iomsg);
2959 }
2960 if (fp->iostat)
2961 {
2962 fputs (" IOSTAT=", dumpfile);
2963 show_expr (fp->iostat);
2964 }
2965 if (fp->err != NULL)
2966 fprintf (dumpfile, " ERR=%d", fp->err->value);
2967 break;
2968
2969 case EXEC_INQUIRE:
2970 fputs ("INQUIRE", dumpfile);
2971 i = c->ext.inquire;
2972
2973 if (i->unit)
2974 {
2975 fputs (" UNIT=", dumpfile);
2976 show_expr (i->unit);
2977 }
2978 if (i->file)
2979 {
2980 fputs (" FILE=", dumpfile);
2981 show_expr (i->file);
2982 }
2983
2984 if (i->iomsg)
2985 {
2986 fputs (" IOMSG=", dumpfile);
2987 show_expr (i->iomsg);
2988 }
2989 if (i->iostat)
2990 {
2991 fputs (" IOSTAT=", dumpfile);
2992 show_expr (i->iostat);
2993 }
2994 if (i->exist)
2995 {
2996 fputs (" EXIST=", dumpfile);
2997 show_expr (i->exist);
2998 }
2999 if (i->opened)
3000 {
3001 fputs (" OPENED=", dumpfile);
3002 show_expr (i->opened);
3003 }
3004 if (i->number)
3005 {
3006 fputs (" NUMBER=", dumpfile);
3007 show_expr (i->number);
3008 }
3009 if (i->named)
3010 {
3011 fputs (" NAMED=", dumpfile);
3012 show_expr (i->named);
3013 }
3014 if (i->name)
3015 {
3016 fputs (" NAME=", dumpfile);
3017 show_expr (i->name);
3018 }
3019 if (i->access)
3020 {
3021 fputs (" ACCESS=", dumpfile);
3022 show_expr (i->access);
3023 }
3024 if (i->sequential)
3025 {
3026 fputs (" SEQUENTIAL=", dumpfile);
3027 show_expr (i->sequential);
3028 }
3029
3030 if (i->direct)
3031 {
3032 fputs (" DIRECT=", dumpfile);
3033 show_expr (i->direct);
3034 }
3035 if (i->form)
3036 {
3037 fputs (" FORM=", dumpfile);
3038 show_expr (i->form);
3039 }
3040 if (i->formatted)
3041 {
3042 fputs (" FORMATTED", dumpfile);
3043 show_expr (i->formatted);
3044 }
3045 if (i->unformatted)
3046 {
3047 fputs (" UNFORMATTED=", dumpfile);
3048 show_expr (i->unformatted);
3049 }
3050 if (i->recl)
3051 {
3052 fputs (" RECL=", dumpfile);
3053 show_expr (i->recl);
3054 }
3055 if (i->nextrec)
3056 {
3057 fputs (" NEXTREC=", dumpfile);
3058 show_expr (i->nextrec);
3059 }
3060 if (i->blank)
3061 {
3062 fputs (" BLANK=", dumpfile);
3063 show_expr (i->blank);
3064 }
3065 if (i->position)
3066 {
3067 fputs (" POSITION=", dumpfile);
3068 show_expr (i->position);
3069 }
3070 if (i->action)
3071 {
3072 fputs (" ACTION=", dumpfile);
3073 show_expr (i->action);
3074 }
3075 if (i->read)
3076 {
3077 fputs (" READ=", dumpfile);
3078 show_expr (i->read);
3079 }
3080 if (i->write)
3081 {
3082 fputs (" WRITE=", dumpfile);
3083 show_expr (i->write);
3084 }
3085 if (i->readwrite)
3086 {
3087 fputs (" READWRITE=", dumpfile);
3088 show_expr (i->readwrite);
3089 }
3090 if (i->delim)
3091 {
3092 fputs (" DELIM=", dumpfile);
3093 show_expr (i->delim);
3094 }
3095 if (i->pad)
3096 {
3097 fputs (" PAD=", dumpfile);
3098 show_expr (i->pad);
3099 }
3100 if (i->convert)
3101 {
3102 fputs (" CONVERT=", dumpfile);
3103 show_expr (i->convert);
3104 }
3105 if (i->asynchronous)
3106 {
3107 fputs (" ASYNCHRONOUS=", dumpfile);
3108 show_expr (i->asynchronous);
3109 }
3110 if (i->decimal)
3111 {
3112 fputs (" DECIMAL=", dumpfile);
3113 show_expr (i->decimal);
3114 }
3115 if (i->encoding)
3116 {
3117 fputs (" ENCODING=", dumpfile);
3118 show_expr (i->encoding);
3119 }
3120 if (i->pending)
3121 {
3122 fputs (" PENDING=", dumpfile);
3123 show_expr (i->pending);
3124 }
3125 if (i->round)
3126 {
3127 fputs (" ROUND=", dumpfile);
3128 show_expr (i->round);
3129 }
3130 if (i->sign)
3131 {
3132 fputs (" SIGN=", dumpfile);
3133 show_expr (i->sign);
3134 }
3135 if (i->size)
3136 {
3137 fputs (" SIZE=", dumpfile);
3138 show_expr (i->size);
3139 }
3140 if (i->id)
3141 {
3142 fputs (" ID=", dumpfile);
3143 show_expr (i->id);
3144 }
3145
3146 if (i->err != NULL)
3147 fprintf (dumpfile, " ERR=%d", i->err->value);
3148 break;
3149
3150 case EXEC_IOLENGTH:
3151 fputs ("IOLENGTH ", dumpfile);
3152 show_expr (c->expr1);
3153 goto show_dt_code;
3154 break;
3155
3156 case EXEC_READ:
3157 fputs ("READ", dumpfile);
3158 goto show_dt;
3159
3160 case EXEC_WRITE:
3161 fputs ("WRITE", dumpfile);
3162
3163 show_dt:
3164 dt = c->ext.dt;
3165 if (dt->io_unit)
3166 {
3167 fputs (" UNIT=", dumpfile);
3168 show_expr (dt->io_unit);
3169 }
3170
3171 if (dt->format_expr)
3172 {
3173 fputs (" FMT=", dumpfile);
3174 show_expr (dt->format_expr);
3175 }
3176
3177 if (dt->format_label != NULL)
3178 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
3179 if (dt->namelist)
3180 fprintf (dumpfile, " NML=%s", dt->namelist->name);
3181
3182 if (dt->iomsg)
3183 {
3184 fputs (" IOMSG=", dumpfile);
3185 show_expr (dt->iomsg);
3186 }
3187 if (dt->iostat)
3188 {
3189 fputs (" IOSTAT=", dumpfile);
3190 show_expr (dt->iostat);
3191 }
3192 if (dt->size)
3193 {
3194 fputs (" SIZE=", dumpfile);
3195 show_expr (dt->size);
3196 }
3197 if (dt->rec)
3198 {
3199 fputs (" REC=", dumpfile);
3200 show_expr (dt->rec);
3201 }
3202 if (dt->advance)
3203 {
3204 fputs (" ADVANCE=", dumpfile);
3205 show_expr (dt->advance);
3206 }
3207 if (dt->id)
3208 {
3209 fputs (" ID=", dumpfile);
3210 show_expr (dt->id);
3211 }
3212 if (dt->pos)
3213 {
3214 fputs (" POS=", dumpfile);
3215 show_expr (dt->pos);
3216 }
3217 if (dt->asynchronous)
3218 {
3219 fputs (" ASYNCHRONOUS=", dumpfile);
3220 show_expr (dt->asynchronous);
3221 }
3222 if (dt->blank)
3223 {
3224 fputs (" BLANK=", dumpfile);
3225 show_expr (dt->blank);
3226 }
3227 if (dt->decimal)
3228 {
3229 fputs (" DECIMAL=", dumpfile);
3230 show_expr (dt->decimal);
3231 }
3232 if (dt->delim)
3233 {
3234 fputs (" DELIM=", dumpfile);
3235 show_expr (dt->delim);
3236 }
3237 if (dt->pad)
3238 {
3239 fputs (" PAD=", dumpfile);
3240 show_expr (dt->pad);
3241 }
3242 if (dt->round)
3243 {
3244 fputs (" ROUND=", dumpfile);
3245 show_expr (dt->round);
3246 }
3247 if (dt->sign)
3248 {
3249 fputs (" SIGN=", dumpfile);
3250 show_expr (dt->sign);
3251 }
3252
3253 show_dt_code:
3254 for (c = c->block->next; c; c = c->next)
3255 show_code_node (level + (c->next != NULL), c);
3256 return;
3257
3258 case EXEC_TRANSFER:
3259 fputs ("TRANSFER ", dumpfile);
3260 show_expr (c->expr1);
3261 break;
3262
3263 case EXEC_DT_END:
3264 fputs ("DT_END", dumpfile);
3265 dt = c->ext.dt;
3266
3267 if (dt->err != NULL)
3268 fprintf (dumpfile, " ERR=%d", dt->err->value);
3269 if (dt->end != NULL)
3270 fprintf (dumpfile, " END=%d", dt->end->value);
3271 if (dt->eor != NULL)
3272 fprintf (dumpfile, " EOR=%d", dt->eor->value);
3273 break;
3274
3275 case EXEC_WAIT:
3276 fputs ("WAIT", dumpfile);
3277
3278 if (c->ext.wait != NULL)
3279 {
3280 gfc_wait *wait = c->ext.wait;
3281 if (wait->unit)
3282 {
3283 fputs (" UNIT=", dumpfile);
3284 show_expr (wait->unit);
3285 }
3286 if (wait->iostat)
3287 {
3288 fputs (" IOSTAT=", dumpfile);
3289 show_expr (wait->iostat);
3290 }
3291 if (wait->iomsg)
3292 {
3293 fputs (" IOMSG=", dumpfile);
3294 show_expr (wait->iomsg);
3295 }
3296 if (wait->id)
3297 {
3298 fputs (" ID=", dumpfile);
3299 show_expr (wait->id);
3300 }
3301 if (wait->err)
3302 fprintf (dumpfile, " ERR=%d", wait->err->value);
3303 if (wait->end)
3304 fprintf (dumpfile, " END=%d", wait->end->value);
3305 if (wait->eor)
3306 fprintf (dumpfile, " EOR=%d", wait->eor->value);
3307 }
3308 break;
3309
3310 case EXEC_OACC_PARALLEL_LOOP:
3311 case EXEC_OACC_PARALLEL:
3312 case EXEC_OACC_KERNELS_LOOP:
3313 case EXEC_OACC_KERNELS:
3314 case EXEC_OACC_SERIAL_LOOP:
3315 case EXEC_OACC_SERIAL:
3316 case EXEC_OACC_DATA:
3317 case EXEC_OACC_HOST_DATA:
3318 case EXEC_OACC_LOOP:
3319 case EXEC_OACC_UPDATE:
3320 case EXEC_OACC_WAIT:
3321 case EXEC_OACC_CACHE:
3322 case EXEC_OACC_ENTER_DATA:
3323 case EXEC_OACC_EXIT_DATA:
3324 case EXEC_OMP_ATOMIC:
3325 case EXEC_OMP_CANCEL:
3326 case EXEC_OMP_CANCELLATION_POINT:
3327 case EXEC_OMP_BARRIER:
3328 case EXEC_OMP_CRITICAL:
3329 case EXEC_OMP_DEPOBJ:
3330 case EXEC_OMP_DISTRIBUTE:
3331 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3332 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3333 case EXEC_OMP_DISTRIBUTE_SIMD:
3334 case EXEC_OMP_DO:
3335 case EXEC_OMP_DO_SIMD:
3336 case EXEC_OMP_ERROR:
3337 case EXEC_OMP_FLUSH:
3338 case EXEC_OMP_LOOP:
3339 case EXEC_OMP_MASKED:
3340 case EXEC_OMP_MASKED_TASKLOOP:
3341 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
3342 case EXEC_OMP_MASTER:
3343 case EXEC_OMP_MASTER_TASKLOOP:
3344 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
3345 case EXEC_OMP_ORDERED:
3346 case EXEC_OMP_PARALLEL:
3347 case EXEC_OMP_PARALLEL_DO:
3348 case EXEC_OMP_PARALLEL_DO_SIMD:
3349 case EXEC_OMP_PARALLEL_LOOP:
3350 case EXEC_OMP_PARALLEL_MASKED:
3351 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
3352 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
3353 case EXEC_OMP_PARALLEL_MASTER:
3354 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
3355 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
3356 case EXEC_OMP_PARALLEL_SECTIONS:
3357 case EXEC_OMP_PARALLEL_WORKSHARE:
3358 case EXEC_OMP_SCAN:
3359 case EXEC_OMP_SCOPE:
3360 case EXEC_OMP_SECTIONS:
3361 case EXEC_OMP_SIMD:
3362 case EXEC_OMP_SINGLE:
3363 case EXEC_OMP_TARGET:
3364 case EXEC_OMP_TARGET_DATA:
3365 case EXEC_OMP_TARGET_ENTER_DATA:
3366 case EXEC_OMP_TARGET_EXIT_DATA:
3367 case EXEC_OMP_TARGET_PARALLEL:
3368 case EXEC_OMP_TARGET_PARALLEL_DO:
3369 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
3370 case EXEC_OMP_TARGET_PARALLEL_LOOP:
3371 case EXEC_OMP_TARGET_SIMD:
3372 case EXEC_OMP_TARGET_TEAMS:
3373 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3374 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3375 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3376 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3377 case EXEC_OMP_TARGET_TEAMS_LOOP:
3378 case EXEC_OMP_TARGET_UPDATE:
3379 case EXEC_OMP_TASK:
3380 case EXEC_OMP_TASKGROUP:
3381 case EXEC_OMP_TASKLOOP:
3382 case EXEC_OMP_TASKLOOP_SIMD:
3383 case EXEC_OMP_TASKWAIT:
3384 case EXEC_OMP_TASKYIELD:
3385 case EXEC_OMP_TEAMS:
3386 case EXEC_OMP_TEAMS_DISTRIBUTE:
3387 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3388 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3389 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3390 case EXEC_OMP_TEAMS_LOOP:
3391 case EXEC_OMP_WORKSHARE:
3392 show_omp_node (level, c);
3393 break;
3394
3395 default:
3396 gfc_internal_error ("show_code_node(): Bad statement code");
3397 }
3398 }
3399
3400
3401 /* Show an equivalence chain. */
3402
3403 static void
show_equiv(gfc_equiv * eq)3404 show_equiv (gfc_equiv *eq)
3405 {
3406 show_indent ();
3407 fputs ("Equivalence: ", dumpfile);
3408 while (eq)
3409 {
3410 show_expr (eq->expr);
3411 eq = eq->eq;
3412 if (eq)
3413 fputs (", ", dumpfile);
3414 }
3415 }
3416
3417
3418 /* Show a freakin' whole namespace. */
3419
3420 static void
show_namespace(gfc_namespace * ns)3421 show_namespace (gfc_namespace *ns)
3422 {
3423 gfc_interface *intr;
3424 gfc_namespace *save;
3425 int op;
3426 gfc_equiv *eq;
3427 int i;
3428
3429 gcc_assert (ns);
3430 save = gfc_current_ns;
3431
3432 show_indent ();
3433 fputs ("Namespace:", dumpfile);
3434
3435 i = 0;
3436 do
3437 {
3438 int l = i;
3439 while (i < GFC_LETTERS - 1
3440 && gfc_compare_types (&ns->default_type[i+1],
3441 &ns->default_type[l]))
3442 i++;
3443
3444 if (i > l)
3445 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
3446 else
3447 fprintf (dumpfile, " %c: ", l+'A');
3448
3449 show_typespec(&ns->default_type[l]);
3450 i++;
3451 } while (i < GFC_LETTERS);
3452
3453 if (ns->proc_name != NULL)
3454 {
3455 show_indent ();
3456 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
3457 }
3458
3459 ++show_level;
3460 gfc_current_ns = ns;
3461 gfc_traverse_symtree (ns->common_root, show_common);
3462
3463 gfc_traverse_symtree (ns->sym_root, show_symtree);
3464
3465 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
3466 {
3467 /* User operator interfaces */
3468 intr = ns->op[op];
3469 if (intr == NULL)
3470 continue;
3471
3472 show_indent ();
3473 fprintf (dumpfile, "Operator interfaces for %s:",
3474 gfc_op2string ((gfc_intrinsic_op) op));
3475
3476 for (; intr; intr = intr->next)
3477 fprintf (dumpfile, " %s", intr->sym->name);
3478 }
3479
3480 if (ns->uop_root != NULL)
3481 {
3482 show_indent ();
3483 fputs ("User operators:\n", dumpfile);
3484 gfc_traverse_user_op (ns, show_uop);
3485 }
3486
3487 for (eq = ns->equiv; eq; eq = eq->next)
3488 show_equiv (eq);
3489
3490 if (ns->oacc_declare)
3491 {
3492 struct gfc_oacc_declare *decl;
3493 /* Dump !$ACC DECLARE clauses. */
3494 for (decl = ns->oacc_declare; decl; decl = decl->next)
3495 {
3496 show_indent ();
3497 fprintf (dumpfile, "!$ACC DECLARE");
3498 show_omp_clauses (decl->clauses);
3499 }
3500 }
3501
3502 fputc ('\n', dumpfile);
3503 show_indent ();
3504 fputs ("code:", dumpfile);
3505 show_code (show_level, ns->code);
3506 --show_level;
3507
3508 for (ns = ns->contained; ns; ns = ns->sibling)
3509 {
3510 fputs ("\nCONTAINS\n", dumpfile);
3511 ++show_level;
3512 show_namespace (ns);
3513 --show_level;
3514 }
3515
3516 fputc ('\n', dumpfile);
3517 gfc_current_ns = save;
3518 }
3519
3520
3521 /* Main function for dumping a parse tree. */
3522
3523 void
gfc_dump_parse_tree(gfc_namespace * ns,FILE * file)3524 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
3525 {
3526 dumpfile = file;
3527 show_namespace (ns);
3528 }
3529
3530 /* This part writes BIND(C) definition for use in external C programs. */
3531
3532 static void write_interop_decl (gfc_symbol *);
3533 static void write_proc (gfc_symbol *, bool);
3534
3535 void
gfc_dump_c_prototypes(gfc_namespace * ns,FILE * file)3536 gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file)
3537 {
3538 int error_count;
3539 gfc_get_errors (NULL, &error_count);
3540 if (error_count != 0)
3541 return;
3542 dumpfile = file;
3543 gfc_traverse_ns (ns, write_interop_decl);
3544 }
3545
3546 /* Loop over all global symbols, writing out their declarations. */
3547
3548 void
gfc_dump_external_c_prototypes(FILE * file)3549 gfc_dump_external_c_prototypes (FILE * file)
3550 {
3551 dumpfile = file;
3552 fprintf (dumpfile,
3553 _("/* Prototypes for external procedures generated from %s\n"
3554 " by GNU Fortran %s%s.\n\n"
3555 " Use of this interface is discouraged, consider using the\n"
3556 " BIND(C) feature of standard Fortran instead. */\n\n"),
3557 gfc_source_file, pkgversion_string, version_string);
3558
3559 for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
3560 gfc_current_ns = gfc_current_ns->sibling)
3561 {
3562 gfc_symbol *sym = gfc_current_ns->proc_name;
3563
3564 if (sym == NULL || sym->attr.flavor != FL_PROCEDURE
3565 || sym->attr.is_bind_c)
3566 continue;
3567
3568 write_proc (sym, false);
3569 }
3570 return;
3571 }
3572
3573 enum type_return { T_OK=0, T_WARN, T_ERROR };
3574
3575 /* Return the name of the type for later output. Both function pointers and
3576 void pointers will be mapped to void *. */
3577
3578 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)3579 get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
3580 const char **type_name, bool *asterisk, const char **post,
3581 bool func_ret)
3582 {
3583 static char post_buffer[40];
3584 enum type_return ret;
3585 ret = T_ERROR;
3586
3587 *pre = " ";
3588 *asterisk = false;
3589 *post = "";
3590 *type_name = "<error>";
3591 if (ts->type == BT_REAL || ts->type == BT_INTEGER || ts->type == BT_COMPLEX)
3592 {
3593 if (ts->is_c_interop && ts->interop_kind)
3594 ret = T_OK;
3595 else
3596 ret = T_WARN;
3597
3598 for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3599 {
3600 if (c_interop_kinds_table[i].f90_type == ts->type
3601 && c_interop_kinds_table[i].value == ts->kind)
3602 {
3603 /* Skip over 'c_'. */
3604 *type_name = c_interop_kinds_table[i].name + 2;
3605 if (strcmp (*type_name, "long_long") == 0)
3606 *type_name = "long long";
3607 if (strcmp (*type_name, "long_double") == 0)
3608 *type_name = "long double";
3609 if (strcmp (*type_name, "signed_char") == 0)
3610 *type_name = "signed char";
3611 else if (strcmp (*type_name, "size_t") == 0)
3612 *type_name = "ssize_t";
3613 else if (strcmp (*type_name, "float_complex") == 0)
3614 *type_name = "__GFORTRAN_FLOAT_COMPLEX";
3615 else if (strcmp (*type_name, "double_complex") == 0)
3616 *type_name = "__GFORTRAN_DOUBLE_COMPLEX";
3617 else if (strcmp (*type_name, "long_double_complex") == 0)
3618 *type_name = "__GFORTRAN_LONG_DOUBLE_COMPLEX";
3619
3620 break;
3621 }
3622 }
3623 }
3624 else if (ts->type == BT_LOGICAL)
3625 {
3626 if (ts->is_c_interop && ts->interop_kind)
3627 {
3628 *type_name = "_Bool";
3629 ret = T_OK;
3630 }
3631 else
3632 {
3633 /* Let's select an appropriate int, with a warning. */
3634 for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3635 {
3636 if (c_interop_kinds_table[i].f90_type == BT_INTEGER
3637 && c_interop_kinds_table[i].value == ts->kind)
3638 {
3639 *type_name = c_interop_kinds_table[i].name + 2;
3640 ret = T_WARN;
3641 }
3642 }
3643 }
3644 }
3645 else if (ts->type == BT_CHARACTER)
3646 {
3647 if (ts->is_c_interop)
3648 {
3649 *type_name = "char";
3650 ret = T_OK;
3651 }
3652 else
3653 {
3654 if (ts->kind == gfc_default_character_kind)
3655 *type_name = "char";
3656 else
3657 /* Let's select an appropriate int. */
3658 for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3659 {
3660 if (c_interop_kinds_table[i].f90_type == BT_INTEGER
3661 && c_interop_kinds_table[i].value == ts->kind)
3662 {
3663 *type_name = c_interop_kinds_table[i].name + 2;
3664 break;
3665 }
3666 }
3667 ret = T_WARN;
3668
3669 }
3670 }
3671 else if (ts->type == BT_DERIVED)
3672 {
3673 if (ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
3674 {
3675 if (strcmp (ts->u.derived->name, "c_ptr") == 0)
3676 *type_name = "void";
3677 else if (strcmp (ts->u.derived->name, "c_funptr") == 0)
3678 {
3679 *type_name = "int ";
3680 if (func_ret)
3681 {
3682 *pre = "(";
3683 *post = "())";
3684 }
3685 else
3686 {
3687 *pre = "(";
3688 *post = ")()";
3689 }
3690 }
3691 *asterisk = true;
3692 ret = T_OK;
3693 }
3694 else
3695 *type_name = ts->u.derived->name;
3696
3697 ret = T_OK;
3698 }
3699
3700 if (ret != T_ERROR && as)
3701 {
3702 mpz_t sz;
3703 bool size_ok;
3704 size_ok = spec_size (as, &sz);
3705 gcc_assert (size_ok == true);
3706 gmp_snprintf (post_buffer, sizeof(post_buffer), "[%Zd]", sz);
3707 *post = post_buffer;
3708 mpz_clear (sz);
3709 }
3710 return ret;
3711 }
3712
3713 /* Write out a declaration. */
3714 static void
write_decl(gfc_typespec * ts,gfc_array_spec * as,const char * sym_name,bool func_ret,locus * where,bool bind_c)3715 write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
3716 bool func_ret, locus *where, bool bind_c)
3717 {
3718 const char *pre, *type_name, *post;
3719 bool asterisk;
3720 enum type_return rok;
3721
3722 rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret);
3723 if (rok == T_ERROR)
3724 {
3725 gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3726 gfc_typename (ts), where);
3727 fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */",
3728 gfc_typename (ts));
3729 return;
3730 }
3731 fputs (type_name, dumpfile);
3732 fputs (pre, dumpfile);
3733 if (asterisk)
3734 fputs ("*", dumpfile);
3735
3736 fputs (sym_name, dumpfile);
3737 fputs (post, dumpfile);
3738
3739 if (rok == T_WARN && bind_c)
3740 fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
3741 gfc_typename (ts));
3742 }
3743
3744 /* Write out an interoperable type. It will be written as a typedef
3745 for a struct. */
3746
3747 static void
write_type(gfc_symbol * sym)3748 write_type (gfc_symbol *sym)
3749 {
3750 gfc_component *c;
3751
3752 fprintf (dumpfile, "typedef struct %s {\n", sym->name);
3753 for (c = sym->components; c; c = c->next)
3754 {
3755 fputs (" ", dumpfile);
3756 write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at, true);
3757 fputs (";\n", dumpfile);
3758 }
3759
3760 fprintf (dumpfile, "} %s;\n", sym->name);
3761 }
3762
3763 /* Write out a variable. */
3764
3765 static void
write_variable(gfc_symbol * sym)3766 write_variable (gfc_symbol *sym)
3767 {
3768 const char *sym_name;
3769
3770 gcc_assert (sym->attr.flavor == FL_VARIABLE);
3771
3772 if (sym->binding_label)
3773 sym_name = sym->binding_label;
3774 else
3775 sym_name = sym->name;
3776
3777 fputs ("extern ", dumpfile);
3778 write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at, true);
3779 fputs (";\n", dumpfile);
3780 }
3781
3782
3783 /* Write out a procedure, including its arguments. */
3784 static void
write_proc(gfc_symbol * sym,bool bind_c)3785 write_proc (gfc_symbol *sym, bool bind_c)
3786 {
3787 const char *pre, *type_name, *post;
3788 bool asterisk;
3789 enum type_return rok;
3790 gfc_formal_arglist *f;
3791 const char *sym_name;
3792 const char *intent_in;
3793 bool external_character;
3794
3795 external_character = sym->ts.type == BT_CHARACTER && !bind_c;
3796
3797 if (sym->binding_label)
3798 sym_name = sym->binding_label;
3799 else
3800 sym_name = sym->name;
3801
3802 if (sym->ts.type == BT_UNKNOWN || external_character)
3803 {
3804 fprintf (dumpfile, "void ");
3805 fputs (sym_name, dumpfile);
3806 }
3807 else
3808 write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at, bind_c);
3809
3810 if (!bind_c)
3811 fputs ("_", dumpfile);
3812
3813 fputs (" (", dumpfile);
3814 if (external_character)
3815 {
3816 fprintf (dumpfile, "char *result_%s, size_t result_%s_len",
3817 sym_name, sym_name);
3818 if (sym->formal)
3819 fputs (", ", dumpfile);
3820 }
3821
3822 for (f = sym->formal; f; f = f->next)
3823 {
3824 gfc_symbol *s;
3825 s = f->sym;
3826 rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk,
3827 &post, false);
3828 if (rok == T_ERROR)
3829 {
3830 gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3831 gfc_typename (&s->ts), &s->declared_at);
3832 fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */",
3833 gfc_typename (&s->ts));
3834 return;
3835 }
3836
3837 if (!s->attr.value)
3838 asterisk = true;
3839
3840 if (s->attr.intent == INTENT_IN && !s->attr.value)
3841 intent_in = "const ";
3842 else
3843 intent_in = "";
3844
3845 fputs (intent_in, dumpfile);
3846 fputs (type_name, dumpfile);
3847 fputs (pre, dumpfile);
3848 if (asterisk)
3849 fputs ("*", dumpfile);
3850
3851 fputs (s->name, dumpfile);
3852 fputs (post, dumpfile);
3853 if (bind_c && rok == T_WARN)
3854 fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile);
3855
3856 if (f->next)
3857 fputs(", ", dumpfile);
3858 }
3859 if (!bind_c)
3860 for (f = sym->formal; f; f = f->next)
3861 if (f->sym->ts.type == BT_CHARACTER)
3862 fprintf (dumpfile, ", size_t %s_len", f->sym->name);
3863
3864 fputs (");\n", dumpfile);
3865 }
3866
3867
3868 /* Write a C-interoperable declaration as a C prototype or extern
3869 declaration. */
3870
3871 static void
write_interop_decl(gfc_symbol * sym)3872 write_interop_decl (gfc_symbol *sym)
3873 {
3874 /* Only dump bind(c) entities. */
3875 if (!sym->attr.is_bind_c)
3876 return;
3877
3878 /* Don't dump our iso c module. */
3879 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
3880 return;
3881
3882 if (sym->attr.flavor == FL_VARIABLE)
3883 write_variable (sym);
3884 else if (sym->attr.flavor == FL_DERIVED)
3885 write_type (sym);
3886 else if (sym->attr.flavor == FL_PROCEDURE)
3887 write_proc (sym, true);
3888 }
3889
3890 /* This section deals with dumping the global symbol tree. */
3891
3892 /* Callback function for printing out the contents of the tree. */
3893
3894 static void
show_global_symbol(gfc_gsymbol * gsym,void * f_data)3895 show_global_symbol (gfc_gsymbol *gsym, void *f_data)
3896 {
3897 FILE *out;
3898 out = (FILE *) f_data;
3899
3900 if (gsym->name)
3901 fprintf (out, "name=%s", gsym->name);
3902
3903 if (gsym->sym_name)
3904 fprintf (out, ", sym_name=%s", gsym->sym_name);
3905
3906 if (gsym->mod_name)
3907 fprintf (out, ", mod_name=%s", gsym->mod_name);
3908
3909 if (gsym->binding_label)
3910 fprintf (out, ", binding_label=%s", gsym->binding_label);
3911
3912 fputc ('\n', out);
3913 }
3914
3915 /* Show all global symbols. */
3916
3917 void
gfc_dump_global_symbols(FILE * f)3918 gfc_dump_global_symbols (FILE *f)
3919 {
3920 if (gfc_gsym_root == NULL)
3921 fprintf (f, "empty\n");
3922 else
3923 gfc_traverse_gsymbol (gfc_gsym_root, show_global_symbol, (void *) f);
3924 }
3925
3926 /* Show an array ref. */
3927
debug(gfc_array_ref * ar)3928 void debug (gfc_array_ref *ar)
3929 {
3930 FILE *tmp = dumpfile;
3931 dumpfile = stderr;
3932 show_array_ref (ar);
3933 fputc ('\n', dumpfile);
3934 dumpfile = tmp;
3935 }
3936