2 Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Steven Bosscher
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* Actually this is just a collection of routines that used to be
24 scattered around the sources. Now that they are all in a single
25 file, almost all of them can be static, and the other files don't
26 have this mess in them.
28 As a nice side-effect, this file can act as documentation of the
29 gfc_code and gfc_expr structures and all their friends and
37 /* Keep track of indentation for symbol tree dumps. */
38 static int show_level = 0;
40 /* The file handle we're dumping to is kept in a static variable. This
41 is not too cool, but it avoids a lot of passing it around. */
42 static FILE *dumpfile;
44 /* Forward declaration of some of the functions. */
45 static void show_expr (gfc_expr *p);
46 static void show_code_node (int, gfc_code *);
47 static void show_namespace (gfc_namespace *ns);
50 /* Do indentation for a specific level. */
53 code_indent (int level, gfc_st_label *label)
58 fprintf (dumpfile, "%-5d ", label->value);
60 fputs (" ", dumpfile);
62 for (i = 0; i < 2 * level; i++)
63 fputc (' ', dumpfile);
67 /* Simple indentation at the current level. This one
68 is used to show symbols. */
73 fputc ('\n', dumpfile);
74 code_indent (show_level, NULL);
78 /* Show type-specific information. */
81 show_typespec (gfc_typespec *ts)
83 fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
88 fprintf (dumpfile, "%s", ts->derived->name);
92 show_expr (ts->cl->length);
96 fprintf (dumpfile, "%d", ts->kind);
100 fputc (')', dumpfile);
104 /* Show an actual argument list. */
107 show_actual_arglist (gfc_actual_arglist *a)
109 fputc ('(', dumpfile);
111 for (; a; a = a->next)
113 fputc ('(', dumpfile);
115 fprintf (dumpfile, "%s = ", a->name);
119 fputs ("(arg not-present)", dumpfile);
121 fputc (')', dumpfile);
123 fputc (' ', dumpfile);
126 fputc (')', dumpfile);
130 /* Show a gfc_array_spec array specification structure. */
133 show_array_spec (gfc_array_spec *as)
140 fputs ("()", dumpfile);
144 fprintf (dumpfile, "(%d", as->rank);
150 case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
151 case AS_DEFERRED: c = "AS_DEFERRED"; break;
152 case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
153 case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
155 gfc_internal_error ("show_array_spec(): Unhandled array shape "
158 fprintf (dumpfile, " %s ", c);
160 for (i = 0; i < as->rank; i++)
162 show_expr (as->lower[i]);
163 fputc (' ', dumpfile);
164 show_expr (as->upper[i]);
165 fputc (' ', dumpfile);
169 fputc (')', dumpfile);
173 /* Show a gfc_array_ref array reference structure. */
176 show_array_ref (gfc_array_ref * ar)
180 fputc ('(', dumpfile);
185 fputs ("FULL", dumpfile);
189 for (i = 0; i < ar->dimen; i++)
191 /* There are two types of array sections: either the
192 elements are identified by an integer array ('vector'),
193 or by an index range. In the former case we only have to
194 print the start expression which contains the vector, in
195 the latter case we have to print any of lower and upper
196 bound and the stride, if they're present. */
198 if (ar->start[i] != NULL)
199 show_expr (ar->start[i]);
201 if (ar->dimen_type[i] == DIMEN_RANGE)
203 fputc (':', dumpfile);
205 if (ar->end[i] != NULL)
206 show_expr (ar->end[i]);
208 if (ar->stride[i] != NULL)
210 fputc (':', dumpfile);
211 show_expr (ar->stride[i]);
215 if (i != ar->dimen - 1)
216 fputs (" , ", dumpfile);
221 for (i = 0; i < ar->dimen; i++)
223 show_expr (ar->start[i]);
224 if (i != ar->dimen - 1)
225 fputs (" , ", dumpfile);
230 fputs ("UNKNOWN", dumpfile);
234 gfc_internal_error ("show_array_ref(): Unknown array reference");
237 fputc (')', dumpfile);
241 /* Show a list of gfc_ref structures. */
244 show_ref (gfc_ref *p)
246 for (; p; p = p->next)
250 show_array_ref (&p->u.ar);
254 fprintf (dumpfile, " %% %s", p->u.c.component->name);
258 fputc ('(', dumpfile);
259 show_expr (p->u.ss.start);
260 fputc (':', dumpfile);
261 show_expr (p->u.ss.end);
262 fputc (')', dumpfile);
266 gfc_internal_error ("show_ref(): Bad component code");
271 /* Display a constructor. Works recursively for array constructors. */
274 show_constructor (gfc_constructor *c)
276 for (; c; c = c->next)
278 if (c->iterator == NULL)
282 fputc ('(', dumpfile);
285 fputc (' ', dumpfile);
286 show_expr (c->iterator->var);
287 fputc ('=', dumpfile);
288 show_expr (c->iterator->start);
289 fputc (',', dumpfile);
290 show_expr (c->iterator->end);
291 fputc (',', dumpfile);
292 show_expr (c->iterator->step);
294 fputc (')', dumpfile);
298 fputs (" , ", dumpfile);
304 show_char_const (const gfc_char_t *c, int length)
308 fputc ('\'', dumpfile);
309 for (i = 0; i < length; i++)
312 fputs ("''", dumpfile);
314 fputs (gfc_print_wide_char (c[i]), dumpfile);
316 fputc ('\'', dumpfile);
320 /* Show a component-call expression. */
323 show_compcall (gfc_expr* p)
325 gcc_assert (p->expr_type == EXPR_COMPCALL);
327 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
329 fprintf (dumpfile, "%s", p->value.compcall.name);
331 show_actual_arglist (p->value.compcall.actual);
335 /* Show an expression. */
338 show_expr (gfc_expr *p)
345 fputs ("()", dumpfile);
349 switch (p->expr_type)
352 show_char_const (p->value.character.string, p->value.character.length);
357 fprintf (dumpfile, "%s(", p->ts.derived->name);
358 show_constructor (p->value.constructor);
359 fputc (')', dumpfile);
363 fputs ("(/ ", dumpfile);
364 show_constructor (p->value.constructor);
365 fputs (" /)", dumpfile);
371 fputs ("NULL()", dumpfile);
378 mpz_out_str (stdout, 10, p->value.integer);
380 if (p->ts.kind != gfc_default_integer_kind)
381 fprintf (dumpfile, "_%d", p->ts.kind);
385 if (p->value.logical)
386 fputs (".true.", dumpfile);
388 fputs (".false.", dumpfile);
392 mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
393 if (p->ts.kind != gfc_default_real_kind)
394 fprintf (dumpfile, "_%d", p->ts.kind);
398 show_char_const (p->value.character.string,
399 p->value.character.length);
403 fputs ("(complex ", dumpfile);
405 mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
406 if (p->ts.kind != gfc_default_complex_kind)
407 fprintf (dumpfile, "_%d", p->ts.kind);
409 fputc (' ', dumpfile);
411 mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE);
412 if (p->ts.kind != gfc_default_complex_kind)
413 fprintf (dumpfile, "_%d", p->ts.kind);
415 fputc (')', dumpfile);
419 fprintf (dumpfile, "%dH", p->representation.length);
420 c = p->representation.string;
421 for (i = 0; i < p->representation.length; i++, c++)
423 fputc (*c, dumpfile);
428 fputs ("???", dumpfile);
432 if (p->representation.string)
434 fputs (" {", dumpfile);
435 c = p->representation.string;
436 for (i = 0; i < p->representation.length; i++, c++)
438 fprintf (dumpfile, "%.2x", (unsigned int) *c);
439 if (i < p->representation.length - 1)
440 fputc (',', dumpfile);
442 fputc ('}', dumpfile);
448 if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
449 fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
450 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
455 fputc ('(', dumpfile);
456 switch (p->value.op.op)
458 case INTRINSIC_UPLUS:
459 fputs ("U+ ", dumpfile);
461 case INTRINSIC_UMINUS:
462 fputs ("U- ", dumpfile);
465 fputs ("+ ", dumpfile);
467 case INTRINSIC_MINUS:
468 fputs ("- ", dumpfile);
470 case INTRINSIC_TIMES:
471 fputs ("* ", dumpfile);
473 case INTRINSIC_DIVIDE:
474 fputs ("/ ", dumpfile);
476 case INTRINSIC_POWER:
477 fputs ("** ", dumpfile);
479 case INTRINSIC_CONCAT:
480 fputs ("// ", dumpfile);
483 fputs ("AND ", dumpfile);
486 fputs ("OR ", dumpfile);
489 fputs ("EQV ", dumpfile);
492 fputs ("NEQV ", dumpfile);
495 case INTRINSIC_EQ_OS:
496 fputs ("= ", dumpfile);
499 case INTRINSIC_NE_OS:
500 fputs ("/= ", dumpfile);
503 case INTRINSIC_GT_OS:
504 fputs ("> ", dumpfile);
507 case INTRINSIC_GE_OS:
508 fputs (">= ", dumpfile);
511 case INTRINSIC_LT_OS:
512 fputs ("< ", dumpfile);
515 case INTRINSIC_LE_OS:
516 fputs ("<= ", dumpfile);
519 fputs ("NOT ", dumpfile);
521 case INTRINSIC_PARENTHESES:
522 fputs ("parens", dumpfile);
527 ("show_expr(): Bad intrinsic in expression!");
530 show_expr (p->value.op.op1);
534 fputc (' ', dumpfile);
535 show_expr (p->value.op.op2);
538 fputc (')', dumpfile);
542 if (p->value.function.name == NULL)
544 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
545 if (is_proc_ptr_comp (p, NULL))
547 fputc ('[', dumpfile);
548 show_actual_arglist (p->value.function.actual);
549 fputc (']', dumpfile);
553 fprintf (dumpfile, "%s", p->value.function.name);
554 if (is_proc_ptr_comp (p, NULL))
556 fputc ('[', dumpfile);
557 fputc ('[', dumpfile);
558 show_actual_arglist (p->value.function.actual);
559 fputc (']', dumpfile);
560 fputc (']', dumpfile);
570 gfc_internal_error ("show_expr(): Don't know how to show expr");
574 /* Show symbol attributes. The flavor and intent are followed by
575 whatever single bit attributes are present. */
578 show_attr (symbol_attribute *attr)
581 fprintf (dumpfile, "(%s %s %s %s %s",
582 gfc_code2string (flavors, attr->flavor),
583 gfc_intent_string (attr->intent),
584 gfc_code2string (access_types, attr->access),
585 gfc_code2string (procedures, attr->proc),
586 gfc_code2string (save_status, attr->save));
588 if (attr->allocatable)
589 fputs (" ALLOCATABLE", dumpfile);
591 fputs (" DIMENSION", dumpfile);
593 fputs (" EXTERNAL", dumpfile);
595 fputs (" INTRINSIC", dumpfile);
597 fputs (" OPTIONAL", dumpfile);
599 fputs (" POINTER", dumpfile);
600 if (attr->is_protected)
601 fputs (" PROTECTED", dumpfile);
603 fputs (" VALUE", dumpfile);
605 fputs (" VOLATILE", dumpfile);
606 if (attr->threadprivate)
607 fputs (" THREADPRIVATE", dumpfile);
609 fputs (" TARGET", dumpfile);
611 fputs (" DUMMY", dumpfile);
613 fputs (" RESULT", dumpfile);
615 fputs (" ENTRY", dumpfile);
617 fputs (" BIND(C)", dumpfile);
620 fputs (" DATA", dumpfile);
622 fputs (" USE-ASSOC", dumpfile);
623 if (attr->in_namelist)
624 fputs (" IN-NAMELIST", dumpfile);
626 fputs (" IN-COMMON", dumpfile);
629 fputs (" ABSTRACT", dumpfile);
631 fputs (" FUNCTION", dumpfile);
632 if (attr->subroutine)
633 fputs (" SUBROUTINE", dumpfile);
634 if (attr->implicit_type)
635 fputs (" IMPLICIT-TYPE", dumpfile);
638 fputs (" SEQUENCE", dumpfile);
640 fputs (" ELEMENTAL", dumpfile);
642 fputs (" PURE", dumpfile);
644 fputs (" RECURSIVE", dumpfile);
646 fputc (')', dumpfile);
650 /* Show components of a derived type. */
653 show_components (gfc_symbol *sym)
657 for (c = sym->components; c; c = c->next)
659 fprintf (dumpfile, "(%s ", c->name);
660 show_typespec (&c->ts);
662 fputs (" POINTER", dumpfile);
663 if (c->attr.proc_pointer)
664 fputs (" PPC", dumpfile);
665 if (c->attr.dimension)
666 fputs (" DIMENSION", dumpfile);
667 fputc (' ', dumpfile);
668 show_array_spec (c->as);
670 fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
671 fputc (')', dumpfile);
673 fputc (' ', dumpfile);
678 /* Show the f2k_derived namespace with procedure bindings. */
681 show_typebound (gfc_symtree* st)
688 if (st->n.tb->is_generic)
689 fputs ("GENERIC", dumpfile);
692 fputs ("PROCEDURE, ", dumpfile);
693 if (st->n.tb->nopass)
694 fputs ("NOPASS", dumpfile);
697 if (st->n.tb->pass_arg)
698 fprintf (dumpfile, "PASS(%s)", st->n.tb->pass_arg);
700 fputs ("PASS", dumpfile);
702 if (st->n.tb->non_overridable)
703 fputs (", NON_OVERRIDABLE", dumpfile);
706 if (st->n.tb->access == ACCESS_PUBLIC)
707 fputs (", PUBLIC", dumpfile);
709 fputs (", PRIVATE", dumpfile);
711 fprintf (dumpfile, " :: %s => ", st->n.sym->name);
713 if (st->n.tb->is_generic)
716 for (g = st->n.tb->u.generic; g; g = g->next)
718 fputs (g->specific_st->name, dumpfile);
720 fputs (", ", dumpfile);
724 fputs (st->n.tb->u.specific->n.sym->name, dumpfile);
728 show_f2k_derived (gfc_namespace* f2k)
734 /* Finalizer bindings. */
735 for (f = f2k->finalizers; f; f = f->next)
738 fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
741 /* Type-bound procedures. */
742 gfc_traverse_symtree (f2k->sym_root, &show_typebound);
748 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
749 show the interface. Information needed to reconstruct the list of
750 specific interfaces associated with a generic symbol is done within
754 show_symbol (gfc_symbol *sym)
756 gfc_formal_arglist *formal;
764 fprintf (dumpfile, "symbol %s ", sym->name);
765 show_typespec (&sym->ts);
766 show_attr (&sym->attr);
771 fputs ("value: ", dumpfile);
772 show_expr (sym->value);
778 fputs ("Array spec:", dumpfile);
779 show_array_spec (sym->as);
785 fputs ("Generic interfaces:", dumpfile);
786 for (intr = sym->generic; intr; intr = intr->next)
787 fprintf (dumpfile, " %s", intr->sym->name);
793 fprintf (dumpfile, "result: %s", sym->result->name);
799 fputs ("components: ", dumpfile);
800 show_components (sym);
803 if (sym->f2k_derived)
806 fputs ("Procedure bindings:\n", dumpfile);
807 show_f2k_derived (sym->f2k_derived);
813 fputs ("Formal arglist:", dumpfile);
815 for (formal = sym->formal; formal; formal = formal->next)
817 if (formal->sym != NULL)
818 fprintf (dumpfile, " %s", formal->sym->name);
820 fputs (" [Alt Return]", dumpfile);
827 fputs ("Formal namespace", dumpfile);
828 show_namespace (sym->formal_ns);
831 fputc ('\n', dumpfile);
835 /* Show a user-defined operator. Just prints an operator
836 and the name of the associated subroutine, really. */
839 show_uop (gfc_user_op *uop)
844 fprintf (dumpfile, "%s:", uop->name);
846 for (intr = uop->op; intr; intr = intr->next)
847 fprintf (dumpfile, " %s", intr->sym->name);
851 /* Workhorse function for traversing the user operator symtree. */
854 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
861 traverse_uop (st->left, func);
862 traverse_uop (st->right, func);
866 /* Traverse the tree of user operator nodes. */
869 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
871 traverse_uop (ns->uop_root, func);
875 /* Function to display a common block. */
878 show_common (gfc_symtree *st)
883 fprintf (dumpfile, "common: /%s/ ", st->name);
885 s = st->n.common->head;
888 fprintf (dumpfile, "%s", s->name);
891 fputs (", ", dumpfile);
893 fputc ('\n', dumpfile);
897 /* Worker function to display the symbol tree. */
900 show_symtree (gfc_symtree *st)
903 fprintf (dumpfile, "symtree: %s Ambig %d", st->name, st->ambiguous);
905 if (st->n.sym->ns != gfc_current_ns)
906 fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
908 show_symbol (st->n.sym);
912 /******************* Show gfc_code structures **************/
915 /* Show a list of code structures. Mutually recursive with
919 show_code (int level, gfc_code *c)
921 for (; c; c = c->next)
922 show_code_node (level, c);
926 show_namelist (gfc_namelist *n)
928 for (; n->next; n = n->next)
929 fprintf (dumpfile, "%s,", n->sym->name);
930 fprintf (dumpfile, "%s", n->sym->name);
933 /* Show a single OpenMP directive node and everything underneath it
937 show_omp_node (int level, gfc_code *c)
939 gfc_omp_clauses *omp_clauses = NULL;
940 const char *name = NULL;
944 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
945 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
946 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
947 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
948 case EXEC_OMP_DO: name = "DO"; break;
949 case EXEC_OMP_MASTER: name = "MASTER"; break;
950 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
951 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
952 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
953 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
954 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
955 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
956 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
957 case EXEC_OMP_TASK: name = "TASK"; break;
958 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
959 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
963 fprintf (dumpfile, "!$OMP %s", name);
967 case EXEC_OMP_PARALLEL:
968 case EXEC_OMP_PARALLEL_DO:
969 case EXEC_OMP_PARALLEL_SECTIONS:
970 case EXEC_OMP_SECTIONS:
971 case EXEC_OMP_SINGLE:
972 case EXEC_OMP_WORKSHARE:
973 case EXEC_OMP_PARALLEL_WORKSHARE:
975 omp_clauses = c->ext.omp_clauses;
977 case EXEC_OMP_CRITICAL:
979 fprintf (dumpfile, " (%s)", c->ext.omp_name);
982 if (c->ext.omp_namelist)
984 fputs (" (", dumpfile);
985 show_namelist (c->ext.omp_namelist);
986 fputc (')', dumpfile);
989 case EXEC_OMP_BARRIER:
990 case EXEC_OMP_TASKWAIT:
999 if (omp_clauses->if_expr)
1001 fputs (" IF(", dumpfile);
1002 show_expr (omp_clauses->if_expr);
1003 fputc (')', dumpfile);
1005 if (omp_clauses->num_threads)
1007 fputs (" NUM_THREADS(", dumpfile);
1008 show_expr (omp_clauses->num_threads);
1009 fputc (')', dumpfile);
1011 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1014 switch (omp_clauses->sched_kind)
1016 case OMP_SCHED_STATIC: type = "STATIC"; break;
1017 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1018 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1019 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1020 case OMP_SCHED_AUTO: type = "AUTO"; break;
1024 fprintf (dumpfile, " SCHEDULE (%s", type);
1025 if (omp_clauses->chunk_size)
1027 fputc (',', dumpfile);
1028 show_expr (omp_clauses->chunk_size);
1030 fputc (')', dumpfile);
1032 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1035 switch (omp_clauses->default_sharing)
1037 case OMP_DEFAULT_NONE: type = "NONE"; break;
1038 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1039 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1040 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1044 fprintf (dumpfile, " DEFAULT(%s)", type);
1046 if (omp_clauses->ordered)
1047 fputs (" ORDERED", dumpfile);
1048 if (omp_clauses->untied)
1049 fputs (" UNTIED", dumpfile);
1050 if (omp_clauses->collapse)
1051 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1052 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1053 if (omp_clauses->lists[list_type] != NULL
1054 && list_type != OMP_LIST_COPYPRIVATE)
1057 if (list_type >= OMP_LIST_REDUCTION_FIRST)
1061 case OMP_LIST_PLUS: type = "+"; break;
1062 case OMP_LIST_MULT: type = "*"; break;
1063 case OMP_LIST_SUB: type = "-"; break;
1064 case OMP_LIST_AND: type = ".AND."; break;
1065 case OMP_LIST_OR: type = ".OR."; break;
1066 case OMP_LIST_EQV: type = ".EQV."; break;
1067 case OMP_LIST_NEQV: type = ".NEQV."; break;
1068 case OMP_LIST_MAX: type = "MAX"; break;
1069 case OMP_LIST_MIN: type = "MIN"; break;
1070 case OMP_LIST_IAND: type = "IAND"; break;
1071 case OMP_LIST_IOR: type = "IOR"; break;
1072 case OMP_LIST_IEOR: type = "IEOR"; break;
1076 fprintf (dumpfile, " REDUCTION(%s:", type);
1082 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1083 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1084 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1085 case OMP_LIST_SHARED: type = "SHARED"; break;
1086 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1090 fprintf (dumpfile, " %s(", type);
1092 show_namelist (omp_clauses->lists[list_type]);
1093 fputc (')', dumpfile);
1096 fputc ('\n', dumpfile);
1097 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1099 gfc_code *d = c->block;
1102 show_code (level + 1, d->next);
1103 if (d->block == NULL)
1105 code_indent (level, 0);
1106 fputs ("!$OMP SECTION\n", dumpfile);
1111 show_code (level + 1, c->block->next);
1112 if (c->op == EXEC_OMP_ATOMIC)
1114 code_indent (level, 0);
1115 fprintf (dumpfile, "!$OMP END %s", name);
1116 if (omp_clauses != NULL)
1118 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1120 fputs (" COPYPRIVATE(", dumpfile);
1121 show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1122 fputc (')', dumpfile);
1124 else if (omp_clauses->nowait)
1125 fputs (" NOWAIT", dumpfile);
1127 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1128 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1132 /* Show a single code node and everything underneath it if necessary. */
1135 show_code_node (int level, gfc_code *c)
1137 gfc_forall_iterator *fa;
1147 code_indent (level, c->here);
1151 case EXEC_END_PROCEDURE:
1155 fputs ("NOP", dumpfile);
1159 fputs ("CONTINUE", dumpfile);
1163 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1166 case EXEC_INIT_ASSIGN:
1168 fputs ("ASSIGN ", dumpfile);
1169 show_expr (c->expr);
1170 fputc (' ', dumpfile);
1171 show_expr (c->expr2);
1174 case EXEC_LABEL_ASSIGN:
1175 fputs ("LABEL ASSIGN ", dumpfile);
1176 show_expr (c->expr);
1177 fprintf (dumpfile, " %d", c->label1->value);
1180 case EXEC_POINTER_ASSIGN:
1181 fputs ("POINTER ASSIGN ", dumpfile);
1182 show_expr (c->expr);
1183 fputc (' ', dumpfile);
1184 show_expr (c->expr2);
1188 fputs ("GOTO ", dumpfile);
1190 fprintf (dumpfile, "%d", c->label1->value);
1193 show_expr (c->expr);
1197 fputs (", (", dumpfile);
1198 for (; d; d = d ->block)
1200 code_indent (level, d->label1);
1201 if (d->block != NULL)
1202 fputc (',', dumpfile);
1204 fputc (')', dumpfile);
1211 case EXEC_ASSIGN_CALL:
1212 if (c->resolved_sym)
1213 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1214 else if (c->symtree)
1215 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1217 fputs ("CALL ?? ", dumpfile);
1219 show_actual_arglist (c->ext.actual);
1223 fputs ("CALL ", dumpfile);
1224 show_compcall (c->expr);
1228 fputs ("CALL ", dumpfile);
1229 show_expr (c->expr);
1230 show_actual_arglist (c->ext.actual);
1234 fputs ("RETURN ", dumpfile);
1236 show_expr (c->expr);
1240 fputs ("PAUSE ", dumpfile);
1242 if (c->expr != NULL)
1243 show_expr (c->expr);
1245 fprintf (dumpfile, "%d", c->ext.stop_code);
1250 fputs ("STOP ", dumpfile);
1252 if (c->expr != NULL)
1253 show_expr (c->expr);
1255 fprintf (dumpfile, "%d", c->ext.stop_code);
1259 case EXEC_ARITHMETIC_IF:
1260 fputs ("IF ", dumpfile);
1261 show_expr (c->expr);
1262 fprintf (dumpfile, " %d, %d, %d",
1263 c->label1->value, c->label2->value, c->label3->value);
1268 fputs ("IF ", dumpfile);
1269 show_expr (d->expr);
1270 fputc ('\n', dumpfile);
1271 show_code (level + 1, d->next);
1274 for (; d; d = d->block)
1276 code_indent (level, 0);
1278 if (d->expr == NULL)
1279 fputs ("ELSE\n", dumpfile);
1282 fputs ("ELSE IF ", dumpfile);
1283 show_expr (d->expr);
1284 fputc ('\n', dumpfile);
1287 show_code (level + 1, d->next);
1290 code_indent (level, c->label1);
1292 fputs ("ENDIF", dumpfile);
1297 fputs ("SELECT CASE ", dumpfile);
1298 show_expr (c->expr);
1299 fputc ('\n', dumpfile);
1301 for (; d; d = d->block)
1303 code_indent (level, 0);
1305 fputs ("CASE ", dumpfile);
1306 for (cp = d->ext.case_list; cp; cp = cp->next)
1308 fputc ('(', dumpfile);
1309 show_expr (cp->low);
1310 fputc (' ', dumpfile);
1311 show_expr (cp->high);
1312 fputc (')', dumpfile);
1313 fputc (' ', dumpfile);
1315 fputc ('\n', dumpfile);
1317 show_code (level + 1, d->next);
1320 code_indent (level, c->label1);
1321 fputs ("END SELECT", dumpfile);
1325 fputs ("WHERE ", dumpfile);
1328 show_expr (d->expr);
1329 fputc ('\n', dumpfile);
1331 show_code (level + 1, d->next);
1333 for (d = d->block; d; d = d->block)
1335 code_indent (level, 0);
1336 fputs ("ELSE WHERE ", dumpfile);
1337 show_expr (d->expr);
1338 fputc ('\n', dumpfile);
1339 show_code (level + 1, d->next);
1342 code_indent (level, 0);
1343 fputs ("END WHERE", dumpfile);
1348 fputs ("FORALL ", dumpfile);
1349 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1351 show_expr (fa->var);
1352 fputc (' ', dumpfile);
1353 show_expr (fa->start);
1354 fputc (':', dumpfile);
1355 show_expr (fa->end);
1356 fputc (':', dumpfile);
1357 show_expr (fa->stride);
1359 if (fa->next != NULL)
1360 fputc (',', dumpfile);
1363 if (c->expr != NULL)
1365 fputc (',', dumpfile);
1366 show_expr (c->expr);
1368 fputc ('\n', dumpfile);
1370 show_code (level + 1, c->block->next);
1372 code_indent (level, 0);
1373 fputs ("END FORALL", dumpfile);
1377 fputs ("DO ", dumpfile);
1379 show_expr (c->ext.iterator->var);
1380 fputc ('=', dumpfile);
1381 show_expr (c->ext.iterator->start);
1382 fputc (' ', dumpfile);
1383 show_expr (c->ext.iterator->end);
1384 fputc (' ', dumpfile);
1385 show_expr (c->ext.iterator->step);
1386 fputc ('\n', dumpfile);
1388 show_code (level + 1, c->block->next);
1390 code_indent (level, 0);
1391 fputs ("END DO", dumpfile);
1395 fputs ("DO WHILE ", dumpfile);
1396 show_expr (c->expr);
1397 fputc ('\n', dumpfile);
1399 show_code (level + 1, c->block->next);
1401 code_indent (level, c->label1);
1402 fputs ("END DO", dumpfile);
1406 fputs ("CYCLE", dumpfile);
1408 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1412 fputs ("EXIT", dumpfile);
1414 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1418 fputs ("ALLOCATE ", dumpfile);
1421 fputs (" STAT=", dumpfile);
1422 show_expr (c->expr);
1425 for (a = c->ext.alloc_list; a; a = a->next)
1427 fputc (' ', dumpfile);
1428 show_expr (a->expr);
1433 case EXEC_DEALLOCATE:
1434 fputs ("DEALLOCATE ", dumpfile);
1437 fputs (" STAT=", dumpfile);
1438 show_expr (c->expr);
1441 for (a = c->ext.alloc_list; a; a = a->next)
1443 fputc (' ', dumpfile);
1444 show_expr (a->expr);
1450 fputs ("OPEN", dumpfile);
1455 fputs (" UNIT=", dumpfile);
1456 show_expr (open->unit);
1460 fputs (" IOMSG=", dumpfile);
1461 show_expr (open->iomsg);
1465 fputs (" IOSTAT=", dumpfile);
1466 show_expr (open->iostat);
1470 fputs (" FILE=", dumpfile);
1471 show_expr (open->file);
1475 fputs (" STATUS=", dumpfile);
1476 show_expr (open->status);
1480 fputs (" ACCESS=", dumpfile);
1481 show_expr (open->access);
1485 fputs (" FORM=", dumpfile);
1486 show_expr (open->form);
1490 fputs (" RECL=", dumpfile);
1491 show_expr (open->recl);
1495 fputs (" BLANK=", dumpfile);
1496 show_expr (open->blank);
1500 fputs (" POSITION=", dumpfile);
1501 show_expr (open->position);
1505 fputs (" ACTION=", dumpfile);
1506 show_expr (open->action);
1510 fputs (" DELIM=", dumpfile);
1511 show_expr (open->delim);
1515 fputs (" PAD=", dumpfile);
1516 show_expr (open->pad);
1520 fputs (" DECIMAL=", dumpfile);
1521 show_expr (open->decimal);
1525 fputs (" ENCODING=", dumpfile);
1526 show_expr (open->encoding);
1530 fputs (" ROUND=", dumpfile);
1531 show_expr (open->round);
1535 fputs (" SIGN=", dumpfile);
1536 show_expr (open->sign);
1540 fputs (" CONVERT=", dumpfile);
1541 show_expr (open->convert);
1543 if (open->asynchronous)
1545 fputs (" ASYNCHRONOUS=", dumpfile);
1546 show_expr (open->asynchronous);
1548 if (open->err != NULL)
1549 fprintf (dumpfile, " ERR=%d", open->err->value);
1554 fputs ("CLOSE", dumpfile);
1555 close = c->ext.close;
1559 fputs (" UNIT=", dumpfile);
1560 show_expr (close->unit);
1564 fputs (" IOMSG=", dumpfile);
1565 show_expr (close->iomsg);
1569 fputs (" IOSTAT=", dumpfile);
1570 show_expr (close->iostat);
1574 fputs (" STATUS=", dumpfile);
1575 show_expr (close->status);
1577 if (close->err != NULL)
1578 fprintf (dumpfile, " ERR=%d", close->err->value);
1581 case EXEC_BACKSPACE:
1582 fputs ("BACKSPACE", dumpfile);
1586 fputs ("ENDFILE", dumpfile);
1590 fputs ("REWIND", dumpfile);
1594 fputs ("FLUSH", dumpfile);
1597 fp = c->ext.filepos;
1601 fputs (" UNIT=", dumpfile);
1602 show_expr (fp->unit);
1606 fputs (" IOMSG=", dumpfile);
1607 show_expr (fp->iomsg);
1611 fputs (" IOSTAT=", dumpfile);
1612 show_expr (fp->iostat);
1614 if (fp->err != NULL)
1615 fprintf (dumpfile, " ERR=%d", fp->err->value);
1619 fputs ("INQUIRE", dumpfile);
1624 fputs (" UNIT=", dumpfile);
1625 show_expr (i->unit);
1629 fputs (" FILE=", dumpfile);
1630 show_expr (i->file);
1635 fputs (" IOMSG=", dumpfile);
1636 show_expr (i->iomsg);
1640 fputs (" IOSTAT=", dumpfile);
1641 show_expr (i->iostat);
1645 fputs (" EXIST=", dumpfile);
1646 show_expr (i->exist);
1650 fputs (" OPENED=", dumpfile);
1651 show_expr (i->opened);
1655 fputs (" NUMBER=", dumpfile);
1656 show_expr (i->number);
1660 fputs (" NAMED=", dumpfile);
1661 show_expr (i->named);
1665 fputs (" NAME=", dumpfile);
1666 show_expr (i->name);
1670 fputs (" ACCESS=", dumpfile);
1671 show_expr (i->access);
1675 fputs (" SEQUENTIAL=", dumpfile);
1676 show_expr (i->sequential);
1681 fputs (" DIRECT=", dumpfile);
1682 show_expr (i->direct);
1686 fputs (" FORM=", dumpfile);
1687 show_expr (i->form);
1691 fputs (" FORMATTED", dumpfile);
1692 show_expr (i->formatted);
1696 fputs (" UNFORMATTED=", dumpfile);
1697 show_expr (i->unformatted);
1701 fputs (" RECL=", dumpfile);
1702 show_expr (i->recl);
1706 fputs (" NEXTREC=", dumpfile);
1707 show_expr (i->nextrec);
1711 fputs (" BLANK=", dumpfile);
1712 show_expr (i->blank);
1716 fputs (" POSITION=", dumpfile);
1717 show_expr (i->position);
1721 fputs (" ACTION=", dumpfile);
1722 show_expr (i->action);
1726 fputs (" READ=", dumpfile);
1727 show_expr (i->read);
1731 fputs (" WRITE=", dumpfile);
1732 show_expr (i->write);
1736 fputs (" READWRITE=", dumpfile);
1737 show_expr (i->readwrite);
1741 fputs (" DELIM=", dumpfile);
1742 show_expr (i->delim);
1746 fputs (" PAD=", dumpfile);
1751 fputs (" CONVERT=", dumpfile);
1752 show_expr (i->convert);
1754 if (i->asynchronous)
1756 fputs (" ASYNCHRONOUS=", dumpfile);
1757 show_expr (i->asynchronous);
1761 fputs (" DECIMAL=", dumpfile);
1762 show_expr (i->decimal);
1766 fputs (" ENCODING=", dumpfile);
1767 show_expr (i->encoding);
1771 fputs (" PENDING=", dumpfile);
1772 show_expr (i->pending);
1776 fputs (" ROUND=", dumpfile);
1777 show_expr (i->round);
1781 fputs (" SIGN=", dumpfile);
1782 show_expr (i->sign);
1786 fputs (" SIZE=", dumpfile);
1787 show_expr (i->size);
1791 fputs (" ID=", dumpfile);
1796 fprintf (dumpfile, " ERR=%d", i->err->value);
1800 fputs ("IOLENGTH ", dumpfile);
1801 show_expr (c->expr);
1806 fputs ("READ", dumpfile);
1810 fputs ("WRITE", dumpfile);
1816 fputs (" UNIT=", dumpfile);
1817 show_expr (dt->io_unit);
1820 if (dt->format_expr)
1822 fputs (" FMT=", dumpfile);
1823 show_expr (dt->format_expr);
1826 if (dt->format_label != NULL)
1827 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1829 fprintf (dumpfile, " NML=%s", dt->namelist->name);
1833 fputs (" IOMSG=", dumpfile);
1834 show_expr (dt->iomsg);
1838 fputs (" IOSTAT=", dumpfile);
1839 show_expr (dt->iostat);
1843 fputs (" SIZE=", dumpfile);
1844 show_expr (dt->size);
1848 fputs (" REC=", dumpfile);
1849 show_expr (dt->rec);
1853 fputs (" ADVANCE=", dumpfile);
1854 show_expr (dt->advance);
1858 fputs (" ID=", dumpfile);
1863 fputs (" POS=", dumpfile);
1864 show_expr (dt->pos);
1866 if (dt->asynchronous)
1868 fputs (" ASYNCHRONOUS=", dumpfile);
1869 show_expr (dt->asynchronous);
1873 fputs (" BLANK=", dumpfile);
1874 show_expr (dt->blank);
1878 fputs (" DECIMAL=", dumpfile);
1879 show_expr (dt->decimal);
1883 fputs (" DELIM=", dumpfile);
1884 show_expr (dt->delim);
1888 fputs (" PAD=", dumpfile);
1889 show_expr (dt->pad);
1893 fputs (" ROUND=", dumpfile);
1894 show_expr (dt->round);
1898 fputs (" SIGN=", dumpfile);
1899 show_expr (dt->sign);
1903 fputc ('\n', dumpfile);
1904 for (c = c->block->next; c; c = c->next)
1905 show_code_node (level + (c->next != NULL), c);
1909 fputs ("TRANSFER ", dumpfile);
1910 show_expr (c->expr);
1914 fputs ("DT_END", dumpfile);
1917 if (dt->err != NULL)
1918 fprintf (dumpfile, " ERR=%d", dt->err->value);
1919 if (dt->end != NULL)
1920 fprintf (dumpfile, " END=%d", dt->end->value);
1921 if (dt->eor != NULL)
1922 fprintf (dumpfile, " EOR=%d", dt->eor->value);
1925 case EXEC_OMP_ATOMIC:
1926 case EXEC_OMP_BARRIER:
1927 case EXEC_OMP_CRITICAL:
1928 case EXEC_OMP_FLUSH:
1930 case EXEC_OMP_MASTER:
1931 case EXEC_OMP_ORDERED:
1932 case EXEC_OMP_PARALLEL:
1933 case EXEC_OMP_PARALLEL_DO:
1934 case EXEC_OMP_PARALLEL_SECTIONS:
1935 case EXEC_OMP_PARALLEL_WORKSHARE:
1936 case EXEC_OMP_SECTIONS:
1937 case EXEC_OMP_SINGLE:
1939 case EXEC_OMP_TASKWAIT:
1940 case EXEC_OMP_WORKSHARE:
1941 show_omp_node (level, c);
1945 gfc_internal_error ("show_code_node(): Bad statement code");
1948 fputc ('\n', dumpfile);
1952 /* Show an equivalence chain. */
1955 show_equiv (gfc_equiv *eq)
1958 fputs ("Equivalence: ", dumpfile);
1961 show_expr (eq->expr);
1964 fputs (", ", dumpfile);
1969 /* Show a freakin' whole namespace. */
1972 show_namespace (gfc_namespace *ns)
1974 gfc_interface *intr;
1975 gfc_namespace *save;
1976 gfc_intrinsic_op op;
1980 save = gfc_current_ns;
1984 fputs ("Namespace:", dumpfile);
1992 while (i < GFC_LETTERS - 1
1993 && gfc_compare_types(&ns->default_type[i+1],
1994 &ns->default_type[l]))
1998 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2000 fprintf (dumpfile, " %c: ", l+'A');
2002 show_typespec(&ns->default_type[l]);
2004 } while (i < GFC_LETTERS);
2006 if (ns->proc_name != NULL)
2009 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2012 gfc_current_ns = ns;
2013 gfc_traverse_symtree (ns->common_root, show_common);
2015 gfc_traverse_symtree (ns->sym_root, show_symtree);
2017 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2019 /* User operator interfaces */
2025 fprintf (dumpfile, "Operator interfaces for %s:",
2026 gfc_op2string (op));
2028 for (; intr; intr = intr->next)
2029 fprintf (dumpfile, " %s", intr->sym->name);
2032 if (ns->uop_root != NULL)
2035 fputs ("User operators:\n", dumpfile);
2036 gfc_traverse_user_op (ns, show_uop);
2040 for (eq = ns->equiv; eq; eq = eq->next)
2043 fputc ('\n', dumpfile);
2044 fputc ('\n', dumpfile);
2046 show_code (0, ns->code);
2048 for (ns = ns->contained; ns; ns = ns->sibling)
2051 fputs ("CONTAINS\n", dumpfile);
2052 show_namespace (ns);
2056 fputc ('\n', dumpfile);
2057 gfc_current_ns = save;
2061 /* Main function for dumping a parse tree. */
2064 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2067 show_namespace (ns);