2 Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009
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->u.derived->name);
92 show_expr (ts->u.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.u.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, mpc_realref (p->value.complex),
407 if (p->ts.kind != gfc_default_complex_kind)
408 fprintf (dumpfile, "_%d", p->ts.kind);
410 fputc (' ', dumpfile);
412 mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
414 if (p->ts.kind != gfc_default_complex_kind)
415 fprintf (dumpfile, "_%d", p->ts.kind);
417 fputc (')', dumpfile);
421 fprintf (dumpfile, "%dH", p->representation.length);
422 c = p->representation.string;
423 for (i = 0; i < p->representation.length; i++, c++)
425 fputc (*c, dumpfile);
430 fputs ("???", dumpfile);
434 if (p->representation.string)
436 fputs (" {", dumpfile);
437 c = p->representation.string;
438 for (i = 0; i < p->representation.length; i++, c++)
440 fprintf (dumpfile, "%.2x", (unsigned int) *c);
441 if (i < p->representation.length - 1)
442 fputc (',', dumpfile);
444 fputc ('}', dumpfile);
450 if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
451 fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
452 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
457 fputc ('(', dumpfile);
458 switch (p->value.op.op)
460 case INTRINSIC_UPLUS:
461 fputs ("U+ ", dumpfile);
463 case INTRINSIC_UMINUS:
464 fputs ("U- ", dumpfile);
467 fputs ("+ ", dumpfile);
469 case INTRINSIC_MINUS:
470 fputs ("- ", dumpfile);
472 case INTRINSIC_TIMES:
473 fputs ("* ", dumpfile);
475 case INTRINSIC_DIVIDE:
476 fputs ("/ ", dumpfile);
478 case INTRINSIC_POWER:
479 fputs ("** ", dumpfile);
481 case INTRINSIC_CONCAT:
482 fputs ("// ", dumpfile);
485 fputs ("AND ", dumpfile);
488 fputs ("OR ", dumpfile);
491 fputs ("EQV ", dumpfile);
494 fputs ("NEQV ", dumpfile);
497 case INTRINSIC_EQ_OS:
498 fputs ("= ", dumpfile);
501 case INTRINSIC_NE_OS:
502 fputs ("/= ", dumpfile);
505 case INTRINSIC_GT_OS:
506 fputs ("> ", dumpfile);
509 case INTRINSIC_GE_OS:
510 fputs (">= ", dumpfile);
513 case INTRINSIC_LT_OS:
514 fputs ("< ", dumpfile);
517 case INTRINSIC_LE_OS:
518 fputs ("<= ", dumpfile);
521 fputs ("NOT ", dumpfile);
523 case INTRINSIC_PARENTHESES:
524 fputs ("parens", dumpfile);
529 ("show_expr(): Bad intrinsic in expression!");
532 show_expr (p->value.op.op1);
536 fputc (' ', dumpfile);
537 show_expr (p->value.op.op2);
540 fputc (')', dumpfile);
544 if (p->value.function.name == NULL)
546 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
547 if (gfc_is_proc_ptr_comp (p, NULL))
549 fputc ('[', dumpfile);
550 show_actual_arglist (p->value.function.actual);
551 fputc (']', dumpfile);
555 fprintf (dumpfile, "%s", p->value.function.name);
556 if (gfc_is_proc_ptr_comp (p, NULL))
558 fputc ('[', dumpfile);
559 fputc ('[', dumpfile);
560 show_actual_arglist (p->value.function.actual);
561 fputc (']', dumpfile);
562 fputc (']', dumpfile);
572 gfc_internal_error ("show_expr(): Don't know how to show expr");
576 /* Show symbol attributes. The flavor and intent are followed by
577 whatever single bit attributes are present. */
580 show_attr (symbol_attribute *attr)
583 fprintf (dumpfile, "(%s %s %s %s %s",
584 gfc_code2string (flavors, attr->flavor),
585 gfc_intent_string (attr->intent),
586 gfc_code2string (access_types, attr->access),
587 gfc_code2string (procedures, attr->proc),
588 gfc_code2string (save_status, attr->save));
590 if (attr->allocatable)
591 fputs (" ALLOCATABLE", dumpfile);
593 fputs (" DIMENSION", dumpfile);
595 fputs (" EXTERNAL", dumpfile);
597 fputs (" INTRINSIC", dumpfile);
599 fputs (" OPTIONAL", dumpfile);
601 fputs (" POINTER", dumpfile);
602 if (attr->is_protected)
603 fputs (" PROTECTED", dumpfile);
605 fputs (" VALUE", dumpfile);
607 fputs (" VOLATILE", dumpfile);
608 if (attr->threadprivate)
609 fputs (" THREADPRIVATE", dumpfile);
611 fputs (" TARGET", dumpfile);
613 fputs (" DUMMY", dumpfile);
615 fputs (" RESULT", dumpfile);
617 fputs (" ENTRY", dumpfile);
619 fputs (" BIND(C)", dumpfile);
622 fputs (" DATA", dumpfile);
624 fputs (" USE-ASSOC", dumpfile);
625 if (attr->in_namelist)
626 fputs (" IN-NAMELIST", dumpfile);
628 fputs (" IN-COMMON", dumpfile);
631 fputs (" ABSTRACT", dumpfile);
633 fputs (" FUNCTION", dumpfile);
634 if (attr->subroutine)
635 fputs (" SUBROUTINE", dumpfile);
636 if (attr->implicit_type)
637 fputs (" IMPLICIT-TYPE", dumpfile);
640 fputs (" SEQUENCE", dumpfile);
642 fputs (" ELEMENTAL", dumpfile);
644 fputs (" PURE", dumpfile);
646 fputs (" RECURSIVE", dumpfile);
648 fputc (')', dumpfile);
652 /* Show components of a derived type. */
655 show_components (gfc_symbol *sym)
659 for (c = sym->components; c; c = c->next)
661 fprintf (dumpfile, "(%s ", c->name);
662 show_typespec (&c->ts);
664 fputs (" POINTER", dumpfile);
665 if (c->attr.proc_pointer)
666 fputs (" PPC", dumpfile);
667 if (c->attr.dimension)
668 fputs (" DIMENSION", dumpfile);
669 fputc (' ', dumpfile);
670 show_array_spec (c->as);
672 fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
673 fputc (')', dumpfile);
675 fputc (' ', dumpfile);
680 /* Show the f2k_derived namespace with procedure bindings. */
683 show_typebound_proc (gfc_typebound_proc* tb, const char* name)
688 fputs ("GENERIC", dumpfile);
691 fputs ("PROCEDURE, ", dumpfile);
693 fputs ("NOPASS", dumpfile);
697 fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
699 fputs ("PASS", dumpfile);
701 if (tb->non_overridable)
702 fputs (", NON_OVERRIDABLE", dumpfile);
705 if (tb->access == ACCESS_PUBLIC)
706 fputs (", PUBLIC", dumpfile);
708 fputs (", PRIVATE", dumpfile);
710 fprintf (dumpfile, " :: %s => ", name);
715 for (g = tb->u.generic; g; g = g->next)
717 fputs (g->specific_st->name, dumpfile);
719 fputs (", ", dumpfile);
723 fputs (tb->u.specific->n.sym->name, dumpfile);
727 show_typebound_symtree (gfc_symtree* st)
729 gcc_assert (st->n.tb);
730 show_typebound_proc (st->n.tb, st->name);
734 show_f2k_derived (gfc_namespace* f2k)
740 fputs ("Procedure bindings:", dumpfile);
743 /* Finalizer bindings. */
744 for (f = f2k->finalizers; f; f = f->next)
747 fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
750 /* Type-bound procedures. */
751 gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
756 fputs ("Operator bindings:", dumpfile);
759 /* User-defined operators. */
760 gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
762 /* Intrinsic operators. */
763 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
765 show_typebound_proc (f2k->tb_op[op],
766 gfc_op2string ((gfc_intrinsic_op) op));
772 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
773 show the interface. Information needed to reconstruct the list of
774 specific interfaces associated with a generic symbol is done within
778 show_symbol (gfc_symbol *sym)
780 gfc_formal_arglist *formal;
788 fprintf (dumpfile, "symbol %s ", sym->name);
789 show_typespec (&sym->ts);
790 show_attr (&sym->attr);
795 fputs ("value: ", dumpfile);
796 show_expr (sym->value);
802 fputs ("Array spec:", dumpfile);
803 show_array_spec (sym->as);
809 fputs ("Generic interfaces:", dumpfile);
810 for (intr = sym->generic; intr; intr = intr->next)
811 fprintf (dumpfile, " %s", intr->sym->name);
817 fprintf (dumpfile, "result: %s", sym->result->name);
823 fputs ("components: ", dumpfile);
824 show_components (sym);
827 if (sym->f2k_derived)
828 show_f2k_derived (sym->f2k_derived);
833 fputs ("Formal arglist:", dumpfile);
835 for (formal = sym->formal; formal; formal = formal->next)
837 if (formal->sym != NULL)
838 fprintf (dumpfile, " %s", formal->sym->name);
840 fputs (" [Alt Return]", dumpfile);
847 fputs ("Formal namespace", dumpfile);
848 show_namespace (sym->formal_ns);
851 fputc ('\n', dumpfile);
855 /* Show a user-defined operator. Just prints an operator
856 and the name of the associated subroutine, really. */
859 show_uop (gfc_user_op *uop)
864 fprintf (dumpfile, "%s:", uop->name);
866 for (intr = uop->op; intr; intr = intr->next)
867 fprintf (dumpfile, " %s", intr->sym->name);
871 /* Workhorse function for traversing the user operator symtree. */
874 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
881 traverse_uop (st->left, func);
882 traverse_uop (st->right, func);
886 /* Traverse the tree of user operator nodes. */
889 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
891 traverse_uop (ns->uop_root, func);
895 /* Function to display a common block. */
898 show_common (gfc_symtree *st)
903 fprintf (dumpfile, "common: /%s/ ", st->name);
905 s = st->n.common->head;
908 fprintf (dumpfile, "%s", s->name);
911 fputs (", ", dumpfile);
913 fputc ('\n', dumpfile);
917 /* Worker function to display the symbol tree. */
920 show_symtree (gfc_symtree *st)
923 fprintf (dumpfile, "symtree: %s Ambig %d", st->name, st->ambiguous);
925 if (st->n.sym->ns != gfc_current_ns)
926 fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
928 show_symbol (st->n.sym);
932 /******************* Show gfc_code structures **************/
935 /* Show a list of code structures. Mutually recursive with
939 show_code (int level, gfc_code *c)
941 for (; c; c = c->next)
942 show_code_node (level, c);
946 show_namelist (gfc_namelist *n)
948 for (; n->next; n = n->next)
949 fprintf (dumpfile, "%s,", n->sym->name);
950 fprintf (dumpfile, "%s", n->sym->name);
953 /* Show a single OpenMP directive node and everything underneath it
957 show_omp_node (int level, gfc_code *c)
959 gfc_omp_clauses *omp_clauses = NULL;
960 const char *name = NULL;
964 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
965 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
966 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
967 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
968 case EXEC_OMP_DO: name = "DO"; break;
969 case EXEC_OMP_MASTER: name = "MASTER"; break;
970 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
971 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
972 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
973 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
974 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
975 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
976 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
977 case EXEC_OMP_TASK: name = "TASK"; break;
978 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
979 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
983 fprintf (dumpfile, "!$OMP %s", name);
987 case EXEC_OMP_PARALLEL:
988 case EXEC_OMP_PARALLEL_DO:
989 case EXEC_OMP_PARALLEL_SECTIONS:
990 case EXEC_OMP_SECTIONS:
991 case EXEC_OMP_SINGLE:
992 case EXEC_OMP_WORKSHARE:
993 case EXEC_OMP_PARALLEL_WORKSHARE:
995 omp_clauses = c->ext.omp_clauses;
997 case EXEC_OMP_CRITICAL:
999 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1001 case EXEC_OMP_FLUSH:
1002 if (c->ext.omp_namelist)
1004 fputs (" (", dumpfile);
1005 show_namelist (c->ext.omp_namelist);
1006 fputc (')', dumpfile);
1009 case EXEC_OMP_BARRIER:
1010 case EXEC_OMP_TASKWAIT:
1019 if (omp_clauses->if_expr)
1021 fputs (" IF(", dumpfile);
1022 show_expr (omp_clauses->if_expr);
1023 fputc (')', dumpfile);
1025 if (omp_clauses->num_threads)
1027 fputs (" NUM_THREADS(", dumpfile);
1028 show_expr (omp_clauses->num_threads);
1029 fputc (')', dumpfile);
1031 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1034 switch (omp_clauses->sched_kind)
1036 case OMP_SCHED_STATIC: type = "STATIC"; break;
1037 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1038 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1039 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1040 case OMP_SCHED_AUTO: type = "AUTO"; break;
1044 fprintf (dumpfile, " SCHEDULE (%s", type);
1045 if (omp_clauses->chunk_size)
1047 fputc (',', dumpfile);
1048 show_expr (omp_clauses->chunk_size);
1050 fputc (')', dumpfile);
1052 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1055 switch (omp_clauses->default_sharing)
1057 case OMP_DEFAULT_NONE: type = "NONE"; break;
1058 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1059 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1060 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1064 fprintf (dumpfile, " DEFAULT(%s)", type);
1066 if (omp_clauses->ordered)
1067 fputs (" ORDERED", dumpfile);
1068 if (omp_clauses->untied)
1069 fputs (" UNTIED", dumpfile);
1070 if (omp_clauses->collapse)
1071 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1072 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1073 if (omp_clauses->lists[list_type] != NULL
1074 && list_type != OMP_LIST_COPYPRIVATE)
1077 if (list_type >= OMP_LIST_REDUCTION_FIRST)
1081 case OMP_LIST_PLUS: type = "+"; break;
1082 case OMP_LIST_MULT: type = "*"; break;
1083 case OMP_LIST_SUB: type = "-"; break;
1084 case OMP_LIST_AND: type = ".AND."; break;
1085 case OMP_LIST_OR: type = ".OR."; break;
1086 case OMP_LIST_EQV: type = ".EQV."; break;
1087 case OMP_LIST_NEQV: type = ".NEQV."; break;
1088 case OMP_LIST_MAX: type = "MAX"; break;
1089 case OMP_LIST_MIN: type = "MIN"; break;
1090 case OMP_LIST_IAND: type = "IAND"; break;
1091 case OMP_LIST_IOR: type = "IOR"; break;
1092 case OMP_LIST_IEOR: type = "IEOR"; break;
1096 fprintf (dumpfile, " REDUCTION(%s:", type);
1102 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1103 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1104 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1105 case OMP_LIST_SHARED: type = "SHARED"; break;
1106 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1110 fprintf (dumpfile, " %s(", type);
1112 show_namelist (omp_clauses->lists[list_type]);
1113 fputc (')', dumpfile);
1116 fputc ('\n', dumpfile);
1117 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1119 gfc_code *d = c->block;
1122 show_code (level + 1, d->next);
1123 if (d->block == NULL)
1125 code_indent (level, 0);
1126 fputs ("!$OMP SECTION\n", dumpfile);
1131 show_code (level + 1, c->block->next);
1132 if (c->op == EXEC_OMP_ATOMIC)
1134 code_indent (level, 0);
1135 fprintf (dumpfile, "!$OMP END %s", name);
1136 if (omp_clauses != NULL)
1138 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1140 fputs (" COPYPRIVATE(", dumpfile);
1141 show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1142 fputc (')', dumpfile);
1144 else if (omp_clauses->nowait)
1145 fputs (" NOWAIT", dumpfile);
1147 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1148 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1152 /* Show a single code node and everything underneath it if necessary. */
1155 show_code_node (int level, gfc_code *c)
1157 gfc_forall_iterator *fa;
1167 code_indent (level, c->here);
1171 case EXEC_END_PROCEDURE:
1175 fputs ("NOP", dumpfile);
1179 fputs ("CONTINUE", dumpfile);
1183 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1186 case EXEC_INIT_ASSIGN:
1188 fputs ("ASSIGN ", dumpfile);
1189 show_expr (c->expr1);
1190 fputc (' ', dumpfile);
1191 show_expr (c->expr2);
1194 case EXEC_LABEL_ASSIGN:
1195 fputs ("LABEL ASSIGN ", dumpfile);
1196 show_expr (c->expr1);
1197 fprintf (dumpfile, " %d", c->label1->value);
1200 case EXEC_POINTER_ASSIGN:
1201 fputs ("POINTER ASSIGN ", dumpfile);
1202 show_expr (c->expr1);
1203 fputc (' ', dumpfile);
1204 show_expr (c->expr2);
1208 fputs ("GOTO ", dumpfile);
1210 fprintf (dumpfile, "%d", c->label1->value);
1213 show_expr (c->expr1);
1217 fputs (", (", dumpfile);
1218 for (; d; d = d ->block)
1220 code_indent (level, d->label1);
1221 if (d->block != NULL)
1222 fputc (',', dumpfile);
1224 fputc (')', dumpfile);
1231 case EXEC_ASSIGN_CALL:
1232 if (c->resolved_sym)
1233 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1234 else if (c->symtree)
1235 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1237 fputs ("CALL ?? ", dumpfile);
1239 show_actual_arglist (c->ext.actual);
1243 fputs ("CALL ", dumpfile);
1244 show_compcall (c->expr1);
1248 fputs ("CALL ", dumpfile);
1249 show_expr (c->expr1);
1250 show_actual_arglist (c->ext.actual);
1254 fputs ("RETURN ", dumpfile);
1256 show_expr (c->expr1);
1260 fputs ("PAUSE ", dumpfile);
1262 if (c->expr1 != NULL)
1263 show_expr (c->expr1);
1265 fprintf (dumpfile, "%d", c->ext.stop_code);
1270 fputs ("STOP ", dumpfile);
1272 if (c->expr1 != NULL)
1273 show_expr (c->expr1);
1275 fprintf (dumpfile, "%d", c->ext.stop_code);
1279 case EXEC_ARITHMETIC_IF:
1280 fputs ("IF ", dumpfile);
1281 show_expr (c->expr1);
1282 fprintf (dumpfile, " %d, %d, %d",
1283 c->label1->value, c->label2->value, c->label3->value);
1288 fputs ("IF ", dumpfile);
1289 show_expr (d->expr1);
1290 fputc ('\n', dumpfile);
1291 show_code (level + 1, d->next);
1294 for (; d; d = d->block)
1296 code_indent (level, 0);
1298 if (d->expr1 == NULL)
1299 fputs ("ELSE\n", dumpfile);
1302 fputs ("ELSE IF ", dumpfile);
1303 show_expr (d->expr1);
1304 fputc ('\n', dumpfile);
1307 show_code (level + 1, d->next);
1310 code_indent (level, c->label1);
1312 fputs ("ENDIF", dumpfile);
1317 fputs ("SELECT CASE ", dumpfile);
1318 show_expr (c->expr1);
1319 fputc ('\n', dumpfile);
1321 for (; d; d = d->block)
1323 code_indent (level, 0);
1325 fputs ("CASE ", dumpfile);
1326 for (cp = d->ext.case_list; cp; cp = cp->next)
1328 fputc ('(', dumpfile);
1329 show_expr (cp->low);
1330 fputc (' ', dumpfile);
1331 show_expr (cp->high);
1332 fputc (')', dumpfile);
1333 fputc (' ', dumpfile);
1335 fputc ('\n', dumpfile);
1337 show_code (level + 1, d->next);
1340 code_indent (level, c->label1);
1341 fputs ("END SELECT", dumpfile);
1345 fputs ("WHERE ", dumpfile);
1348 show_expr (d->expr1);
1349 fputc ('\n', dumpfile);
1351 show_code (level + 1, d->next);
1353 for (d = d->block; d; d = d->block)
1355 code_indent (level, 0);
1356 fputs ("ELSE WHERE ", dumpfile);
1357 show_expr (d->expr1);
1358 fputc ('\n', dumpfile);
1359 show_code (level + 1, d->next);
1362 code_indent (level, 0);
1363 fputs ("END WHERE", dumpfile);
1368 fputs ("FORALL ", dumpfile);
1369 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1371 show_expr (fa->var);
1372 fputc (' ', dumpfile);
1373 show_expr (fa->start);
1374 fputc (':', dumpfile);
1375 show_expr (fa->end);
1376 fputc (':', dumpfile);
1377 show_expr (fa->stride);
1379 if (fa->next != NULL)
1380 fputc (',', dumpfile);
1383 if (c->expr1 != NULL)
1385 fputc (',', dumpfile);
1386 show_expr (c->expr1);
1388 fputc ('\n', dumpfile);
1390 show_code (level + 1, c->block->next);
1392 code_indent (level, 0);
1393 fputs ("END FORALL", dumpfile);
1397 fputs ("DO ", dumpfile);
1399 show_expr (c->ext.iterator->var);
1400 fputc ('=', dumpfile);
1401 show_expr (c->ext.iterator->start);
1402 fputc (' ', dumpfile);
1403 show_expr (c->ext.iterator->end);
1404 fputc (' ', dumpfile);
1405 show_expr (c->ext.iterator->step);
1406 fputc ('\n', dumpfile);
1408 show_code (level + 1, c->block->next);
1410 code_indent (level, 0);
1411 fputs ("END DO", dumpfile);
1415 fputs ("DO WHILE ", dumpfile);
1416 show_expr (c->expr1);
1417 fputc ('\n', dumpfile);
1419 show_code (level + 1, c->block->next);
1421 code_indent (level, c->label1);
1422 fputs ("END DO", dumpfile);
1426 fputs ("CYCLE", dumpfile);
1428 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1432 fputs ("EXIT", dumpfile);
1434 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1438 fputs ("ALLOCATE ", dumpfile);
1441 fputs (" STAT=", dumpfile);
1442 show_expr (c->expr1);
1447 fputs (" ERRMSG=", dumpfile);
1448 show_expr (c->expr2);
1451 for (a = c->ext.alloc_list; a; a = a->next)
1453 fputc (' ', dumpfile);
1454 show_expr (a->expr);
1459 case EXEC_DEALLOCATE:
1460 fputs ("DEALLOCATE ", dumpfile);
1463 fputs (" STAT=", dumpfile);
1464 show_expr (c->expr1);
1469 fputs (" ERRMSG=", dumpfile);
1470 show_expr (c->expr2);
1473 for (a = c->ext.alloc_list; a; a = a->next)
1475 fputc (' ', dumpfile);
1476 show_expr (a->expr);
1482 fputs ("OPEN", dumpfile);
1487 fputs (" UNIT=", dumpfile);
1488 show_expr (open->unit);
1492 fputs (" IOMSG=", dumpfile);
1493 show_expr (open->iomsg);
1497 fputs (" IOSTAT=", dumpfile);
1498 show_expr (open->iostat);
1502 fputs (" FILE=", dumpfile);
1503 show_expr (open->file);
1507 fputs (" STATUS=", dumpfile);
1508 show_expr (open->status);
1512 fputs (" ACCESS=", dumpfile);
1513 show_expr (open->access);
1517 fputs (" FORM=", dumpfile);
1518 show_expr (open->form);
1522 fputs (" RECL=", dumpfile);
1523 show_expr (open->recl);
1527 fputs (" BLANK=", dumpfile);
1528 show_expr (open->blank);
1532 fputs (" POSITION=", dumpfile);
1533 show_expr (open->position);
1537 fputs (" ACTION=", dumpfile);
1538 show_expr (open->action);
1542 fputs (" DELIM=", dumpfile);
1543 show_expr (open->delim);
1547 fputs (" PAD=", dumpfile);
1548 show_expr (open->pad);
1552 fputs (" DECIMAL=", dumpfile);
1553 show_expr (open->decimal);
1557 fputs (" ENCODING=", dumpfile);
1558 show_expr (open->encoding);
1562 fputs (" ROUND=", dumpfile);
1563 show_expr (open->round);
1567 fputs (" SIGN=", dumpfile);
1568 show_expr (open->sign);
1572 fputs (" CONVERT=", dumpfile);
1573 show_expr (open->convert);
1575 if (open->asynchronous)
1577 fputs (" ASYNCHRONOUS=", dumpfile);
1578 show_expr (open->asynchronous);
1580 if (open->err != NULL)
1581 fprintf (dumpfile, " ERR=%d", open->err->value);
1586 fputs ("CLOSE", dumpfile);
1587 close = c->ext.close;
1591 fputs (" UNIT=", dumpfile);
1592 show_expr (close->unit);
1596 fputs (" IOMSG=", dumpfile);
1597 show_expr (close->iomsg);
1601 fputs (" IOSTAT=", dumpfile);
1602 show_expr (close->iostat);
1606 fputs (" STATUS=", dumpfile);
1607 show_expr (close->status);
1609 if (close->err != NULL)
1610 fprintf (dumpfile, " ERR=%d", close->err->value);
1613 case EXEC_BACKSPACE:
1614 fputs ("BACKSPACE", dumpfile);
1618 fputs ("ENDFILE", dumpfile);
1622 fputs ("REWIND", dumpfile);
1626 fputs ("FLUSH", dumpfile);
1629 fp = c->ext.filepos;
1633 fputs (" UNIT=", dumpfile);
1634 show_expr (fp->unit);
1638 fputs (" IOMSG=", dumpfile);
1639 show_expr (fp->iomsg);
1643 fputs (" IOSTAT=", dumpfile);
1644 show_expr (fp->iostat);
1646 if (fp->err != NULL)
1647 fprintf (dumpfile, " ERR=%d", fp->err->value);
1651 fputs ("INQUIRE", dumpfile);
1656 fputs (" UNIT=", dumpfile);
1657 show_expr (i->unit);
1661 fputs (" FILE=", dumpfile);
1662 show_expr (i->file);
1667 fputs (" IOMSG=", dumpfile);
1668 show_expr (i->iomsg);
1672 fputs (" IOSTAT=", dumpfile);
1673 show_expr (i->iostat);
1677 fputs (" EXIST=", dumpfile);
1678 show_expr (i->exist);
1682 fputs (" OPENED=", dumpfile);
1683 show_expr (i->opened);
1687 fputs (" NUMBER=", dumpfile);
1688 show_expr (i->number);
1692 fputs (" NAMED=", dumpfile);
1693 show_expr (i->named);
1697 fputs (" NAME=", dumpfile);
1698 show_expr (i->name);
1702 fputs (" ACCESS=", dumpfile);
1703 show_expr (i->access);
1707 fputs (" SEQUENTIAL=", dumpfile);
1708 show_expr (i->sequential);
1713 fputs (" DIRECT=", dumpfile);
1714 show_expr (i->direct);
1718 fputs (" FORM=", dumpfile);
1719 show_expr (i->form);
1723 fputs (" FORMATTED", dumpfile);
1724 show_expr (i->formatted);
1728 fputs (" UNFORMATTED=", dumpfile);
1729 show_expr (i->unformatted);
1733 fputs (" RECL=", dumpfile);
1734 show_expr (i->recl);
1738 fputs (" NEXTREC=", dumpfile);
1739 show_expr (i->nextrec);
1743 fputs (" BLANK=", dumpfile);
1744 show_expr (i->blank);
1748 fputs (" POSITION=", dumpfile);
1749 show_expr (i->position);
1753 fputs (" ACTION=", dumpfile);
1754 show_expr (i->action);
1758 fputs (" READ=", dumpfile);
1759 show_expr (i->read);
1763 fputs (" WRITE=", dumpfile);
1764 show_expr (i->write);
1768 fputs (" READWRITE=", dumpfile);
1769 show_expr (i->readwrite);
1773 fputs (" DELIM=", dumpfile);
1774 show_expr (i->delim);
1778 fputs (" PAD=", dumpfile);
1783 fputs (" CONVERT=", dumpfile);
1784 show_expr (i->convert);
1786 if (i->asynchronous)
1788 fputs (" ASYNCHRONOUS=", dumpfile);
1789 show_expr (i->asynchronous);
1793 fputs (" DECIMAL=", dumpfile);
1794 show_expr (i->decimal);
1798 fputs (" ENCODING=", dumpfile);
1799 show_expr (i->encoding);
1803 fputs (" PENDING=", dumpfile);
1804 show_expr (i->pending);
1808 fputs (" ROUND=", dumpfile);
1809 show_expr (i->round);
1813 fputs (" SIGN=", dumpfile);
1814 show_expr (i->sign);
1818 fputs (" SIZE=", dumpfile);
1819 show_expr (i->size);
1823 fputs (" ID=", dumpfile);
1828 fprintf (dumpfile, " ERR=%d", i->err->value);
1832 fputs ("IOLENGTH ", dumpfile);
1833 show_expr (c->expr1);
1838 fputs ("READ", dumpfile);
1842 fputs ("WRITE", dumpfile);
1848 fputs (" UNIT=", dumpfile);
1849 show_expr (dt->io_unit);
1852 if (dt->format_expr)
1854 fputs (" FMT=", dumpfile);
1855 show_expr (dt->format_expr);
1858 if (dt->format_label != NULL)
1859 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1861 fprintf (dumpfile, " NML=%s", dt->namelist->name);
1865 fputs (" IOMSG=", dumpfile);
1866 show_expr (dt->iomsg);
1870 fputs (" IOSTAT=", dumpfile);
1871 show_expr (dt->iostat);
1875 fputs (" SIZE=", dumpfile);
1876 show_expr (dt->size);
1880 fputs (" REC=", dumpfile);
1881 show_expr (dt->rec);
1885 fputs (" ADVANCE=", dumpfile);
1886 show_expr (dt->advance);
1890 fputs (" ID=", dumpfile);
1895 fputs (" POS=", dumpfile);
1896 show_expr (dt->pos);
1898 if (dt->asynchronous)
1900 fputs (" ASYNCHRONOUS=", dumpfile);
1901 show_expr (dt->asynchronous);
1905 fputs (" BLANK=", dumpfile);
1906 show_expr (dt->blank);
1910 fputs (" DECIMAL=", dumpfile);
1911 show_expr (dt->decimal);
1915 fputs (" DELIM=", dumpfile);
1916 show_expr (dt->delim);
1920 fputs (" PAD=", dumpfile);
1921 show_expr (dt->pad);
1925 fputs (" ROUND=", dumpfile);
1926 show_expr (dt->round);
1930 fputs (" SIGN=", dumpfile);
1931 show_expr (dt->sign);
1935 fputc ('\n', dumpfile);
1936 for (c = c->block->next; c; c = c->next)
1937 show_code_node (level + (c->next != NULL), c);
1941 fputs ("TRANSFER ", dumpfile);
1942 show_expr (c->expr1);
1946 fputs ("DT_END", dumpfile);
1949 if (dt->err != NULL)
1950 fprintf (dumpfile, " ERR=%d", dt->err->value);
1951 if (dt->end != NULL)
1952 fprintf (dumpfile, " END=%d", dt->end->value);
1953 if (dt->eor != NULL)
1954 fprintf (dumpfile, " EOR=%d", dt->eor->value);
1957 case EXEC_OMP_ATOMIC:
1958 case EXEC_OMP_BARRIER:
1959 case EXEC_OMP_CRITICAL:
1960 case EXEC_OMP_FLUSH:
1962 case EXEC_OMP_MASTER:
1963 case EXEC_OMP_ORDERED:
1964 case EXEC_OMP_PARALLEL:
1965 case EXEC_OMP_PARALLEL_DO:
1966 case EXEC_OMP_PARALLEL_SECTIONS:
1967 case EXEC_OMP_PARALLEL_WORKSHARE:
1968 case EXEC_OMP_SECTIONS:
1969 case EXEC_OMP_SINGLE:
1971 case EXEC_OMP_TASKWAIT:
1972 case EXEC_OMP_WORKSHARE:
1973 show_omp_node (level, c);
1977 gfc_internal_error ("show_code_node(): Bad statement code");
1980 fputc ('\n', dumpfile);
1984 /* Show an equivalence chain. */
1987 show_equiv (gfc_equiv *eq)
1990 fputs ("Equivalence: ", dumpfile);
1993 show_expr (eq->expr);
1996 fputs (", ", dumpfile);
2001 /* Show a freakin' whole namespace. */
2004 show_namespace (gfc_namespace *ns)
2006 gfc_interface *intr;
2007 gfc_namespace *save;
2012 save = gfc_current_ns;
2016 fputs ("Namespace:", dumpfile);
2024 while (i < GFC_LETTERS - 1
2025 && gfc_compare_types(&ns->default_type[i+1],
2026 &ns->default_type[l]))
2030 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2032 fprintf (dumpfile, " %c: ", l+'A');
2034 show_typespec(&ns->default_type[l]);
2036 } while (i < GFC_LETTERS);
2038 if (ns->proc_name != NULL)
2041 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2044 gfc_current_ns = ns;
2045 gfc_traverse_symtree (ns->common_root, show_common);
2047 gfc_traverse_symtree (ns->sym_root, show_symtree);
2049 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2051 /* User operator interfaces */
2057 fprintf (dumpfile, "Operator interfaces for %s:",
2058 gfc_op2string ((gfc_intrinsic_op) op));
2060 for (; intr; intr = intr->next)
2061 fprintf (dumpfile, " %s", intr->sym->name);
2064 if (ns->uop_root != NULL)
2067 fputs ("User operators:\n", dumpfile);
2068 gfc_traverse_user_op (ns, show_uop);
2072 for (eq = ns->equiv; eq; eq = eq->next)
2075 fputc ('\n', dumpfile);
2076 fputc ('\n', dumpfile);
2078 show_code (0, ns->code);
2080 for (ns = ns->contained; ns; ns = ns->sibling)
2083 fputs ("CONTAINS\n", dumpfile);
2084 show_namespace (ns);
2088 fputc ('\n', dumpfile);
2089 gfc_current_ns = save;
2093 /* Main function for dumping a parse tree. */
2096 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2099 show_namespace (ns);