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