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