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