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