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