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