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