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