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