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