projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Update ChangeLogs for wide-int work.
[gcc.git] / gcc / fortran / dump-parse-tree.c
1 /* Parse tree dumper
2 Copyright (C) 2003-2014 Free Software Foundation, Inc.
3 Contributed by Steven Bosscher
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21
22 /* Actually this is just a collection of routines that used to be
23 scattered around the sources. Now that they are all in a single
24 file, almost all of them can be static, and the other files don't
25 have this mess in them.
26
27 As a nice side-effect, this file can act as documentation of the
28 gfc_code and gfc_expr structures and all their friends and
29 relatives.
30
31 TODO: Dump DATA. */
32
33 #include "config.h"
34 #include "system.h"
35 #include "coretypes.h"
36 #include "gfortran.h"
37 #include "constructor.h"
38
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
51
52 /* Allow dumping of an expression in the debugger. */
53 void gfc_debug_expr (gfc_expr *);
54
55 void
56 gfc_debug_expr (gfc_expr *e)
57 {
58 FILE *tmp = dumpfile;
59 dumpfile = stderr;
60 show_expr (e);
61 fputc ('\n', dumpfile);
62 dumpfile = tmp;
63 }
64
65
66 /* Do indentation for a specific level. */
67
68 static inline void
69 code_indent (int level, gfc_st_label *label)
70 {
71 int i;
72
73 if (label != NULL)
74 fprintf (dumpfile, "%-5d ", label->value);
75
76 for (i = 0; i < (2 * level - (label ? 6 : 0)); i++)
77 fputc (' ', dumpfile);
78 }
79
80
81 /* Simple indentation at the current level. This one
82 is used to show symbols. */
83
84 static inline void
85 show_indent (void)
86 {
87 fputc ('\n', dumpfile);
88 code_indent (show_level, NULL);
89 }
90
91
92 /* Show type-specific information. */
93
94 static void
95 show_typespec (gfc_typespec *ts)
96 {
97 if (ts->type == BT_ASSUMED)
98 {
99 fputs ("(TYPE(*))", dumpfile);
100 return;
101 }
102
103 fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
104
105 switch (ts->type)
106 {
107 case BT_DERIVED:
108 case BT_CLASS:
109 fprintf (dumpfile, "%s", ts->u.derived->name);
110 break;
111
112 case BT_CHARACTER:
113 if (ts->u.cl)
114 show_expr (ts->u.cl->length);
115 fprintf(dumpfile, " %d", ts->kind);
116 break;
117
118 default:
119 fprintf (dumpfile, "%d", ts->kind);
120 break;
121 }
122
123 fputc (')', dumpfile);
124 }
125
126
127 /* Show an actual argument list. */
128
129 static void
130 show_actual_arglist (gfc_actual_arglist *a)
131 {
132 fputc ('(', dumpfile);
133
134 for (; a; a = a->next)
135 {
136 fputc ('(', dumpfile);
137 if (a->name != NULL)
138 fprintf (dumpfile, "%s = ", a->name);
139 if (a->expr != NULL)
140 show_expr (a->expr);
141 else
142 fputs ("(arg not-present)", dumpfile);
143
144 fputc (')', dumpfile);
145 if (a->next != NULL)
146 fputc (' ', dumpfile);
147 }
148
149 fputc (')', dumpfile);
150 }
151
152
153 /* Show a gfc_array_spec array specification structure. */
154
155 static void
156 show_array_spec (gfc_array_spec *as)
157 {
158 const char *c;
159 int i;
160
161 if (as == NULL)
162 {
163 fputs ("()", dumpfile);
164 return;
165 }
166
167 fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
168
169 if (as->rank + as->corank > 0 || as->rank == -1)
170 {
171 switch (as->type)
172 {
173 case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
174 case AS_DEFERRED: c = "AS_DEFERRED"; break;
175 case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
176 case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
177 case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break;
178 default:
179 gfc_internal_error ("show_array_spec(): Unhandled array shape "
180 "type.");
181 }
182 fprintf (dumpfile, " %s ", c);
183
184 for (i = 0; i < as->rank + as->corank; i++)
185 {
186 show_expr (as->lower[i]);
187 fputc (' ', dumpfile);
188 show_expr (as->upper[i]);
189 fputc (' ', dumpfile);
190 }
191 }
192
193 fputc (')', dumpfile);
194 }
195
196
197 /* Show a gfc_array_ref array reference structure. */
198
199 static void
200 show_array_ref (gfc_array_ref * ar)
201 {
202 int i;
203
204 fputc ('(', dumpfile);
205
206 switch (ar->type)
207 {
208 case AR_FULL:
209 fputs ("FULL", dumpfile);
210 break;
211
212 case AR_SECTION:
213 for (i = 0; i < ar->dimen; i++)
214 {
215 /* There are two types of array sections: either the
216 elements are identified by an integer array ('vector'),
217 or by an index range. In the former case we only have to
218 print the start expression which contains the vector, in
219 the latter case we have to print any of lower and upper
220 bound and the stride, if they're present. */
221
222 if (ar->start[i] != NULL)
223 show_expr (ar->start[i]);
224
225 if (ar->dimen_type[i] == DIMEN_RANGE)
226 {
227 fputc (':', dumpfile);
228
229 if (ar->end[i] != NULL)
230 show_expr (ar->end[i]);
231
232 if (ar->stride[i] != NULL)
233 {
234 fputc (':', dumpfile);
235 show_expr (ar->stride[i]);
236 }
237 }
238
239 if (i != ar->dimen - 1)
240 fputs (" , ", dumpfile);
241 }
242 break;
243
244 case AR_ELEMENT:
245 for (i = 0; i < ar->dimen; i++)
246 {
247 show_expr (ar->start[i]);
248 if (i != ar->dimen - 1)
249 fputs (" , ", dumpfile);
250 }
251 break;
252
253 case AR_UNKNOWN:
254 fputs ("UNKNOWN", dumpfile);
255 break;
256
257 default:
258 gfc_internal_error ("show_array_ref(): Unknown array reference");
259 }
260
261 fputc (')', dumpfile);
262 }
263
264
265 /* Show a list of gfc_ref structures. */
266
267 static void
268 show_ref (gfc_ref *p)
269 {
270 for (; p; p = p->next)
271 switch (p->type)
272 {
273 case REF_ARRAY:
274 show_array_ref (&p->u.ar);
275 break;
276
277 case REF_COMPONENT:
278 fprintf (dumpfile, " %% %s", p->u.c.component->name);
279 break;
280
281 case REF_SUBSTRING:
282 fputc ('(', dumpfile);
283 show_expr (p->u.ss.start);
284 fputc (':', dumpfile);
285 show_expr (p->u.ss.end);
286 fputc (')', dumpfile);
287 break;
288
289 default:
290 gfc_internal_error ("show_ref(): Bad component code");
291 }
292 }
293
294
295 /* Display a constructor. Works recursively for array constructors. */
296
297 static void
298 show_constructor (gfc_constructor_base base)
299 {
300 gfc_constructor *c;
301 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
302 {
303 if (c->iterator == NULL)
304 show_expr (c->expr);
305 else
306 {
307 fputc ('(', dumpfile);
308 show_expr (c->expr);
309
310 fputc (' ', dumpfile);
311 show_expr (c->iterator->var);
312 fputc ('=', dumpfile);
313 show_expr (c->iterator->start);
314 fputc (',', dumpfile);
315 show_expr (c->iterator->end);
316 fputc (',', dumpfile);
317 show_expr (c->iterator->step);
318
319 fputc (')', dumpfile);
320 }
321
322 if (gfc_constructor_next (c) != NULL)
323 fputs (" , ", dumpfile);
324 }
325 }
326
327
328 static void
329 show_char_const (const gfc_char_t *c, int length)
330 {
331 int i;
332
333 fputc ('\'', dumpfile);
334 for (i = 0; i < length; i++)
335 {
336 if (c[i] == '\'')
337 fputs ("''", dumpfile);
338 else
339 fputs (gfc_print_wide_char (c[i]), dumpfile);
340 }
341 fputc ('\'', dumpfile);
342 }
343
344
345 /* Show a component-call expression. */
346
347 static void
348 show_compcall (gfc_expr* p)
349 {
350 gcc_assert (p->expr_type == EXPR_COMPCALL);
351
352 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
353 show_ref (p->ref);
354 fprintf (dumpfile, "%s", p->value.compcall.name);
355
356 show_actual_arglist (p->value.compcall.actual);
357 }
358
359
360 /* Show an expression. */
361
362 static void
363 show_expr (gfc_expr *p)
364 {
365 const char *c;
366 int i;
367
368 if (p == NULL)
369 {
370 fputs ("()", dumpfile);
371 return;
372 }
373
374 switch (p->expr_type)
375 {
376 case EXPR_SUBSTRING:
377 show_char_const (p->value.character.string, p->value.character.length);
378 show_ref (p->ref);
379 break;
380
381 case EXPR_STRUCTURE:
382 fprintf (dumpfile, "%s(", p->ts.u.derived->name);
383 show_constructor (p->value.constructor);
384 fputc (')', dumpfile);
385 break;
386
387 case EXPR_ARRAY:
388 fputs ("(/ ", dumpfile);
389 show_constructor (p->value.constructor);
390 fputs (" /)", dumpfile);
391
392 show_ref (p->ref);
393 break;
394
395 case EXPR_NULL:
396 fputs ("NULL()", dumpfile);
397 break;
398
399 case EXPR_CONSTANT:
400 switch (p->ts.type)
401 {
402 case BT_INTEGER:
403 mpz_out_str (stdout, 10, p->value.integer);
404
405 if (p->ts.kind != gfc_default_integer_kind)
406 fprintf (dumpfile, "_%d", p->ts.kind);
407 break;
408
409 case BT_LOGICAL:
410 if (p->value.logical)
411 fputs (".true.", dumpfile);
412 else
413 fputs (".false.", dumpfile);
414 break;
415
416 case BT_REAL:
417 mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
418 if (p->ts.kind != gfc_default_real_kind)
419 fprintf (dumpfile, "_%d", p->ts.kind);
420 break;
421
422 case BT_CHARACTER:
423 show_char_const (p->value.character.string,
424 p->value.character.length);
425 break;
426
427 case BT_COMPLEX:
428 fputs ("(complex ", dumpfile);
429
430 mpfr_out_str (stdout, 10, 0, mpc_realref (p->value.complex),
431 GFC_RND_MODE);
432 if (p->ts.kind != gfc_default_complex_kind)
433 fprintf (dumpfile, "_%d", p->ts.kind);
434
435 fputc (' ', dumpfile);
436
437 mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
438 GFC_RND_MODE);
439 if (p->ts.kind != gfc_default_complex_kind)
440 fprintf (dumpfile, "_%d", p->ts.kind);
441
442 fputc (')', dumpfile);
443 break;
444
445 case BT_HOLLERITH:
446 fprintf (dumpfile, "%dH", p->representation.length);
447 c = p->representation.string;
448 for (i = 0; i < p->representation.length; i++, c++)
449 {
450 fputc (*c, dumpfile);
451 }
452 break;
453
454 default:
455 fputs ("???", dumpfile);
456 break;
457 }
458
459 if (p->representation.string)
460 {
461 fputs (" {", dumpfile);
462 c = p->representation.string;
463 for (i = 0; i < p->representation.length; i++, c++)
464 {
465 fprintf (dumpfile, "%.2x", (unsigned int) *c);
466 if (i < p->representation.length - 1)
467 fputc (',', dumpfile);
468 }
469 fputc ('}', dumpfile);
470 }
471
472 break;
473
474 case EXPR_VARIABLE:
475 if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
476 fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
477 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
478 show_ref (p->ref);
479 break;
480
481 case EXPR_OP:
482 fputc ('(', dumpfile);
483 switch (p->value.op.op)
484 {
485 case INTRINSIC_UPLUS:
486 fputs ("U+ ", dumpfile);
487 break;
488 case INTRINSIC_UMINUS:
489 fputs ("U- ", dumpfile);
490 break;
491 case INTRINSIC_PLUS:
492 fputs ("+ ", dumpfile);
493 break;
494 case INTRINSIC_MINUS:
495 fputs ("- ", dumpfile);
496 break;
497 case INTRINSIC_TIMES:
498 fputs ("* ", dumpfile);
499 break;
500 case INTRINSIC_DIVIDE:
501 fputs ("/ ", dumpfile);
502 break;
503 case INTRINSIC_POWER:
504 fputs ("** ", dumpfile);
505 break;
506 case INTRINSIC_CONCAT:
507 fputs ("// ", dumpfile);
508 break;
509 case INTRINSIC_AND:
510 fputs ("AND ", dumpfile);
511 break;
512 case INTRINSIC_OR:
513 fputs ("OR ", dumpfile);
514 break;
515 case INTRINSIC_EQV:
516 fputs ("EQV ", dumpfile);
517 break;
518 case INTRINSIC_NEQV:
519 fputs ("NEQV ", dumpfile);
520 break;
521 case INTRINSIC_EQ:
522 case INTRINSIC_EQ_OS:
523 fputs ("= ", dumpfile);
524 break;
525 case INTRINSIC_NE:
526 case INTRINSIC_NE_OS:
527 fputs ("/= ", dumpfile);
528 break;
529 case INTRINSIC_GT:
530 case INTRINSIC_GT_OS:
531 fputs ("> ", dumpfile);
532 break;
533 case INTRINSIC_GE:
534 case INTRINSIC_GE_OS:
535 fputs (">= ", dumpfile);
536 break;
537 case INTRINSIC_LT:
538 case INTRINSIC_LT_OS:
539 fputs ("< ", dumpfile);
540 break;
541 case INTRINSIC_LE:
542 case INTRINSIC_LE_OS:
543 fputs ("<= ", dumpfile);
544 break;
545 case INTRINSIC_NOT:
546 fputs ("NOT ", dumpfile);
547 break;
548 case INTRINSIC_PARENTHESES:
549 fputs ("parens ", dumpfile);
550 break;
551
552 default:
553 gfc_internal_error
554 ("show_expr(): Bad intrinsic in expression!");
555 }
556
557 show_expr (p->value.op.op1);
558
559 if (p->value.op.op2)
560 {
561 fputc (' ', dumpfile);
562 show_expr (p->value.op.op2);
563 }
564
565 fputc (')', dumpfile);
566 break;
567
568 case EXPR_FUNCTION:
569 if (p->value.function.name == NULL)
570 {
571 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
572 if (gfc_is_proc_ptr_comp (p))
573 show_ref (p->ref);
574 fputc ('[', dumpfile);
575 show_actual_arglist (p->value.function.actual);
576 fputc (']', dumpfile);
577 }
578 else
579 {
580 fprintf (dumpfile, "%s", p->value.function.name);
581 if (gfc_is_proc_ptr_comp (p))
582 show_ref (p->ref);
583 fputc ('[', dumpfile);
584 fputc ('[', dumpfile);
585 show_actual_arglist (p->value.function.actual);
586 fputc (']', dumpfile);
587 fputc (']', dumpfile);
588 }
589
590 break;
591
592 case EXPR_COMPCALL:
593 show_compcall (p);
594 break;
595
596 default:
597 gfc_internal_error ("show_expr(): Don't know how to show expr");
598 }
599 }
600
601 /* Show symbol attributes. The flavor and intent are followed by
602 whatever single bit attributes are present. */
603
604 static void
605 show_attr (symbol_attribute *attr, const char * module)
606 {
607 if (attr->flavor != FL_UNKNOWN)
608 fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor));
609 if (attr->access != ACCESS_UNKNOWN)
610 fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access));
611 if (attr->proc != PROC_UNKNOWN)
612 fprintf (dumpfile, "%s ", gfc_code2string (procedures, attr->proc));
613 if (attr->save != SAVE_NONE)
614 fprintf (dumpfile, "%s", gfc_code2string (save_status, attr->save));
615
616 if (attr->artificial)
617 fputs (" ARTIFICIAL", dumpfile);
618 if (attr->allocatable)
619 fputs (" ALLOCATABLE", dumpfile);
620 if (attr->asynchronous)
621 fputs (" ASYNCHRONOUS", dumpfile);
622 if (attr->codimension)
623 fputs (" CODIMENSION", dumpfile);
624 if (attr->dimension)
625 fputs (" DIMENSION", dumpfile);
626 if (attr->contiguous)
627 fputs (" CONTIGUOUS", dumpfile);
628 if (attr->external)
629 fputs (" EXTERNAL", dumpfile);
630 if (attr->intrinsic)
631 fputs (" INTRINSIC", dumpfile);
632 if (attr->optional)
633 fputs (" OPTIONAL", dumpfile);
634 if (attr->pointer)
635 fputs (" POINTER", dumpfile);
636 if (attr->is_protected)
637 fputs (" PROTECTED", dumpfile);
638 if (attr->value)
639 fputs (" VALUE", dumpfile);
640 if (attr->volatile_)
641 fputs (" VOLATILE", dumpfile);
642 if (attr->threadprivate)
643 fputs (" THREADPRIVATE", dumpfile);
644 if (attr->target)
645 fputs (" TARGET", dumpfile);
646 if (attr->dummy)
647 {
648 fputs (" DUMMY", dumpfile);
649 if (attr->intent != INTENT_UNKNOWN)
650 fprintf (dumpfile, "(%s)", gfc_intent_string (attr->intent));
651 }
652
653 if (attr->result)
654 fputs (" RESULT", dumpfile);
655 if (attr->entry)
656 fputs (" ENTRY", dumpfile);
657 if (attr->is_bind_c)
658 fputs (" BIND(C)", dumpfile);
659
660 if (attr->data)
661 fputs (" DATA", dumpfile);
662 if (attr->use_assoc)
663 {
664 fputs (" USE-ASSOC", dumpfile);
665 if (module != NULL)
666 fprintf (dumpfile, "(%s)", module);
667 }
668
669 if (attr->in_namelist)
670 fputs (" IN-NAMELIST", dumpfile);
671 if (attr->in_common)
672 fputs (" IN-COMMON", dumpfile);
673
674 if (attr->abstract)
675 fputs (" ABSTRACT", dumpfile);
676 if (attr->function)
677 fputs (" FUNCTION", dumpfile);
678 if (attr->subroutine)
679 fputs (" SUBROUTINE", dumpfile);
680 if (attr->implicit_type)
681 fputs (" IMPLICIT-TYPE", dumpfile);
682
683 if (attr->sequence)
684 fputs (" SEQUENCE", dumpfile);
685 if (attr->elemental)
686 fputs (" ELEMENTAL", dumpfile);
687 if (attr->pure)
688 fputs (" PURE", dumpfile);
689 if (attr->recursive)
690 fputs (" RECURSIVE", dumpfile);
691
692 fputc (')', dumpfile);
693 }
694
695
696 /* Show components of a derived type. */
697
698 static void
699 show_components (gfc_symbol *sym)
700 {
701 gfc_component *c;
702
703 for (c = sym->components; c; c = c->next)
704 {
705 fprintf (dumpfile, "(%s ", c->name);
706 show_typespec (&c->ts);
707 if (c->attr.allocatable)
708 fputs (" ALLOCATABLE", dumpfile);
709 if (c->attr.pointer)
710 fputs (" POINTER", dumpfile);
711 if (c->attr.proc_pointer)
712 fputs (" PPC", dumpfile);
713 if (c->attr.dimension)
714 fputs (" DIMENSION", dumpfile);
715 fputc (' ', dumpfile);
716 show_array_spec (c->as);
717 if (c->attr.access)
718 fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
719 fputc (')', dumpfile);
720 if (c->next != NULL)
721 fputc (' ', dumpfile);
722 }
723 }
724
725
726 /* Show the f2k_derived namespace with procedure bindings. */
727
728 static void
729 show_typebound_proc (gfc_typebound_proc* tb, const char* name)
730 {
731 show_indent ();
732
733 if (tb->is_generic)
734 fputs ("GENERIC", dumpfile);
735 else
736 {
737 fputs ("PROCEDURE, ", dumpfile);
738 if (tb->nopass)
739 fputs ("NOPASS", dumpfile);
740 else
741 {
742 if (tb->pass_arg)
743 fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
744 else
745 fputs ("PASS", dumpfile);
746 }
747 if (tb->non_overridable)
748 fputs (", NON_OVERRIDABLE", dumpfile);
749 }
750
751 if (tb->access == ACCESS_PUBLIC)
752 fputs (", PUBLIC", dumpfile);
753 else
754 fputs (", PRIVATE", dumpfile);
755
756 fprintf (dumpfile, " :: %s => ", name);
757
758 if (tb->is_generic)
759 {
760 gfc_tbp_generic* g;
761 for (g = tb->u.generic; g; g = g->next)
762 {
763 fputs (g->specific_st->name, dumpfile);
764 if (g->next)
765 fputs (", ", dumpfile);
766 }
767 }
768 else
769 fputs (tb->u.specific->n.sym->name, dumpfile);
770 }
771
772 static void
773 show_typebound_symtree (gfc_symtree* st)
774 {
775 gcc_assert (st->n.tb);
776 show_typebound_proc (st->n.tb, st->name);
777 }
778
779 static void
780 show_f2k_derived (gfc_namespace* f2k)
781 {
782 gfc_finalizer* f;
783 int op;
784
785 show_indent ();
786 fputs ("Procedure bindings:", dumpfile);
787 ++show_level;
788
789 /* Finalizer bindings. */
790 for (f = f2k->finalizers; f; f = f->next)
791 {
792 show_indent ();
793 fprintf (dumpfile, "FINAL %s", f->proc_tree->n.sym->name);
794 }
795
796 /* Type-bound procedures. */
797 gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
798
799 --show_level;
800
801 show_indent ();
802 fputs ("Operator bindings:", dumpfile);
803 ++show_level;
804
805 /* User-defined operators. */
806 gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
807
808 /* Intrinsic operators. */
809 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
810 if (f2k->tb_op[op])
811 show_typebound_proc (f2k->tb_op[op],
812 gfc_op2string ((gfc_intrinsic_op) op));
813
814 --show_level;
815 }
816
817
818 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
819 show the interface. Information needed to reconstruct the list of
820 specific interfaces associated with a generic symbol is done within
821 that symbol. */
822
823 static void
824 show_symbol (gfc_symbol *sym)
825 {
826 gfc_formal_arglist *formal;
827 gfc_interface *intr;
828 int i,len;
829
830 if (sym == NULL)
831 return;
832
833 fprintf (dumpfile, "|| symbol: '%s' ", sym->name);
834 len = strlen (sym->name);
835 for (i=len; i<12; i++)
836 fputc(' ', dumpfile);
837
838 ++show_level;
839
840 show_indent ();
841 fputs ("type spec : ", dumpfile);
842 show_typespec (&sym->ts);
843
844 show_indent ();
845 fputs ("attributes: ", dumpfile);
846 show_attr (&sym->attr, sym->module);
847
848 if (sym->value)
849 {
850 show_indent ();
851 fputs ("value: ", dumpfile);
852 show_expr (sym->value);
853 }
854
855 if (sym->as)
856 {
857 show_indent ();
858 fputs ("Array spec:", dumpfile);
859 show_array_spec (sym->as);
860 }
861
862 if (sym->generic)
863 {
864 show_indent ();
865 fputs ("Generic interfaces:", dumpfile);
866 for (intr = sym->generic; intr; intr = intr->next)
867 fprintf (dumpfile, " %s", intr->sym->name);
868 }
869
870 if (sym->result)
871 {
872 show_indent ();
873 fprintf (dumpfile, "result: %s", sym->result->name);
874 }
875
876 if (sym->components)
877 {
878 show_indent ();
879 fputs ("components: ", dumpfile);
880 show_components (sym);
881 }
882
883 if (sym->f2k_derived)
884 {
885 show_indent ();
886 if (sym->hash_value)
887 fprintf (dumpfile, "hash: %d", sym->hash_value);
888 show_f2k_derived (sym->f2k_derived);
889 }
890
891 if (sym->formal)
892 {
893 show_indent ();
894 fputs ("Formal arglist:", dumpfile);
895
896 for (formal = sym->formal; formal; formal = formal->next)
897 {
898 if (formal->sym != NULL)
899 fprintf (dumpfile, " %s", formal->sym->name);
900 else
901 fputs (" [Alt Return]", dumpfile);
902 }
903 }
904
905 if (sym->formal_ns && (sym->formal_ns->proc_name != sym)
906 && sym->attr.proc != PROC_ST_FUNCTION
907 && !sym->attr.entry)
908 {
909 show_indent ();
910 fputs ("Formal namespace", dumpfile);
911 show_namespace (sym->formal_ns);
912 }
913 --show_level;
914 }
915
916
917 /* Show a user-defined operator. Just prints an operator
918 and the name of the associated subroutine, really. */
919
920 static void
921 show_uop (gfc_user_op *uop)
922 {
923 gfc_interface *intr;
924
925 show_indent ();
926 fprintf (dumpfile, "%s:", uop->name);
927
928 for (intr = uop->op; intr; intr = intr->next)
929 fprintf (dumpfile, " %s", intr->sym->name);
930 }
931
932
933 /* Workhorse function for traversing the user operator symtree. */
934
935 static void
936 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
937 {
938 if (st == NULL)
939 return;
940
941 (*func) (st->n.uop);
942
943 traverse_uop (st->left, func);
944 traverse_uop (st->right, func);
945 }
946
947
948 /* Traverse the tree of user operator nodes. */
949
950 void
951 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
952 {
953 traverse_uop (ns->uop_root, func);
954 }
955
956
957 /* Function to display a common block. */
958
959 static void
960 show_common (gfc_symtree *st)
961 {
962 gfc_symbol *s;
963
964 show_indent ();
965 fprintf (dumpfile, "common: /%s/ ", st->name);
966
967 s = st->n.common->head;
968 while (s)
969 {
970 fprintf (dumpfile, "%s", s->name);
971 s = s->common_next;
972 if (s)
973 fputs (", ", dumpfile);
974 }
975 fputc ('\n', dumpfile);
976 }
977
978
979 /* Worker function to display the symbol tree. */
980
981 static void
982 show_symtree (gfc_symtree *st)
983 {
984 int len, i;
985
986 show_indent ();
987
988 len = strlen(st->name);
989 fprintf (dumpfile, "symtree: '%s'", st->name);
990
991 for (i=len; i<12; i++)
992 fputc(' ', dumpfile);
993
994 if (st->ambiguous)
995 fputs( " Ambiguous", dumpfile);
996
997 if (st->n.sym->ns != gfc_current_ns)
998 fprintf (dumpfile, "|| symbol: '%s' from namespace '%s'", st->n.sym->name,
999 st->n.sym->ns->proc_name->name);
1000 else
1001 show_symbol (st->n.sym);
1002 }
1003
1004
1005 /******************* Show gfc_code structures **************/
1006
1007
1008 /* Show a list of code structures. Mutually recursive with
1009 show_code_node(). */
1010
1011 static void
1012 show_code (int level, gfc_code *c)
1013 {
1014 for (; c; c = c->next)
1015 show_code_node (level, c);
1016 }
1017
1018 static void
1019 show_namelist (gfc_namelist *n)
1020 {
1021 for (; n->next; n = n->next)
1022 fprintf (dumpfile, "%s,", n->sym->name);
1023 fprintf (dumpfile, "%s", n->sym->name);
1024 }
1025
1026 /* Show a single OpenMP directive node and everything underneath it
1027 if necessary. */
1028
1029 static void
1030 show_omp_node (int level, gfc_code *c)
1031 {
1032 gfc_omp_clauses *omp_clauses = NULL;
1033 const char *name = NULL;
1034
1035 switch (c->op)
1036 {
1037 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
1038 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
1039 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
1040 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
1041 case EXEC_OMP_DO: name = "DO"; break;
1042 case EXEC_OMP_MASTER: name = "MASTER"; break;
1043 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
1044 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
1045 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
1046 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
1047 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
1048 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
1049 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
1050 case EXEC_OMP_TASK: name = "TASK"; break;
1051 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
1052 case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
1053 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
1054 default:
1055 gcc_unreachable ();
1056 }
1057 fprintf (dumpfile, "!$OMP %s", name);
1058 switch (c->op)
1059 {
1060 case EXEC_OMP_DO:
1061 case EXEC_OMP_PARALLEL:
1062 case EXEC_OMP_PARALLEL_DO:
1063 case EXEC_OMP_PARALLEL_SECTIONS:
1064 case EXEC_OMP_SECTIONS:
1065 case EXEC_OMP_SINGLE:
1066 case EXEC_OMP_WORKSHARE:
1067 case EXEC_OMP_PARALLEL_WORKSHARE:
1068 case EXEC_OMP_TASK:
1069 omp_clauses = c->ext.omp_clauses;
1070 break;
1071 case EXEC_OMP_CRITICAL:
1072 if (c->ext.omp_name)
1073 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1074 break;
1075 case EXEC_OMP_FLUSH:
1076 if (c->ext.omp_namelist)
1077 {
1078 fputs (" (", dumpfile);
1079 show_namelist (c->ext.omp_namelist);
1080 fputc (')', dumpfile);
1081 }
1082 return;
1083 case EXEC_OMP_BARRIER:
1084 case EXEC_OMP_TASKWAIT:
1085 case EXEC_OMP_TASKYIELD:
1086 return;
1087 default:
1088 break;
1089 }
1090 if (omp_clauses)
1091 {
1092 int list_type;
1093
1094 if (omp_clauses->if_expr)
1095 {
1096 fputs (" IF(", dumpfile);
1097 show_expr (omp_clauses->if_expr);
1098 fputc (')', dumpfile);
1099 }
1100 if (omp_clauses->final_expr)
1101 {
1102 fputs (" FINAL(", dumpfile);
1103 show_expr (omp_clauses->final_expr);
1104 fputc (')', dumpfile);
1105 }
1106 if (omp_clauses->num_threads)
1107 {
1108 fputs (" NUM_THREADS(", dumpfile);
1109 show_expr (omp_clauses->num_threads);
1110 fputc (')', dumpfile);
1111 }
1112 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1113 {
1114 const char *type;
1115 switch (omp_clauses->sched_kind)
1116 {
1117 case OMP_SCHED_STATIC: type = "STATIC"; break;
1118 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1119 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1120 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1121 case OMP_SCHED_AUTO: type = "AUTO"; break;
1122 default:
1123 gcc_unreachable ();
1124 }
1125 fprintf (dumpfile, " SCHEDULE (%s", type);
1126 if (omp_clauses->chunk_size)
1127 {
1128 fputc (',', dumpfile);
1129 show_expr (omp_clauses->chunk_size);
1130 }
1131 fputc (')', dumpfile);
1132 }
1133 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1134 {
1135 const char *type;
1136 switch (omp_clauses->default_sharing)
1137 {
1138 case OMP_DEFAULT_NONE: type = "NONE"; break;
1139 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1140 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1141 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1142 default:
1143 gcc_unreachable ();
1144 }
1145 fprintf (dumpfile, " DEFAULT(%s)", type);
1146 }
1147 if (omp_clauses->ordered)
1148 fputs (" ORDERED", dumpfile);
1149 if (omp_clauses->untied)
1150 fputs (" UNTIED", dumpfile);
1151 if (omp_clauses->mergeable)
1152 fputs (" MERGEABLE", dumpfile);
1153 if (omp_clauses->collapse)
1154 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1155 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1156 if (omp_clauses->lists[list_type] != NULL
1157 && list_type != OMP_LIST_COPYPRIVATE)
1158 {
1159 const char *type;
1160 if (list_type >= OMP_LIST_REDUCTION_FIRST)
1161 {
1162 switch (list_type)
1163 {
1164 case OMP_LIST_PLUS: type = "+"; break;
1165 case OMP_LIST_MULT: type = "*"; break;
1166 case OMP_LIST_SUB: type = "-"; break;
1167 case OMP_LIST_AND: type = ".AND."; break;
1168 case OMP_LIST_OR: type = ".OR."; break;
1169 case OMP_LIST_EQV: type = ".EQV."; break;
1170 case OMP_LIST_NEQV: type = ".NEQV."; break;
1171 case OMP_LIST_MAX: type = "MAX"; break;
1172 case OMP_LIST_MIN: type = "MIN"; break;
1173 case OMP_LIST_IAND: type = "IAND"; break;
1174 case OMP_LIST_IOR: type = "IOR"; break;
1175 case OMP_LIST_IEOR: type = "IEOR"; break;
1176 default:
1177 gcc_unreachable ();
1178 }
1179 fprintf (dumpfile, " REDUCTION(%s:", type);
1180 }
1181 else
1182 {
1183 switch (list_type)
1184 {
1185 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1186 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1187 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1188 case OMP_LIST_SHARED: type = "SHARED"; break;
1189 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1190 default:
1191 gcc_unreachable ();
1192 }
1193 fprintf (dumpfile, " %s(", type);
1194 }
1195 show_namelist (omp_clauses->lists[list_type]);
1196 fputc (')', dumpfile);
1197 }
1198 }
1199 fputc ('\n', dumpfile);
1200 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1201 {
1202 gfc_code *d = c->block;
1203 while (d != NULL)
1204 {
1205 show_code (level + 1, d->next);
1206 if (d->block == NULL)
1207 break;
1208 code_indent (level, 0);
1209 fputs ("!$OMP SECTION\n", dumpfile);
1210 d = d->block;
1211 }
1212 }
1213 else
1214 show_code (level + 1, c->block->next);
1215 if (c->op == EXEC_OMP_ATOMIC)
1216 return;
1217 code_indent (level, 0);
1218 fprintf (dumpfile, "!$OMP END %s", name);
1219 if (omp_clauses != NULL)
1220 {
1221 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1222 {
1223 fputs (" COPYPRIVATE(", dumpfile);
1224 show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1225 fputc (')', dumpfile);
1226 }
1227 else if (omp_clauses->nowait)
1228 fputs (" NOWAIT", dumpfile);
1229 }
1230 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1231 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1232 }
1233
1234
1235 /* Show a single code node and everything underneath it if necessary. */
1236
1237 static void
1238 show_code_node (int level, gfc_code *c)
1239 {
1240 gfc_forall_iterator *fa;
1241 gfc_open *open;
1242 gfc_case *cp;
1243 gfc_alloc *a;
1244 gfc_code *d;
1245 gfc_close *close;
1246 gfc_filepos *fp;
1247 gfc_inquire *i;
1248 gfc_dt *dt;
1249 gfc_namespace *ns;
1250
1251 if (c->here)
1252 {
1253 fputc ('\n', dumpfile);
1254 code_indent (level, c->here);
1255 }
1256 else
1257 show_indent ();
1258
1259 switch (c->op)
1260 {
1261 case EXEC_END_PROCEDURE:
1262 break;
1263
1264 case EXEC_NOP:
1265 fputs ("NOP", dumpfile);
1266 break;
1267
1268 case EXEC_CONTINUE:
1269 fputs ("CONTINUE", dumpfile);
1270 break;
1271
1272 case EXEC_ENTRY:
1273 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1274 break;
1275
1276 case EXEC_INIT_ASSIGN:
1277 case EXEC_ASSIGN:
1278 fputs ("ASSIGN ", dumpfile);
1279 show_expr (c->expr1);
1280 fputc (' ', dumpfile);
1281 show_expr (c->expr2);
1282 break;
1283
1284 case EXEC_LABEL_ASSIGN:
1285 fputs ("LABEL ASSIGN ", dumpfile);
1286 show_expr (c->expr1);
1287 fprintf (dumpfile, " %d", c->label1->value);
1288 break;
1289
1290 case EXEC_POINTER_ASSIGN:
1291 fputs ("POINTER ASSIGN ", dumpfile);
1292 show_expr (c->expr1);
1293 fputc (' ', dumpfile);
1294 show_expr (c->expr2);
1295 break;
1296
1297 case EXEC_GOTO:
1298 fputs ("GOTO ", dumpfile);
1299 if (c->label1)
1300 fprintf (dumpfile, "%d", c->label1->value);
1301 else
1302 {
1303 show_expr (c->expr1);
1304 d = c->block;
1305 if (d != NULL)
1306 {
1307 fputs (", (", dumpfile);
1308 for (; d; d = d ->block)
1309 {
1310 code_indent (level, d->label1);
1311 if (d->block != NULL)
1312 fputc (',', dumpfile);
1313 else
1314 fputc (')', dumpfile);
1315 }
1316 }
1317 }
1318 break;
1319
1320 case EXEC_CALL:
1321 case EXEC_ASSIGN_CALL:
1322 if (c->resolved_sym)
1323 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1324 else if (c->symtree)
1325 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1326 else
1327 fputs ("CALL ?? ", dumpfile);
1328
1329 show_actual_arglist (c->ext.actual);
1330 break;
1331
1332 case EXEC_COMPCALL:
1333 fputs ("CALL ", dumpfile);
1334 show_compcall (c->expr1);
1335 break;
1336
1337 case EXEC_CALL_PPC:
1338 fputs ("CALL ", dumpfile);
1339 show_expr (c->expr1);
1340 show_actual_arglist (c->ext.actual);
1341 break;
1342
1343 case EXEC_RETURN:
1344 fputs ("RETURN ", dumpfile);
1345 if (c->expr1)
1346 show_expr (c->expr1);
1347 break;
1348
1349 case EXEC_PAUSE:
1350 fputs ("PAUSE ", dumpfile);
1351
1352 if (c->expr1 != NULL)
1353 show_expr (c->expr1);
1354 else
1355 fprintf (dumpfile, "%d", c->ext.stop_code);
1356
1357 break;
1358
1359 case EXEC_ERROR_STOP:
1360 fputs ("ERROR ", dumpfile);
1361 /* Fall through. */
1362
1363 case EXEC_STOP:
1364 fputs ("STOP ", dumpfile);
1365
1366 if (c->expr1 != NULL)
1367 show_expr (c->expr1);
1368 else
1369 fprintf (dumpfile, "%d", c->ext.stop_code);
1370
1371 break;
1372
1373 case EXEC_SYNC_ALL:
1374 fputs ("SYNC ALL ", dumpfile);
1375 if (c->expr2 != NULL)
1376 {
1377 fputs (" stat=", dumpfile);
1378 show_expr (c->expr2);
1379 }
1380 if (c->expr3 != NULL)
1381 {
1382 fputs (" errmsg=", dumpfile);
1383 show_expr (c->expr3);
1384 }
1385 break;
1386
1387 case EXEC_SYNC_MEMORY:
1388 fputs ("SYNC MEMORY ", dumpfile);
1389 if (c->expr2 != NULL)
1390 {
1391 fputs (" stat=", dumpfile);
1392 show_expr (c->expr2);
1393 }
1394 if (c->expr3 != NULL)
1395 {
1396 fputs (" errmsg=", dumpfile);
1397 show_expr (c->expr3);
1398 }
1399 break;
1400
1401 case EXEC_SYNC_IMAGES:
1402 fputs ("SYNC IMAGES image-set=", dumpfile);
1403 if (c->expr1 != NULL)
1404 show_expr (c->expr1);
1405 else
1406 fputs ("* ", dumpfile);
1407 if (c->expr2 != NULL)
1408 {
1409 fputs (" stat=", dumpfile);
1410 show_expr (c->expr2);
1411 }
1412 if (c->expr3 != NULL)
1413 {
1414 fputs (" errmsg=", dumpfile);
1415 show_expr (c->expr3);
1416 }
1417 break;
1418
1419 case EXEC_LOCK:
1420 case EXEC_UNLOCK:
1421 if (c->op == EXEC_LOCK)
1422 fputs ("LOCK ", dumpfile);
1423 else
1424 fputs ("UNLOCK ", dumpfile);
1425
1426 fputs ("lock-variable=", dumpfile);
1427 if (c->expr1 != NULL)
1428 show_expr (c->expr1);
1429 if (c->expr4 != NULL)
1430 {
1431 fputs (" acquired_lock=", dumpfile);
1432 show_expr (c->expr4);
1433 }
1434 if (c->expr2 != NULL)
1435 {
1436 fputs (" stat=", dumpfile);
1437 show_expr (c->expr2);
1438 }
1439 if (c->expr3 != NULL)
1440 {
1441 fputs (" errmsg=", dumpfile);
1442 show_expr (c->expr3);
1443 }
1444 break;
1445
1446 case EXEC_ARITHMETIC_IF:
1447 fputs ("IF ", dumpfile);
1448 show_expr (c->expr1);
1449 fprintf (dumpfile, " %d, %d, %d",
1450 c->label1->value, c->label2->value, c->label3->value);
1451 break;
1452
1453 case EXEC_IF:
1454 d = c->block;
1455 fputs ("IF ", dumpfile);
1456 show_expr (d->expr1);
1457
1458 ++show_level;
1459 show_code (level + 1, d->next);
1460 --show_level;
1461
1462 d = d->block;
1463 for (; d; d = d->block)
1464 {
1465 code_indent (level, 0);
1466
1467 if (d->expr1 == NULL)
1468 fputs ("ELSE", dumpfile);
1469 else
1470 {
1471 fputs ("ELSE IF ", dumpfile);
1472 show_expr (d->expr1);
1473 }
1474
1475 ++show_level;
1476 show_code (level + 1, d->next);
1477 --show_level;
1478 }
1479
1480 if (c->label1)
1481 code_indent (level, c->label1);
1482 else
1483 show_indent ();
1484
1485 fputs ("ENDIF", dumpfile);
1486 break;
1487
1488 case EXEC_BLOCK:
1489 {
1490 const char* blocktype;
1491 gfc_namespace *saved_ns;
1492
1493 if (c->ext.block.assoc)
1494 blocktype = "ASSOCIATE";
1495 else
1496 blocktype = "BLOCK";
1497 show_indent ();
1498 fprintf (dumpfile, "%s ", blocktype);
1499 ++show_level;
1500 ns = c->ext.block.ns;
1501 saved_ns = gfc_current_ns;
1502 gfc_current_ns = ns;
1503 gfc_traverse_symtree (ns->sym_root, show_symtree);
1504 gfc_current_ns = saved_ns;
1505 show_code (show_level, ns->code);
1506 --show_level;
1507 show_indent ();
1508 fprintf (dumpfile, "END %s ", blocktype);
1509 break;
1510 }
1511
1512 case EXEC_SELECT:
1513 d = c->block;
1514 fputs ("SELECT CASE ", dumpfile);
1515 show_expr (c->expr1);
1516 fputc ('\n', dumpfile);
1517
1518 for (; d; d = d->block)
1519 {
1520 code_indent (level, 0);
1521
1522 fputs ("CASE ", dumpfile);
1523 for (cp = d->ext.block.case_list; cp; cp = cp->next)
1524 {
1525 fputc ('(', dumpfile);
1526 show_expr (cp->low);
1527 fputc (' ', dumpfile);
1528 show_expr (cp->high);
1529 fputc (')', dumpfile);
1530 fputc (' ', dumpfile);
1531 }
1532 fputc ('\n', dumpfile);
1533
1534 show_code (level + 1, d->next);
1535 }
1536
1537 code_indent (level, c->label1);
1538 fputs ("END SELECT", dumpfile);
1539 break;
1540
1541 case EXEC_WHERE:
1542 fputs ("WHERE ", dumpfile);
1543
1544 d = c->block;
1545 show_expr (d->expr1);
1546 fputc ('\n', dumpfile);
1547
1548 show_code (level + 1, d->next);
1549
1550 for (d = d->block; d; d = d->block)
1551 {
1552 code_indent (level, 0);
1553 fputs ("ELSE WHERE ", dumpfile);
1554 show_expr (d->expr1);
1555 fputc ('\n', dumpfile);
1556 show_code (level + 1, d->next);
1557 }
1558
1559 code_indent (level, 0);
1560 fputs ("END WHERE", dumpfile);
1561 break;
1562
1563
1564 case EXEC_FORALL:
1565 fputs ("FORALL ", dumpfile);
1566 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1567 {
1568 show_expr (fa->var);
1569 fputc (' ', dumpfile);
1570 show_expr (fa->start);
1571 fputc (':', dumpfile);
1572 show_expr (fa->end);
1573 fputc (':', dumpfile);
1574 show_expr (fa->stride);
1575
1576 if (fa->next != NULL)
1577 fputc (',', dumpfile);
1578 }
1579
1580 if (c->expr1 != NULL)
1581 {
1582 fputc (',', dumpfile);
1583 show_expr (c->expr1);
1584 }
1585 fputc ('\n', dumpfile);
1586
1587 show_code (level + 1, c->block->next);
1588
1589 code_indent (level, 0);
1590 fputs ("END FORALL", dumpfile);
1591 break;
1592
1593 case EXEC_CRITICAL:
1594 fputs ("CRITICAL\n", dumpfile);
1595 show_code (level + 1, c->block->next);
1596 code_indent (level, 0);
1597 fputs ("END CRITICAL", dumpfile);
1598 break;
1599
1600 case EXEC_DO:
1601 fputs ("DO ", dumpfile);
1602 if (c->label1)
1603 fprintf (dumpfile, " %-5d ", c->label1->value);
1604
1605 show_expr (c->ext.iterator->var);
1606 fputc ('=', dumpfile);
1607 show_expr (c->ext.iterator->start);
1608 fputc (' ', dumpfile);
1609 show_expr (c->ext.iterator->end);
1610 fputc (' ', dumpfile);
1611 show_expr (c->ext.iterator->step);
1612
1613 ++show_level;
1614 show_code (level + 1, c->block->next);
1615 --show_level;
1616
1617 if (c->label1)
1618 break;
1619
1620 show_indent ();
1621 fputs ("END DO", dumpfile);
1622 break;
1623
1624 case EXEC_DO_CONCURRENT:
1625 fputs ("DO CONCURRENT ", dumpfile);
1626 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1627 {
1628 show_expr (fa->var);
1629 fputc (' ', dumpfile);
1630 show_expr (fa->start);
1631 fputc (':', dumpfile);
1632 show_expr (fa->end);
1633 fputc (':', dumpfile);
1634 show_expr (fa->stride);
1635
1636 if (fa->next != NULL)
1637 fputc (',', dumpfile);
1638 }
1639 show_expr (c->expr1);
1640
1641 show_code (level + 1, c->block->next);
1642 code_indent (level, c->label1);
1643 fputs ("END DO", dumpfile);
1644 break;
1645
1646 case EXEC_DO_WHILE:
1647 fputs ("DO WHILE ", dumpfile);
1648 show_expr (c->expr1);
1649 fputc ('\n', dumpfile);
1650
1651 show_code (level + 1, c->block->next);
1652
1653 code_indent (level, c->label1);
1654 fputs ("END DO", dumpfile);
1655 break;
1656
1657 case EXEC_CYCLE:
1658 fputs ("CYCLE", dumpfile);
1659 if (c->symtree)
1660 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1661 break;
1662
1663 case EXEC_EXIT:
1664 fputs ("EXIT", dumpfile);
1665 if (c->symtree)
1666 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1667 break;
1668
1669 case EXEC_ALLOCATE:
1670 fputs ("ALLOCATE ", dumpfile);
1671 if (c->expr1)
1672 {
1673 fputs (" STAT=", dumpfile);
1674 show_expr (c->expr1);
1675 }
1676
1677 if (c->expr2)
1678 {
1679 fputs (" ERRMSG=", dumpfile);
1680 show_expr (c->expr2);
1681 }
1682
1683 if (c->expr3)
1684 {
1685 if (c->expr3->mold)
1686 fputs (" MOLD=", dumpfile);
1687 else
1688 fputs (" SOURCE=", dumpfile);
1689 show_expr (c->expr3);
1690 }
1691
1692 for (a = c->ext.alloc.list; a; a = a->next)
1693 {
1694 fputc (' ', dumpfile);
1695 show_expr (a->expr);
1696 }
1697
1698 break;
1699
1700 case EXEC_DEALLOCATE:
1701 fputs ("DEALLOCATE ", dumpfile);
1702 if (c->expr1)
1703 {
1704 fputs (" STAT=", dumpfile);
1705 show_expr (c->expr1);
1706 }
1707
1708 if (c->expr2)
1709 {
1710 fputs (" ERRMSG=", dumpfile);
1711 show_expr (c->expr2);
1712 }
1713
1714 for (a = c->ext.alloc.list; a; a = a->next)
1715 {
1716 fputc (' ', dumpfile);
1717 show_expr (a->expr);
1718 }
1719
1720 break;
1721
1722 case EXEC_OPEN:
1723 fputs ("OPEN", dumpfile);
1724 open = c->ext.open;
1725
1726 if (open->unit)
1727 {
1728 fputs (" UNIT=", dumpfile);
1729 show_expr (open->unit);
1730 }
1731 if (open->iomsg)
1732 {
1733 fputs (" IOMSG=", dumpfile);
1734 show_expr (open->iomsg);
1735 }
1736 if (open->iostat)
1737 {
1738 fputs (" IOSTAT=", dumpfile);
1739 show_expr (open->iostat);
1740 }
1741 if (open->file)
1742 {
1743 fputs (" FILE=", dumpfile);
1744 show_expr (open->file);
1745 }
1746 if (open->status)
1747 {
1748 fputs (" STATUS=", dumpfile);
1749 show_expr (open->status);
1750 }
1751 if (open->access)
1752 {
1753 fputs (" ACCESS=", dumpfile);
1754 show_expr (open->access);
1755 }
1756 if (open->form)
1757 {
1758 fputs (" FORM=", dumpfile);
1759 show_expr (open->form);
1760 }
1761 if (open->recl)
1762 {
1763 fputs (" RECL=", dumpfile);
1764 show_expr (open->recl);
1765 }
1766 if (open->blank)
1767 {
1768 fputs (" BLANK=", dumpfile);
1769 show_expr (open->blank);
1770 }
1771 if (open->position)
1772 {
1773 fputs (" POSITION=", dumpfile);
1774 show_expr (open->position);
1775 }
1776 if (open->action)
1777 {
1778 fputs (" ACTION=", dumpfile);
1779 show_expr (open->action);
1780 }
1781 if (open->delim)
1782 {
1783 fputs (" DELIM=", dumpfile);
1784 show_expr (open->delim);
1785 }
1786 if (open->pad)
1787 {
1788 fputs (" PAD=", dumpfile);
1789 show_expr (open->pad);
1790 }
1791 if (open->decimal)
1792 {
1793 fputs (" DECIMAL=", dumpfile);
1794 show_expr (open->decimal);
1795 }
1796 if (open->encoding)
1797 {
1798 fputs (" ENCODING=", dumpfile);
1799 show_expr (open->encoding);
1800 }
1801 if (open->round)
1802 {
1803 fputs (" ROUND=", dumpfile);
1804 show_expr (open->round);
1805 }
1806 if (open->sign)
1807 {
1808 fputs (" SIGN=", dumpfile);
1809 show_expr (open->sign);
1810 }
1811 if (open->convert)
1812 {
1813 fputs (" CONVERT=", dumpfile);
1814 show_expr (open->convert);
1815 }
1816 if (open->asynchronous)
1817 {
1818 fputs (" ASYNCHRONOUS=", dumpfile);
1819 show_expr (open->asynchronous);
1820 }
1821 if (open->err != NULL)
1822 fprintf (dumpfile, " ERR=%d", open->err->value);
1823
1824 break;
1825
1826 case EXEC_CLOSE:
1827 fputs ("CLOSE", dumpfile);
1828 close = c->ext.close;
1829
1830 if (close->unit)
1831 {
1832 fputs (" UNIT=", dumpfile);
1833 show_expr (close->unit);
1834 }
1835 if (close->iomsg)
1836 {
1837 fputs (" IOMSG=", dumpfile);
1838 show_expr (close->iomsg);
1839 }
1840 if (close->iostat)
1841 {
1842 fputs (" IOSTAT=", dumpfile);
1843 show_expr (close->iostat);
1844 }
1845 if (close->status)
1846 {
1847 fputs (" STATUS=", dumpfile);
1848 show_expr (close->status);
1849 }
1850 if (close->err != NULL)
1851 fprintf (dumpfile, " ERR=%d", close->err->value);
1852 break;
1853
1854 case EXEC_BACKSPACE:
1855 fputs ("BACKSPACE", dumpfile);
1856 goto show_filepos;
1857
1858 case EXEC_ENDFILE:
1859 fputs ("ENDFILE", dumpfile);
1860 goto show_filepos;
1861
1862 case EXEC_REWIND:
1863 fputs ("REWIND", dumpfile);
1864 goto show_filepos;
1865
1866 case EXEC_FLUSH:
1867 fputs ("FLUSH", dumpfile);
1868
1869 show_filepos:
1870 fp = c->ext.filepos;
1871
1872 if (fp->unit)
1873 {
1874 fputs (" UNIT=", dumpfile);
1875 show_expr (fp->unit);
1876 }
1877 if (fp->iomsg)
1878 {
1879 fputs (" IOMSG=", dumpfile);
1880 show_expr (fp->iomsg);
1881 }
1882 if (fp->iostat)
1883 {
1884 fputs (" IOSTAT=", dumpfile);
1885 show_expr (fp->iostat);
1886 }
1887 if (fp->err != NULL)
1888 fprintf (dumpfile, " ERR=%d", fp->err->value);
1889 break;
1890
1891 case EXEC_INQUIRE:
1892 fputs ("INQUIRE", dumpfile);
1893 i = c->ext.inquire;
1894
1895 if (i->unit)
1896 {
1897 fputs (" UNIT=", dumpfile);
1898 show_expr (i->unit);
1899 }
1900 if (i->file)
1901 {
1902 fputs (" FILE=", dumpfile);
1903 show_expr (i->file);
1904 }
1905
1906 if (i->iomsg)
1907 {
1908 fputs (" IOMSG=", dumpfile);
1909 show_expr (i->iomsg);
1910 }
1911 if (i->iostat)
1912 {
1913 fputs (" IOSTAT=", dumpfile);
1914 show_expr (i->iostat);
1915 }
1916 if (i->exist)
1917 {
1918 fputs (" EXIST=", dumpfile);
1919 show_expr (i->exist);
1920 }
1921 if (i->opened)
1922 {
1923 fputs (" OPENED=", dumpfile);
1924 show_expr (i->opened);
1925 }
1926 if (i->number)
1927 {
1928 fputs (" NUMBER=", dumpfile);
1929 show_expr (i->number);
1930 }
1931 if (i->named)
1932 {
1933 fputs (" NAMED=", dumpfile);
1934 show_expr (i->named);
1935 }
1936 if (i->name)
1937 {
1938 fputs (" NAME=", dumpfile);
1939 show_expr (i->name);
1940 }
1941 if (i->access)
1942 {
1943 fputs (" ACCESS=", dumpfile);
1944 show_expr (i->access);
1945 }
1946 if (i->sequential)
1947 {
1948 fputs (" SEQUENTIAL=", dumpfile);
1949 show_expr (i->sequential);
1950 }
1951
1952 if (i->direct)
1953 {
1954 fputs (" DIRECT=", dumpfile);
1955 show_expr (i->direct);
1956 }
1957 if (i->form)
1958 {
1959 fputs (" FORM=", dumpfile);
1960 show_expr (i->form);
1961 }
1962 if (i->formatted)
1963 {
1964 fputs (" FORMATTED", dumpfile);
1965 show_expr (i->formatted);
1966 }
1967 if (i->unformatted)
1968 {
1969 fputs (" UNFORMATTED=", dumpfile);
1970 show_expr (i->unformatted);
1971 }
1972 if (i->recl)
1973 {
1974 fputs (" RECL=", dumpfile);
1975 show_expr (i->recl);
1976 }
1977 if (i->nextrec)
1978 {
1979 fputs (" NEXTREC=", dumpfile);
1980 show_expr (i->nextrec);
1981 }
1982 if (i->blank)
1983 {
1984 fputs (" BLANK=", dumpfile);
1985 show_expr (i->blank);
1986 }
1987 if (i->position)
1988 {
1989 fputs (" POSITION=", dumpfile);
1990 show_expr (i->position);
1991 }
1992 if (i->action)
1993 {
1994 fputs (" ACTION=", dumpfile);
1995 show_expr (i->action);
1996 }
1997 if (i->read)
1998 {
1999 fputs (" READ=", dumpfile);
2000 show_expr (i->read);
2001 }
2002 if (i->write)
2003 {
2004 fputs (" WRITE=", dumpfile);
2005 show_expr (i->write);
2006 }
2007 if (i->readwrite)
2008 {
2009 fputs (" READWRITE=", dumpfile);
2010 show_expr (i->readwrite);
2011 }
2012 if (i->delim)
2013 {
2014 fputs (" DELIM=", dumpfile);
2015 show_expr (i->delim);
2016 }
2017 if (i->pad)
2018 {
2019 fputs (" PAD=", dumpfile);
2020 show_expr (i->pad);
2021 }
2022 if (i->convert)
2023 {
2024 fputs (" CONVERT=", dumpfile);
2025 show_expr (i->convert);
2026 }
2027 if (i->asynchronous)
2028 {
2029 fputs (" ASYNCHRONOUS=", dumpfile);
2030 show_expr (i->asynchronous);
2031 }
2032 if (i->decimal)
2033 {
2034 fputs (" DECIMAL=", dumpfile);
2035 show_expr (i->decimal);
2036 }
2037 if (i->encoding)
2038 {
2039 fputs (" ENCODING=", dumpfile);
2040 show_expr (i->encoding);
2041 }
2042 if (i->pending)
2043 {
2044 fputs (" PENDING=", dumpfile);
2045 show_expr (i->pending);
2046 }
2047 if (i->round)
2048 {
2049 fputs (" ROUND=", dumpfile);
2050 show_expr (i->round);
2051 }
2052 if (i->sign)
2053 {
2054 fputs (" SIGN=", dumpfile);
2055 show_expr (i->sign);
2056 }
2057 if (i->size)
2058 {
2059 fputs (" SIZE=", dumpfile);
2060 show_expr (i->size);
2061 }
2062 if (i->id)
2063 {
2064 fputs (" ID=", dumpfile);
2065 show_expr (i->id);
2066 }
2067
2068 if (i->err != NULL)
2069 fprintf (dumpfile, " ERR=%d", i->err->value);
2070 break;
2071
2072 case EXEC_IOLENGTH:
2073 fputs ("IOLENGTH ", dumpfile);
2074 show_expr (c->expr1);
2075 goto show_dt_code;
2076 break;
2077
2078 case EXEC_READ:
2079 fputs ("READ", dumpfile);
2080 goto show_dt;
2081
2082 case EXEC_WRITE:
2083 fputs ("WRITE", dumpfile);
2084
2085 show_dt:
2086 dt = c->ext.dt;
2087 if (dt->io_unit)
2088 {
2089 fputs (" UNIT=", dumpfile);
2090 show_expr (dt->io_unit);
2091 }
2092
2093 if (dt->format_expr)
2094 {
2095 fputs (" FMT=", dumpfile);
2096 show_expr (dt->format_expr);
2097 }
2098
2099 if (dt->format_label != NULL)
2100 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
2101 if (dt->namelist)
2102 fprintf (dumpfile, " NML=%s", dt->namelist->name);
2103
2104 if (dt->iomsg)
2105 {
2106 fputs (" IOMSG=", dumpfile);
2107 show_expr (dt->iomsg);
2108 }
2109 if (dt->iostat)
2110 {
2111 fputs (" IOSTAT=", dumpfile);
2112 show_expr (dt->iostat);
2113 }
2114 if (dt->size)
2115 {
2116 fputs (" SIZE=", dumpfile);
2117 show_expr (dt->size);
2118 }
2119 if (dt->rec)
2120 {
2121 fputs (" REC=", dumpfile);
2122 show_expr (dt->rec);
2123 }
2124 if (dt->advance)
2125 {
2126 fputs (" ADVANCE=", dumpfile);
2127 show_expr (dt->advance);
2128 }
2129 if (dt->id)
2130 {
2131 fputs (" ID=", dumpfile);
2132 show_expr (dt->id);
2133 }
2134 if (dt->pos)
2135 {
2136 fputs (" POS=", dumpfile);
2137 show_expr (dt->pos);
2138 }
2139 if (dt->asynchronous)
2140 {
2141 fputs (" ASYNCHRONOUS=", dumpfile);
2142 show_expr (dt->asynchronous);
2143 }
2144 if (dt->blank)
2145 {
2146 fputs (" BLANK=", dumpfile);
2147 show_expr (dt->blank);
2148 }
2149 if (dt->decimal)
2150 {
2151 fputs (" DECIMAL=", dumpfile);
2152 show_expr (dt->decimal);
2153 }
2154 if (dt->delim)
2155 {
2156 fputs (" DELIM=", dumpfile);
2157 show_expr (dt->delim);
2158 }
2159 if (dt->pad)
2160 {
2161 fputs (" PAD=", dumpfile);
2162 show_expr (dt->pad);
2163 }
2164 if (dt->round)
2165 {
2166 fputs (" ROUND=", dumpfile);
2167 show_expr (dt->round);
2168 }
2169 if (dt->sign)
2170 {
2171 fputs (" SIGN=", dumpfile);
2172 show_expr (dt->sign);
2173 }
2174
2175 show_dt_code:
2176 for (c = c->block->next; c; c = c->next)
2177 show_code_node (level + (c->next != NULL), c);
2178 return;
2179
2180 case EXEC_TRANSFER:
2181 fputs ("TRANSFER ", dumpfile);
2182 show_expr (c->expr1);
2183 break;
2184
2185 case EXEC_DT_END:
2186 fputs ("DT_END", dumpfile);
2187 dt = c->ext.dt;
2188
2189 if (dt->err != NULL)
2190 fprintf (dumpfile, " ERR=%d", dt->err->value);
2191 if (dt->end != NULL)
2192 fprintf (dumpfile, " END=%d", dt->end->value);
2193 if (dt->eor != NULL)
2194 fprintf (dumpfile, " EOR=%d", dt->eor->value);
2195 break;
2196
2197 case EXEC_OMP_ATOMIC:
2198 case EXEC_OMP_BARRIER:
2199 case EXEC_OMP_CRITICAL:
2200 case EXEC_OMP_FLUSH:
2201 case EXEC_OMP_DO:
2202 case EXEC_OMP_MASTER:
2203 case EXEC_OMP_ORDERED:
2204 case EXEC_OMP_PARALLEL:
2205 case EXEC_OMP_PARALLEL_DO:
2206 case EXEC_OMP_PARALLEL_SECTIONS:
2207 case EXEC_OMP_PARALLEL_WORKSHARE:
2208 case EXEC_OMP_SECTIONS:
2209 case EXEC_OMP_SINGLE:
2210 case EXEC_OMP_TASK:
2211 case EXEC_OMP_TASKWAIT:
2212 case EXEC_OMP_TASKYIELD:
2213 case EXEC_OMP_WORKSHARE:
2214 show_omp_node (level, c);
2215 break;
2216
2217 default:
2218 gfc_internal_error ("show_code_node(): Bad statement code");
2219 }
2220 }
2221
2222
2223 /* Show an equivalence chain. */
2224
2225 static void
2226 show_equiv (gfc_equiv *eq)
2227 {
2228 show_indent ();
2229 fputs ("Equivalence: ", dumpfile);
2230 while (eq)
2231 {
2232 show_expr (eq->expr);
2233 eq = eq->eq;
2234 if (eq)
2235 fputs (", ", dumpfile);
2236 }
2237 }
2238
2239
2240 /* Show a freakin' whole namespace. */
2241
2242 static void
2243 show_namespace (gfc_namespace *ns)
2244 {
2245 gfc_interface *intr;
2246 gfc_namespace *save;
2247 int op;
2248 gfc_equiv *eq;
2249 int i;
2250
2251 gcc_assert (ns);
2252 save = gfc_current_ns;
2253
2254 show_indent ();
2255 fputs ("Namespace:", dumpfile);
2256
2257 i = 0;
2258 do
2259 {
2260 int l = i;
2261 while (i < GFC_LETTERS - 1
2262 && gfc_compare_types (&ns->default_type[i+1],
2263 &ns->default_type[l]))
2264 i++;
2265
2266 if (i > l)
2267 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2268 else
2269 fprintf (dumpfile, " %c: ", l+'A');
2270
2271 show_typespec(&ns->default_type[l]);
2272 i++;
2273 } while (i < GFC_LETTERS);
2274
2275 if (ns->proc_name != NULL)
2276 {
2277 show_indent ();
2278 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2279 }
2280
2281 ++show_level;
2282 gfc_current_ns = ns;
2283 gfc_traverse_symtree (ns->common_root, show_common);
2284
2285 gfc_traverse_symtree (ns->sym_root, show_symtree);
2286
2287 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2288 {
2289 /* User operator interfaces */
2290 intr = ns->op[op];
2291 if (intr == NULL)
2292 continue;
2293
2294 show_indent ();
2295 fprintf (dumpfile, "Operator interfaces for %s:",
2296 gfc_op2string ((gfc_intrinsic_op) op));
2297
2298 for (; intr; intr = intr->next)
2299 fprintf (dumpfile, " %s", intr->sym->name);
2300 }
2301
2302 if (ns->uop_root != NULL)
2303 {
2304 show_indent ();
2305 fputs ("User operators:\n", dumpfile);
2306 gfc_traverse_user_op (ns, show_uop);
2307 }
2308
2309 for (eq = ns->equiv; eq; eq = eq->next)
2310 show_equiv (eq);
2311
2312 fputc ('\n', dumpfile);
2313 show_indent ();
2314 fputs ("code:", dumpfile);
2315 show_code (show_level, ns->code);
2316 --show_level;
2317
2318 for (ns = ns->contained; ns; ns = ns->sibling)
2319 {
2320 fputs ("\nCONTAINS\n", dumpfile);
2321 ++show_level;
2322 show_namespace (ns);
2323 --show_level;
2324 }
2325
2326 fputc ('\n', dumpfile);
2327 gfc_current_ns = save;
2328 }
2329
2330
2331 /* Main function for dumping a parse tree. */
2332
2333 void
2334 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2335 {
2336 dumpfile = file;
2337 show_namespace (ns);
2338 }
2339