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