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