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