?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2017-09-26 Thomas Koenig <tkoenig@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / dump-parse-tree.c
bloba9107c15e59b67bfc452e12b83c6b99d15d0be21
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 --show_level;
973 }
974
975
976 /* Show a user-defined operator. Just prints an operator
977 and the name of the associated subroutine, really. */
978
979 static void
980 show_uop (gfc_user_op *uop)
981 {
982 gfc_interface *intr;
983
984 show_indent ();
985 fprintf (dumpfile, "%s:", uop->name);
986
987 for (intr = uop->op; intr; intr = intr->next)
988 fprintf (dumpfile, " %s", intr->sym->name);
989 }
990
991
992 /* Workhorse function for traversing the user operator symtree. */
993
994 static void
995 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
996 {
997 if (st == NULL)
998 return;
999
1000 (*func) (st->n.uop);
1001
1002 traverse_uop (st->left, func);
1003 traverse_uop (st->right, func);
1004 }
1005
1006
1007 /* Traverse the tree of user operator nodes. */
1008
1009 void
1010 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
1011 {
1012 traverse_uop (ns->uop_root, func);
1013 }
1014
1015
1016 /* Function to display a common block. */
1017
1018 static void
1019 show_common (gfc_symtree *st)
1020 {
1021 gfc_symbol *s;
1022
1023 show_indent ();
1024 fprintf (dumpfile, "common: /%s/ ", st->name);
1025
1026 s = st->n.common->head;
1027 while (s)
1028 {
1029 fprintf (dumpfile, "%s", s->name);
1030 s = s->common_next;
1031 if (s)
1032 fputs (", ", dumpfile);
1033 }
1034 fputc ('\n', dumpfile);
1035 }
1036
1037
1038 /* Worker function to display the symbol tree. */
1039
1040 static void
1041 show_symtree (gfc_symtree *st)
1042 {
1043 int len, i;
1044
1045 show_indent ();
1046
1047 len = strlen(st->name);
1048 fprintf (dumpfile, "symtree: '%s'", st->name);
1049
1050 for (i=len; i<12; i++)
1051 fputc(' ', dumpfile);
1052
1053 if (st->ambiguous)
1054 fputs( " Ambiguous", dumpfile);
1055
1056 if (st->n.sym->ns != gfc_current_ns)
1057 fprintf (dumpfile, "|| symbol: '%s' from namespace '%s'", st->n.sym->name,
1058 st->n.sym->ns->proc_name->name);
1059 else
1060 show_symbol (st->n.sym);
1061 }
1062
1063
1064 /******************* Show gfc_code structures **************/
1065
1066
1067 /* Show a list of code structures. Mutually recursive with
1068 show_code_node(). */
1069
1070 static void
1071 show_code (int level, gfc_code *c)
1072 {
1073 for (; c; c = c->next)
1074 show_code_node (level, c);
1075 }
1076
1077 static void
1078 show_omp_namelist (int list_type, gfc_omp_namelist *n)
1079 {
1080 for (; n; n = n->next)
1081 {
1082 if (list_type == OMP_LIST_REDUCTION)
1083 switch (n->u.reduction_op)
1084 {
1085 case OMP_REDUCTION_PLUS:
1086 case OMP_REDUCTION_TIMES:
1087 case OMP_REDUCTION_MINUS:
1088 case OMP_REDUCTION_AND:
1089 case OMP_REDUCTION_OR:
1090 case OMP_REDUCTION_EQV:
1091 case OMP_REDUCTION_NEQV:
1092 fprintf (dumpfile, "%s:",
1093 gfc_op2string ((gfc_intrinsic_op) n->u.reduction_op));
1094 break;
1095 case OMP_REDUCTION_MAX: fputs ("max:", dumpfile); break;
1096 case OMP_REDUCTION_MIN: fputs ("min:", dumpfile); break;
1097 case OMP_REDUCTION_IAND: fputs ("iand:", dumpfile); break;
1098 case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break;
1099 case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break;
1100 case OMP_REDUCTION_USER:
1101 if (n->udr)
1102 fprintf (dumpfile, "%s:", n->udr->udr->name);
1103 break;
1104 default: break;
1105 }
1106 else if (list_type == OMP_LIST_DEPEND)
1107 switch (n->u.depend_op)
1108 {
1109 case OMP_DEPEND_IN: fputs ("in:", dumpfile); break;
1110 case OMP_DEPEND_OUT: fputs ("out:", dumpfile); break;
1111 case OMP_DEPEND_INOUT: fputs ("inout:", dumpfile); break;
1112 case OMP_DEPEND_SINK_FIRST:
1113 fputs ("sink:", dumpfile);
1114 while (1)
1115 {
1116 fprintf (dumpfile, "%s", n->sym->name);
1117 if (n->expr)
1118 {
1119 fputc ('+', dumpfile);
1120 show_expr (n->expr);
1121 }
1122 if (n->next == NULL)
1123 break;
1124 else if (n->next->u.depend_op != OMP_DEPEND_SINK)
1125 {
1126 fputs (") DEPEND(", dumpfile);
1127 break;
1128 }
1129 fputc (',', dumpfile);
1130 n = n->next;
1131 }
1132 continue;
1133 default: break;
1134 }
1135 else if (list_type == OMP_LIST_MAP)
1136 switch (n->u.map_op)
1137 {
1138 case OMP_MAP_ALLOC: fputs ("alloc:", dumpfile); break;
1139 case OMP_MAP_TO: fputs ("to:", dumpfile); break;
1140 case OMP_MAP_FROM: fputs ("from:", dumpfile); break;
1141 case OMP_MAP_TOFROM: fputs ("tofrom:", dumpfile); break;
1142 default: break;
1143 }
1144 else if (list_type == OMP_LIST_LINEAR)
1145 switch (n->u.linear_op)
1146 {
1147 case OMP_LINEAR_REF: fputs ("ref(", dumpfile); break;
1148 case OMP_LINEAR_VAL: fputs ("val(", dumpfile); break;
1149 case OMP_LINEAR_UVAL: fputs ("uval(", dumpfile); break;
1150 default: break;
1151 }
1152 fprintf (dumpfile, "%s", n->sym->name);
1153 if (list_type == OMP_LIST_LINEAR && n->u.linear_op != OMP_LINEAR_DEFAULT)
1154 fputc (')', dumpfile);
1155 if (n->expr)
1156 {
1157 fputc (':', dumpfile);
1158 show_expr (n->expr);
1159 }
1160 if (n->next)
1161 fputc (',', dumpfile);
1162 }
1163 }
1164
1165
1166 /* Show OpenMP or OpenACC clauses. */
1167
1168 static void
1169 show_omp_clauses (gfc_omp_clauses *omp_clauses)
1170 {
1171 int list_type, i;
1172
1173 switch (omp_clauses->cancel)
1174 {
1175 case OMP_CANCEL_UNKNOWN:
1176 break;
1177 case OMP_CANCEL_PARALLEL:
1178 fputs (" PARALLEL", dumpfile);
1179 break;
1180 case OMP_CANCEL_SECTIONS:
1181 fputs (" SECTIONS", dumpfile);
1182 break;
1183 case OMP_CANCEL_DO:
1184 fputs (" DO", dumpfile);
1185 break;
1186 case OMP_CANCEL_TASKGROUP:
1187 fputs (" TASKGROUP", dumpfile);
1188 break;
1189 }
1190 if (omp_clauses->if_expr)
1191 {
1192 fputs (" IF(", dumpfile);
1193 show_expr (omp_clauses->if_expr);
1194 fputc (')', dumpfile);
1195 }
1196 if (omp_clauses->final_expr)
1197 {
1198 fputs (" FINAL(", dumpfile);
1199 show_expr (omp_clauses->final_expr);
1200 fputc (')', dumpfile);
1201 }
1202 if (omp_clauses->num_threads)
1203 {
1204 fputs (" NUM_THREADS(", dumpfile);
1205 show_expr (omp_clauses->num_threads);
1206 fputc (')', dumpfile);
1207 }
1208 if (omp_clauses->async)
1209 {
1210 fputs (" ASYNC", dumpfile);
1211 if (omp_clauses->async_expr)
1212 {
1213 fputc ('(', dumpfile);
1214 show_expr (omp_clauses->async_expr);
1215 fputc (')', dumpfile);
1216 }
1217 }
1218 if (omp_clauses->num_gangs_expr)
1219 {
1220 fputs (" NUM_GANGS(", dumpfile);
1221 show_expr (omp_clauses->num_gangs_expr);
1222 fputc (')', dumpfile);
1223 }
1224 if (omp_clauses->num_workers_expr)
1225 {
1226 fputs (" NUM_WORKERS(", dumpfile);
1227 show_expr (omp_clauses->num_workers_expr);
1228 fputc (')', dumpfile);
1229 }
1230 if (omp_clauses->vector_length_expr)
1231 {
1232 fputs (" VECTOR_LENGTH(", dumpfile);
1233 show_expr (omp_clauses->vector_length_expr);
1234 fputc (')', dumpfile);
1235 }
1236 if (omp_clauses->gang)
1237 {
1238 fputs (" GANG", dumpfile);
1239 if (omp_clauses->gang_num_expr || omp_clauses->gang_static_expr)
1240 {
1241 fputc ('(', dumpfile);
1242 if (omp_clauses->gang_num_expr)
1243 {
1244 fprintf (dumpfile, "num:");
1245 show_expr (omp_clauses->gang_num_expr);
1246 }
1247 if (omp_clauses->gang_num_expr && omp_clauses->gang_static)
1248 fputc (',', dumpfile);
1249 if (omp_clauses->gang_static)
1250 {
1251 fprintf (dumpfile, "static:");
1252 if (omp_clauses->gang_static_expr)
1253 show_expr (omp_clauses->gang_static_expr);
1254 else
1255 fputc ('*', dumpfile);
1256 }
1257 fputc (')', dumpfile);
1258 }
1259 }
1260 if (omp_clauses->worker)
1261 {
1262 fputs (" WORKER", dumpfile);
1263 if (omp_clauses->worker_expr)
1264 {
1265 fputc ('(', dumpfile);
1266 show_expr (omp_clauses->worker_expr);
1267 fputc (')', dumpfile);
1268 }
1269 }
1270 if (omp_clauses->vector)
1271 {
1272 fputs (" VECTOR", dumpfile);
1273 if (omp_clauses->vector_expr)
1274 {
1275 fputc ('(', dumpfile);
1276 show_expr (omp_clauses->vector_expr);
1277 fputc (')', dumpfile);
1278 }
1279 }
1280 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1281 {
1282 const char *type;
1283 switch (omp_clauses->sched_kind)
1284 {
1285 case OMP_SCHED_STATIC: type = "STATIC"; break;
1286 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1287 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1288 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1289 case OMP_SCHED_AUTO: type = "AUTO"; break;
1290 default:
1291 gcc_unreachable ();
1292 }
1293 fputs (" SCHEDULE (", dumpfile);
1294 if (omp_clauses->sched_simd)
1295 {
1296 if (omp_clauses->sched_monotonic
1297 || omp_clauses->sched_nonmonotonic)
1298 fputs ("SIMD, ", dumpfile);
1299 else
1300 fputs ("SIMD: ", dumpfile);
1301 }
1302 if (omp_clauses->sched_monotonic)
1303 fputs ("MONOTONIC: ", dumpfile);
1304 else if (omp_clauses->sched_nonmonotonic)
1305 fputs ("NONMONOTONIC: ", dumpfile);
1306 fputs (type, dumpfile);
1307 if (omp_clauses->chunk_size)
1308 {
1309 fputc (',', dumpfile);
1310 show_expr (omp_clauses->chunk_size);
1311 }
1312 fputc (')', dumpfile);
1313 }
1314 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1315 {
1316 const char *type;
1317 switch (omp_clauses->default_sharing)
1318 {
1319 case OMP_DEFAULT_NONE: type = "NONE"; break;
1320 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1321 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1322 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1323 case OMP_DEFAULT_PRESENT: type = "PRESENT"; break;
1324 default:
1325 gcc_unreachable ();
1326 }
1327 fprintf (dumpfile, " DEFAULT(%s)", type);
1328 }
1329 if (omp_clauses->tile_list)
1330 {
1331 gfc_expr_list *list;
1332 fputs (" TILE(", dumpfile);
1333 for (list = omp_clauses->tile_list; list; list = list->next)
1334 {
1335 show_expr (list->expr);
1336 if (list->next)
1337 fputs (", ", dumpfile);
1338 }
1339 fputc (')', dumpfile);
1340 }
1341 if (omp_clauses->wait_list)
1342 {
1343 gfc_expr_list *list;
1344 fputs (" WAIT(", dumpfile);
1345 for (list = omp_clauses->wait_list; list; list = list->next)
1346 {
1347 show_expr (list->expr);
1348 if (list->next)
1349 fputs (", ", dumpfile);
1350 }
1351 fputc (')', dumpfile);
1352 }
1353 if (omp_clauses->seq)
1354 fputs (" SEQ", dumpfile);
1355 if (omp_clauses->independent)
1356 fputs (" INDEPENDENT", dumpfile);
1357 if (omp_clauses->ordered)
1358 {
1359 if (omp_clauses->orderedc)
1360 fprintf (dumpfile, " ORDERED(%d)", omp_clauses->orderedc);
1361 else
1362 fputs (" ORDERED", dumpfile);
1363 }
1364 if (omp_clauses->untied)
1365 fputs (" UNTIED", dumpfile);
1366 if (omp_clauses->mergeable)
1367 fputs (" MERGEABLE", dumpfile);
1368 if (omp_clauses->collapse)
1369 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1370 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1371 if (omp_clauses->lists[list_type] != NULL
1372 && list_type != OMP_LIST_COPYPRIVATE)
1373 {
1374 const char *type = NULL;
1375 switch (list_type)
1376 {
1377 case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break;
1378 case OMP_LIST_DEVICE_RESIDENT: type = "USE_DEVICE"; break;
1379 case OMP_LIST_CACHE: type = ""; break;
1380 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1381 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1382 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1383 case OMP_LIST_SHARED: type = "SHARED"; break;
1384 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1385 case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
1386 case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
1387 case OMP_LIST_LINEAR: type = "LINEAR"; break;
1388 case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
1389 case OMP_LIST_IS_DEVICE_PTR: type = "IS_DEVICE_PTR"; break;
1390 case OMP_LIST_USE_DEVICE_PTR: type = "USE_DEVICE_PTR"; break;
1391 case OMP_LIST_DEPEND: type = "DEPEND"; break;
1392 default:
1393 gcc_unreachable ();
1394 }
1395 fprintf (dumpfile, " %s(", type);
1396 show_omp_namelist (list_type, omp_clauses->lists[list_type]);
1397 fputc (')', dumpfile);
1398 }
1399 if (omp_clauses->safelen_expr)
1400 {
1401 fputs (" SAFELEN(", dumpfile);
1402 show_expr (omp_clauses->safelen_expr);
1403 fputc (')', dumpfile);
1404 }
1405 if (omp_clauses->simdlen_expr)
1406 {
1407 fputs (" SIMDLEN(", dumpfile);
1408 show_expr (omp_clauses->simdlen_expr);
1409 fputc (')', dumpfile);
1410 }
1411 if (omp_clauses->inbranch)
1412 fputs (" INBRANCH", dumpfile);
1413 if (omp_clauses->notinbranch)
1414 fputs (" NOTINBRANCH", dumpfile);
1415 if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
1416 {
1417 const char *type;
1418 switch (omp_clauses->proc_bind)
1419 {
1420 case OMP_PROC_BIND_MASTER: type = "MASTER"; break;
1421 case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break;
1422 case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break;
1423 default:
1424 gcc_unreachable ();
1425 }
1426 fprintf (dumpfile, " PROC_BIND(%s)", type);
1427 }
1428 if (omp_clauses->num_teams)
1429 {
1430 fputs (" NUM_TEAMS(", dumpfile);
1431 show_expr (omp_clauses->num_teams);
1432 fputc (')', dumpfile);
1433 }
1434 if (omp_clauses->device)
1435 {
1436 fputs (" DEVICE(", dumpfile);
1437 show_expr (omp_clauses->device);
1438 fputc (')', dumpfile);
1439 }
1440 if (omp_clauses->thread_limit)
1441 {
1442 fputs (" THREAD_LIMIT(", dumpfile);
1443 show_expr (omp_clauses->thread_limit);
1444 fputc (')', dumpfile);
1445 }
1446 if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE)
1447 {
1448 fprintf (dumpfile, " DIST_SCHEDULE (STATIC");
1449 if (omp_clauses->dist_chunk_size)
1450 {
1451 fputc (',', dumpfile);
1452 show_expr (omp_clauses->dist_chunk_size);
1453 }
1454 fputc (')', dumpfile);
1455 }
1456 if (omp_clauses->defaultmap)
1457 fputs (" DEFALTMAP (TOFROM: SCALAR)", dumpfile);
1458 if (omp_clauses->nogroup)
1459 fputs (" NOGROUP", dumpfile);
1460 if (omp_clauses->simd)
1461 fputs (" SIMD", dumpfile);
1462 if (omp_clauses->threads)
1463 fputs (" THREADS", dumpfile);
1464 if (omp_clauses->grainsize)
1465 {
1466 fputs (" GRAINSIZE(", dumpfile);
1467 show_expr (omp_clauses->grainsize);
1468 fputc (')', dumpfile);
1469 }
1470 if (omp_clauses->hint)
1471 {
1472 fputs (" HINT(", dumpfile);
1473 show_expr (omp_clauses->hint);
1474 fputc (')', dumpfile);
1475 }
1476 if (omp_clauses->num_tasks)
1477 {
1478 fputs (" NUM_TASKS(", dumpfile);
1479 show_expr (omp_clauses->num_tasks);
1480 fputc (')', dumpfile);
1481 }
1482 if (omp_clauses->priority)
1483 {
1484 fputs (" PRIORITY(", dumpfile);
1485 show_expr (omp_clauses->priority);
1486 fputc (')', dumpfile);
1487 }
1488 for (i = 0; i < OMP_IF_LAST; i++)
1489 if (omp_clauses->if_exprs[i])
1490 {
1491 static const char *ifs[] = {
1492 "PARALLEL",
1493 "TASK",
1494 "TASKLOOP",
1495 "TARGET",
1496 "TARGET DATA",
1497 "TARGET UPDATE",
1498 "TARGET ENTER DATA",
1499 "TARGET EXIT DATA"
1500 };
1501 fputs (" IF(", dumpfile);
1502 fputs (ifs[i], dumpfile);
1503 fputs (": ", dumpfile);
1504 show_expr (omp_clauses->if_exprs[i]);
1505 fputc (')', dumpfile);
1506 }
1507 if (omp_clauses->depend_source)
1508 fputs (" DEPEND(source)", dumpfile);
1509 }
1510
1511 /* Show a single OpenMP or OpenACC directive node and everything underneath it
1512 if necessary. */
1513
1514 static void
1515 show_omp_node (int level, gfc_code *c)
1516 {
1517 gfc_omp_clauses *omp_clauses = NULL;
1518 const char *name = NULL;
1519 bool is_oacc = false;
1520
1521 switch (c->op)
1522 {
1523 case EXEC_OACC_PARALLEL_LOOP:
1524 name = "PARALLEL LOOP"; is_oacc = true; break;
1525 case EXEC_OACC_PARALLEL: name = "PARALLEL"; is_oacc = true; break;
1526 case EXEC_OACC_KERNELS_LOOP: name = "KERNELS LOOP"; is_oacc = true; break;
1527 case EXEC_OACC_KERNELS: name = "KERNELS"; is_oacc = true; break;
1528 case EXEC_OACC_DATA: name = "DATA"; is_oacc = true; break;
1529 case EXEC_OACC_HOST_DATA: name = "HOST_DATA"; is_oacc = true; break;
1530 case EXEC_OACC_LOOP: name = "LOOP"; is_oacc = true; break;
1531 case EXEC_OACC_UPDATE: name = "UPDATE"; is_oacc = true; break;
1532 case EXEC_OACC_WAIT: name = "WAIT"; is_oacc = true; break;
1533 case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
1534 case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
1535 case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
1536 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
1537 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
1538 case EXEC_OMP_CANCEL: name = "CANCEL"; break;
1539 case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break;
1540 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
1541 case EXEC_OMP_DISTRIBUTE: name = "DISTRIBUTE"; break;
1542 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
1543 name = "DISTRIBUTE PARALLEL DO"; break;
1544 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
1545 name = "DISTRIBUTE PARALLEL DO SIMD"; break;
1546 case EXEC_OMP_DISTRIBUTE_SIMD: name = "DISTRIBUTE SIMD"; break;
1547 case EXEC_OMP_DO: name = "DO"; break;
1548 case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break;
1549 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
1550 case EXEC_OMP_MASTER: name = "MASTER"; break;
1551 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
1552 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
1553 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
1554 case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break;
1555 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
1556 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
1557 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
1558 case EXEC_OMP_SIMD: name = "SIMD"; break;
1559 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
1560 case EXEC_OMP_TARGET: name = "TARGET"; break;
1561 case EXEC_OMP_TARGET_DATA: name = "TARGET DATA"; break;
1562 case EXEC_OMP_TARGET_ENTER_DATA: name = "TARGET ENTER DATA"; break;
1563 case EXEC_OMP_TARGET_EXIT_DATA: name = "TARGET EXIT DATA"; break;
1564 case EXEC_OMP_TARGET_PARALLEL: name = "TARGET PARALLEL"; break;
1565 case EXEC_OMP_TARGET_PARALLEL_DO: name = "TARGET PARALLEL DO"; break;
1566 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
1567 name = "TARGET_PARALLEL_DO_SIMD"; break;
1568 case EXEC_OMP_TARGET_SIMD: name = "TARGET SIMD"; break;
1569 case EXEC_OMP_TARGET_TEAMS: name = "TARGET TEAMS"; break;
1570 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
1571 name = "TARGET TEAMS DISTRIBUTE"; break;
1572 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1573 name = "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break;
1574 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1575 name = "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
1576 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1577 name = "TARGET TEAMS DISTRIBUTE SIMD"; break;
1578 case EXEC_OMP_TARGET_UPDATE: name = "TARGET UPDATE"; break;
1579 case EXEC_OMP_TASK: name = "TASK"; break;
1580 case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break;
1581 case EXEC_OMP_TASKLOOP: name = "TASKLOOP"; break;
1582 case EXEC_OMP_TASKLOOP_SIMD: name = "TASKLOOP SIMD"; break;
1583 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
1584 case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
1585 case EXEC_OMP_TEAMS: name = "TEAMS"; break;
1586 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "TEAMS DISTRIBUTE"; break;
1587 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
1588 name = "TEAMS DISTRIBUTE PARALLEL DO"; break;
1589 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1590 name = "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
1591 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: name = "TEAMS DISTRIBUTE SIMD"; break;
1592 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
1593 default:
1594 gcc_unreachable ();
1595 }
1596 fprintf (dumpfile, "!$%s %s", is_oacc ? "ACC" : "OMP", name);
1597 switch (c->op)
1598 {
1599 case EXEC_OACC_PARALLEL_LOOP:
1600 case EXEC_OACC_PARALLEL:
1601 case EXEC_OACC_KERNELS_LOOP:
1602 case EXEC_OACC_KERNELS:
1603 case EXEC_OACC_DATA:
1604 case EXEC_OACC_HOST_DATA:
1605 case EXEC_OACC_LOOP:
1606 case EXEC_OACC_UPDATE:
1607 case EXEC_OACC_WAIT:
1608 case EXEC_OACC_CACHE:
1609 case EXEC_OACC_ENTER_DATA:
1610 case EXEC_OACC_EXIT_DATA:
1611 case EXEC_OMP_CANCEL:
1612 case EXEC_OMP_CANCELLATION_POINT:
1613 case EXEC_OMP_DISTRIBUTE:
1614 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
1615 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
1616 case EXEC_OMP_DISTRIBUTE_SIMD:
1617 case EXEC_OMP_DO:
1618 case EXEC_OMP_DO_SIMD:
1619 case EXEC_OMP_ORDERED:
1620 case EXEC_OMP_PARALLEL:
1621 case EXEC_OMP_PARALLEL_DO:
1622 case EXEC_OMP_PARALLEL_DO_SIMD:
1623 case EXEC_OMP_PARALLEL_SECTIONS:
1624 case EXEC_OMP_PARALLEL_WORKSHARE:
1625 case EXEC_OMP_SECTIONS:
1626 case EXEC_OMP_SIMD:
1627 case EXEC_OMP_SINGLE:
1628 case EXEC_OMP_TARGET:
1629 case EXEC_OMP_TARGET_DATA:
1630 case EXEC_OMP_TARGET_ENTER_DATA:
1631 case EXEC_OMP_TARGET_EXIT_DATA:
1632 case EXEC_OMP_TARGET_PARALLEL:
1633 case EXEC_OMP_TARGET_PARALLEL_DO:
1634 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
1635 case EXEC_OMP_TARGET_SIMD:
1636 case EXEC_OMP_TARGET_TEAMS:
1637 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
1638 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1639 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1640 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1641 case EXEC_OMP_TARGET_UPDATE:
1642 case EXEC_OMP_TASK:
1643 case EXEC_OMP_TASKLOOP:
1644 case EXEC_OMP_TASKLOOP_SIMD:
1645 case EXEC_OMP_TEAMS:
1646 case EXEC_OMP_TEAMS_DISTRIBUTE:
1647 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
1648 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1649 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
1650 case EXEC_OMP_WORKSHARE:
1651 omp_clauses = c->ext.omp_clauses;
1652 break;
1653 case EXEC_OMP_CRITICAL:
1654 omp_clauses = c->ext.omp_clauses;
1655 if (omp_clauses)
1656 fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name);
1657 break;
1658 case EXEC_OMP_FLUSH:
1659 if (c->ext.omp_namelist)
1660 {
1661 fputs (" (", dumpfile);
1662 show_omp_namelist (OMP_LIST_NUM, c->ext.omp_namelist);
1663 fputc (')', dumpfile);
1664 }
1665 return;
1666 case EXEC_OMP_BARRIER:
1667 case EXEC_OMP_TASKWAIT:
1668 case EXEC_OMP_TASKYIELD:
1669 return;
1670 default:
1671 break;
1672 }
1673 if (omp_clauses)
1674 show_omp_clauses (omp_clauses);
1675 fputc ('\n', dumpfile);
1676
1677 /* OpenMP and OpenACC executable directives don't have associated blocks. */
1678 if (c->op == EXEC_OACC_CACHE || c->op == EXEC_OACC_UPDATE
1679 || c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA
1680 || c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA
1681 || c->op == EXEC_OMP_TARGET_EXIT_DATA
1682 || (c->op == EXEC_OMP_ORDERED && c->block == NULL))
1683 return;
1684 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1685 {
1686 gfc_code *d = c->block;
1687 while (d != NULL)
1688 {
1689 show_code (level + 1, d->next);
1690 if (d->block == NULL)
1691 break;
1692 code_indent (level, 0);
1693 fputs ("!$OMP SECTION\n", dumpfile);
1694 d = d->block;
1695 }
1696 }
1697 else
1698 show_code (level + 1, c->block->next);
1699 if (c->op == EXEC_OMP_ATOMIC)
1700 return;
1701 fputc ('\n', dumpfile);
1702 code_indent (level, 0);
1703 fprintf (dumpfile, "!$%s END %s", is_oacc ? "ACC" : "OMP", name);
1704 if (omp_clauses != NULL)
1705 {
1706 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1707 {
1708 fputs (" COPYPRIVATE(", dumpfile);
1709 show_omp_namelist (OMP_LIST_COPYPRIVATE,
1710 omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1711 fputc (')', dumpfile);
1712 }
1713 else if (omp_clauses->nowait)
1714 fputs (" NOWAIT", dumpfile);
1715 }
1716 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses)
1717 fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name);
1718 }
1719
1720
1721 /* Show a single code node and everything underneath it if necessary. */
1722
1723 static void
1724 show_code_node (int level, gfc_code *c)
1725 {
1726 gfc_forall_iterator *fa;
1727 gfc_open *open;
1728 gfc_case *cp;
1729 gfc_alloc *a;
1730 gfc_code *d;
1731 gfc_close *close;
1732 gfc_filepos *fp;
1733 gfc_inquire *i;
1734 gfc_dt *dt;
1735 gfc_namespace *ns;
1736
1737 if (c->here)
1738 {
1739 fputc ('\n', dumpfile);
1740 code_indent (level, c->here);
1741 }
1742 else
1743 show_indent ();
1744
1745 switch (c->op)
1746 {
1747 case EXEC_END_PROCEDURE:
1748 break;
1749
1750 case EXEC_NOP:
1751 fputs ("NOP", dumpfile);
1752 break;
1753
1754 case EXEC_CONTINUE:
1755 fputs ("CONTINUE", dumpfile);
1756 break;
1757
1758 case EXEC_ENTRY:
1759 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1760 break;
1761
1762 case EXEC_INIT_ASSIGN:
1763 case EXEC_ASSIGN:
1764 fputs ("ASSIGN ", dumpfile);
1765 show_expr (c->expr1);
1766 fputc (' ', dumpfile);
1767 show_expr (c->expr2);
1768 break;
1769
1770 case EXEC_LABEL_ASSIGN:
1771 fputs ("LABEL ASSIGN ", dumpfile);
1772 show_expr (c->expr1);
1773 fprintf (dumpfile, " %d", c->label1->value);
1774 break;
1775
1776 case EXEC_POINTER_ASSIGN:
1777 fputs ("POINTER ASSIGN ", dumpfile);
1778 show_expr (c->expr1);
1779 fputc (' ', dumpfile);
1780 show_expr (c->expr2);
1781 break;
1782
1783 case EXEC_GOTO:
1784 fputs ("GOTO ", dumpfile);
1785 if (c->label1)
1786 fprintf (dumpfile, "%d", c->label1->value);
1787 else
1788 {
1789 show_expr (c->expr1);
1790 d = c->block;
1791 if (d != NULL)
1792 {
1793 fputs (", (", dumpfile);
1794 for (; d; d = d ->block)
1795 {
1796 code_indent (level, d->label1);
1797 if (d->block != NULL)
1798 fputc (',', dumpfile);
1799 else
1800 fputc (')', dumpfile);
1801 }
1802 }
1803 }
1804 break;
1805
1806 case EXEC_CALL:
1807 case EXEC_ASSIGN_CALL:
1808 if (c->resolved_sym)
1809 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1810 else if (c->symtree)
1811 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1812 else
1813 fputs ("CALL ?? ", dumpfile);
1814
1815 show_actual_arglist (c->ext.actual);
1816 break;
1817
1818 case EXEC_COMPCALL:
1819 fputs ("CALL ", dumpfile);
1820 show_compcall (c->expr1);
1821 break;
1822
1823 case EXEC_CALL_PPC:
1824 fputs ("CALL ", dumpfile);
1825 show_expr (c->expr1);
1826 show_actual_arglist (c->ext.actual);
1827 break;
1828
1829 case EXEC_RETURN:
1830 fputs ("RETURN ", dumpfile);
1831 if (c->expr1)
1832 show_expr (c->expr1);
1833 break;
1834
1835 case EXEC_PAUSE:
1836 fputs ("PAUSE ", dumpfile);
1837
1838 if (c->expr1 != NULL)
1839 show_expr (c->expr1);
1840 else
1841 fprintf (dumpfile, "%d", c->ext.stop_code);
1842
1843 break;
1844
1845 case EXEC_ERROR_STOP:
1846 fputs ("ERROR ", dumpfile);
1847 /* Fall through. */
1848
1849 case EXEC_STOP:
1850 fputs ("STOP ", dumpfile);
1851
1852 if (c->expr1 != NULL)
1853 show_expr (c->expr1);
1854 else
1855 fprintf (dumpfile, "%d", c->ext.stop_code);
1856
1857 break;
1858
1859 case EXEC_FAIL_IMAGE:
1860 fputs ("FAIL IMAGE ", dumpfile);
1861 break;
1862
1863 case EXEC_SYNC_ALL:
1864 fputs ("SYNC ALL ", dumpfile);
1865 if (c->expr2 != NULL)
1866 {
1867 fputs (" stat=", dumpfile);
1868 show_expr (c->expr2);
1869 }
1870 if (c->expr3 != NULL)
1871 {
1872 fputs (" errmsg=", dumpfile);
1873 show_expr (c->expr3);
1874 }
1875 break;
1876
1877 case EXEC_SYNC_MEMORY:
1878 fputs ("SYNC MEMORY ", dumpfile);
1879 if (c->expr2 != NULL)
1880 {
1881 fputs (" stat=", dumpfile);
1882 show_expr (c->expr2);
1883 }
1884 if (c->expr3 != NULL)
1885 {
1886 fputs (" errmsg=", dumpfile);
1887 show_expr (c->expr3);
1888 }
1889 break;
1890
1891 case EXEC_SYNC_IMAGES:
1892 fputs ("SYNC IMAGES image-set=", dumpfile);
1893 if (c->expr1 != NULL)
1894 show_expr (c->expr1);
1895 else
1896 fputs ("* ", dumpfile);
1897 if (c->expr2 != NULL)
1898 {
1899 fputs (" stat=", dumpfile);
1900 show_expr (c->expr2);
1901 }
1902 if (c->expr3 != NULL)
1903 {
1904 fputs (" errmsg=", dumpfile);
1905 show_expr (c->expr3);
1906 }
1907 break;
1908
1909 case EXEC_EVENT_POST:
1910 case EXEC_EVENT_WAIT:
1911 if (c->op == EXEC_EVENT_POST)
1912 fputs ("EVENT POST ", dumpfile);
1913 else
1914 fputs ("EVENT WAIT ", dumpfile);
1915
1916 fputs ("event-variable=", dumpfile);
1917 if (c->expr1 != NULL)
1918 show_expr (c->expr1);
1919 if (c->expr4 != NULL)
1920 {
1921 fputs (" until_count=", dumpfile);
1922 show_expr (c->expr4);
1923 }
1924 if (c->expr2 != NULL)
1925 {
1926 fputs (" stat=", dumpfile);
1927 show_expr (c->expr2);
1928 }
1929 if (c->expr3 != NULL)
1930 {
1931 fputs (" errmsg=", dumpfile);
1932 show_expr (c->expr3);
1933 }
1934 break;
1935
1936 case EXEC_LOCK:
1937 case EXEC_UNLOCK:
1938 if (c->op == EXEC_LOCK)
1939 fputs ("LOCK ", dumpfile);
1940 else
1941 fputs ("UNLOCK ", dumpfile);
1942
1943 fputs ("lock-variable=", dumpfile);
1944 if (c->expr1 != NULL)
1945 show_expr (c->expr1);
1946 if (c->expr4 != NULL)
1947 {
1948 fputs (" acquired_lock=", dumpfile);
1949 show_expr (c->expr4);
1950 }
1951 if (c->expr2 != NULL)
1952 {
1953 fputs (" stat=", dumpfile);
1954 show_expr (c->expr2);
1955 }
1956 if (c->expr3 != NULL)
1957 {
1958 fputs (" errmsg=", dumpfile);
1959 show_expr (c->expr3);
1960 }
1961 break;
1962
1963 case EXEC_ARITHMETIC_IF:
1964 fputs ("IF ", dumpfile);
1965 show_expr (c->expr1);
1966 fprintf (dumpfile, " %d, %d, %d",
1967 c->label1->value, c->label2->value, c->label3->value);
1968 break;
1969
1970 case EXEC_IF:
1971 d = c->block;
1972 fputs ("IF ", dumpfile);
1973 show_expr (d->expr1);
1974
1975 ++show_level;
1976 show_code (level + 1, d->next);
1977 --show_level;
1978
1979 d = d->block;
1980 for (; d; d = d->block)
1981 {
1982 code_indent (level, 0);
1983
1984 if (d->expr1 == NULL)
1985 fputs ("ELSE", dumpfile);
1986 else
1987 {
1988 fputs ("ELSE IF ", dumpfile);
1989 show_expr (d->expr1);
1990 }
1991
1992 ++show_level;
1993 show_code (level + 1, d->next);
1994 --show_level;
1995 }
1996
1997 if (c->label1)
1998 code_indent (level, c->label1);
1999 else
2000 show_indent ();
2001
2002 fputs ("ENDIF", dumpfile);
2003 break;
2004
2005 case EXEC_BLOCK:
2006 {
2007 const char* blocktype;
2008 gfc_namespace *saved_ns;
2009 gfc_association_list *alist;
2010
2011 if (c->ext.block.assoc)
2012 blocktype = "ASSOCIATE";
2013 else
2014 blocktype = "BLOCK";
2015 show_indent ();
2016 fprintf (dumpfile, "%s ", blocktype);
2017 for (alist = c->ext.block.assoc; alist; alist = alist->next)
2018 {
2019 fprintf (dumpfile, " %s = ", alist->name);
2020 show_expr (alist->target);
2021 }
2022
2023 ++show_level;
2024 ns = c->ext.block.ns;
2025 saved_ns = gfc_current_ns;
2026 gfc_current_ns = ns;
2027 gfc_traverse_symtree (ns->sym_root, show_symtree);
2028 gfc_current_ns = saved_ns;
2029 show_code (show_level, ns->code);
2030 --show_level;
2031 show_indent ();
2032 fprintf (dumpfile, "END %s ", blocktype);
2033 break;
2034 }
2035
2036 case EXEC_END_BLOCK:
2037 /* Only come here when there is a label on an
2038 END ASSOCIATE construct. */
2039 break;
2040
2041 case EXEC_SELECT:
2042 case EXEC_SELECT_TYPE:
2043 d = c->block;
2044 if (c->op == EXEC_SELECT_TYPE)
2045 fputs ("SELECT TYPE ", dumpfile);
2046 else
2047 fputs ("SELECT CASE ", dumpfile);
2048 show_expr (c->expr1);
2049 fputc ('\n', dumpfile);
2050
2051 for (; d; d = d->block)
2052 {
2053 code_indent (level, 0);
2054
2055 fputs ("CASE ", dumpfile);
2056 for (cp = d->ext.block.case_list; cp; cp = cp->next)
2057 {
2058 fputc ('(', dumpfile);
2059 show_expr (cp->low);
2060 fputc (' ', dumpfile);
2061 show_expr (cp->high);
2062 fputc (')', dumpfile);
2063 fputc (' ', dumpfile);
2064 }
2065 fputc ('\n', dumpfile);
2066
2067 show_code (level + 1, d->next);
2068 }
2069
2070 code_indent (level, c->label1);
2071 fputs ("END SELECT", dumpfile);
2072 break;
2073
2074 case EXEC_WHERE:
2075 fputs ("WHERE ", dumpfile);
2076
2077 d = c->block;
2078 show_expr (d->expr1);
2079 fputc ('\n', dumpfile);
2080
2081 show_code (level + 1, d->next);
2082
2083 for (d = d->block; d; d = d->block)
2084 {
2085 code_indent (level, 0);
2086 fputs ("ELSE WHERE ", dumpfile);
2087 show_expr (d->expr1);
2088 fputc ('\n', dumpfile);
2089 show_code (level + 1, d->next);
2090 }
2091
2092 code_indent (level, 0);
2093 fputs ("END WHERE", dumpfile);
2094 break;
2095
2096
2097 case EXEC_FORALL:
2098 fputs ("FORALL ", dumpfile);
2099 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
2100 {
2101 show_expr (fa->var);
2102 fputc (' ', dumpfile);
2103 show_expr (fa->start);
2104 fputc (':', dumpfile);
2105 show_expr (fa->end);
2106 fputc (':', dumpfile);
2107 show_expr (fa->stride);
2108
2109 if (fa->next != NULL)
2110 fputc (',', dumpfile);
2111 }
2112
2113 if (c->expr1 != NULL)
2114 {
2115 fputc (',', dumpfile);
2116 show_expr (c->expr1);
2117 }
2118 fputc ('\n', dumpfile);
2119
2120 show_code (level + 1, c->block->next);
2121
2122 code_indent (level, 0);
2123 fputs ("END FORALL", dumpfile);
2124 break;
2125
2126 case EXEC_CRITICAL:
2127 fputs ("CRITICAL\n", dumpfile);
2128 show_code (level + 1, c->block->next);
2129 code_indent (level, 0);
2130 fputs ("END CRITICAL", dumpfile);
2131 break;
2132
2133 case EXEC_DO:
2134 fputs ("DO ", dumpfile);
2135 if (c->label1)
2136 fprintf (dumpfile, " %-5d ", c->label1->value);
2137
2138 show_expr (c->ext.iterator->var);
2139 fputc ('=', dumpfile);
2140 show_expr (c->ext.iterator->start);
2141 fputc (' ', dumpfile);
2142 show_expr (c->ext.iterator->end);
2143 fputc (' ', dumpfile);
2144 show_expr (c->ext.iterator->step);
2145
2146 ++show_level;
2147 show_code (level + 1, c->block->next);
2148 --show_level;
2149
2150 if (c->label1)
2151 break;
2152
2153 show_indent ();
2154 fputs ("END DO", dumpfile);
2155 break;
2156
2157 case EXEC_DO_CONCURRENT:
2158 fputs ("DO CONCURRENT ", dumpfile);
2159 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
2160 {
2161 show_expr (fa->var);
2162 fputc (' ', dumpfile);
2163 show_expr (fa->start);
2164 fputc (':', dumpfile);
2165 show_expr (fa->end);
2166 fputc (':', dumpfile);
2167 show_expr (fa->stride);
2168
2169 if (fa->next != NULL)
2170 fputc (',', dumpfile);
2171 }
2172 show_expr (c->expr1);
2173
2174 show_code (level + 1, c->block->next);
2175 code_indent (level, c->label1);
2176 fputs ("END DO", dumpfile);
2177 break;
2178
2179 case EXEC_DO_WHILE:
2180 fputs ("DO WHILE ", dumpfile);
2181 show_expr (c->expr1);
2182 fputc ('\n', dumpfile);
2183
2184 show_code (level + 1, c->block->next);
2185
2186 code_indent (level, c->label1);
2187 fputs ("END DO", dumpfile);
2188 break;
2189
2190 case EXEC_CYCLE:
2191 fputs ("CYCLE", dumpfile);
2192 if (c->symtree)
2193 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
2194 break;
2195
2196 case EXEC_EXIT:
2197 fputs ("EXIT", dumpfile);
2198 if (c->symtree)
2199 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
2200 break;
2201
2202 case EXEC_ALLOCATE:
2203 fputs ("ALLOCATE ", dumpfile);
2204 if (c->expr1)
2205 {
2206 fputs (" STAT=", dumpfile);
2207 show_expr (c->expr1);
2208 }
2209
2210 if (c->expr2)
2211 {
2212 fputs (" ERRMSG=", dumpfile);
2213 show_expr (c->expr2);
2214 }
2215
2216 if (c->expr3)
2217 {
2218 if (c->expr3->mold)
2219 fputs (" MOLD=", dumpfile);
2220 else
2221 fputs (" SOURCE=", dumpfile);
2222 show_expr (c->expr3);
2223 }
2224
2225 for (a = c->ext.alloc.list; a; a = a->next)
2226 {
2227 fputc (' ', dumpfile);
2228 show_expr (a->expr);
2229 }
2230
2231 break;
2232
2233 case EXEC_DEALLOCATE:
2234 fputs ("DEALLOCATE ", dumpfile);
2235 if (c->expr1)
2236 {
2237 fputs (" STAT=", dumpfile);
2238 show_expr (c->expr1);
2239 }
2240
2241 if (c->expr2)
2242 {
2243 fputs (" ERRMSG=", dumpfile);
2244 show_expr (c->expr2);
2245 }
2246
2247 for (a = c->ext.alloc.list; a; a = a->next)
2248 {
2249 fputc (' ', dumpfile);
2250 show_expr (a->expr);
2251 }
2252
2253 break;
2254
2255 case EXEC_OPEN:
2256 fputs ("OPEN", dumpfile);
2257 open = c->ext.open;
2258
2259 if (open->unit)
2260 {
2261 fputs (" UNIT=", dumpfile);
2262 show_expr (open->unit);
2263 }
2264 if (open->iomsg)
2265 {
2266 fputs (" IOMSG=", dumpfile);
2267 show_expr (open->iomsg);
2268 }
2269 if (open->iostat)
2270 {
2271 fputs (" IOSTAT=", dumpfile);
2272 show_expr (open->iostat);
2273 }
2274 if (open->file)
2275 {
2276 fputs (" FILE=", dumpfile);
2277 show_expr (open->file);
2278 }
2279 if (open->status)
2280 {
2281 fputs (" STATUS=", dumpfile);
2282 show_expr (open->status);
2283 }
2284 if (open->access)
2285 {
2286 fputs (" ACCESS=", dumpfile);
2287 show_expr (open->access);
2288 }
2289 if (open->form)
2290 {
2291 fputs (" FORM=", dumpfile);
2292 show_expr (open->form);
2293 }
2294 if (open->recl)
2295 {
2296 fputs (" RECL=", dumpfile);
2297 show_expr (open->recl);
2298 }
2299 if (open->blank)
2300 {
2301 fputs (" BLANK=", dumpfile);
2302 show_expr (open->blank);
2303 }
2304 if (open->position)
2305 {
2306 fputs (" POSITION=", dumpfile);
2307 show_expr (open->position);
2308 }
2309 if (open->action)
2310 {
2311 fputs (" ACTION=", dumpfile);
2312 show_expr (open->action);
2313 }
2314 if (open->delim)
2315 {
2316 fputs (" DELIM=", dumpfile);
2317 show_expr (open->delim);
2318 }
2319 if (open->pad)
2320 {
2321 fputs (" PAD=", dumpfile);
2322 show_expr (open->pad);
2323 }
2324 if (open->decimal)
2325 {
2326 fputs (" DECIMAL=", dumpfile);
2327 show_expr (open->decimal);
2328 }
2329 if (open->encoding)
2330 {
2331 fputs (" ENCODING=", dumpfile);
2332 show_expr (open->encoding);
2333 }
2334 if (open->round)
2335 {
2336 fputs (" ROUND=", dumpfile);
2337 show_expr (open->round);
2338 }
2339 if (open->sign)
2340 {
2341 fputs (" SIGN=", dumpfile);
2342 show_expr (open->sign);
2343 }
2344 if (open->convert)
2345 {
2346 fputs (" CONVERT=", dumpfile);
2347 show_expr (open->convert);
2348 }
2349 if (open->asynchronous)
2350 {
2351 fputs (" ASYNCHRONOUS=", dumpfile);
2352 show_expr (open->asynchronous);
2353 }
2354 if (open->err != NULL)
2355 fprintf (dumpfile, " ERR=%d", open->err->value);
2356
2357 break;
2358
2359 case EXEC_CLOSE:
2360 fputs ("CLOSE", dumpfile);
2361 close = c->ext.close;
2362
2363 if (close->unit)
2364 {
2365 fputs (" UNIT=", dumpfile);
2366 show_expr (close->unit);
2367 }
2368 if (close->iomsg)
2369 {
2370 fputs (" IOMSG=", dumpfile);
2371 show_expr (close->iomsg);
2372 }
2373 if (close->iostat)
2374 {
2375 fputs (" IOSTAT=", dumpfile);
2376 show_expr (close->iostat);
2377 }
2378 if (close->status)
2379 {
2380 fputs (" STATUS=", dumpfile);
2381 show_expr (close->status);
2382 }
2383 if (close->err != NULL)
2384 fprintf (dumpfile, " ERR=%d", close->err->value);
2385 break;
2386
2387 case EXEC_BACKSPACE:
2388 fputs ("BACKSPACE", dumpfile);
2389 goto show_filepos;
2390
2391 case EXEC_ENDFILE:
2392 fputs ("ENDFILE", dumpfile);
2393 goto show_filepos;
2394
2395 case EXEC_REWIND:
2396 fputs ("REWIND", dumpfile);
2397 goto show_filepos;
2398
2399 case EXEC_FLUSH:
2400 fputs ("FLUSH", dumpfile);
2401
2402 show_filepos:
2403 fp = c->ext.filepos;
2404
2405 if (fp->unit)
2406 {
2407 fputs (" UNIT=", dumpfile);
2408 show_expr (fp->unit);
2409 }
2410 if (fp->iomsg)
2411 {
2412 fputs (" IOMSG=", dumpfile);
2413 show_expr (fp->iomsg);
2414 }
2415 if (fp->iostat)
2416 {
2417 fputs (" IOSTAT=", dumpfile);
2418 show_expr (fp->iostat);
2419 }
2420 if (fp->err != NULL)
2421 fprintf (dumpfile, " ERR=%d", fp->err->value);
2422 break;
2423
2424 case EXEC_INQUIRE:
2425 fputs ("INQUIRE", dumpfile);
2426 i = c->ext.inquire;
2427
2428 if (i->unit)
2429 {
2430 fputs (" UNIT=", dumpfile);
2431 show_expr (i->unit);
2432 }
2433 if (i->file)
2434 {
2435 fputs (" FILE=", dumpfile);
2436 show_expr (i->file);
2437 }
2438
2439 if (i->iomsg)
2440 {
2441 fputs (" IOMSG=", dumpfile);
2442 show_expr (i->iomsg);
2443 }
2444 if (i->iostat)
2445 {
2446 fputs (" IOSTAT=", dumpfile);
2447 show_expr (i->iostat);
2448 }
2449 if (i->exist)
2450 {
2451 fputs (" EXIST=", dumpfile);
2452 show_expr (i->exist);
2453 }
2454 if (i->opened)
2455 {
2456 fputs (" OPENED=", dumpfile);
2457 show_expr (i->opened);
2458 }
2459 if (i->number)
2460 {
2461 fputs (" NUMBER=", dumpfile);
2462 show_expr (i->number);
2463 }
2464 if (i->named)
2465 {
2466 fputs (" NAMED=", dumpfile);
2467 show_expr (i->named);
2468 }
2469 if (i->name)
2470 {
2471 fputs (" NAME=", dumpfile);
2472 show_expr (i->name);
2473 }
2474 if (i->access)
2475 {
2476 fputs (" ACCESS=", dumpfile);
2477 show_expr (i->access);
2478 }
2479 if (i->sequential)
2480 {
2481 fputs (" SEQUENTIAL=", dumpfile);
2482 show_expr (i->sequential);
2483 }
2484
2485 if (i->direct)
2486 {
2487 fputs (" DIRECT=", dumpfile);
2488 show_expr (i->direct);
2489 }
2490 if (i->form)
2491 {
2492 fputs (" FORM=", dumpfile);
2493 show_expr (i->form);
2494 }
2495 if (i->formatted)
2496 {
2497 fputs (" FORMATTED", dumpfile);
2498 show_expr (i->formatted);
2499 }
2500 if (i->unformatted)
2501 {
2502 fputs (" UNFORMATTED=", dumpfile);
2503 show_expr (i->unformatted);
2504 }
2505 if (i->recl)
2506 {
2507 fputs (" RECL=", dumpfile);
2508 show_expr (i->recl);
2509 }
2510 if (i->nextrec)
2511 {
2512 fputs (" NEXTREC=", dumpfile);
2513 show_expr (i->nextrec);
2514 }
2515 if (i->blank)
2516 {
2517 fputs (" BLANK=", dumpfile);
2518 show_expr (i->blank);
2519 }
2520 if (i->position)
2521 {
2522 fputs (" POSITION=", dumpfile);
2523 show_expr (i->position);
2524 }
2525 if (i->action)
2526 {
2527 fputs (" ACTION=", dumpfile);
2528 show_expr (i->action);
2529 }
2530 if (i->read)
2531 {
2532 fputs (" READ=", dumpfile);
2533 show_expr (i->read);
2534 }
2535 if (i->write)
2536 {
2537 fputs (" WRITE=", dumpfile);
2538 show_expr (i->write);
2539 }
2540 if (i->readwrite)
2541 {
2542 fputs (" READWRITE=", dumpfile);
2543 show_expr (i->readwrite);
2544 }
2545 if (i->delim)
2546 {
2547 fputs (" DELIM=", dumpfile);
2548 show_expr (i->delim);
2549 }
2550 if (i->pad)
2551 {
2552 fputs (" PAD=", dumpfile);
2553 show_expr (i->pad);
2554 }
2555 if (i->convert)
2556 {
2557 fputs (" CONVERT=", dumpfile);
2558 show_expr (i->convert);
2559 }
2560 if (i->asynchronous)
2561 {
2562 fputs (" ASYNCHRONOUS=", dumpfile);
2563 show_expr (i->asynchronous);
2564 }
2565 if (i->decimal)
2566 {
2567 fputs (" DECIMAL=", dumpfile);
2568 show_expr (i->decimal);
2569 }
2570 if (i->encoding)
2571 {
2572 fputs (" ENCODING=", dumpfile);
2573 show_expr (i->encoding);
2574 }
2575 if (i->pending)
2576 {
2577 fputs (" PENDING=", dumpfile);
2578 show_expr (i->pending);
2579 }
2580 if (i->round)
2581 {
2582 fputs (" ROUND=", dumpfile);
2583 show_expr (i->round);
2584 }
2585 if (i->sign)
2586 {
2587 fputs (" SIGN=", dumpfile);
2588 show_expr (i->sign);
2589 }
2590 if (i->size)
2591 {
2592 fputs (" SIZE=", dumpfile);
2593 show_expr (i->size);
2594 }
2595 if (i->id)
2596 {
2597 fputs (" ID=", dumpfile);
2598 show_expr (i->id);
2599 }
2600
2601 if (i->err != NULL)
2602 fprintf (dumpfile, " ERR=%d", i->err->value);
2603 break;
2604
2605 case EXEC_IOLENGTH:
2606 fputs ("IOLENGTH ", dumpfile);
2607 show_expr (c->expr1);
2608 goto show_dt_code;
2609 break;
2610
2611 case EXEC_READ:
2612 fputs ("READ", dumpfile);
2613 goto show_dt;
2614
2615 case EXEC_WRITE:
2616 fputs ("WRITE", dumpfile);
2617
2618 show_dt:
2619 dt = c->ext.dt;
2620 if (dt->io_unit)
2621 {
2622 fputs (" UNIT=", dumpfile);
2623 show_expr (dt->io_unit);
2624 }
2625
2626 if (dt->format_expr)
2627 {
2628 fputs (" FMT=", dumpfile);
2629 show_expr (dt->format_expr);
2630 }
2631
2632 if (dt->format_label != NULL)
2633 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
2634 if (dt->namelist)
2635 fprintf (dumpfile, " NML=%s", dt->namelist->name);
2636
2637 if (dt->iomsg)
2638 {
2639 fputs (" IOMSG=", dumpfile);
2640 show_expr (dt->iomsg);
2641 }
2642 if (dt->iostat)
2643 {
2644 fputs (" IOSTAT=", dumpfile);
2645 show_expr (dt->iostat);
2646 }
2647 if (dt->size)
2648 {
2649 fputs (" SIZE=", dumpfile);
2650 show_expr (dt->size);
2651 }
2652 if (dt->rec)
2653 {
2654 fputs (" REC=", dumpfile);
2655 show_expr (dt->rec);
2656 }
2657 if (dt->advance)
2658 {
2659 fputs (" ADVANCE=", dumpfile);
2660 show_expr (dt->advance);
2661 }
2662 if (dt->id)
2663 {
2664 fputs (" ID=", dumpfile);
2665 show_expr (dt->id);
2666 }
2667 if (dt->pos)
2668 {
2669 fputs (" POS=", dumpfile);
2670 show_expr (dt->pos);
2671 }
2672 if (dt->asynchronous)
2673 {
2674 fputs (" ASYNCHRONOUS=", dumpfile);
2675 show_expr (dt->asynchronous);
2676 }
2677 if (dt->blank)
2678 {
2679 fputs (" BLANK=", dumpfile);
2680 show_expr (dt->blank);
2681 }
2682 if (dt->decimal)
2683 {
2684 fputs (" DECIMAL=", dumpfile);
2685 show_expr (dt->decimal);
2686 }
2687 if (dt->delim)
2688 {
2689 fputs (" DELIM=", dumpfile);
2690 show_expr (dt->delim);
2691 }
2692 if (dt->pad)
2693 {
2694 fputs (" PAD=", dumpfile);
2695 show_expr (dt->pad);
2696 }
2697 if (dt->round)
2698 {
2699 fputs (" ROUND=", dumpfile);
2700 show_expr (dt->round);
2701 }
2702 if (dt->sign)
2703 {
2704 fputs (" SIGN=", dumpfile);
2705 show_expr (dt->sign);
2706 }
2707
2708 show_dt_code:
2709 for (c = c->block->next; c; c = c->next)
2710 show_code_node (level + (c->next != NULL), c);
2711 return;
2712
2713 case EXEC_TRANSFER:
2714 fputs ("TRANSFER ", dumpfile);
2715 show_expr (c->expr1);
2716 break;
2717
2718 case EXEC_DT_END:
2719 fputs ("DT_END", dumpfile);
2720 dt = c->ext.dt;
2721
2722 if (dt->err != NULL)
2723 fprintf (dumpfile, " ERR=%d", dt->err->value);
2724 if (dt->end != NULL)
2725 fprintf (dumpfile, " END=%d", dt->end->value);
2726 if (dt->eor != NULL)
2727 fprintf (dumpfile, " EOR=%d", dt->eor->value);
2728 break;
2729
2730 case EXEC_OACC_PARALLEL_LOOP:
2731 case EXEC_OACC_PARALLEL:
2732 case EXEC_OACC_KERNELS_LOOP:
2733 case EXEC_OACC_KERNELS:
2734 case EXEC_OACC_DATA:
2735 case EXEC_OACC_HOST_DATA:
2736 case EXEC_OACC_LOOP:
2737 case EXEC_OACC_UPDATE:
2738 case EXEC_OACC_WAIT:
2739 case EXEC_OACC_CACHE:
2740 case EXEC_OACC_ENTER_DATA:
2741 case EXEC_OACC_EXIT_DATA:
2742 case EXEC_OMP_ATOMIC:
2743 case EXEC_OMP_CANCEL:
2744 case EXEC_OMP_CANCELLATION_POINT:
2745 case EXEC_OMP_BARRIER:
2746 case EXEC_OMP_CRITICAL:
2747 case EXEC_OMP_DISTRIBUTE:
2748 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2749 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2750 case EXEC_OMP_DISTRIBUTE_SIMD:
2751 case EXEC_OMP_DO:
2752 case EXEC_OMP_DO_SIMD:
2753 case EXEC_OMP_FLUSH:
2754 case EXEC_OMP_MASTER:
2755 case EXEC_OMP_ORDERED:
2756 case EXEC_OMP_PARALLEL:
2757 case EXEC_OMP_PARALLEL_DO:
2758 case EXEC_OMP_PARALLEL_DO_SIMD:
2759 case EXEC_OMP_PARALLEL_SECTIONS:
2760 case EXEC_OMP_PARALLEL_WORKSHARE:
2761 case EXEC_OMP_SECTIONS:
2762 case EXEC_OMP_SIMD:
2763 case EXEC_OMP_SINGLE:
2764 case EXEC_OMP_TARGET:
2765 case EXEC_OMP_TARGET_DATA:
2766 case EXEC_OMP_TARGET_ENTER_DATA:
2767 case EXEC_OMP_TARGET_EXIT_DATA:
2768 case EXEC_OMP_TARGET_PARALLEL:
2769 case EXEC_OMP_TARGET_PARALLEL_DO:
2770 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2771 case EXEC_OMP_TARGET_SIMD:
2772 case EXEC_OMP_TARGET_TEAMS:
2773 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2774 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2775 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2776 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2777 case EXEC_OMP_TARGET_UPDATE:
2778 case EXEC_OMP_TASK:
2779 case EXEC_OMP_TASKGROUP:
2780 case EXEC_OMP_TASKLOOP:
2781 case EXEC_OMP_TASKLOOP_SIMD:
2782 case EXEC_OMP_TASKWAIT:
2783 case EXEC_OMP_TASKYIELD:
2784 case EXEC_OMP_TEAMS:
2785 case EXEC_OMP_TEAMS_DISTRIBUTE:
2786 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2787 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2788 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2789 case EXEC_OMP_WORKSHARE:
2790 show_omp_node (level, c);
2791 break;
2792
2793 default:
2794 gfc_internal_error ("show_code_node(): Bad statement code");
2795 }
2796 }
2797
2798
2799 /* Show an equivalence chain. */
2800
2801 static void
2802 show_equiv (gfc_equiv *eq)
2803 {
2804 show_indent ();
2805 fputs ("Equivalence: ", dumpfile);
2806 while (eq)
2807 {
2808 show_expr (eq->expr);
2809 eq = eq->eq;
2810 if (eq)
2811 fputs (", ", dumpfile);
2812 }
2813 }
2814
2815
2816 /* Show a freakin' whole namespace. */
2817
2818 static void
2819 show_namespace (gfc_namespace *ns)
2820 {
2821 gfc_interface *intr;
2822 gfc_namespace *save;
2823 int op;
2824 gfc_equiv *eq;
2825 int i;
2826
2827 gcc_assert (ns);
2828 save = gfc_current_ns;
2829
2830 show_indent ();
2831 fputs ("Namespace:", dumpfile);
2832
2833 i = 0;
2834 do
2835 {
2836 int l = i;
2837 while (i < GFC_LETTERS - 1
2838 && gfc_compare_types (&ns->default_type[i+1],
2839 &ns->default_type[l]))
2840 i++;
2841
2842 if (i > l)
2843 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2844 else
2845 fprintf (dumpfile, " %c: ", l+'A');
2846
2847 show_typespec(&ns->default_type[l]);
2848 i++;
2849 } while (i < GFC_LETTERS);
2850
2851 if (ns->proc_name != NULL)
2852 {
2853 show_indent ();
2854 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2855 }
2856
2857 ++show_level;
2858 gfc_current_ns = ns;
2859 gfc_traverse_symtree (ns->common_root, show_common);
2860
2861 gfc_traverse_symtree (ns->sym_root, show_symtree);
2862
2863 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2864 {
2865 /* User operator interfaces */
2866 intr = ns->op[op];
2867 if (intr == NULL)
2868 continue;
2869
2870 show_indent ();
2871 fprintf (dumpfile, "Operator interfaces for %s:",
2872 gfc_op2string ((gfc_intrinsic_op) op));
2873
2874 for (; intr; intr = intr->next)
2875 fprintf (dumpfile, " %s", intr->sym->name);
2876 }
2877
2878 if (ns->uop_root != NULL)
2879 {
2880 show_indent ();
2881 fputs ("User operators:\n", dumpfile);
2882 gfc_traverse_user_op (ns, show_uop);
2883 }
2884
2885 for (eq = ns->equiv; eq; eq = eq->next)
2886 show_equiv (eq);
2887
2888 if (ns->oacc_declare)
2889 {
2890 struct gfc_oacc_declare *decl;
2891 /* Dump !$ACC DECLARE clauses. */
2892 for (decl = ns->oacc_declare; decl; decl = decl->next)
2893 {
2894 show_indent ();
2895 fprintf (dumpfile, "!$ACC DECLARE");
2896 show_omp_clauses (decl->clauses);
2897 }
2898 }
2899
2900 fputc ('\n', dumpfile);
2901 show_indent ();
2902 fputs ("code:", dumpfile);
2903 show_code (show_level, ns->code);
2904 --show_level;
2905
2906 for (ns = ns->contained; ns; ns = ns->sibling)
2907 {
2908 fputs ("\nCONTAINS\n", dumpfile);
2909 ++show_level;
2910 show_namespace (ns);
2911 --show_level;
2912 }
2913
2914 fputc ('\n', dumpfile);
2915 gfc_current_ns = save;
2916 }
2917
2918
2919 /* Main function for dumping a parse tree. */
2920
2921 void
2922 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2923 {
2924 dumpfile = file;
2925 show_namespace (ns);
2926 }
2927
2928 /* This part writes BIND(C) definition for use in external C programs. */
2929
2930 static void write_interop_decl (gfc_symbol *);
2931
2932 void
2933 gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file)
2934 {
2935 int error_count;
2936 gfc_get_errors (NULL, &error_count);
2937 if (error_count != 0)
2938 return;
2939 dumpfile = file;
2940 gfc_traverse_ns (ns, write_interop_decl);
2941 }
2942
2943 enum type_return { T_OK=0, T_WARN, T_ERROR };
2944
2945 /* Return the name of the type for later output. Both function pointers and
2946 void pointers will be mapped to void *. */
2947
2948 static enum type_return
2949 get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
2950 const char **type_name, bool *asterisk, const char **post,
2951 bool func_ret)
2952 {
2953 static char post_buffer[40];
2954 enum type_return ret;
2955 ret = T_ERROR;
2956
2957 *pre = " ";
2958 *asterisk = false;
2959 *post = "";
2960 *type_name = "<error>";
2961 if (ts->type == BT_REAL || ts->type == BT_INTEGER)
2962 {
2963
2964 if (ts->is_c_interop && ts->interop_kind)
2965 {
2966 *type_name = ts->interop_kind->name + 2;
2967 if (strcmp (*type_name, "signed_char") == 0)
2968 *type_name = "signed char";
2969 else if (strcmp (*type_name, "size_t") == 0)
2970 *type_name = "ssize_t";
2971
2972 ret = T_OK;
2973 }
2974 else
2975 {
2976 /* The user did not specify a C interop type. Let's look through
2977 the available table and use the first one, but warn. */
2978 int i;
2979 for (i=0; i<ISOCBINDING_NUMBER; i++)
2980 {
2981 if (c_interop_kinds_table[i].f90_type == ts->type
2982 && c_interop_kinds_table[i].value == ts->kind)
2983 {
2984 *type_name = c_interop_kinds_table[i].name + 2;
2985 if (strcmp (*type_name, "signed_char") == 0)
2986 *type_name = "signed char";
2987 else if (strcmp (*type_name, "size_t") == 0)
2988 *type_name = "ssize_t";
2989
2990 ret = T_WARN;
2991 break;
2992 }
2993 }
2994 }
2995 }
2996 else if (ts->type == BT_DERIVED)
2997 {
2998 if (ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
2999 {
3000 if (strcmp (ts->u.derived->name, "c_ptr") == 0)
3001 *type_name = "void";
3002 else if (strcmp (ts->u.derived->name, "c_funptr") == 0)
3003 {
3004 *type_name = "int ";
3005 if (func_ret)
3006 {
3007 *pre = "(";
3008 *post = "())";
3009 }
3010 else
3011 {
3012 *pre = "(";
3013 *post = ")()";
3014 }
3015 }
3016 *asterisk = true;
3017 }
3018 else
3019 *type_name = ts->u.derived->name;
3020
3021 ret = T_OK;
3022 }
3023 if (ret != T_ERROR && as)
3024 {
3025 mpz_t sz;
3026 bool size_ok;
3027 size_ok = spec_size (as, &sz);
3028 gcc_assert (size_ok == true);
3029 gmp_snprintf (post_buffer, sizeof(post_buffer), "[%Zd]", sz);
3030 *post = post_buffer;
3031 mpz_clear (sz);
3032 }
3033 return ret;
3034 }
3035
3036 /* Write out a declaration. */
3037 static void
3038 write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
3039 bool func_ret)
3040 {
3041 const char *pre, *type_name, *post;
3042 bool asterisk;
3043 enum type_return rok;
3044
3045 rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret);
3046 gcc_assert (rok != T_ERROR);
3047 fputs (type_name, dumpfile);
3048 fputs (pre, dumpfile);
3049 if (asterisk)
3050 fputs ("*", dumpfile);
3051
3052 fputs (sym_name, dumpfile);
3053 fputs (post, dumpfile);
3054
3055 if (rok == T_WARN)
3056 fputs(" /* WARNING: non-interoperable KIND */", dumpfile);
3057 }
3058
3059 /* Write out an interoperable type. It will be written as a typedef
3060 for a struct. */
3061
3062 static void
3063 write_type (gfc_symbol *sym)
3064 {
3065 gfc_component *c;
3066
3067 fprintf (dumpfile, "typedef struct %s {\n", sym->name);
3068 for (c = sym->components; c; c = c->next)
3069 {
3070 fputs (" ", dumpfile);
3071 write_decl (&(c->ts), c->as, c->name, false);
3072 fputs (";\n", dumpfile);
3073 }
3074
3075 fprintf (dumpfile, "} %s;\n", sym->name);
3076 }
3077
3078 /* Write out a variable. */
3079
3080 static void
3081 write_variable (gfc_symbol *sym)
3082 {
3083 const char *sym_name;
3084
3085 gcc_assert (sym->attr.flavor == FL_VARIABLE);
3086
3087 if (sym->binding_label)
3088 sym_name = sym->binding_label;
3089 else
3090 sym_name = sym->name;
3091
3092 fputs ("extern ", dumpfile);
3093 write_decl (&(sym->ts), sym->as, sym_name, false);
3094 fputs (";\n", dumpfile);
3095 }
3096
3097
3098 /* Write out a procedure, including its arguments. */
3099 static void
3100 write_proc (gfc_symbol *sym)
3101 {
3102 const char *pre, *type_name, *post;
3103 bool asterisk;
3104 enum type_return rok;
3105 gfc_formal_arglist *f;
3106 const char *sym_name;
3107 const char *intent_in;
3108
3109 if (sym->binding_label)
3110 sym_name = sym->binding_label;
3111 else
3112 sym_name = sym->name;
3113
3114 if (sym->ts.type == BT_UNKNOWN)
3115 {
3116 fprintf (dumpfile, "void ");
3117 fputs (sym_name, dumpfile);
3118 }
3119 else
3120 write_decl (&(sym->ts), sym->as, sym->name, true);
3121
3122 fputs (" (", dumpfile);
3123
3124 for (f = sym->formal; f; f = f->next)
3125 {
3126 gfc_symbol *s;
3127 s = f->sym;
3128 rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk,
3129 &post, false);
3130 gcc_assert (rok != T_ERROR);
3131
3132 if (!s->attr.value)
3133 asterisk = true;
3134
3135 if (s->attr.intent == INTENT_IN && !s->attr.value)
3136 intent_in = "const ";
3137 else
3138 intent_in = "";
3139
3140 fputs (intent_in, dumpfile);
3141 fputs (type_name, dumpfile);
3142 fputs (pre, dumpfile);
3143 if (asterisk)
3144 fputs ("*", dumpfile);
3145
3146 fputs (s->name, dumpfile);
3147 fputs (post, dumpfile);
3148 if (rok == T_WARN)
3149 fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile);
3150
3151 fputs (f->next ? ", " : ")", dumpfile);
3152 }
3153 fputs (";\n", dumpfile);
3154 }
3155
3156
3157 /* Write a C-interoperable declaration as a C prototype or extern
3158 declaration. */
3159
3160 static void
3161 write_interop_decl (gfc_symbol *sym)
3162 {
3163 /* Only dump bind(c) entities. */
3164 if (!sym->attr.is_bind_c)
3165 return;
3166
3167 /* Don't dump our iso c module. */
3168 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
3169 return;
3170
3171 if (sym->attr.flavor == FL_VARIABLE)
3172 write_variable (sym);
3173 else if (sym->attr.flavor == FL_DERIVED)
3174 write_type (sym);
3175 else if (sym->attr.flavor == FL_PROCEDURE)
3176 write_proc (sym);
3177 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org