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