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