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