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
37 #include "constructor.h"
39 /* Keep track of indentation for symbol tree dumps. */
40 static int show_level = 0;
42 /* The file handle we're dumping to is kept in a static variable. This
43 is not too cool, but it avoids a lot of passing it around. */
44 static FILE *dumpfile;
46 /* Forward declaration of some of the functions. */
47 static void show_expr (gfc_expr *p);
48 static void show_code_node (int, gfc_code *);
49 static void show_namespace (gfc_namespace *ns);
52 /* Do indentation for a specific level. */
55 code_indent (int level, gfc_st_label *label)
60 fprintf (dumpfile, "%-5d ", label->value);
62 fputs (" ", dumpfile);
64 for (i = 0; i < 2 * level; i++)
65 fputc (' ', dumpfile);
69 /* Simple indentation at the current level. This one
70 is used to show symbols. */
75 fputc ('\n', dumpfile);
76 code_indent (show_level, NULL);
80 /* Show type-specific information. */
83 show_typespec (gfc_typespec *ts)
85 fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
90 fprintf (dumpfile, "%s", ts->u.derived->name);
94 show_expr (ts->u.cl->length);
98 fprintf (dumpfile, "%d", ts->kind);
102 fputc (')', dumpfile);
106 /* Show an actual argument list. */
109 show_actual_arglist (gfc_actual_arglist *a)
111 fputc ('(', dumpfile);
113 for (; a; a = a->next)
115 fputc ('(', dumpfile);
117 fprintf (dumpfile, "%s = ", a->name);
121 fputs ("(arg not-present)", dumpfile);
123 fputc (')', dumpfile);
125 fputc (' ', dumpfile);
128 fputc (')', dumpfile);
132 /* Show a gfc_array_spec array specification structure. */
135 show_array_spec (gfc_array_spec *as)
142 fputs ("()", dumpfile);
146 fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
148 if (as->rank + as->corank > 0)
152 case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
153 case AS_DEFERRED: c = "AS_DEFERRED"; break;
154 case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
155 case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
157 gfc_internal_error ("show_array_spec(): Unhandled array shape "
160 fprintf (dumpfile, " %s ", c);
162 for (i = 0; i < as->rank + as->corank; i++)
164 show_expr (as->lower[i]);
165 fputc (' ', dumpfile);
166 show_expr (as->upper[i]);
167 fputc (' ', dumpfile);
171 fputc (')', dumpfile);
175 /* Show a gfc_array_ref array reference structure. */
178 show_array_ref (gfc_array_ref * ar)
182 fputc ('(', dumpfile);
187 fputs ("FULL", dumpfile);
191 for (i = 0; i < ar->dimen; i++)
193 /* There are two types of array sections: either the
194 elements are identified by an integer array ('vector'),
195 or by an index range. In the former case we only have to
196 print the start expression which contains the vector, in
197 the latter case we have to print any of lower and upper
198 bound and the stride, if they're present. */
200 if (ar->start[i] != NULL)
201 show_expr (ar->start[i]);
203 if (ar->dimen_type[i] == DIMEN_RANGE)
205 fputc (':', dumpfile);
207 if (ar->end[i] != NULL)
208 show_expr (ar->end[i]);
210 if (ar->stride[i] != NULL)
212 fputc (':', dumpfile);
213 show_expr (ar->stride[i]);
217 if (i != ar->dimen - 1)
218 fputs (" , ", dumpfile);
223 for (i = 0; i < ar->dimen; i++)
225 show_expr (ar->start[i]);
226 if (i != ar->dimen - 1)
227 fputs (" , ", dumpfile);
232 fputs ("UNKNOWN", dumpfile);
236 gfc_internal_error ("show_array_ref(): Unknown array reference");
239 fputc (')', dumpfile);
243 /* Show a list of gfc_ref structures. */
246 show_ref (gfc_ref *p)
248 for (; p; p = p->next)
252 show_array_ref (&p->u.ar);
256 fprintf (dumpfile, " %% %s", p->u.c.component->name);
260 fputc ('(', dumpfile);
261 show_expr (p->u.ss.start);
262 fputc (':', dumpfile);
263 show_expr (p->u.ss.end);
264 fputc (')', dumpfile);
268 gfc_internal_error ("show_ref(): Bad component code");
273 /* Display a constructor. Works recursively for array constructors. */
276 show_constructor (gfc_constructor_base base)
279 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
281 if (c->iterator == NULL)
285 fputc ('(', dumpfile);
288 fputc (' ', dumpfile);
289 show_expr (c->iterator->var);
290 fputc ('=', dumpfile);
291 show_expr (c->iterator->start);
292 fputc (',', dumpfile);
293 show_expr (c->iterator->end);
294 fputc (',', dumpfile);
295 show_expr (c->iterator->step);
297 fputc (')', dumpfile);
300 if (gfc_constructor_next (c) != NULL)
301 fputs (" , ", dumpfile);
307 show_char_const (const gfc_char_t *c, int length)
311 fputc ('\'', dumpfile);
312 for (i = 0; i < length; i++)
315 fputs ("''", dumpfile);
317 fputs (gfc_print_wide_char (c[i]), dumpfile);
319 fputc ('\'', dumpfile);
323 /* Show a component-call expression. */
326 show_compcall (gfc_expr* p)
328 gcc_assert (p->expr_type == EXPR_COMPCALL);
330 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
332 fprintf (dumpfile, "%s", p->value.compcall.name);
334 show_actual_arglist (p->value.compcall.actual);
338 /* Show an expression. */
341 show_expr (gfc_expr *p)
348 fputs ("()", dumpfile);
352 switch (p->expr_type)
355 show_char_const (p->value.character.string, p->value.character.length);
360 fprintf (dumpfile, "%s(", p->ts.u.derived->name);
361 show_constructor (p->value.constructor);
362 fputc (')', dumpfile);
366 fputs ("(/ ", dumpfile);
367 show_constructor (p->value.constructor);
368 fputs (" /)", dumpfile);
374 fputs ("NULL()", dumpfile);
381 mpz_out_str (stdout, 10, p->value.integer);
383 if (p->ts.kind != gfc_default_integer_kind)
384 fprintf (dumpfile, "_%d", p->ts.kind);
388 if (p->value.logical)
389 fputs (".true.", dumpfile);
391 fputs (".false.", dumpfile);
395 mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
396 if (p->ts.kind != gfc_default_real_kind)
397 fprintf (dumpfile, "_%d", p->ts.kind);
401 show_char_const (p->value.character.string,
402 p->value.character.length);
406 fputs ("(complex ", dumpfile);
408 mpfr_out_str (stdout, 10, 0, mpc_realref (p->value.complex),
410 if (p->ts.kind != gfc_default_complex_kind)
411 fprintf (dumpfile, "_%d", p->ts.kind);
413 fputc (' ', dumpfile);
415 mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
417 if (p->ts.kind != gfc_default_complex_kind)
418 fprintf (dumpfile, "_%d", p->ts.kind);
420 fputc (')', dumpfile);
424 fprintf (dumpfile, "%dH", p->representation.length);
425 c = p->representation.string;
426 for (i = 0; i < p->representation.length; i++, c++)
428 fputc (*c, dumpfile);
433 fputs ("???", dumpfile);
437 if (p->representation.string)
439 fputs (" {", dumpfile);
440 c = p->representation.string;
441 for (i = 0; i < p->representation.length; i++, c++)
443 fprintf (dumpfile, "%.2x", (unsigned int) *c);
444 if (i < p->representation.length - 1)
445 fputc (',', dumpfile);
447 fputc ('}', dumpfile);
453 if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
454 fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
455 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
460 fputc ('(', dumpfile);
461 switch (p->value.op.op)
463 case INTRINSIC_UPLUS:
464 fputs ("U+ ", dumpfile);
466 case INTRINSIC_UMINUS:
467 fputs ("U- ", dumpfile);
470 fputs ("+ ", dumpfile);
472 case INTRINSIC_MINUS:
473 fputs ("- ", dumpfile);
475 case INTRINSIC_TIMES:
476 fputs ("* ", dumpfile);
478 case INTRINSIC_DIVIDE:
479 fputs ("/ ", dumpfile);
481 case INTRINSIC_POWER:
482 fputs ("** ", dumpfile);
484 case INTRINSIC_CONCAT:
485 fputs ("// ", dumpfile);
488 fputs ("AND ", dumpfile);
491 fputs ("OR ", dumpfile);
494 fputs ("EQV ", dumpfile);
497 fputs ("NEQV ", dumpfile);
500 case INTRINSIC_EQ_OS:
501 fputs ("= ", dumpfile);
504 case INTRINSIC_NE_OS:
505 fputs ("/= ", dumpfile);
508 case INTRINSIC_GT_OS:
509 fputs ("> ", dumpfile);
512 case INTRINSIC_GE_OS:
513 fputs (">= ", dumpfile);
516 case INTRINSIC_LT_OS:
517 fputs ("< ", dumpfile);
520 case INTRINSIC_LE_OS:
521 fputs ("<= ", dumpfile);
524 fputs ("NOT ", dumpfile);
526 case INTRINSIC_PARENTHESES:
527 fputs ("parens", dumpfile);
532 ("show_expr(): Bad intrinsic in expression!");
535 show_expr (p->value.op.op1);
539 fputc (' ', dumpfile);
540 show_expr (p->value.op.op2);
543 fputc (')', dumpfile);
547 if (p->value.function.name == NULL)
549 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
550 if (gfc_is_proc_ptr_comp (p, NULL))
552 fputc ('[', dumpfile);
553 show_actual_arglist (p->value.function.actual);
554 fputc (']', dumpfile);
558 fprintf (dumpfile, "%s", p->value.function.name);
559 if (gfc_is_proc_ptr_comp (p, NULL))
561 fputc ('[', dumpfile);
562 fputc ('[', dumpfile);
563 show_actual_arglist (p->value.function.actual);
564 fputc (']', dumpfile);
565 fputc (']', dumpfile);
575 gfc_internal_error ("show_expr(): Don't know how to show expr");
579 /* Show symbol attributes. The flavor and intent are followed by
580 whatever single bit attributes are present. */
583 show_attr (symbol_attribute *attr)
586 fprintf (dumpfile, "(%s %s %s %s %s",
587 gfc_code2string (flavors, attr->flavor),
588 gfc_intent_string (attr->intent),
589 gfc_code2string (access_types, attr->access),
590 gfc_code2string (procedures, attr->proc),
591 gfc_code2string (save_status, attr->save));
593 if (attr->allocatable)
594 fputs (" ALLOCATABLE", dumpfile);
595 if (attr->asynchronous)
596 fputs (" ASYNCHRONOUS", dumpfile);
597 if (attr->codimension)
598 fputs (" CODIMENSION", dumpfile);
600 fputs (" DIMENSION", dumpfile);
602 fputs (" EXTERNAL", dumpfile);
604 fputs (" INTRINSIC", dumpfile);
606 fputs (" OPTIONAL", dumpfile);
608 fputs (" POINTER", dumpfile);
609 if (attr->is_protected)
610 fputs (" PROTECTED", dumpfile);
612 fputs (" VALUE", dumpfile);
614 fputs (" VOLATILE", dumpfile);
615 if (attr->threadprivate)
616 fputs (" THREADPRIVATE", dumpfile);
618 fputs (" TARGET", dumpfile);
620 fputs (" DUMMY", dumpfile);
622 fputs (" RESULT", dumpfile);
624 fputs (" ENTRY", dumpfile);
626 fputs (" BIND(C)", dumpfile);
629 fputs (" DATA", dumpfile);
631 fputs (" USE-ASSOC", dumpfile);
632 if (attr->in_namelist)
633 fputs (" IN-NAMELIST", dumpfile);
635 fputs (" IN-COMMON", dumpfile);
638 fputs (" ABSTRACT", dumpfile);
640 fputs (" FUNCTION", dumpfile);
641 if (attr->subroutine)
642 fputs (" SUBROUTINE", dumpfile);
643 if (attr->implicit_type)
644 fputs (" IMPLICIT-TYPE", dumpfile);
647 fputs (" SEQUENCE", dumpfile);
649 fputs (" ELEMENTAL", dumpfile);
651 fputs (" PURE", dumpfile);
653 fputs (" RECURSIVE", dumpfile);
655 fputc (')', dumpfile);
659 /* Show components of a derived type. */
662 show_components (gfc_symbol *sym)
666 for (c = sym->components; c; c = c->next)
668 fprintf (dumpfile, "(%s ", c->name);
669 show_typespec (&c->ts);
671 fputs (" POINTER", dumpfile);
672 if (c->attr.proc_pointer)
673 fputs (" PPC", dumpfile);
674 if (c->attr.dimension)
675 fputs (" DIMENSION", dumpfile);
676 fputc (' ', dumpfile);
677 show_array_spec (c->as);
679 fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
680 fputc (')', dumpfile);
682 fputc (' ', dumpfile);
687 /* Show the f2k_derived namespace with procedure bindings. */
690 show_typebound_proc (gfc_typebound_proc* tb, const char* name)
695 fputs ("GENERIC", dumpfile);
698 fputs ("PROCEDURE, ", dumpfile);
700 fputs ("NOPASS", dumpfile);
704 fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
706 fputs ("PASS", dumpfile);
708 if (tb->non_overridable)
709 fputs (", NON_OVERRIDABLE", dumpfile);
712 if (tb->access == ACCESS_PUBLIC)
713 fputs (", PUBLIC", dumpfile);
715 fputs (", PRIVATE", dumpfile);
717 fprintf (dumpfile, " :: %s => ", name);
722 for (g = tb->u.generic; g; g = g->next)
724 fputs (g->specific_st->name, dumpfile);
726 fputs (", ", dumpfile);
730 fputs (tb->u.specific->n.sym->name, dumpfile);
734 show_typebound_symtree (gfc_symtree* st)
736 gcc_assert (st->n.tb);
737 show_typebound_proc (st->n.tb, st->name);
741 show_f2k_derived (gfc_namespace* f2k)
747 fputs ("Procedure bindings:", dumpfile);
750 /* Finalizer bindings. */
751 for (f = f2k->finalizers; f; f = f->next)
754 fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
757 /* Type-bound procedures. */
758 gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
763 fputs ("Operator bindings:", dumpfile);
766 /* User-defined operators. */
767 gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
769 /* Intrinsic operators. */
770 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
772 show_typebound_proc (f2k->tb_op[op],
773 gfc_op2string ((gfc_intrinsic_op) op));
779 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
780 show the interface. Information needed to reconstruct the list of
781 specific interfaces associated with a generic symbol is done within
785 show_symbol (gfc_symbol *sym)
787 gfc_formal_arglist *formal;
795 fprintf (dumpfile, "symbol %s ", sym->name);
796 show_typespec (&sym->ts);
797 show_attr (&sym->attr);
802 fputs ("value: ", dumpfile);
803 show_expr (sym->value);
809 fputs ("Array spec:", dumpfile);
810 show_array_spec (sym->as);
816 fputs ("Generic interfaces:", dumpfile);
817 for (intr = sym->generic; intr; intr = intr->next)
818 fprintf (dumpfile, " %s", intr->sym->name);
824 fprintf (dumpfile, "result: %s", sym->result->name);
830 fputs ("components: ", dumpfile);
831 show_components (sym);
834 if (sym->f2k_derived)
838 fprintf (dumpfile, "hash: %d", sym->hash_value);
839 show_f2k_derived (sym->f2k_derived);
845 fputs ("Formal arglist:", dumpfile);
847 for (formal = sym->formal; formal; formal = formal->next)
849 if (formal->sym != NULL)
850 fprintf (dumpfile, " %s", formal->sym->name);
852 fputs (" [Alt Return]", dumpfile);
859 fputs ("Formal namespace", dumpfile);
860 show_namespace (sym->formal_ns);
863 fputc ('\n', dumpfile);
867 /* Show a user-defined operator. Just prints an operator
868 and the name of the associated subroutine, really. */
871 show_uop (gfc_user_op *uop)
876 fprintf (dumpfile, "%s:", uop->name);
878 for (intr = uop->op; intr; intr = intr->next)
879 fprintf (dumpfile, " %s", intr->sym->name);
883 /* Workhorse function for traversing the user operator symtree. */
886 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
893 traverse_uop (st->left, func);
894 traverse_uop (st->right, func);
898 /* Traverse the tree of user operator nodes. */
901 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
903 traverse_uop (ns->uop_root, func);
907 /* Function to display a common block. */
910 show_common (gfc_symtree *st)
915 fprintf (dumpfile, "common: /%s/ ", st->name);
917 s = st->n.common->head;
920 fprintf (dumpfile, "%s", s->name);
923 fputs (", ", dumpfile);
925 fputc ('\n', dumpfile);
929 /* Worker function to display the symbol tree. */
932 show_symtree (gfc_symtree *st)
935 fprintf (dumpfile, "symtree: %s Ambig %d", st->name, st->ambiguous);
937 if (st->n.sym->ns != gfc_current_ns)
938 fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
940 show_symbol (st->n.sym);
944 /******************* Show gfc_code structures **************/
947 /* Show a list of code structures. Mutually recursive with
951 show_code (int level, gfc_code *c)
953 for (; c; c = c->next)
954 show_code_node (level, c);
958 show_namelist (gfc_namelist *n)
960 for (; n->next; n = n->next)
961 fprintf (dumpfile, "%s,", n->sym->name);
962 fprintf (dumpfile, "%s", n->sym->name);
965 /* Show a single OpenMP directive node and everything underneath it
969 show_omp_node (int level, gfc_code *c)
971 gfc_omp_clauses *omp_clauses = NULL;
972 const char *name = NULL;
976 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
977 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
978 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
979 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
980 case EXEC_OMP_DO: name = "DO"; break;
981 case EXEC_OMP_MASTER: name = "MASTER"; break;
982 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
983 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
984 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
985 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
986 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
987 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
988 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
989 case EXEC_OMP_TASK: name = "TASK"; break;
990 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
991 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
995 fprintf (dumpfile, "!$OMP %s", name);
999 case EXEC_OMP_PARALLEL:
1000 case EXEC_OMP_PARALLEL_DO:
1001 case EXEC_OMP_PARALLEL_SECTIONS:
1002 case EXEC_OMP_SECTIONS:
1003 case EXEC_OMP_SINGLE:
1004 case EXEC_OMP_WORKSHARE:
1005 case EXEC_OMP_PARALLEL_WORKSHARE:
1007 omp_clauses = c->ext.omp_clauses;
1009 case EXEC_OMP_CRITICAL:
1010 if (c->ext.omp_name)
1011 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1013 case EXEC_OMP_FLUSH:
1014 if (c->ext.omp_namelist)
1016 fputs (" (", dumpfile);
1017 show_namelist (c->ext.omp_namelist);
1018 fputc (')', dumpfile);
1021 case EXEC_OMP_BARRIER:
1022 case EXEC_OMP_TASKWAIT:
1031 if (omp_clauses->if_expr)
1033 fputs (" IF(", dumpfile);
1034 show_expr (omp_clauses->if_expr);
1035 fputc (')', dumpfile);
1037 if (omp_clauses->num_threads)
1039 fputs (" NUM_THREADS(", dumpfile);
1040 show_expr (omp_clauses->num_threads);
1041 fputc (')', dumpfile);
1043 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1046 switch (omp_clauses->sched_kind)
1048 case OMP_SCHED_STATIC: type = "STATIC"; break;
1049 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1050 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1051 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1052 case OMP_SCHED_AUTO: type = "AUTO"; break;
1056 fprintf (dumpfile, " SCHEDULE (%s", type);
1057 if (omp_clauses->chunk_size)
1059 fputc (',', dumpfile);
1060 show_expr (omp_clauses->chunk_size);
1062 fputc (')', dumpfile);
1064 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1067 switch (omp_clauses->default_sharing)
1069 case OMP_DEFAULT_NONE: type = "NONE"; break;
1070 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1071 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1072 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1076 fprintf (dumpfile, " DEFAULT(%s)", type);
1078 if (omp_clauses->ordered)
1079 fputs (" ORDERED", dumpfile);
1080 if (omp_clauses->untied)
1081 fputs (" UNTIED", dumpfile);
1082 if (omp_clauses->collapse)
1083 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1084 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1085 if (omp_clauses->lists[list_type] != NULL
1086 && list_type != OMP_LIST_COPYPRIVATE)
1089 if (list_type >= OMP_LIST_REDUCTION_FIRST)
1093 case OMP_LIST_PLUS: type = "+"; break;
1094 case OMP_LIST_MULT: type = "*"; break;
1095 case OMP_LIST_SUB: type = "-"; break;
1096 case OMP_LIST_AND: type = ".AND."; break;
1097 case OMP_LIST_OR: type = ".OR."; break;
1098 case OMP_LIST_EQV: type = ".EQV."; break;
1099 case OMP_LIST_NEQV: type = ".NEQV."; break;
1100 case OMP_LIST_MAX: type = "MAX"; break;
1101 case OMP_LIST_MIN: type = "MIN"; break;
1102 case OMP_LIST_IAND: type = "IAND"; break;
1103 case OMP_LIST_IOR: type = "IOR"; break;
1104 case OMP_LIST_IEOR: type = "IEOR"; break;
1108 fprintf (dumpfile, " REDUCTION(%s:", type);
1114 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1115 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1116 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1117 case OMP_LIST_SHARED: type = "SHARED"; break;
1118 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1122 fprintf (dumpfile, " %s(", type);
1124 show_namelist (omp_clauses->lists[list_type]);
1125 fputc (')', dumpfile);
1128 fputc ('\n', dumpfile);
1129 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1131 gfc_code *d = c->block;
1134 show_code (level + 1, d->next);
1135 if (d->block == NULL)
1137 code_indent (level, 0);
1138 fputs ("!$OMP SECTION\n", dumpfile);
1143 show_code (level + 1, c->block->next);
1144 if (c->op == EXEC_OMP_ATOMIC)
1146 code_indent (level, 0);
1147 fprintf (dumpfile, "!$OMP END %s", name);
1148 if (omp_clauses != NULL)
1150 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1152 fputs (" COPYPRIVATE(", dumpfile);
1153 show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1154 fputc (')', dumpfile);
1156 else if (omp_clauses->nowait)
1157 fputs (" NOWAIT", dumpfile);
1159 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1160 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1164 /* Show a single code node and everything underneath it if necessary. */
1167 show_code_node (int level, gfc_code *c)
1169 gfc_forall_iterator *fa;
1179 code_indent (level, c->here);
1183 case EXEC_END_PROCEDURE:
1187 fputs ("NOP", dumpfile);
1191 fputs ("CONTINUE", dumpfile);
1195 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1198 case EXEC_INIT_ASSIGN:
1200 fputs ("ASSIGN ", dumpfile);
1201 show_expr (c->expr1);
1202 fputc (' ', dumpfile);
1203 show_expr (c->expr2);
1206 case EXEC_LABEL_ASSIGN:
1207 fputs ("LABEL ASSIGN ", dumpfile);
1208 show_expr (c->expr1);
1209 fprintf (dumpfile, " %d", c->label1->value);
1212 case EXEC_POINTER_ASSIGN:
1213 fputs ("POINTER ASSIGN ", dumpfile);
1214 show_expr (c->expr1);
1215 fputc (' ', dumpfile);
1216 show_expr (c->expr2);
1220 fputs ("GOTO ", dumpfile);
1222 fprintf (dumpfile, "%d", c->label1->value);
1225 show_expr (c->expr1);
1229 fputs (", (", dumpfile);
1230 for (; d; d = d ->block)
1232 code_indent (level, d->label1);
1233 if (d->block != NULL)
1234 fputc (',', dumpfile);
1236 fputc (')', dumpfile);
1243 case EXEC_ASSIGN_CALL:
1244 if (c->resolved_sym)
1245 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1246 else if (c->symtree)
1247 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1249 fputs ("CALL ?? ", dumpfile);
1251 show_actual_arglist (c->ext.actual);
1255 fputs ("CALL ", dumpfile);
1256 show_compcall (c->expr1);
1260 fputs ("CALL ", dumpfile);
1261 show_expr (c->expr1);
1262 show_actual_arglist (c->ext.actual);
1266 fputs ("RETURN ", dumpfile);
1268 show_expr (c->expr1);
1272 fputs ("PAUSE ", dumpfile);
1274 if (c->expr1 != NULL)
1275 show_expr (c->expr1);
1277 fprintf (dumpfile, "%d", c->ext.stop_code);
1281 case EXEC_ERROR_STOP:
1282 fputs ("ERROR ", dumpfile);
1286 fputs ("STOP ", dumpfile);
1288 if (c->expr1 != NULL)
1289 show_expr (c->expr1);
1291 fprintf (dumpfile, "%d", c->ext.stop_code);
1296 fputs ("SYNC ALL ", dumpfile);
1297 if (c->expr2 != NULL)
1299 fputs (" stat=", dumpfile);
1300 show_expr (c->expr2);
1302 if (c->expr3 != NULL)
1304 fputs (" errmsg=", dumpfile);
1305 show_expr (c->expr3);
1309 case EXEC_SYNC_MEMORY:
1310 fputs ("SYNC MEMORY ", dumpfile);
1311 if (c->expr2 != NULL)
1313 fputs (" stat=", dumpfile);
1314 show_expr (c->expr2);
1316 if (c->expr3 != NULL)
1318 fputs (" errmsg=", dumpfile);
1319 show_expr (c->expr3);
1323 case EXEC_SYNC_IMAGES:
1324 fputs ("SYNC IMAGES image-set=", dumpfile);
1325 if (c->expr1 != NULL)
1326 show_expr (c->expr1);
1328 fputs ("* ", dumpfile);
1329 if (c->expr2 != NULL)
1331 fputs (" stat=", dumpfile);
1332 show_expr (c->expr2);
1334 if (c->expr3 != NULL)
1336 fputs (" errmsg=", dumpfile);
1337 show_expr (c->expr3);
1341 case EXEC_ARITHMETIC_IF:
1342 fputs ("IF ", dumpfile);
1343 show_expr (c->expr1);
1344 fprintf (dumpfile, " %d, %d, %d",
1345 c->label1->value, c->label2->value, c->label3->value);
1350 fputs ("IF ", dumpfile);
1351 show_expr (d->expr1);
1352 fputc ('\n', dumpfile);
1353 show_code (level + 1, d->next);
1356 for (; d; d = d->block)
1358 code_indent (level, 0);
1360 if (d->expr1 == NULL)
1361 fputs ("ELSE\n", dumpfile);
1364 fputs ("ELSE IF ", dumpfile);
1365 show_expr (d->expr1);
1366 fputc ('\n', dumpfile);
1369 show_code (level + 1, d->next);
1372 code_indent (level, c->label1);
1374 fputs ("ENDIF", dumpfile);
1379 fputs ("SELECT CASE ", dumpfile);
1380 show_expr (c->expr1);
1381 fputc ('\n', dumpfile);
1383 for (; d; d = d->block)
1385 code_indent (level, 0);
1387 fputs ("CASE ", dumpfile);
1388 for (cp = d->ext.case_list; cp; cp = cp->next)
1390 fputc ('(', dumpfile);
1391 show_expr (cp->low);
1392 fputc (' ', dumpfile);
1393 show_expr (cp->high);
1394 fputc (')', dumpfile);
1395 fputc (' ', dumpfile);
1397 fputc ('\n', dumpfile);
1399 show_code (level + 1, d->next);
1402 code_indent (level, c->label1);
1403 fputs ("END SELECT", dumpfile);
1407 fputs ("WHERE ", dumpfile);
1410 show_expr (d->expr1);
1411 fputc ('\n', dumpfile);
1413 show_code (level + 1, d->next);
1415 for (d = d->block; d; d = d->block)
1417 code_indent (level, 0);
1418 fputs ("ELSE WHERE ", dumpfile);
1419 show_expr (d->expr1);
1420 fputc ('\n', dumpfile);
1421 show_code (level + 1, d->next);
1424 code_indent (level, 0);
1425 fputs ("END WHERE", dumpfile);
1430 fputs ("FORALL ", dumpfile);
1431 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1433 show_expr (fa->var);
1434 fputc (' ', dumpfile);
1435 show_expr (fa->start);
1436 fputc (':', dumpfile);
1437 show_expr (fa->end);
1438 fputc (':', dumpfile);
1439 show_expr (fa->stride);
1441 if (fa->next != NULL)
1442 fputc (',', dumpfile);
1445 if (c->expr1 != NULL)
1447 fputc (',', dumpfile);
1448 show_expr (c->expr1);
1450 fputc ('\n', dumpfile);
1452 show_code (level + 1, c->block->next);
1454 code_indent (level, 0);
1455 fputs ("END FORALL", dumpfile);
1459 fputs ("CRITICAL\n", dumpfile);
1460 show_code (level + 1, c->block->next);
1461 code_indent (level, 0);
1462 fputs ("END CRITICAL", dumpfile);
1466 fputs ("DO ", dumpfile);
1468 show_expr (c->ext.iterator->var);
1469 fputc ('=', dumpfile);
1470 show_expr (c->ext.iterator->start);
1471 fputc (' ', dumpfile);
1472 show_expr (c->ext.iterator->end);
1473 fputc (' ', dumpfile);
1474 show_expr (c->ext.iterator->step);
1475 fputc ('\n', dumpfile);
1477 show_code (level + 1, c->block->next);
1479 code_indent (level, 0);
1480 fputs ("END DO", dumpfile);
1484 fputs ("DO WHILE ", dumpfile);
1485 show_expr (c->expr1);
1486 fputc ('\n', dumpfile);
1488 show_code (level + 1, c->block->next);
1490 code_indent (level, c->label1);
1491 fputs ("END DO", dumpfile);
1495 fputs ("CYCLE", dumpfile);
1497 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1501 fputs ("EXIT", dumpfile);
1503 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1507 fputs ("ALLOCATE ", dumpfile);
1510 fputs (" STAT=", dumpfile);
1511 show_expr (c->expr1);
1516 fputs (" ERRMSG=", dumpfile);
1517 show_expr (c->expr2);
1520 for (a = c->ext.alloc.list; a; a = a->next)
1522 fputc (' ', dumpfile);
1523 show_expr (a->expr);
1528 case EXEC_DEALLOCATE:
1529 fputs ("DEALLOCATE ", dumpfile);
1532 fputs (" STAT=", dumpfile);
1533 show_expr (c->expr1);
1538 fputs (" ERRMSG=", dumpfile);
1539 show_expr (c->expr2);
1542 for (a = c->ext.alloc.list; a; a = a->next)
1544 fputc (' ', dumpfile);
1545 show_expr (a->expr);
1551 fputs ("OPEN", dumpfile);
1556 fputs (" UNIT=", dumpfile);
1557 show_expr (open->unit);
1561 fputs (" IOMSG=", dumpfile);
1562 show_expr (open->iomsg);
1566 fputs (" IOSTAT=", dumpfile);
1567 show_expr (open->iostat);
1571 fputs (" FILE=", dumpfile);
1572 show_expr (open->file);
1576 fputs (" STATUS=", dumpfile);
1577 show_expr (open->status);
1581 fputs (" ACCESS=", dumpfile);
1582 show_expr (open->access);
1586 fputs (" FORM=", dumpfile);
1587 show_expr (open->form);
1591 fputs (" RECL=", dumpfile);
1592 show_expr (open->recl);
1596 fputs (" BLANK=", dumpfile);
1597 show_expr (open->blank);
1601 fputs (" POSITION=", dumpfile);
1602 show_expr (open->position);
1606 fputs (" ACTION=", dumpfile);
1607 show_expr (open->action);
1611 fputs (" DELIM=", dumpfile);
1612 show_expr (open->delim);
1616 fputs (" PAD=", dumpfile);
1617 show_expr (open->pad);
1621 fputs (" DECIMAL=", dumpfile);
1622 show_expr (open->decimal);
1626 fputs (" ENCODING=", dumpfile);
1627 show_expr (open->encoding);
1631 fputs (" ROUND=", dumpfile);
1632 show_expr (open->round);
1636 fputs (" SIGN=", dumpfile);
1637 show_expr (open->sign);
1641 fputs (" CONVERT=", dumpfile);
1642 show_expr (open->convert);
1644 if (open->asynchronous)
1646 fputs (" ASYNCHRONOUS=", dumpfile);
1647 show_expr (open->asynchronous);
1649 if (open->err != NULL)
1650 fprintf (dumpfile, " ERR=%d", open->err->value);
1655 fputs ("CLOSE", dumpfile);
1656 close = c->ext.close;
1660 fputs (" UNIT=", dumpfile);
1661 show_expr (close->unit);
1665 fputs (" IOMSG=", dumpfile);
1666 show_expr (close->iomsg);
1670 fputs (" IOSTAT=", dumpfile);
1671 show_expr (close->iostat);
1675 fputs (" STATUS=", dumpfile);
1676 show_expr (close->status);
1678 if (close->err != NULL)
1679 fprintf (dumpfile, " ERR=%d", close->err->value);
1682 case EXEC_BACKSPACE:
1683 fputs ("BACKSPACE", dumpfile);
1687 fputs ("ENDFILE", dumpfile);
1691 fputs ("REWIND", dumpfile);
1695 fputs ("FLUSH", dumpfile);
1698 fp = c->ext.filepos;
1702 fputs (" UNIT=", dumpfile);
1703 show_expr (fp->unit);
1707 fputs (" IOMSG=", dumpfile);
1708 show_expr (fp->iomsg);
1712 fputs (" IOSTAT=", dumpfile);
1713 show_expr (fp->iostat);
1715 if (fp->err != NULL)
1716 fprintf (dumpfile, " ERR=%d", fp->err->value);
1720 fputs ("INQUIRE", dumpfile);
1725 fputs (" UNIT=", dumpfile);
1726 show_expr (i->unit);
1730 fputs (" FILE=", dumpfile);
1731 show_expr (i->file);
1736 fputs (" IOMSG=", dumpfile);
1737 show_expr (i->iomsg);
1741 fputs (" IOSTAT=", dumpfile);
1742 show_expr (i->iostat);
1746 fputs (" EXIST=", dumpfile);
1747 show_expr (i->exist);
1751 fputs (" OPENED=", dumpfile);
1752 show_expr (i->opened);
1756 fputs (" NUMBER=", dumpfile);
1757 show_expr (i->number);
1761 fputs (" NAMED=", dumpfile);
1762 show_expr (i->named);
1766 fputs (" NAME=", dumpfile);
1767 show_expr (i->name);
1771 fputs (" ACCESS=", dumpfile);
1772 show_expr (i->access);
1776 fputs (" SEQUENTIAL=", dumpfile);
1777 show_expr (i->sequential);
1782 fputs (" DIRECT=", dumpfile);
1783 show_expr (i->direct);
1787 fputs (" FORM=", dumpfile);
1788 show_expr (i->form);
1792 fputs (" FORMATTED", dumpfile);
1793 show_expr (i->formatted);
1797 fputs (" UNFORMATTED=", dumpfile);
1798 show_expr (i->unformatted);
1802 fputs (" RECL=", dumpfile);
1803 show_expr (i->recl);
1807 fputs (" NEXTREC=", dumpfile);
1808 show_expr (i->nextrec);
1812 fputs (" BLANK=", dumpfile);
1813 show_expr (i->blank);
1817 fputs (" POSITION=", dumpfile);
1818 show_expr (i->position);
1822 fputs (" ACTION=", dumpfile);
1823 show_expr (i->action);
1827 fputs (" READ=", dumpfile);
1828 show_expr (i->read);
1832 fputs (" WRITE=", dumpfile);
1833 show_expr (i->write);
1837 fputs (" READWRITE=", dumpfile);
1838 show_expr (i->readwrite);
1842 fputs (" DELIM=", dumpfile);
1843 show_expr (i->delim);
1847 fputs (" PAD=", dumpfile);
1852 fputs (" CONVERT=", dumpfile);
1853 show_expr (i->convert);
1855 if (i->asynchronous)
1857 fputs (" ASYNCHRONOUS=", dumpfile);
1858 show_expr (i->asynchronous);
1862 fputs (" DECIMAL=", dumpfile);
1863 show_expr (i->decimal);
1867 fputs (" ENCODING=", dumpfile);
1868 show_expr (i->encoding);
1872 fputs (" PENDING=", dumpfile);
1873 show_expr (i->pending);
1877 fputs (" ROUND=", dumpfile);
1878 show_expr (i->round);
1882 fputs (" SIGN=", dumpfile);
1883 show_expr (i->sign);
1887 fputs (" SIZE=", dumpfile);
1888 show_expr (i->size);
1892 fputs (" ID=", dumpfile);
1897 fprintf (dumpfile, " ERR=%d", i->err->value);
1901 fputs ("IOLENGTH ", dumpfile);
1902 show_expr (c->expr1);
1907 fputs ("READ", dumpfile);
1911 fputs ("WRITE", dumpfile);
1917 fputs (" UNIT=", dumpfile);
1918 show_expr (dt->io_unit);
1921 if (dt->format_expr)
1923 fputs (" FMT=", dumpfile);
1924 show_expr (dt->format_expr);
1927 if (dt->format_label != NULL)
1928 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1930 fprintf (dumpfile, " NML=%s", dt->namelist->name);
1934 fputs (" IOMSG=", dumpfile);
1935 show_expr (dt->iomsg);
1939 fputs (" IOSTAT=", dumpfile);
1940 show_expr (dt->iostat);
1944 fputs (" SIZE=", dumpfile);
1945 show_expr (dt->size);
1949 fputs (" REC=", dumpfile);
1950 show_expr (dt->rec);
1954 fputs (" ADVANCE=", dumpfile);
1955 show_expr (dt->advance);
1959 fputs (" ID=", dumpfile);
1964 fputs (" POS=", dumpfile);
1965 show_expr (dt->pos);
1967 if (dt->asynchronous)
1969 fputs (" ASYNCHRONOUS=", dumpfile);
1970 show_expr (dt->asynchronous);
1974 fputs (" BLANK=", dumpfile);
1975 show_expr (dt->blank);
1979 fputs (" DECIMAL=", dumpfile);
1980 show_expr (dt->decimal);
1984 fputs (" DELIM=", dumpfile);
1985 show_expr (dt->delim);
1989 fputs (" PAD=", dumpfile);
1990 show_expr (dt->pad);
1994 fputs (" ROUND=", dumpfile);
1995 show_expr (dt->round);
1999 fputs (" SIGN=", dumpfile);
2000 show_expr (dt->sign);
2004 fputc ('\n', dumpfile);
2005 for (c = c->block->next; c; c = c->next)
2006 show_code_node (level + (c->next != NULL), c);
2010 fputs ("TRANSFER ", dumpfile);
2011 show_expr (c->expr1);
2015 fputs ("DT_END", dumpfile);
2018 if (dt->err != NULL)
2019 fprintf (dumpfile, " ERR=%d", dt->err->value);
2020 if (dt->end != NULL)
2021 fprintf (dumpfile, " END=%d", dt->end->value);
2022 if (dt->eor != NULL)
2023 fprintf (dumpfile, " EOR=%d", dt->eor->value);
2026 case EXEC_OMP_ATOMIC:
2027 case EXEC_OMP_BARRIER:
2028 case EXEC_OMP_CRITICAL:
2029 case EXEC_OMP_FLUSH:
2031 case EXEC_OMP_MASTER:
2032 case EXEC_OMP_ORDERED:
2033 case EXEC_OMP_PARALLEL:
2034 case EXEC_OMP_PARALLEL_DO:
2035 case EXEC_OMP_PARALLEL_SECTIONS:
2036 case EXEC_OMP_PARALLEL_WORKSHARE:
2037 case EXEC_OMP_SECTIONS:
2038 case EXEC_OMP_SINGLE:
2040 case EXEC_OMP_TASKWAIT:
2041 case EXEC_OMP_WORKSHARE:
2042 show_omp_node (level, c);
2046 gfc_internal_error ("show_code_node(): Bad statement code");
2049 fputc ('\n', dumpfile);
2053 /* Show an equivalence chain. */
2056 show_equiv (gfc_equiv *eq)
2059 fputs ("Equivalence: ", dumpfile);
2062 show_expr (eq->expr);
2065 fputs (", ", dumpfile);
2070 /* Show a freakin' whole namespace. */
2073 show_namespace (gfc_namespace *ns)
2075 gfc_interface *intr;
2076 gfc_namespace *save;
2081 save = gfc_current_ns;
2085 fputs ("Namespace:", dumpfile);
2093 while (i < GFC_LETTERS - 1
2094 && gfc_compare_types(&ns->default_type[i+1],
2095 &ns->default_type[l]))
2099 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2101 fprintf (dumpfile, " %c: ", l+'A');
2103 show_typespec(&ns->default_type[l]);
2105 } while (i < GFC_LETTERS);
2107 if (ns->proc_name != NULL)
2110 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2113 gfc_current_ns = ns;
2114 gfc_traverse_symtree (ns->common_root, show_common);
2116 gfc_traverse_symtree (ns->sym_root, show_symtree);
2118 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2120 /* User operator interfaces */
2126 fprintf (dumpfile, "Operator interfaces for %s:",
2127 gfc_op2string ((gfc_intrinsic_op) op));
2129 for (; intr; intr = intr->next)
2130 fprintf (dumpfile, " %s", intr->sym->name);
2133 if (ns->uop_root != NULL)
2136 fputs ("User operators:\n", dumpfile);
2137 gfc_traverse_user_op (ns, show_uop);
2141 for (eq = ns->equiv; eq; eq = eq->next)
2144 fputc ('\n', dumpfile);
2145 fputc ('\n', dumpfile);
2147 show_code (0, ns->code);
2149 for (ns = ns->contained; ns; ns = ns->sibling)
2152 fputs ("CONTAINS\n", dumpfile);
2153 show_namespace (ns);
2157 fputc ('\n', dumpfile);
2158 gfc_current_ns = save;
2162 /* Main function for dumping a parse tree. */
2165 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2168 show_namespace (ns);