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);
592 if (attr->asynchronous)
593 fputs (" ASYNCHRONOUS", dumpfile);
595 fputs (" DIMENSION", dumpfile);
597 fputs (" EXTERNAL", dumpfile);
599 fputs (" INTRINSIC", dumpfile);
601 fputs (" OPTIONAL", dumpfile);
603 fputs (" POINTER", dumpfile);
604 if (attr->is_protected)
605 fputs (" PROTECTED", dumpfile);
607 fputs (" VALUE", dumpfile);
609 fputs (" VOLATILE", dumpfile);
610 if (attr->threadprivate)
611 fputs (" THREADPRIVATE", dumpfile);
613 fputs (" TARGET", dumpfile);
615 fputs (" DUMMY", dumpfile);
617 fputs (" RESULT", dumpfile);
619 fputs (" ENTRY", dumpfile);
621 fputs (" BIND(C)", dumpfile);
624 fputs (" DATA", dumpfile);
626 fputs (" USE-ASSOC", dumpfile);
627 if (attr->in_namelist)
628 fputs (" IN-NAMELIST", dumpfile);
630 fputs (" IN-COMMON", dumpfile);
633 fputs (" ABSTRACT", dumpfile);
635 fputs (" FUNCTION", dumpfile);
636 if (attr->subroutine)
637 fputs (" SUBROUTINE", dumpfile);
638 if (attr->implicit_type)
639 fputs (" IMPLICIT-TYPE", dumpfile);
642 fputs (" SEQUENCE", dumpfile);
644 fputs (" ELEMENTAL", dumpfile);
646 fputs (" PURE", dumpfile);
648 fputs (" RECURSIVE", dumpfile);
650 fputc (')', dumpfile);
654 /* Show components of a derived type. */
657 show_components (gfc_symbol *sym)
661 for (c = sym->components; c; c = c->next)
663 fprintf (dumpfile, "(%s ", c->name);
664 show_typespec (&c->ts);
666 fputs (" POINTER", dumpfile);
667 if (c->attr.proc_pointer)
668 fputs (" PPC", dumpfile);
669 if (c->attr.dimension)
670 fputs (" DIMENSION", dumpfile);
671 fputc (' ', dumpfile);
672 show_array_spec (c->as);
674 fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
675 fputc (')', dumpfile);
677 fputc (' ', dumpfile);
682 /* Show the f2k_derived namespace with procedure bindings. */
685 show_typebound_proc (gfc_typebound_proc* tb, const char* name)
690 fputs ("GENERIC", dumpfile);
693 fputs ("PROCEDURE, ", dumpfile);
695 fputs ("NOPASS", dumpfile);
699 fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
701 fputs ("PASS", dumpfile);
703 if (tb->non_overridable)
704 fputs (", NON_OVERRIDABLE", dumpfile);
707 if (tb->access == ACCESS_PUBLIC)
708 fputs (", PUBLIC", dumpfile);
710 fputs (", PRIVATE", dumpfile);
712 fprintf (dumpfile, " :: %s => ", name);
717 for (g = tb->u.generic; g; g = g->next)
719 fputs (g->specific_st->name, dumpfile);
721 fputs (", ", dumpfile);
725 fputs (tb->u.specific->n.sym->name, dumpfile);
729 show_typebound_symtree (gfc_symtree* st)
731 gcc_assert (st->n.tb);
732 show_typebound_proc (st->n.tb, st->name);
736 show_f2k_derived (gfc_namespace* f2k)
742 fputs ("Procedure bindings:", dumpfile);
745 /* Finalizer bindings. */
746 for (f = f2k->finalizers; f; f = f->next)
749 fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
752 /* Type-bound procedures. */
753 gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
758 fputs ("Operator bindings:", dumpfile);
761 /* User-defined operators. */
762 gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
764 /* Intrinsic operators. */
765 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
767 show_typebound_proc (f2k->tb_op[op],
768 gfc_op2string ((gfc_intrinsic_op) op));
774 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
775 show the interface. Information needed to reconstruct the list of
776 specific interfaces associated with a generic symbol is done within
780 show_symbol (gfc_symbol *sym)
782 gfc_formal_arglist *formal;
790 fprintf (dumpfile, "symbol %s ", sym->name);
791 show_typespec (&sym->ts);
792 show_attr (&sym->attr);
797 fputs ("value: ", dumpfile);
798 show_expr (sym->value);
804 fputs ("Array spec:", dumpfile);
805 show_array_spec (sym->as);
811 fputs ("Generic interfaces:", dumpfile);
812 for (intr = sym->generic; intr; intr = intr->next)
813 fprintf (dumpfile, " %s", intr->sym->name);
819 fprintf (dumpfile, "result: %s", sym->result->name);
825 fputs ("components: ", dumpfile);
826 show_components (sym);
829 if (sym->f2k_derived)
833 fprintf (dumpfile, "hash: %d", sym->hash_value);
834 show_f2k_derived (sym->f2k_derived);
840 fputs ("Formal arglist:", dumpfile);
842 for (formal = sym->formal; formal; formal = formal->next)
844 if (formal->sym != NULL)
845 fprintf (dumpfile, " %s", formal->sym->name);
847 fputs (" [Alt Return]", dumpfile);
854 fputs ("Formal namespace", dumpfile);
855 show_namespace (sym->formal_ns);
858 fputc ('\n', dumpfile);
862 /* Show a user-defined operator. Just prints an operator
863 and the name of the associated subroutine, really. */
866 show_uop (gfc_user_op *uop)
871 fprintf (dumpfile, "%s:", uop->name);
873 for (intr = uop->op; intr; intr = intr->next)
874 fprintf (dumpfile, " %s", intr->sym->name);
878 /* Workhorse function for traversing the user operator symtree. */
881 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
888 traverse_uop (st->left, func);
889 traverse_uop (st->right, func);
893 /* Traverse the tree of user operator nodes. */
896 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
898 traverse_uop (ns->uop_root, func);
902 /* Function to display a common block. */
905 show_common (gfc_symtree *st)
910 fprintf (dumpfile, "common: /%s/ ", st->name);
912 s = st->n.common->head;
915 fprintf (dumpfile, "%s", s->name);
918 fputs (", ", dumpfile);
920 fputc ('\n', dumpfile);
924 /* Worker function to display the symbol tree. */
927 show_symtree (gfc_symtree *st)
930 fprintf (dumpfile, "symtree: %s Ambig %d", st->name, st->ambiguous);
932 if (st->n.sym->ns != gfc_current_ns)
933 fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
935 show_symbol (st->n.sym);
939 /******************* Show gfc_code structures **************/
942 /* Show a list of code structures. Mutually recursive with
946 show_code (int level, gfc_code *c)
948 for (; c; c = c->next)
949 show_code_node (level, c);
953 show_namelist (gfc_namelist *n)
955 for (; n->next; n = n->next)
956 fprintf (dumpfile, "%s,", n->sym->name);
957 fprintf (dumpfile, "%s", n->sym->name);
960 /* Show a single OpenMP directive node and everything underneath it
964 show_omp_node (int level, gfc_code *c)
966 gfc_omp_clauses *omp_clauses = NULL;
967 const char *name = NULL;
971 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
972 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
973 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
974 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
975 case EXEC_OMP_DO: name = "DO"; break;
976 case EXEC_OMP_MASTER: name = "MASTER"; break;
977 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
978 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
979 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
980 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
981 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
982 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
983 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
984 case EXEC_OMP_TASK: name = "TASK"; break;
985 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
986 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
990 fprintf (dumpfile, "!$OMP %s", name);
994 case EXEC_OMP_PARALLEL:
995 case EXEC_OMP_PARALLEL_DO:
996 case EXEC_OMP_PARALLEL_SECTIONS:
997 case EXEC_OMP_SECTIONS:
998 case EXEC_OMP_SINGLE:
999 case EXEC_OMP_WORKSHARE:
1000 case EXEC_OMP_PARALLEL_WORKSHARE:
1002 omp_clauses = c->ext.omp_clauses;
1004 case EXEC_OMP_CRITICAL:
1005 if (c->ext.omp_name)
1006 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1008 case EXEC_OMP_FLUSH:
1009 if (c->ext.omp_namelist)
1011 fputs (" (", dumpfile);
1012 show_namelist (c->ext.omp_namelist);
1013 fputc (')', dumpfile);
1016 case EXEC_OMP_BARRIER:
1017 case EXEC_OMP_TASKWAIT:
1026 if (omp_clauses->if_expr)
1028 fputs (" IF(", dumpfile);
1029 show_expr (omp_clauses->if_expr);
1030 fputc (')', dumpfile);
1032 if (omp_clauses->num_threads)
1034 fputs (" NUM_THREADS(", dumpfile);
1035 show_expr (omp_clauses->num_threads);
1036 fputc (')', dumpfile);
1038 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1041 switch (omp_clauses->sched_kind)
1043 case OMP_SCHED_STATIC: type = "STATIC"; break;
1044 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1045 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1046 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1047 case OMP_SCHED_AUTO: type = "AUTO"; break;
1051 fprintf (dumpfile, " SCHEDULE (%s", type);
1052 if (omp_clauses->chunk_size)
1054 fputc (',', dumpfile);
1055 show_expr (omp_clauses->chunk_size);
1057 fputc (')', dumpfile);
1059 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1062 switch (omp_clauses->default_sharing)
1064 case OMP_DEFAULT_NONE: type = "NONE"; break;
1065 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1066 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1067 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1071 fprintf (dumpfile, " DEFAULT(%s)", type);
1073 if (omp_clauses->ordered)
1074 fputs (" ORDERED", dumpfile);
1075 if (omp_clauses->untied)
1076 fputs (" UNTIED", dumpfile);
1077 if (omp_clauses->collapse)
1078 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1079 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1080 if (omp_clauses->lists[list_type] != NULL
1081 && list_type != OMP_LIST_COPYPRIVATE)
1084 if (list_type >= OMP_LIST_REDUCTION_FIRST)
1088 case OMP_LIST_PLUS: type = "+"; break;
1089 case OMP_LIST_MULT: type = "*"; break;
1090 case OMP_LIST_SUB: type = "-"; break;
1091 case OMP_LIST_AND: type = ".AND."; break;
1092 case OMP_LIST_OR: type = ".OR."; break;
1093 case OMP_LIST_EQV: type = ".EQV."; break;
1094 case OMP_LIST_NEQV: type = ".NEQV."; break;
1095 case OMP_LIST_MAX: type = "MAX"; break;
1096 case OMP_LIST_MIN: type = "MIN"; break;
1097 case OMP_LIST_IAND: type = "IAND"; break;
1098 case OMP_LIST_IOR: type = "IOR"; break;
1099 case OMP_LIST_IEOR: type = "IEOR"; break;
1103 fprintf (dumpfile, " REDUCTION(%s:", type);
1109 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1110 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1111 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1112 case OMP_LIST_SHARED: type = "SHARED"; break;
1113 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1117 fprintf (dumpfile, " %s(", type);
1119 show_namelist (omp_clauses->lists[list_type]);
1120 fputc (')', dumpfile);
1123 fputc ('\n', dumpfile);
1124 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1126 gfc_code *d = c->block;
1129 show_code (level + 1, d->next);
1130 if (d->block == NULL)
1132 code_indent (level, 0);
1133 fputs ("!$OMP SECTION\n", dumpfile);
1138 show_code (level + 1, c->block->next);
1139 if (c->op == EXEC_OMP_ATOMIC)
1141 code_indent (level, 0);
1142 fprintf (dumpfile, "!$OMP END %s", name);
1143 if (omp_clauses != NULL)
1145 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1147 fputs (" COPYPRIVATE(", dumpfile);
1148 show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1149 fputc (')', dumpfile);
1151 else if (omp_clauses->nowait)
1152 fputs (" NOWAIT", dumpfile);
1154 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1155 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1159 /* Show a single code node and everything underneath it if necessary. */
1162 show_code_node (int level, gfc_code *c)
1164 gfc_forall_iterator *fa;
1174 code_indent (level, c->here);
1178 case EXEC_END_PROCEDURE:
1182 fputs ("NOP", dumpfile);
1186 fputs ("CONTINUE", dumpfile);
1190 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1193 case EXEC_INIT_ASSIGN:
1195 fputs ("ASSIGN ", dumpfile);
1196 show_expr (c->expr1);
1197 fputc (' ', dumpfile);
1198 show_expr (c->expr2);
1201 case EXEC_LABEL_ASSIGN:
1202 fputs ("LABEL ASSIGN ", dumpfile);
1203 show_expr (c->expr1);
1204 fprintf (dumpfile, " %d", c->label1->value);
1207 case EXEC_POINTER_ASSIGN:
1208 fputs ("POINTER ASSIGN ", dumpfile);
1209 show_expr (c->expr1);
1210 fputc (' ', dumpfile);
1211 show_expr (c->expr2);
1215 fputs ("GOTO ", dumpfile);
1217 fprintf (dumpfile, "%d", c->label1->value);
1220 show_expr (c->expr1);
1224 fputs (", (", dumpfile);
1225 for (; d; d = d ->block)
1227 code_indent (level, d->label1);
1228 if (d->block != NULL)
1229 fputc (',', dumpfile);
1231 fputc (')', dumpfile);
1238 case EXEC_ASSIGN_CALL:
1239 if (c->resolved_sym)
1240 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1241 else if (c->symtree)
1242 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1244 fputs ("CALL ?? ", dumpfile);
1246 show_actual_arglist (c->ext.actual);
1250 fputs ("CALL ", dumpfile);
1251 show_compcall (c->expr1);
1255 fputs ("CALL ", dumpfile);
1256 show_expr (c->expr1);
1257 show_actual_arglist (c->ext.actual);
1261 fputs ("RETURN ", dumpfile);
1263 show_expr (c->expr1);
1267 fputs ("PAUSE ", dumpfile);
1269 if (c->expr1 != NULL)
1270 show_expr (c->expr1);
1272 fprintf (dumpfile, "%d", c->ext.stop_code);
1277 fputs ("STOP ", dumpfile);
1279 if (c->expr1 != NULL)
1280 show_expr (c->expr1);
1282 fprintf (dumpfile, "%d", c->ext.stop_code);
1286 case EXEC_ARITHMETIC_IF:
1287 fputs ("IF ", dumpfile);
1288 show_expr (c->expr1);
1289 fprintf (dumpfile, " %d, %d, %d",
1290 c->label1->value, c->label2->value, c->label3->value);
1295 fputs ("IF ", dumpfile);
1296 show_expr (d->expr1);
1297 fputc ('\n', dumpfile);
1298 show_code (level + 1, d->next);
1301 for (; d; d = d->block)
1303 code_indent (level, 0);
1305 if (d->expr1 == NULL)
1306 fputs ("ELSE\n", dumpfile);
1309 fputs ("ELSE IF ", dumpfile);
1310 show_expr (d->expr1);
1311 fputc ('\n', dumpfile);
1314 show_code (level + 1, d->next);
1317 code_indent (level, c->label1);
1319 fputs ("ENDIF", dumpfile);
1324 fputs ("SELECT CASE ", dumpfile);
1325 show_expr (c->expr1);
1326 fputc ('\n', dumpfile);
1328 for (; d; d = d->block)
1330 code_indent (level, 0);
1332 fputs ("CASE ", dumpfile);
1333 for (cp = d->ext.case_list; cp; cp = cp->next)
1335 fputc ('(', dumpfile);
1336 show_expr (cp->low);
1337 fputc (' ', dumpfile);
1338 show_expr (cp->high);
1339 fputc (')', dumpfile);
1340 fputc (' ', dumpfile);
1342 fputc ('\n', dumpfile);
1344 show_code (level + 1, d->next);
1347 code_indent (level, c->label1);
1348 fputs ("END SELECT", dumpfile);
1352 fputs ("WHERE ", dumpfile);
1355 show_expr (d->expr1);
1356 fputc ('\n', dumpfile);
1358 show_code (level + 1, d->next);
1360 for (d = d->block; d; d = d->block)
1362 code_indent (level, 0);
1363 fputs ("ELSE WHERE ", dumpfile);
1364 show_expr (d->expr1);
1365 fputc ('\n', dumpfile);
1366 show_code (level + 1, d->next);
1369 code_indent (level, 0);
1370 fputs ("END WHERE", dumpfile);
1375 fputs ("FORALL ", dumpfile);
1376 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1378 show_expr (fa->var);
1379 fputc (' ', dumpfile);
1380 show_expr (fa->start);
1381 fputc (':', dumpfile);
1382 show_expr (fa->end);
1383 fputc (':', dumpfile);
1384 show_expr (fa->stride);
1386 if (fa->next != NULL)
1387 fputc (',', dumpfile);
1390 if (c->expr1 != NULL)
1392 fputc (',', dumpfile);
1393 show_expr (c->expr1);
1395 fputc ('\n', dumpfile);
1397 show_code (level + 1, c->block->next);
1399 code_indent (level, 0);
1400 fputs ("END FORALL", dumpfile);
1404 fputs ("DO ", dumpfile);
1406 show_expr (c->ext.iterator->var);
1407 fputc ('=', dumpfile);
1408 show_expr (c->ext.iterator->start);
1409 fputc (' ', dumpfile);
1410 show_expr (c->ext.iterator->end);
1411 fputc (' ', dumpfile);
1412 show_expr (c->ext.iterator->step);
1413 fputc ('\n', dumpfile);
1415 show_code (level + 1, c->block->next);
1417 code_indent (level, 0);
1418 fputs ("END DO", dumpfile);
1422 fputs ("DO WHILE ", dumpfile);
1423 show_expr (c->expr1);
1424 fputc ('\n', dumpfile);
1426 show_code (level + 1, c->block->next);
1428 code_indent (level, c->label1);
1429 fputs ("END DO", dumpfile);
1433 fputs ("CYCLE", dumpfile);
1435 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1439 fputs ("EXIT", dumpfile);
1441 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1445 fputs ("ALLOCATE ", dumpfile);
1448 fputs (" STAT=", dumpfile);
1449 show_expr (c->expr1);
1454 fputs (" ERRMSG=", dumpfile);
1455 show_expr (c->expr2);
1458 for (a = c->ext.alloc.list; a; a = a->next)
1460 fputc (' ', dumpfile);
1461 show_expr (a->expr);
1466 case EXEC_DEALLOCATE:
1467 fputs ("DEALLOCATE ", dumpfile);
1470 fputs (" STAT=", dumpfile);
1471 show_expr (c->expr1);
1476 fputs (" ERRMSG=", dumpfile);
1477 show_expr (c->expr2);
1480 for (a = c->ext.alloc.list; a; a = a->next)
1482 fputc (' ', dumpfile);
1483 show_expr (a->expr);
1489 fputs ("OPEN", dumpfile);
1494 fputs (" UNIT=", dumpfile);
1495 show_expr (open->unit);
1499 fputs (" IOMSG=", dumpfile);
1500 show_expr (open->iomsg);
1504 fputs (" IOSTAT=", dumpfile);
1505 show_expr (open->iostat);
1509 fputs (" FILE=", dumpfile);
1510 show_expr (open->file);
1514 fputs (" STATUS=", dumpfile);
1515 show_expr (open->status);
1519 fputs (" ACCESS=", dumpfile);
1520 show_expr (open->access);
1524 fputs (" FORM=", dumpfile);
1525 show_expr (open->form);
1529 fputs (" RECL=", dumpfile);
1530 show_expr (open->recl);
1534 fputs (" BLANK=", dumpfile);
1535 show_expr (open->blank);
1539 fputs (" POSITION=", dumpfile);
1540 show_expr (open->position);
1544 fputs (" ACTION=", dumpfile);
1545 show_expr (open->action);
1549 fputs (" DELIM=", dumpfile);
1550 show_expr (open->delim);
1554 fputs (" PAD=", dumpfile);
1555 show_expr (open->pad);
1559 fputs (" DECIMAL=", dumpfile);
1560 show_expr (open->decimal);
1564 fputs (" ENCODING=", dumpfile);
1565 show_expr (open->encoding);
1569 fputs (" ROUND=", dumpfile);
1570 show_expr (open->round);
1574 fputs (" SIGN=", dumpfile);
1575 show_expr (open->sign);
1579 fputs (" CONVERT=", dumpfile);
1580 show_expr (open->convert);
1582 if (open->asynchronous)
1584 fputs (" ASYNCHRONOUS=", dumpfile);
1585 show_expr (open->asynchronous);
1587 if (open->err != NULL)
1588 fprintf (dumpfile, " ERR=%d", open->err->value);
1593 fputs ("CLOSE", dumpfile);
1594 close = c->ext.close;
1598 fputs (" UNIT=", dumpfile);
1599 show_expr (close->unit);
1603 fputs (" IOMSG=", dumpfile);
1604 show_expr (close->iomsg);
1608 fputs (" IOSTAT=", dumpfile);
1609 show_expr (close->iostat);
1613 fputs (" STATUS=", dumpfile);
1614 show_expr (close->status);
1616 if (close->err != NULL)
1617 fprintf (dumpfile, " ERR=%d", close->err->value);
1620 case EXEC_BACKSPACE:
1621 fputs ("BACKSPACE", dumpfile);
1625 fputs ("ENDFILE", dumpfile);
1629 fputs ("REWIND", dumpfile);
1633 fputs ("FLUSH", dumpfile);
1636 fp = c->ext.filepos;
1640 fputs (" UNIT=", dumpfile);
1641 show_expr (fp->unit);
1645 fputs (" IOMSG=", dumpfile);
1646 show_expr (fp->iomsg);
1650 fputs (" IOSTAT=", dumpfile);
1651 show_expr (fp->iostat);
1653 if (fp->err != NULL)
1654 fprintf (dumpfile, " ERR=%d", fp->err->value);
1658 fputs ("INQUIRE", dumpfile);
1663 fputs (" UNIT=", dumpfile);
1664 show_expr (i->unit);
1668 fputs (" FILE=", dumpfile);
1669 show_expr (i->file);
1674 fputs (" IOMSG=", dumpfile);
1675 show_expr (i->iomsg);
1679 fputs (" IOSTAT=", dumpfile);
1680 show_expr (i->iostat);
1684 fputs (" EXIST=", dumpfile);
1685 show_expr (i->exist);
1689 fputs (" OPENED=", dumpfile);
1690 show_expr (i->opened);
1694 fputs (" NUMBER=", dumpfile);
1695 show_expr (i->number);
1699 fputs (" NAMED=", dumpfile);
1700 show_expr (i->named);
1704 fputs (" NAME=", dumpfile);
1705 show_expr (i->name);
1709 fputs (" ACCESS=", dumpfile);
1710 show_expr (i->access);
1714 fputs (" SEQUENTIAL=", dumpfile);
1715 show_expr (i->sequential);
1720 fputs (" DIRECT=", dumpfile);
1721 show_expr (i->direct);
1725 fputs (" FORM=", dumpfile);
1726 show_expr (i->form);
1730 fputs (" FORMATTED", dumpfile);
1731 show_expr (i->formatted);
1735 fputs (" UNFORMATTED=", dumpfile);
1736 show_expr (i->unformatted);
1740 fputs (" RECL=", dumpfile);
1741 show_expr (i->recl);
1745 fputs (" NEXTREC=", dumpfile);
1746 show_expr (i->nextrec);
1750 fputs (" BLANK=", dumpfile);
1751 show_expr (i->blank);
1755 fputs (" POSITION=", dumpfile);
1756 show_expr (i->position);
1760 fputs (" ACTION=", dumpfile);
1761 show_expr (i->action);
1765 fputs (" READ=", dumpfile);
1766 show_expr (i->read);
1770 fputs (" WRITE=", dumpfile);
1771 show_expr (i->write);
1775 fputs (" READWRITE=", dumpfile);
1776 show_expr (i->readwrite);
1780 fputs (" DELIM=", dumpfile);
1781 show_expr (i->delim);
1785 fputs (" PAD=", dumpfile);
1790 fputs (" CONVERT=", dumpfile);
1791 show_expr (i->convert);
1793 if (i->asynchronous)
1795 fputs (" ASYNCHRONOUS=", dumpfile);
1796 show_expr (i->asynchronous);
1800 fputs (" DECIMAL=", dumpfile);
1801 show_expr (i->decimal);
1805 fputs (" ENCODING=", dumpfile);
1806 show_expr (i->encoding);
1810 fputs (" PENDING=", dumpfile);
1811 show_expr (i->pending);
1815 fputs (" ROUND=", dumpfile);
1816 show_expr (i->round);
1820 fputs (" SIGN=", dumpfile);
1821 show_expr (i->sign);
1825 fputs (" SIZE=", dumpfile);
1826 show_expr (i->size);
1830 fputs (" ID=", dumpfile);
1835 fprintf (dumpfile, " ERR=%d", i->err->value);
1839 fputs ("IOLENGTH ", dumpfile);
1840 show_expr (c->expr1);
1845 fputs ("READ", dumpfile);
1849 fputs ("WRITE", dumpfile);
1855 fputs (" UNIT=", dumpfile);
1856 show_expr (dt->io_unit);
1859 if (dt->format_expr)
1861 fputs (" FMT=", dumpfile);
1862 show_expr (dt->format_expr);
1865 if (dt->format_label != NULL)
1866 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1868 fprintf (dumpfile, " NML=%s", dt->namelist->name);
1872 fputs (" IOMSG=", dumpfile);
1873 show_expr (dt->iomsg);
1877 fputs (" IOSTAT=", dumpfile);
1878 show_expr (dt->iostat);
1882 fputs (" SIZE=", dumpfile);
1883 show_expr (dt->size);
1887 fputs (" REC=", dumpfile);
1888 show_expr (dt->rec);
1892 fputs (" ADVANCE=", dumpfile);
1893 show_expr (dt->advance);
1897 fputs (" ID=", dumpfile);
1902 fputs (" POS=", dumpfile);
1903 show_expr (dt->pos);
1905 if (dt->asynchronous)
1907 fputs (" ASYNCHRONOUS=", dumpfile);
1908 show_expr (dt->asynchronous);
1912 fputs (" BLANK=", dumpfile);
1913 show_expr (dt->blank);
1917 fputs (" DECIMAL=", dumpfile);
1918 show_expr (dt->decimal);
1922 fputs (" DELIM=", dumpfile);
1923 show_expr (dt->delim);
1927 fputs (" PAD=", dumpfile);
1928 show_expr (dt->pad);
1932 fputs (" ROUND=", dumpfile);
1933 show_expr (dt->round);
1937 fputs (" SIGN=", dumpfile);
1938 show_expr (dt->sign);
1942 fputc ('\n', dumpfile);
1943 for (c = c->block->next; c; c = c->next)
1944 show_code_node (level + (c->next != NULL), c);
1948 fputs ("TRANSFER ", dumpfile);
1949 show_expr (c->expr1);
1953 fputs ("DT_END", dumpfile);
1956 if (dt->err != NULL)
1957 fprintf (dumpfile, " ERR=%d", dt->err->value);
1958 if (dt->end != NULL)
1959 fprintf (dumpfile, " END=%d", dt->end->value);
1960 if (dt->eor != NULL)
1961 fprintf (dumpfile, " EOR=%d", dt->eor->value);
1964 case EXEC_OMP_ATOMIC:
1965 case EXEC_OMP_BARRIER:
1966 case EXEC_OMP_CRITICAL:
1967 case EXEC_OMP_FLUSH:
1969 case EXEC_OMP_MASTER:
1970 case EXEC_OMP_ORDERED:
1971 case EXEC_OMP_PARALLEL:
1972 case EXEC_OMP_PARALLEL_DO:
1973 case EXEC_OMP_PARALLEL_SECTIONS:
1974 case EXEC_OMP_PARALLEL_WORKSHARE:
1975 case EXEC_OMP_SECTIONS:
1976 case EXEC_OMP_SINGLE:
1978 case EXEC_OMP_TASKWAIT:
1979 case EXEC_OMP_WORKSHARE:
1980 show_omp_node (level, c);
1984 gfc_internal_error ("show_code_node(): Bad statement code");
1987 fputc ('\n', dumpfile);
1991 /* Show an equivalence chain. */
1994 show_equiv (gfc_equiv *eq)
1997 fputs ("Equivalence: ", dumpfile);
2000 show_expr (eq->expr);
2003 fputs (", ", dumpfile);
2008 /* Show a freakin' whole namespace. */
2011 show_namespace (gfc_namespace *ns)
2013 gfc_interface *intr;
2014 gfc_namespace *save;
2019 save = gfc_current_ns;
2023 fputs ("Namespace:", dumpfile);
2031 while (i < GFC_LETTERS - 1
2032 && gfc_compare_types(&ns->default_type[i+1],
2033 &ns->default_type[l]))
2037 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2039 fprintf (dumpfile, " %c: ", l+'A');
2041 show_typespec(&ns->default_type[l]);
2043 } while (i < GFC_LETTERS);
2045 if (ns->proc_name != NULL)
2048 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2051 gfc_current_ns = ns;
2052 gfc_traverse_symtree (ns->common_root, show_common);
2054 gfc_traverse_symtree (ns->sym_root, show_symtree);
2056 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2058 /* User operator interfaces */
2064 fprintf (dumpfile, "Operator interfaces for %s:",
2065 gfc_op2string ((gfc_intrinsic_op) op));
2067 for (; intr; intr = intr->next)
2068 fprintf (dumpfile, " %s", intr->sym->name);
2071 if (ns->uop_root != NULL)
2074 fputs ("User operators:\n", dumpfile);
2075 gfc_traverse_user_op (ns, show_uop);
2079 for (eq = ns->equiv; eq; eq = eq->next)
2082 fputc ('\n', dumpfile);
2083 fputc ('\n', dumpfile);
2085 show_code (0, ns->code);
2087 for (ns = ns->contained; ns; ns = ns->sibling)
2090 fputs ("CONTAINS\n", dumpfile);
2091 show_namespace (ns);
2095 fputc ('\n', dumpfile);
2096 gfc_current_ns = save;
2100 /* Main function for dumping a parse tree. */
2103 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2106 show_namespace (ns);