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