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