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