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