2 Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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
36 #include "constructor.h"
38 /* Keep track of indentation for symbol tree dumps. */
39 static int show_level = 0;
41 /* The file handle we're dumping to is kept in a static variable. This
42 is not too cool, but it avoids a lot of passing it around. */
43 static FILE *dumpfile;
45 /* Forward declaration of some of the functions. */
46 static void show_expr (gfc_expr *p);
47 static void show_code_node (int, gfc_code *);
48 static void show_namespace (gfc_namespace *ns);
51 /* Do indentation for a specific level. */
54 code_indent (int level, gfc_st_label *label)
59 fprintf (dumpfile, "%-5d ", label->value);
61 fputs (" ", dumpfile);
63 for (i = 0; i < 2 * level; i++)
64 fputc (' ', dumpfile);
68 /* Simple indentation at the current level. This one
69 is used to show symbols. */
74 fputc ('\n', dumpfile);
75 code_indent (show_level, NULL);
79 /* Show type-specific information. */
82 show_typespec (gfc_typespec *ts)
84 fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
89 fprintf (dumpfile, "%s", ts->u.derived->name);
93 show_expr (ts->u.cl->length);
97 fprintf (dumpfile, "%d", ts->kind);
101 fputc (')', dumpfile);
105 /* Show an actual argument list. */
108 show_actual_arglist (gfc_actual_arglist *a)
110 fputc ('(', dumpfile);
112 for (; a; a = a->next)
114 fputc ('(', dumpfile);
116 fprintf (dumpfile, "%s = ", a->name);
120 fputs ("(arg not-present)", dumpfile);
122 fputc (')', dumpfile);
124 fputc (' ', dumpfile);
127 fputc (')', dumpfile);
131 /* Show a gfc_array_spec array specification structure. */
134 show_array_spec (gfc_array_spec *as)
141 fputs ("()", dumpfile);
145 fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
147 if (as->rank + as->corank > 0)
151 case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
152 case AS_DEFERRED: c = "AS_DEFERRED"; break;
153 case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
154 case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
156 gfc_internal_error ("show_array_spec(): Unhandled array shape "
159 fprintf (dumpfile, " %s ", c);
161 for (i = 0; i < as->rank + as->corank; i++)
163 show_expr (as->lower[i]);
164 fputc (' ', dumpfile);
165 show_expr (as->upper[i]);
166 fputc (' ', dumpfile);
170 fputc (')', dumpfile);
174 /* Show a gfc_array_ref array reference structure. */
177 show_array_ref (gfc_array_ref * ar)
181 fputc ('(', dumpfile);
186 fputs ("FULL", dumpfile);
190 for (i = 0; i < ar->dimen; i++)
192 /* There are two types of array sections: either the
193 elements are identified by an integer array ('vector'),
194 or by an index range. In the former case we only have to
195 print the start expression which contains the vector, in
196 the latter case we have to print any of lower and upper
197 bound and the stride, if they're present. */
199 if (ar->start[i] != NULL)
200 show_expr (ar->start[i]);
202 if (ar->dimen_type[i] == DIMEN_RANGE)
204 fputc (':', dumpfile);
206 if (ar->end[i] != NULL)
207 show_expr (ar->end[i]);
209 if (ar->stride[i] != NULL)
211 fputc (':', dumpfile);
212 show_expr (ar->stride[i]);
216 if (i != ar->dimen - 1)
217 fputs (" , ", dumpfile);
222 for (i = 0; i < ar->dimen; i++)
224 show_expr (ar->start[i]);
225 if (i != ar->dimen - 1)
226 fputs (" , ", dumpfile);
231 fputs ("UNKNOWN", dumpfile);
235 gfc_internal_error ("show_array_ref(): Unknown array reference");
238 fputc (')', dumpfile);
242 /* Show a list of gfc_ref structures. */
245 show_ref (gfc_ref *p)
247 for (; p; p = p->next)
251 show_array_ref (&p->u.ar);
255 fprintf (dumpfile, " %% %s", p->u.c.component->name);
259 fputc ('(', dumpfile);
260 show_expr (p->u.ss.start);
261 fputc (':', dumpfile);
262 show_expr (p->u.ss.end);
263 fputc (')', dumpfile);
267 gfc_internal_error ("show_ref(): Bad component code");
272 /* Display a constructor. Works recursively for array constructors. */
275 show_constructor (gfc_constructor_base base)
278 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
280 if (c->iterator == NULL)
284 fputc ('(', dumpfile);
287 fputc (' ', dumpfile);
288 show_expr (c->iterator->var);
289 fputc ('=', dumpfile);
290 show_expr (c->iterator->start);
291 fputc (',', dumpfile);
292 show_expr (c->iterator->end);
293 fputc (',', dumpfile);
294 show_expr (c->iterator->step);
296 fputc (')', dumpfile);
299 if (gfc_constructor_next (c) != NULL)
300 fputs (" , ", dumpfile);
306 show_char_const (const gfc_char_t *c, int length)
310 fputc ('\'', dumpfile);
311 for (i = 0; i < length; i++)
314 fputs ("''", dumpfile);
316 fputs (gfc_print_wide_char (c[i]), dumpfile);
318 fputc ('\'', dumpfile);
322 /* Show a component-call expression. */
325 show_compcall (gfc_expr* p)
327 gcc_assert (p->expr_type == EXPR_COMPCALL);
329 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
331 fprintf (dumpfile, "%s", p->value.compcall.name);
333 show_actual_arglist (p->value.compcall.actual);
337 /* Show an expression. */
340 show_expr (gfc_expr *p)
347 fputs ("()", dumpfile);
351 switch (p->expr_type)
354 show_char_const (p->value.character.string, p->value.character.length);
359 fprintf (dumpfile, "%s(", p->ts.u.derived->name);
360 show_constructor (p->value.constructor);
361 fputc (')', dumpfile);
365 fputs ("(/ ", dumpfile);
366 show_constructor (p->value.constructor);
367 fputs (" /)", dumpfile);
373 fputs ("NULL()", dumpfile);
380 mpz_out_str (stdout, 10, p->value.integer);
382 if (p->ts.kind != gfc_default_integer_kind)
383 fprintf (dumpfile, "_%d", p->ts.kind);
387 if (p->value.logical)
388 fputs (".true.", dumpfile);
390 fputs (".false.", dumpfile);
394 mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
395 if (p->ts.kind != gfc_default_real_kind)
396 fprintf (dumpfile, "_%d", p->ts.kind);
400 show_char_const (p->value.character.string,
401 p->value.character.length);
405 fputs ("(complex ", dumpfile);
407 mpfr_out_str (stdout, 10, 0, mpc_realref (p->value.complex),
409 if (p->ts.kind != gfc_default_complex_kind)
410 fprintf (dumpfile, "_%d", p->ts.kind);
412 fputc (' ', dumpfile);
414 mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
416 if (p->ts.kind != gfc_default_complex_kind)
417 fprintf (dumpfile, "_%d", p->ts.kind);
419 fputc (')', dumpfile);
423 fprintf (dumpfile, "%dH", p->representation.length);
424 c = p->representation.string;
425 for (i = 0; i < p->representation.length; i++, c++)
427 fputc (*c, dumpfile);
432 fputs ("???", dumpfile);
436 if (p->representation.string)
438 fputs (" {", dumpfile);
439 c = p->representation.string;
440 for (i = 0; i < p->representation.length; i++, c++)
442 fprintf (dumpfile, "%.2x", (unsigned int) *c);
443 if (i < p->representation.length - 1)
444 fputc (',', dumpfile);
446 fputc ('}', dumpfile);
452 if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
453 fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
454 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
459 fputc ('(', dumpfile);
460 switch (p->value.op.op)
462 case INTRINSIC_UPLUS:
463 fputs ("U+ ", dumpfile);
465 case INTRINSIC_UMINUS:
466 fputs ("U- ", dumpfile);
469 fputs ("+ ", dumpfile);
471 case INTRINSIC_MINUS:
472 fputs ("- ", dumpfile);
474 case INTRINSIC_TIMES:
475 fputs ("* ", dumpfile);
477 case INTRINSIC_DIVIDE:
478 fputs ("/ ", dumpfile);
480 case INTRINSIC_POWER:
481 fputs ("** ", dumpfile);
483 case INTRINSIC_CONCAT:
484 fputs ("// ", dumpfile);
487 fputs ("AND ", dumpfile);
490 fputs ("OR ", dumpfile);
493 fputs ("EQV ", dumpfile);
496 fputs ("NEQV ", dumpfile);
499 case INTRINSIC_EQ_OS:
500 fputs ("= ", dumpfile);
503 case INTRINSIC_NE_OS:
504 fputs ("/= ", dumpfile);
507 case INTRINSIC_GT_OS:
508 fputs ("> ", dumpfile);
511 case INTRINSIC_GE_OS:
512 fputs (">= ", dumpfile);
515 case INTRINSIC_LT_OS:
516 fputs ("< ", dumpfile);
519 case INTRINSIC_LE_OS:
520 fputs ("<= ", dumpfile);
523 fputs ("NOT ", dumpfile);
525 case INTRINSIC_PARENTHESES:
526 fputs ("parens", dumpfile);
531 ("show_expr(): Bad intrinsic in expression!");
534 show_expr (p->value.op.op1);
538 fputc (' ', dumpfile);
539 show_expr (p->value.op.op2);
542 fputc (')', dumpfile);
546 if (p->value.function.name == NULL)
548 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
549 if (gfc_is_proc_ptr_comp (p, NULL))
551 fputc ('[', dumpfile);
552 show_actual_arglist (p->value.function.actual);
553 fputc (']', dumpfile);
557 fprintf (dumpfile, "%s", p->value.function.name);
558 if (gfc_is_proc_ptr_comp (p, NULL))
560 fputc ('[', dumpfile);
561 fputc ('[', dumpfile);
562 show_actual_arglist (p->value.function.actual);
563 fputc (']', dumpfile);
564 fputc (']', dumpfile);
574 gfc_internal_error ("show_expr(): Don't know how to show expr");
578 /* Show symbol attributes. The flavor and intent are followed by
579 whatever single bit attributes are present. */
582 show_attr (symbol_attribute *attr)
585 fprintf (dumpfile, "(%s %s %s %s %s",
586 gfc_code2string (flavors, attr->flavor),
587 gfc_intent_string (attr->intent),
588 gfc_code2string (access_types, attr->access),
589 gfc_code2string (procedures, attr->proc),
590 gfc_code2string (save_status, attr->save));
592 if (attr->allocatable)
593 fputs (" ALLOCATABLE", dumpfile);
594 if (attr->asynchronous)
595 fputs (" ASYNCHRONOUS", dumpfile);
596 if (attr->codimension)
597 fputs (" CODIMENSION", dumpfile);
599 fputs (" DIMENSION", dumpfile);
601 fputs (" EXTERNAL", dumpfile);
603 fputs (" INTRINSIC", dumpfile);
605 fputs (" OPTIONAL", dumpfile);
607 fputs (" POINTER", dumpfile);
608 if (attr->is_protected)
609 fputs (" PROTECTED", dumpfile);
611 fputs (" VALUE", dumpfile);
613 fputs (" VOLATILE", dumpfile);
614 if (attr->threadprivate)
615 fputs (" THREADPRIVATE", dumpfile);
617 fputs (" TARGET", dumpfile);
619 fputs (" DUMMY", dumpfile);
621 fputs (" RESULT", dumpfile);
623 fputs (" ENTRY", dumpfile);
625 fputs (" BIND(C)", dumpfile);
628 fputs (" DATA", dumpfile);
630 fputs (" USE-ASSOC", dumpfile);
631 if (attr->in_namelist)
632 fputs (" IN-NAMELIST", dumpfile);
634 fputs (" IN-COMMON", dumpfile);
637 fputs (" ABSTRACT", dumpfile);
639 fputs (" FUNCTION", dumpfile);
640 if (attr->subroutine)
641 fputs (" SUBROUTINE", dumpfile);
642 if (attr->implicit_type)
643 fputs (" IMPLICIT-TYPE", dumpfile);
646 fputs (" SEQUENCE", dumpfile);
648 fputs (" ELEMENTAL", dumpfile);
650 fputs (" PURE", dumpfile);
652 fputs (" RECURSIVE", dumpfile);
654 fputc (')', dumpfile);
658 /* Show components of a derived type. */
661 show_components (gfc_symbol *sym)
665 for (c = sym->components; c; c = c->next)
667 fprintf (dumpfile, "(%s ", c->name);
668 show_typespec (&c->ts);
670 fputs (" POINTER", dumpfile);
671 if (c->attr.proc_pointer)
672 fputs (" PPC", dumpfile);
673 if (c->attr.dimension)
674 fputs (" DIMENSION", dumpfile);
675 fputc (' ', dumpfile);
676 show_array_spec (c->as);
678 fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
679 fputc (')', dumpfile);
681 fputc (' ', dumpfile);
686 /* Show the f2k_derived namespace with procedure bindings. */
689 show_typebound_proc (gfc_typebound_proc* tb, const char* name)
694 fputs ("GENERIC", dumpfile);
697 fputs ("PROCEDURE, ", dumpfile);
699 fputs ("NOPASS", dumpfile);
703 fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
705 fputs ("PASS", dumpfile);
707 if (tb->non_overridable)
708 fputs (", NON_OVERRIDABLE", dumpfile);
711 if (tb->access == ACCESS_PUBLIC)
712 fputs (", PUBLIC", dumpfile);
714 fputs (", PRIVATE", dumpfile);
716 fprintf (dumpfile, " :: %s => ", name);
721 for (g = tb->u.generic; g; g = g->next)
723 fputs (g->specific_st->name, dumpfile);
725 fputs (", ", dumpfile);
729 fputs (tb->u.specific->n.sym->name, dumpfile);
733 show_typebound_symtree (gfc_symtree* st)
735 gcc_assert (st->n.tb);
736 show_typebound_proc (st->n.tb, st->name);
740 show_f2k_derived (gfc_namespace* f2k)
746 fputs ("Procedure bindings:", dumpfile);
749 /* Finalizer bindings. */
750 for (f = f2k->finalizers; f; f = f->next)
753 fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
756 /* Type-bound procedures. */
757 gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
762 fputs ("Operator bindings:", dumpfile);
765 /* User-defined operators. */
766 gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
768 /* Intrinsic operators. */
769 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
771 show_typebound_proc (f2k->tb_op[op],
772 gfc_op2string ((gfc_intrinsic_op) op));
778 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
779 show the interface. Information needed to reconstruct the list of
780 specific interfaces associated with a generic symbol is done within
784 show_symbol (gfc_symbol *sym)
786 gfc_formal_arglist *formal;
794 fprintf (dumpfile, "symbol %s ", sym->name);
795 show_typespec (&sym->ts);
796 show_attr (&sym->attr);
801 fputs ("value: ", dumpfile);
802 show_expr (sym->value);
808 fputs ("Array spec:", dumpfile);
809 show_array_spec (sym->as);
815 fputs ("Generic interfaces:", dumpfile);
816 for (intr = sym->generic; intr; intr = intr->next)
817 fprintf (dumpfile, " %s", intr->sym->name);
823 fprintf (dumpfile, "result: %s", sym->result->name);
829 fputs ("components: ", dumpfile);
830 show_components (sym);
833 if (sym->f2k_derived)
837 fprintf (dumpfile, "hash: %d", sym->hash_value);
838 show_f2k_derived (sym->f2k_derived);
844 fputs ("Formal arglist:", dumpfile);
846 for (formal = sym->formal; formal; formal = formal->next)
848 if (formal->sym != NULL)
849 fprintf (dumpfile, " %s", formal->sym->name);
851 fputs (" [Alt Return]", dumpfile);
858 fputs ("Formal namespace", dumpfile);
859 show_namespace (sym->formal_ns);
862 fputc ('\n', dumpfile);
866 /* Show a user-defined operator. Just prints an operator
867 and the name of the associated subroutine, really. */
870 show_uop (gfc_user_op *uop)
875 fprintf (dumpfile, "%s:", uop->name);
877 for (intr = uop->op; intr; intr = intr->next)
878 fprintf (dumpfile, " %s", intr->sym->name);
882 /* Workhorse function for traversing the user operator symtree. */
885 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
892 traverse_uop (st->left, func);
893 traverse_uop (st->right, func);
897 /* Traverse the tree of user operator nodes. */
900 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
902 traverse_uop (ns->uop_root, func);
906 /* Function to display a common block. */
909 show_common (gfc_symtree *st)
914 fprintf (dumpfile, "common: /%s/ ", st->name);
916 s = st->n.common->head;
919 fprintf (dumpfile, "%s", s->name);
922 fputs (", ", dumpfile);
924 fputc ('\n', dumpfile);
928 /* Worker function to display the symbol tree. */
931 show_symtree (gfc_symtree *st)
934 fprintf (dumpfile, "symtree: %s Ambig %d", st->name, st->ambiguous);
936 if (st->n.sym->ns != gfc_current_ns)
937 fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
939 show_symbol (st->n.sym);
943 /******************* Show gfc_code structures **************/
946 /* Show a list of code structures. Mutually recursive with
950 show_code (int level, gfc_code *c)
952 for (; c; c = c->next)
953 show_code_node (level, c);
957 show_namelist (gfc_namelist *n)
959 for (; n->next; n = n->next)
960 fprintf (dumpfile, "%s,", n->sym->name);
961 fprintf (dumpfile, "%s", n->sym->name);
964 /* Show a single OpenMP directive node and everything underneath it
968 show_omp_node (int level, gfc_code *c)
970 gfc_omp_clauses *omp_clauses = NULL;
971 const char *name = NULL;
975 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
976 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
977 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
978 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
979 case EXEC_OMP_DO: name = "DO"; break;
980 case EXEC_OMP_MASTER: name = "MASTER"; break;
981 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
982 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
983 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
984 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
985 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
986 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
987 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
988 case EXEC_OMP_TASK: name = "TASK"; break;
989 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
990 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
994 fprintf (dumpfile, "!$OMP %s", name);
998 case EXEC_OMP_PARALLEL:
999 case EXEC_OMP_PARALLEL_DO:
1000 case EXEC_OMP_PARALLEL_SECTIONS:
1001 case EXEC_OMP_SECTIONS:
1002 case EXEC_OMP_SINGLE:
1003 case EXEC_OMP_WORKSHARE:
1004 case EXEC_OMP_PARALLEL_WORKSHARE:
1006 omp_clauses = c->ext.omp_clauses;
1008 case EXEC_OMP_CRITICAL:
1009 if (c->ext.omp_name)
1010 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1012 case EXEC_OMP_FLUSH:
1013 if (c->ext.omp_namelist)
1015 fputs (" (", dumpfile);
1016 show_namelist (c->ext.omp_namelist);
1017 fputc (')', dumpfile);
1020 case EXEC_OMP_BARRIER:
1021 case EXEC_OMP_TASKWAIT:
1030 if (omp_clauses->if_expr)
1032 fputs (" IF(", dumpfile);
1033 show_expr (omp_clauses->if_expr);
1034 fputc (')', dumpfile);
1036 if (omp_clauses->num_threads)
1038 fputs (" NUM_THREADS(", dumpfile);
1039 show_expr (omp_clauses->num_threads);
1040 fputc (')', dumpfile);
1042 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1045 switch (omp_clauses->sched_kind)
1047 case OMP_SCHED_STATIC: type = "STATIC"; break;
1048 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1049 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1050 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1051 case OMP_SCHED_AUTO: type = "AUTO"; break;
1055 fprintf (dumpfile, " SCHEDULE (%s", type);
1056 if (omp_clauses->chunk_size)
1058 fputc (',', dumpfile);
1059 show_expr (omp_clauses->chunk_size);
1061 fputc (')', dumpfile);
1063 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1066 switch (omp_clauses->default_sharing)
1068 case OMP_DEFAULT_NONE: type = "NONE"; break;
1069 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1070 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1071 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1075 fprintf (dumpfile, " DEFAULT(%s)", type);
1077 if (omp_clauses->ordered)
1078 fputs (" ORDERED", dumpfile);
1079 if (omp_clauses->untied)
1080 fputs (" UNTIED", dumpfile);
1081 if (omp_clauses->collapse)
1082 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1083 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1084 if (omp_clauses->lists[list_type] != NULL
1085 && list_type != OMP_LIST_COPYPRIVATE)
1088 if (list_type >= OMP_LIST_REDUCTION_FIRST)
1092 case OMP_LIST_PLUS: type = "+"; break;
1093 case OMP_LIST_MULT: type = "*"; break;
1094 case OMP_LIST_SUB: type = "-"; break;
1095 case OMP_LIST_AND: type = ".AND."; break;
1096 case OMP_LIST_OR: type = ".OR."; break;
1097 case OMP_LIST_EQV: type = ".EQV."; break;
1098 case OMP_LIST_NEQV: type = ".NEQV."; break;
1099 case OMP_LIST_MAX: type = "MAX"; break;
1100 case OMP_LIST_MIN: type = "MIN"; break;
1101 case OMP_LIST_IAND: type = "IAND"; break;
1102 case OMP_LIST_IOR: type = "IOR"; break;
1103 case OMP_LIST_IEOR: type = "IEOR"; break;
1107 fprintf (dumpfile, " REDUCTION(%s:", type);
1113 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1114 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1115 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1116 case OMP_LIST_SHARED: type = "SHARED"; break;
1117 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1121 fprintf (dumpfile, " %s(", type);
1123 show_namelist (omp_clauses->lists[list_type]);
1124 fputc (')', dumpfile);
1127 fputc ('\n', dumpfile);
1128 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1130 gfc_code *d = c->block;
1133 show_code (level + 1, d->next);
1134 if (d->block == NULL)
1136 code_indent (level, 0);
1137 fputs ("!$OMP SECTION\n", dumpfile);
1142 show_code (level + 1, c->block->next);
1143 if (c->op == EXEC_OMP_ATOMIC)
1145 code_indent (level, 0);
1146 fprintf (dumpfile, "!$OMP END %s", name);
1147 if (omp_clauses != NULL)
1149 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1151 fputs (" COPYPRIVATE(", dumpfile);
1152 show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1153 fputc (')', dumpfile);
1155 else if (omp_clauses->nowait)
1156 fputs (" NOWAIT", dumpfile);
1158 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1159 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1163 /* Show a single code node and everything underneath it if necessary. */
1166 show_code_node (int level, gfc_code *c)
1168 gfc_forall_iterator *fa;
1178 code_indent (level, c->here);
1182 case EXEC_END_PROCEDURE:
1186 fputs ("NOP", dumpfile);
1190 fputs ("CONTINUE", dumpfile);
1194 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1197 case EXEC_INIT_ASSIGN:
1199 fputs ("ASSIGN ", dumpfile);
1200 show_expr (c->expr1);
1201 fputc (' ', dumpfile);
1202 show_expr (c->expr2);
1205 case EXEC_LABEL_ASSIGN:
1206 fputs ("LABEL ASSIGN ", dumpfile);
1207 show_expr (c->expr1);
1208 fprintf (dumpfile, " %d", c->label1->value);
1211 case EXEC_POINTER_ASSIGN:
1212 fputs ("POINTER ASSIGN ", dumpfile);
1213 show_expr (c->expr1);
1214 fputc (' ', dumpfile);
1215 show_expr (c->expr2);
1219 fputs ("GOTO ", dumpfile);
1221 fprintf (dumpfile, "%d", c->label1->value);
1224 show_expr (c->expr1);
1228 fputs (", (", dumpfile);
1229 for (; d; d = d ->block)
1231 code_indent (level, d->label1);
1232 if (d->block != NULL)
1233 fputc (',', dumpfile);
1235 fputc (')', dumpfile);
1242 case EXEC_ASSIGN_CALL:
1243 if (c->resolved_sym)
1244 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1245 else if (c->symtree)
1246 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1248 fputs ("CALL ?? ", dumpfile);
1250 show_actual_arglist (c->ext.actual);
1254 fputs ("CALL ", dumpfile);
1255 show_compcall (c->expr1);
1259 fputs ("CALL ", dumpfile);
1260 show_expr (c->expr1);
1261 show_actual_arglist (c->ext.actual);
1265 fputs ("RETURN ", dumpfile);
1267 show_expr (c->expr1);
1271 fputs ("PAUSE ", dumpfile);
1273 if (c->expr1 != NULL)
1274 show_expr (c->expr1);
1276 fprintf (dumpfile, "%d", c->ext.stop_code);
1280 case EXEC_ERROR_STOP:
1281 fputs ("ERROR ", dumpfile);
1285 fputs ("STOP ", dumpfile);
1287 if (c->expr1 != NULL)
1288 show_expr (c->expr1);
1290 fprintf (dumpfile, "%d", c->ext.stop_code);
1295 fputs ("SYNC ALL ", dumpfile);
1296 if (c->expr2 != NULL)
1298 fputs (" stat=", dumpfile);
1299 show_expr (c->expr2);
1301 if (c->expr3 != NULL)
1303 fputs (" errmsg=", dumpfile);
1304 show_expr (c->expr3);
1308 case EXEC_SYNC_MEMORY:
1309 fputs ("SYNC MEMORY ", dumpfile);
1310 if (c->expr2 != NULL)
1312 fputs (" stat=", dumpfile);
1313 show_expr (c->expr2);
1315 if (c->expr3 != NULL)
1317 fputs (" errmsg=", dumpfile);
1318 show_expr (c->expr3);
1322 case EXEC_SYNC_IMAGES:
1323 fputs ("SYNC IMAGES image-set=", dumpfile);
1324 if (c->expr1 != NULL)
1325 show_expr (c->expr1);
1327 fputs ("* ", dumpfile);
1328 if (c->expr2 != NULL)
1330 fputs (" stat=", dumpfile);
1331 show_expr (c->expr2);
1333 if (c->expr3 != NULL)
1335 fputs (" errmsg=", dumpfile);
1336 show_expr (c->expr3);
1340 case EXEC_ARITHMETIC_IF:
1341 fputs ("IF ", dumpfile);
1342 show_expr (c->expr1);
1343 fprintf (dumpfile, " %d, %d, %d",
1344 c->label1->value, c->label2->value, c->label3->value);
1349 fputs ("IF ", dumpfile);
1350 show_expr (d->expr1);
1351 fputc ('\n', dumpfile);
1352 show_code (level + 1, d->next);
1355 for (; d; d = d->block)
1357 code_indent (level, 0);
1359 if (d->expr1 == NULL)
1360 fputs ("ELSE\n", dumpfile);
1363 fputs ("ELSE IF ", dumpfile);
1364 show_expr (d->expr1);
1365 fputc ('\n', dumpfile);
1368 show_code (level + 1, d->next);
1371 code_indent (level, c->label1);
1373 fputs ("ENDIF", dumpfile);
1378 fputs ("SELECT CASE ", dumpfile);
1379 show_expr (c->expr1);
1380 fputc ('\n', dumpfile);
1382 for (; d; d = d->block)
1384 code_indent (level, 0);
1386 fputs ("CASE ", dumpfile);
1387 for (cp = d->ext.case_list; cp; cp = cp->next)
1389 fputc ('(', dumpfile);
1390 show_expr (cp->low);
1391 fputc (' ', dumpfile);
1392 show_expr (cp->high);
1393 fputc (')', dumpfile);
1394 fputc (' ', dumpfile);
1396 fputc ('\n', dumpfile);
1398 show_code (level + 1, d->next);
1401 code_indent (level, c->label1);
1402 fputs ("END SELECT", dumpfile);
1406 fputs ("WHERE ", dumpfile);
1409 show_expr (d->expr1);
1410 fputc ('\n', dumpfile);
1412 show_code (level + 1, d->next);
1414 for (d = d->block; d; d = d->block)
1416 code_indent (level, 0);
1417 fputs ("ELSE WHERE ", dumpfile);
1418 show_expr (d->expr1);
1419 fputc ('\n', dumpfile);
1420 show_code (level + 1, d->next);
1423 code_indent (level, 0);
1424 fputs ("END WHERE", dumpfile);
1429 fputs ("FORALL ", dumpfile);
1430 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1432 show_expr (fa->var);
1433 fputc (' ', dumpfile);
1434 show_expr (fa->start);
1435 fputc (':', dumpfile);
1436 show_expr (fa->end);
1437 fputc (':', dumpfile);
1438 show_expr (fa->stride);
1440 if (fa->next != NULL)
1441 fputc (',', dumpfile);
1444 if (c->expr1 != NULL)
1446 fputc (',', dumpfile);
1447 show_expr (c->expr1);
1449 fputc ('\n', dumpfile);
1451 show_code (level + 1, c->block->next);
1453 code_indent (level, 0);
1454 fputs ("END FORALL", dumpfile);
1458 fputs ("CRITICAL\n", dumpfile);
1459 show_code (level + 1, c->block->next);
1460 code_indent (level, 0);
1461 fputs ("END CRITICAL", dumpfile);
1465 fputs ("DO ", dumpfile);
1467 show_expr (c->ext.iterator->var);
1468 fputc ('=', dumpfile);
1469 show_expr (c->ext.iterator->start);
1470 fputc (' ', dumpfile);
1471 show_expr (c->ext.iterator->end);
1472 fputc (' ', dumpfile);
1473 show_expr (c->ext.iterator->step);
1474 fputc ('\n', dumpfile);
1476 show_code (level + 1, c->block->next);
1478 code_indent (level, 0);
1479 fputs ("END DO", dumpfile);
1483 fputs ("DO WHILE ", dumpfile);
1484 show_expr (c->expr1);
1485 fputc ('\n', dumpfile);
1487 show_code (level + 1, c->block->next);
1489 code_indent (level, c->label1);
1490 fputs ("END DO", dumpfile);
1494 fputs ("CYCLE", dumpfile);
1496 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1500 fputs ("EXIT", dumpfile);
1502 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1506 fputs ("ALLOCATE ", dumpfile);
1509 fputs (" STAT=", dumpfile);
1510 show_expr (c->expr1);
1515 fputs (" ERRMSG=", dumpfile);
1516 show_expr (c->expr2);
1519 for (a = c->ext.alloc.list; a; a = a->next)
1521 fputc (' ', dumpfile);
1522 show_expr (a->expr);
1527 case EXEC_DEALLOCATE:
1528 fputs ("DEALLOCATE ", dumpfile);
1531 fputs (" STAT=", dumpfile);
1532 show_expr (c->expr1);
1537 fputs (" ERRMSG=", dumpfile);
1538 show_expr (c->expr2);
1541 for (a = c->ext.alloc.list; a; a = a->next)
1543 fputc (' ', dumpfile);
1544 show_expr (a->expr);
1550 fputs ("OPEN", dumpfile);
1555 fputs (" UNIT=", dumpfile);
1556 show_expr (open->unit);
1560 fputs (" IOMSG=", dumpfile);
1561 show_expr (open->iomsg);
1565 fputs (" IOSTAT=", dumpfile);
1566 show_expr (open->iostat);
1570 fputs (" FILE=", dumpfile);
1571 show_expr (open->file);
1575 fputs (" STATUS=", dumpfile);
1576 show_expr (open->status);
1580 fputs (" ACCESS=", dumpfile);
1581 show_expr (open->access);
1585 fputs (" FORM=", dumpfile);
1586 show_expr (open->form);
1590 fputs (" RECL=", dumpfile);
1591 show_expr (open->recl);
1595 fputs (" BLANK=", dumpfile);
1596 show_expr (open->blank);
1600 fputs (" POSITION=", dumpfile);
1601 show_expr (open->position);
1605 fputs (" ACTION=", dumpfile);
1606 show_expr (open->action);
1610 fputs (" DELIM=", dumpfile);
1611 show_expr (open->delim);
1615 fputs (" PAD=", dumpfile);
1616 show_expr (open->pad);
1620 fputs (" DECIMAL=", dumpfile);
1621 show_expr (open->decimal);
1625 fputs (" ENCODING=", dumpfile);
1626 show_expr (open->encoding);
1630 fputs (" ROUND=", dumpfile);
1631 show_expr (open->round);
1635 fputs (" SIGN=", dumpfile);
1636 show_expr (open->sign);
1640 fputs (" CONVERT=", dumpfile);
1641 show_expr (open->convert);
1643 if (open->asynchronous)
1645 fputs (" ASYNCHRONOUS=", dumpfile);
1646 show_expr (open->asynchronous);
1648 if (open->err != NULL)
1649 fprintf (dumpfile, " ERR=%d", open->err->value);
1654 fputs ("CLOSE", dumpfile);
1655 close = c->ext.close;
1659 fputs (" UNIT=", dumpfile);
1660 show_expr (close->unit);
1664 fputs (" IOMSG=", dumpfile);
1665 show_expr (close->iomsg);
1669 fputs (" IOSTAT=", dumpfile);
1670 show_expr (close->iostat);
1674 fputs (" STATUS=", dumpfile);
1675 show_expr (close->status);
1677 if (close->err != NULL)
1678 fprintf (dumpfile, " ERR=%d", close->err->value);
1681 case EXEC_BACKSPACE:
1682 fputs ("BACKSPACE", dumpfile);
1686 fputs ("ENDFILE", dumpfile);
1690 fputs ("REWIND", dumpfile);
1694 fputs ("FLUSH", dumpfile);
1697 fp = c->ext.filepos;
1701 fputs (" UNIT=", dumpfile);
1702 show_expr (fp->unit);
1706 fputs (" IOMSG=", dumpfile);
1707 show_expr (fp->iomsg);
1711 fputs (" IOSTAT=", dumpfile);
1712 show_expr (fp->iostat);
1714 if (fp->err != NULL)
1715 fprintf (dumpfile, " ERR=%d", fp->err->value);
1719 fputs ("INQUIRE", dumpfile);
1724 fputs (" UNIT=", dumpfile);
1725 show_expr (i->unit);
1729 fputs (" FILE=", dumpfile);
1730 show_expr (i->file);
1735 fputs (" IOMSG=", dumpfile);
1736 show_expr (i->iomsg);
1740 fputs (" IOSTAT=", dumpfile);
1741 show_expr (i->iostat);
1745 fputs (" EXIST=", dumpfile);
1746 show_expr (i->exist);
1750 fputs (" OPENED=", dumpfile);
1751 show_expr (i->opened);
1755 fputs (" NUMBER=", dumpfile);
1756 show_expr (i->number);
1760 fputs (" NAMED=", dumpfile);
1761 show_expr (i->named);
1765 fputs (" NAME=", dumpfile);
1766 show_expr (i->name);
1770 fputs (" ACCESS=", dumpfile);
1771 show_expr (i->access);
1775 fputs (" SEQUENTIAL=", dumpfile);
1776 show_expr (i->sequential);
1781 fputs (" DIRECT=", dumpfile);
1782 show_expr (i->direct);
1786 fputs (" FORM=", dumpfile);
1787 show_expr (i->form);
1791 fputs (" FORMATTED", dumpfile);
1792 show_expr (i->formatted);
1796 fputs (" UNFORMATTED=", dumpfile);
1797 show_expr (i->unformatted);
1801 fputs (" RECL=", dumpfile);
1802 show_expr (i->recl);
1806 fputs (" NEXTREC=", dumpfile);
1807 show_expr (i->nextrec);
1811 fputs (" BLANK=", dumpfile);
1812 show_expr (i->blank);
1816 fputs (" POSITION=", dumpfile);
1817 show_expr (i->position);
1821 fputs (" ACTION=", dumpfile);
1822 show_expr (i->action);
1826 fputs (" READ=", dumpfile);
1827 show_expr (i->read);
1831 fputs (" WRITE=", dumpfile);
1832 show_expr (i->write);
1836 fputs (" READWRITE=", dumpfile);
1837 show_expr (i->readwrite);
1841 fputs (" DELIM=", dumpfile);
1842 show_expr (i->delim);
1846 fputs (" PAD=", dumpfile);
1851 fputs (" CONVERT=", dumpfile);
1852 show_expr (i->convert);
1854 if (i->asynchronous)
1856 fputs (" ASYNCHRONOUS=", dumpfile);
1857 show_expr (i->asynchronous);
1861 fputs (" DECIMAL=", dumpfile);
1862 show_expr (i->decimal);
1866 fputs (" ENCODING=", dumpfile);
1867 show_expr (i->encoding);
1871 fputs (" PENDING=", dumpfile);
1872 show_expr (i->pending);
1876 fputs (" ROUND=", dumpfile);
1877 show_expr (i->round);
1881 fputs (" SIGN=", dumpfile);
1882 show_expr (i->sign);
1886 fputs (" SIZE=", dumpfile);
1887 show_expr (i->size);
1891 fputs (" ID=", dumpfile);
1896 fprintf (dumpfile, " ERR=%d", i->err->value);
1900 fputs ("IOLENGTH ", dumpfile);
1901 show_expr (c->expr1);
1906 fputs ("READ", dumpfile);
1910 fputs ("WRITE", dumpfile);
1916 fputs (" UNIT=", dumpfile);
1917 show_expr (dt->io_unit);
1920 if (dt->format_expr)
1922 fputs (" FMT=", dumpfile);
1923 show_expr (dt->format_expr);
1926 if (dt->format_label != NULL)
1927 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1929 fprintf (dumpfile, " NML=%s", dt->namelist->name);
1933 fputs (" IOMSG=", dumpfile);
1934 show_expr (dt->iomsg);
1938 fputs (" IOSTAT=", dumpfile);
1939 show_expr (dt->iostat);
1943 fputs (" SIZE=", dumpfile);
1944 show_expr (dt->size);
1948 fputs (" REC=", dumpfile);
1949 show_expr (dt->rec);
1953 fputs (" ADVANCE=", dumpfile);
1954 show_expr (dt->advance);
1958 fputs (" ID=", dumpfile);
1963 fputs (" POS=", dumpfile);
1964 show_expr (dt->pos);
1966 if (dt->asynchronous)
1968 fputs (" ASYNCHRONOUS=", dumpfile);
1969 show_expr (dt->asynchronous);
1973 fputs (" BLANK=", dumpfile);
1974 show_expr (dt->blank);
1978 fputs (" DECIMAL=", dumpfile);
1979 show_expr (dt->decimal);
1983 fputs (" DELIM=", dumpfile);
1984 show_expr (dt->delim);
1988 fputs (" PAD=", dumpfile);
1989 show_expr (dt->pad);
1993 fputs (" ROUND=", dumpfile);
1994 show_expr (dt->round);
1998 fputs (" SIGN=", dumpfile);
1999 show_expr (dt->sign);
2003 fputc ('\n', dumpfile);
2004 for (c = c->block->next; c; c = c->next)
2005 show_code_node (level + (c->next != NULL), c);
2009 fputs ("TRANSFER ", dumpfile);
2010 show_expr (c->expr1);
2014 fputs ("DT_END", dumpfile);
2017 if (dt->err != NULL)
2018 fprintf (dumpfile, " ERR=%d", dt->err->value);
2019 if (dt->end != NULL)
2020 fprintf (dumpfile, " END=%d", dt->end->value);
2021 if (dt->eor != NULL)
2022 fprintf (dumpfile, " EOR=%d", dt->eor->value);
2025 case EXEC_OMP_ATOMIC:
2026 case EXEC_OMP_BARRIER:
2027 case EXEC_OMP_CRITICAL:
2028 case EXEC_OMP_FLUSH:
2030 case EXEC_OMP_MASTER:
2031 case EXEC_OMP_ORDERED:
2032 case EXEC_OMP_PARALLEL:
2033 case EXEC_OMP_PARALLEL_DO:
2034 case EXEC_OMP_PARALLEL_SECTIONS:
2035 case EXEC_OMP_PARALLEL_WORKSHARE:
2036 case EXEC_OMP_SECTIONS:
2037 case EXEC_OMP_SINGLE:
2039 case EXEC_OMP_TASKWAIT:
2040 case EXEC_OMP_WORKSHARE:
2041 show_omp_node (level, c);
2045 gfc_internal_error ("show_code_node(): Bad statement code");
2048 fputc ('\n', dumpfile);
2052 /* Show an equivalence chain. */
2055 show_equiv (gfc_equiv *eq)
2058 fputs ("Equivalence: ", dumpfile);
2061 show_expr (eq->expr);
2064 fputs (", ", dumpfile);
2069 /* Show a freakin' whole namespace. */
2072 show_namespace (gfc_namespace *ns)
2074 gfc_interface *intr;
2075 gfc_namespace *save;
2080 save = gfc_current_ns;
2084 fputs ("Namespace:", dumpfile);
2092 while (i < GFC_LETTERS - 1
2093 && gfc_compare_types(&ns->default_type[i+1],
2094 &ns->default_type[l]))
2098 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2100 fprintf (dumpfile, " %c: ", l+'A');
2102 show_typespec(&ns->default_type[l]);
2104 } while (i < GFC_LETTERS);
2106 if (ns->proc_name != NULL)
2109 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2112 gfc_current_ns = ns;
2113 gfc_traverse_symtree (ns->common_root, show_common);
2115 gfc_traverse_symtree (ns->sym_root, show_symtree);
2117 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2119 /* User operator interfaces */
2125 fprintf (dumpfile, "Operator interfaces for %s:",
2126 gfc_op2string ((gfc_intrinsic_op) op));
2128 for (; intr; intr = intr->next)
2129 fprintf (dumpfile, " %s", intr->sym->name);
2132 if (ns->uop_root != NULL)
2135 fputs ("User operators:\n", dumpfile);
2136 gfc_traverse_user_op (ns, show_uop);
2140 for (eq = ns->equiv; eq; eq = eq->next)
2143 fputc ('\n', dumpfile);
2144 fputc ('\n', dumpfile);
2146 show_code (0, ns->code);
2148 for (ns = ns->contained; ns; ns = ns->sibling)
2151 fputs ("CONTAINS\n", dumpfile);
2152 show_namespace (ns);
2156 fputc ('\n', dumpfile);
2157 gfc_current_ns = save;
2161 /* Main function for dumping a parse tree. */
2164 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2167 show_namespace (ns);