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 /* 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 [%d]", as->rank, as->corank);
146 if (as->rank + as->corank > 0)
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 + as->corank; 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);
594 if (attr->codimension)
595 fputs (" CODIMENSION", dumpfile);
597 fputs (" DIMENSION", dumpfile);
599 fputs (" EXTERNAL", dumpfile);
601 fputs (" INTRINSIC", dumpfile);
603 fputs (" OPTIONAL", dumpfile);
605 fputs (" POINTER", dumpfile);
606 if (attr->is_protected)
607 fputs (" PROTECTED", dumpfile);
609 fputs (" VALUE", dumpfile);
611 fputs (" VOLATILE", dumpfile);
612 if (attr->threadprivate)
613 fputs (" THREADPRIVATE", dumpfile);
615 fputs (" TARGET", dumpfile);
617 fputs (" DUMMY", dumpfile);
619 fputs (" RESULT", dumpfile);
621 fputs (" ENTRY", dumpfile);
623 fputs (" BIND(C)", dumpfile);
626 fputs (" DATA", dumpfile);
628 fputs (" USE-ASSOC", dumpfile);
629 if (attr->in_namelist)
630 fputs (" IN-NAMELIST", dumpfile);
632 fputs (" IN-COMMON", dumpfile);
635 fputs (" ABSTRACT", dumpfile);
637 fputs (" FUNCTION", dumpfile);
638 if (attr->subroutine)
639 fputs (" SUBROUTINE", dumpfile);
640 if (attr->implicit_type)
641 fputs (" IMPLICIT-TYPE", dumpfile);
644 fputs (" SEQUENCE", dumpfile);
646 fputs (" ELEMENTAL", dumpfile);
648 fputs (" PURE", dumpfile);
650 fputs (" RECURSIVE", dumpfile);
652 fputc (')', dumpfile);
656 /* Show components of a derived type. */
659 show_components (gfc_symbol *sym)
663 for (c = sym->components; c; c = c->next)
665 fprintf (dumpfile, "(%s ", c->name);
666 show_typespec (&c->ts);
668 fputs (" POINTER", dumpfile);
669 if (c->attr.proc_pointer)
670 fputs (" PPC", dumpfile);
671 if (c->attr.dimension)
672 fputs (" DIMENSION", dumpfile);
673 fputc (' ', dumpfile);
674 show_array_spec (c->as);
676 fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
677 fputc (')', dumpfile);
679 fputc (' ', dumpfile);
684 /* Show the f2k_derived namespace with procedure bindings. */
687 show_typebound_proc (gfc_typebound_proc* tb, const char* name)
692 fputs ("GENERIC", dumpfile);
695 fputs ("PROCEDURE, ", dumpfile);
697 fputs ("NOPASS", dumpfile);
701 fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
703 fputs ("PASS", dumpfile);
705 if (tb->non_overridable)
706 fputs (", NON_OVERRIDABLE", dumpfile);
709 if (tb->access == ACCESS_PUBLIC)
710 fputs (", PUBLIC", dumpfile);
712 fputs (", PRIVATE", dumpfile);
714 fprintf (dumpfile, " :: %s => ", name);
719 for (g = tb->u.generic; g; g = g->next)
721 fputs (g->specific_st->name, dumpfile);
723 fputs (", ", dumpfile);
727 fputs (tb->u.specific->n.sym->name, dumpfile);
731 show_typebound_symtree (gfc_symtree* st)
733 gcc_assert (st->n.tb);
734 show_typebound_proc (st->n.tb, st->name);
738 show_f2k_derived (gfc_namespace* f2k)
744 fputs ("Procedure bindings:", dumpfile);
747 /* Finalizer bindings. */
748 for (f = f2k->finalizers; f; f = f->next)
751 fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
754 /* Type-bound procedures. */
755 gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
760 fputs ("Operator bindings:", dumpfile);
763 /* User-defined operators. */
764 gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
766 /* Intrinsic operators. */
767 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
769 show_typebound_proc (f2k->tb_op[op],
770 gfc_op2string ((gfc_intrinsic_op) op));
776 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
777 show the interface. Information needed to reconstruct the list of
778 specific interfaces associated with a generic symbol is done within
782 show_symbol (gfc_symbol *sym)
784 gfc_formal_arglist *formal;
792 fprintf (dumpfile, "symbol %s ", sym->name);
793 show_typespec (&sym->ts);
794 show_attr (&sym->attr);
799 fputs ("value: ", dumpfile);
800 show_expr (sym->value);
806 fputs ("Array spec:", dumpfile);
807 show_array_spec (sym->as);
813 fputs ("Generic interfaces:", dumpfile);
814 for (intr = sym->generic; intr; intr = intr->next)
815 fprintf (dumpfile, " %s", intr->sym->name);
821 fprintf (dumpfile, "result: %s", sym->result->name);
827 fputs ("components: ", dumpfile);
828 show_components (sym);
831 if (sym->f2k_derived)
835 fprintf (dumpfile, "hash: %d", sym->hash_value);
836 show_f2k_derived (sym->f2k_derived);
842 fputs ("Formal arglist:", dumpfile);
844 for (formal = sym->formal; formal; formal = formal->next)
846 if (formal->sym != NULL)
847 fprintf (dumpfile, " %s", formal->sym->name);
849 fputs (" [Alt Return]", dumpfile);
856 fputs ("Formal namespace", dumpfile);
857 show_namespace (sym->formal_ns);
860 fputc ('\n', dumpfile);
864 /* Show a user-defined operator. Just prints an operator
865 and the name of the associated subroutine, really. */
868 show_uop (gfc_user_op *uop)
873 fprintf (dumpfile, "%s:", uop->name);
875 for (intr = uop->op; intr; intr = intr->next)
876 fprintf (dumpfile, " %s", intr->sym->name);
880 /* Workhorse function for traversing the user operator symtree. */
883 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
890 traverse_uop (st->left, func);
891 traverse_uop (st->right, func);
895 /* Traverse the tree of user operator nodes. */
898 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
900 traverse_uop (ns->uop_root, func);
904 /* Function to display a common block. */
907 show_common (gfc_symtree *st)
912 fprintf (dumpfile, "common: /%s/ ", st->name);
914 s = st->n.common->head;
917 fprintf (dumpfile, "%s", s->name);
920 fputs (", ", dumpfile);
922 fputc ('\n', dumpfile);
926 /* Worker function to display the symbol tree. */
929 show_symtree (gfc_symtree *st)
932 fprintf (dumpfile, "symtree: %s Ambig %d", st->name, st->ambiguous);
934 if (st->n.sym->ns != gfc_current_ns)
935 fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
937 show_symbol (st->n.sym);
941 /******************* Show gfc_code structures **************/
944 /* Show a list of code structures. Mutually recursive with
948 show_code (int level, gfc_code *c)
950 for (; c; c = c->next)
951 show_code_node (level, c);
955 show_namelist (gfc_namelist *n)
957 for (; n->next; n = n->next)
958 fprintf (dumpfile, "%s,", n->sym->name);
959 fprintf (dumpfile, "%s", n->sym->name);
962 /* Show a single OpenMP directive node and everything underneath it
966 show_omp_node (int level, gfc_code *c)
968 gfc_omp_clauses *omp_clauses = NULL;
969 const char *name = NULL;
973 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
974 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
975 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
976 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
977 case EXEC_OMP_DO: name = "DO"; break;
978 case EXEC_OMP_MASTER: name = "MASTER"; break;
979 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
980 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
981 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
982 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
983 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
984 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
985 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
986 case EXEC_OMP_TASK: name = "TASK"; break;
987 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
988 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
992 fprintf (dumpfile, "!$OMP %s", name);
996 case EXEC_OMP_PARALLEL:
997 case EXEC_OMP_PARALLEL_DO:
998 case EXEC_OMP_PARALLEL_SECTIONS:
999 case EXEC_OMP_SECTIONS:
1000 case EXEC_OMP_SINGLE:
1001 case EXEC_OMP_WORKSHARE:
1002 case EXEC_OMP_PARALLEL_WORKSHARE:
1004 omp_clauses = c->ext.omp_clauses;
1006 case EXEC_OMP_CRITICAL:
1007 if (c->ext.omp_name)
1008 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1010 case EXEC_OMP_FLUSH:
1011 if (c->ext.omp_namelist)
1013 fputs (" (", dumpfile);
1014 show_namelist (c->ext.omp_namelist);
1015 fputc (')', dumpfile);
1018 case EXEC_OMP_BARRIER:
1019 case EXEC_OMP_TASKWAIT:
1028 if (omp_clauses->if_expr)
1030 fputs (" IF(", dumpfile);
1031 show_expr (omp_clauses->if_expr);
1032 fputc (')', dumpfile);
1034 if (omp_clauses->num_threads)
1036 fputs (" NUM_THREADS(", dumpfile);
1037 show_expr (omp_clauses->num_threads);
1038 fputc (')', dumpfile);
1040 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1043 switch (omp_clauses->sched_kind)
1045 case OMP_SCHED_STATIC: type = "STATIC"; break;
1046 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1047 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1048 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1049 case OMP_SCHED_AUTO: type = "AUTO"; break;
1053 fprintf (dumpfile, " SCHEDULE (%s", type);
1054 if (omp_clauses->chunk_size)
1056 fputc (',', dumpfile);
1057 show_expr (omp_clauses->chunk_size);
1059 fputc (')', dumpfile);
1061 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1064 switch (omp_clauses->default_sharing)
1066 case OMP_DEFAULT_NONE: type = "NONE"; break;
1067 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1068 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1069 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1073 fprintf (dumpfile, " DEFAULT(%s)", type);
1075 if (omp_clauses->ordered)
1076 fputs (" ORDERED", dumpfile);
1077 if (omp_clauses->untied)
1078 fputs (" UNTIED", dumpfile);
1079 if (omp_clauses->collapse)
1080 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1081 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1082 if (omp_clauses->lists[list_type] != NULL
1083 && list_type != OMP_LIST_COPYPRIVATE)
1086 if (list_type >= OMP_LIST_REDUCTION_FIRST)
1090 case OMP_LIST_PLUS: type = "+"; break;
1091 case OMP_LIST_MULT: type = "*"; break;
1092 case OMP_LIST_SUB: type = "-"; break;
1093 case OMP_LIST_AND: type = ".AND."; break;
1094 case OMP_LIST_OR: type = ".OR."; break;
1095 case OMP_LIST_EQV: type = ".EQV."; break;
1096 case OMP_LIST_NEQV: type = ".NEQV."; break;
1097 case OMP_LIST_MAX: type = "MAX"; break;
1098 case OMP_LIST_MIN: type = "MIN"; break;
1099 case OMP_LIST_IAND: type = "IAND"; break;
1100 case OMP_LIST_IOR: type = "IOR"; break;
1101 case OMP_LIST_IEOR: type = "IEOR"; break;
1105 fprintf (dumpfile, " REDUCTION(%s:", type);
1111 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1112 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1113 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1114 case OMP_LIST_SHARED: type = "SHARED"; break;
1115 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1119 fprintf (dumpfile, " %s(", type);
1121 show_namelist (omp_clauses->lists[list_type]);
1122 fputc (')', dumpfile);
1125 fputc ('\n', dumpfile);
1126 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1128 gfc_code *d = c->block;
1131 show_code (level + 1, d->next);
1132 if (d->block == NULL)
1134 code_indent (level, 0);
1135 fputs ("!$OMP SECTION\n", dumpfile);
1140 show_code (level + 1, c->block->next);
1141 if (c->op == EXEC_OMP_ATOMIC)
1143 code_indent (level, 0);
1144 fprintf (dumpfile, "!$OMP END %s", name);
1145 if (omp_clauses != NULL)
1147 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1149 fputs (" COPYPRIVATE(", dumpfile);
1150 show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1151 fputc (')', dumpfile);
1153 else if (omp_clauses->nowait)
1154 fputs (" NOWAIT", dumpfile);
1156 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1157 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1161 /* Show a single code node and everything underneath it if necessary. */
1164 show_code_node (int level, gfc_code *c)
1166 gfc_forall_iterator *fa;
1176 code_indent (level, c->here);
1180 case EXEC_END_PROCEDURE:
1184 fputs ("NOP", dumpfile);
1188 fputs ("CONTINUE", dumpfile);
1192 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1195 case EXEC_INIT_ASSIGN:
1197 fputs ("ASSIGN ", dumpfile);
1198 show_expr (c->expr1);
1199 fputc (' ', dumpfile);
1200 show_expr (c->expr2);
1203 case EXEC_LABEL_ASSIGN:
1204 fputs ("LABEL ASSIGN ", dumpfile);
1205 show_expr (c->expr1);
1206 fprintf (dumpfile, " %d", c->label1->value);
1209 case EXEC_POINTER_ASSIGN:
1210 fputs ("POINTER ASSIGN ", dumpfile);
1211 show_expr (c->expr1);
1212 fputc (' ', dumpfile);
1213 show_expr (c->expr2);
1217 fputs ("GOTO ", dumpfile);
1219 fprintf (dumpfile, "%d", c->label1->value);
1222 show_expr (c->expr1);
1226 fputs (", (", dumpfile);
1227 for (; d; d = d ->block)
1229 code_indent (level, d->label1);
1230 if (d->block != NULL)
1231 fputc (',', dumpfile);
1233 fputc (')', dumpfile);
1240 case EXEC_ASSIGN_CALL:
1241 if (c->resolved_sym)
1242 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1243 else if (c->symtree)
1244 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1246 fputs ("CALL ?? ", dumpfile);
1248 show_actual_arglist (c->ext.actual);
1252 fputs ("CALL ", dumpfile);
1253 show_compcall (c->expr1);
1257 fputs ("CALL ", dumpfile);
1258 show_expr (c->expr1);
1259 show_actual_arglist (c->ext.actual);
1263 fputs ("RETURN ", dumpfile);
1265 show_expr (c->expr1);
1269 fputs ("PAUSE ", dumpfile);
1271 if (c->expr1 != NULL)
1272 show_expr (c->expr1);
1274 fprintf (dumpfile, "%d", c->ext.stop_code);
1278 case EXEC_ERROR_STOP:
1279 fputs ("ERROR ", dumpfile);
1283 fputs ("STOP ", dumpfile);
1285 if (c->expr1 != NULL)
1286 show_expr (c->expr1);
1288 fprintf (dumpfile, "%d", c->ext.stop_code);
1293 fputs ("SYNC ALL ", dumpfile);
1294 if (c->expr2 != NULL)
1296 fputs (" stat=", dumpfile);
1297 show_expr (c->expr2);
1299 if (c->expr3 != NULL)
1301 fputs (" errmsg=", dumpfile);
1302 show_expr (c->expr3);
1306 case EXEC_SYNC_MEMORY:
1307 fputs ("SYNC MEMORY ", dumpfile);
1308 if (c->expr2 != NULL)
1310 fputs (" stat=", dumpfile);
1311 show_expr (c->expr2);
1313 if (c->expr3 != NULL)
1315 fputs (" errmsg=", dumpfile);
1316 show_expr (c->expr3);
1320 case EXEC_SYNC_IMAGES:
1321 fputs ("SYNC IMAGES image-set=", dumpfile);
1322 if (c->expr1 != NULL)
1323 show_expr (c->expr1);
1325 fputs ("* ", dumpfile);
1326 if (c->expr2 != NULL)
1328 fputs (" stat=", dumpfile);
1329 show_expr (c->expr2);
1331 if (c->expr3 != NULL)
1333 fputs (" errmsg=", dumpfile);
1334 show_expr (c->expr3);
1338 case EXEC_ARITHMETIC_IF:
1339 fputs ("IF ", dumpfile);
1340 show_expr (c->expr1);
1341 fprintf (dumpfile, " %d, %d, %d",
1342 c->label1->value, c->label2->value, c->label3->value);
1347 fputs ("IF ", dumpfile);
1348 show_expr (d->expr1);
1349 fputc ('\n', dumpfile);
1350 show_code (level + 1, d->next);
1353 for (; d; d = d->block)
1355 code_indent (level, 0);
1357 if (d->expr1 == NULL)
1358 fputs ("ELSE\n", dumpfile);
1361 fputs ("ELSE IF ", dumpfile);
1362 show_expr (d->expr1);
1363 fputc ('\n', dumpfile);
1366 show_code (level + 1, d->next);
1369 code_indent (level, c->label1);
1371 fputs ("ENDIF", dumpfile);
1376 fputs ("SELECT CASE ", dumpfile);
1377 show_expr (c->expr1);
1378 fputc ('\n', dumpfile);
1380 for (; d; d = d->block)
1382 code_indent (level, 0);
1384 fputs ("CASE ", dumpfile);
1385 for (cp = d->ext.case_list; cp; cp = cp->next)
1387 fputc ('(', dumpfile);
1388 show_expr (cp->low);
1389 fputc (' ', dumpfile);
1390 show_expr (cp->high);
1391 fputc (')', dumpfile);
1392 fputc (' ', dumpfile);
1394 fputc ('\n', dumpfile);
1396 show_code (level + 1, d->next);
1399 code_indent (level, c->label1);
1400 fputs ("END SELECT", dumpfile);
1404 fputs ("WHERE ", dumpfile);
1407 show_expr (d->expr1);
1408 fputc ('\n', dumpfile);
1410 show_code (level + 1, d->next);
1412 for (d = d->block; d; d = d->block)
1414 code_indent (level, 0);
1415 fputs ("ELSE WHERE ", dumpfile);
1416 show_expr (d->expr1);
1417 fputc ('\n', dumpfile);
1418 show_code (level + 1, d->next);
1421 code_indent (level, 0);
1422 fputs ("END WHERE", dumpfile);
1427 fputs ("FORALL ", dumpfile);
1428 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1430 show_expr (fa->var);
1431 fputc (' ', dumpfile);
1432 show_expr (fa->start);
1433 fputc (':', dumpfile);
1434 show_expr (fa->end);
1435 fputc (':', dumpfile);
1436 show_expr (fa->stride);
1438 if (fa->next != NULL)
1439 fputc (',', dumpfile);
1442 if (c->expr1 != NULL)
1444 fputc (',', dumpfile);
1445 show_expr (c->expr1);
1447 fputc ('\n', dumpfile);
1449 show_code (level + 1, c->block->next);
1451 code_indent (level, 0);
1452 fputs ("END FORALL", dumpfile);
1456 fputs ("CRITICAL\n", dumpfile);
1457 show_code (level + 1, c->block->next);
1458 code_indent (level, 0);
1459 fputs ("END CRITICAL", dumpfile);
1463 fputs ("DO ", dumpfile);
1465 show_expr (c->ext.iterator->var);
1466 fputc ('=', dumpfile);
1467 show_expr (c->ext.iterator->start);
1468 fputc (' ', dumpfile);
1469 show_expr (c->ext.iterator->end);
1470 fputc (' ', dumpfile);
1471 show_expr (c->ext.iterator->step);
1472 fputc ('\n', dumpfile);
1474 show_code (level + 1, c->block->next);
1476 code_indent (level, 0);
1477 fputs ("END DO", dumpfile);
1481 fputs ("DO WHILE ", dumpfile);
1482 show_expr (c->expr1);
1483 fputc ('\n', dumpfile);
1485 show_code (level + 1, c->block->next);
1487 code_indent (level, c->label1);
1488 fputs ("END DO", dumpfile);
1492 fputs ("CYCLE", dumpfile);
1494 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1498 fputs ("EXIT", dumpfile);
1500 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1504 fputs ("ALLOCATE ", dumpfile);
1507 fputs (" STAT=", dumpfile);
1508 show_expr (c->expr1);
1513 fputs (" ERRMSG=", dumpfile);
1514 show_expr (c->expr2);
1517 for (a = c->ext.alloc.list; a; a = a->next)
1519 fputc (' ', dumpfile);
1520 show_expr (a->expr);
1525 case EXEC_DEALLOCATE:
1526 fputs ("DEALLOCATE ", dumpfile);
1529 fputs (" STAT=", dumpfile);
1530 show_expr (c->expr1);
1535 fputs (" ERRMSG=", dumpfile);
1536 show_expr (c->expr2);
1539 for (a = c->ext.alloc.list; a; a = a->next)
1541 fputc (' ', dumpfile);
1542 show_expr (a->expr);
1548 fputs ("OPEN", dumpfile);
1553 fputs (" UNIT=", dumpfile);
1554 show_expr (open->unit);
1558 fputs (" IOMSG=", dumpfile);
1559 show_expr (open->iomsg);
1563 fputs (" IOSTAT=", dumpfile);
1564 show_expr (open->iostat);
1568 fputs (" FILE=", dumpfile);
1569 show_expr (open->file);
1573 fputs (" STATUS=", dumpfile);
1574 show_expr (open->status);
1578 fputs (" ACCESS=", dumpfile);
1579 show_expr (open->access);
1583 fputs (" FORM=", dumpfile);
1584 show_expr (open->form);
1588 fputs (" RECL=", dumpfile);
1589 show_expr (open->recl);
1593 fputs (" BLANK=", dumpfile);
1594 show_expr (open->blank);
1598 fputs (" POSITION=", dumpfile);
1599 show_expr (open->position);
1603 fputs (" ACTION=", dumpfile);
1604 show_expr (open->action);
1608 fputs (" DELIM=", dumpfile);
1609 show_expr (open->delim);
1613 fputs (" PAD=", dumpfile);
1614 show_expr (open->pad);
1618 fputs (" DECIMAL=", dumpfile);
1619 show_expr (open->decimal);
1623 fputs (" ENCODING=", dumpfile);
1624 show_expr (open->encoding);
1628 fputs (" ROUND=", dumpfile);
1629 show_expr (open->round);
1633 fputs (" SIGN=", dumpfile);
1634 show_expr (open->sign);
1638 fputs (" CONVERT=", dumpfile);
1639 show_expr (open->convert);
1641 if (open->asynchronous)
1643 fputs (" ASYNCHRONOUS=", dumpfile);
1644 show_expr (open->asynchronous);
1646 if (open->err != NULL)
1647 fprintf (dumpfile, " ERR=%d", open->err->value);
1652 fputs ("CLOSE", dumpfile);
1653 close = c->ext.close;
1657 fputs (" UNIT=", dumpfile);
1658 show_expr (close->unit);
1662 fputs (" IOMSG=", dumpfile);
1663 show_expr (close->iomsg);
1667 fputs (" IOSTAT=", dumpfile);
1668 show_expr (close->iostat);
1672 fputs (" STATUS=", dumpfile);
1673 show_expr (close->status);
1675 if (close->err != NULL)
1676 fprintf (dumpfile, " ERR=%d", close->err->value);
1679 case EXEC_BACKSPACE:
1680 fputs ("BACKSPACE", dumpfile);
1684 fputs ("ENDFILE", dumpfile);
1688 fputs ("REWIND", dumpfile);
1692 fputs ("FLUSH", dumpfile);
1695 fp = c->ext.filepos;
1699 fputs (" UNIT=", dumpfile);
1700 show_expr (fp->unit);
1704 fputs (" IOMSG=", dumpfile);
1705 show_expr (fp->iomsg);
1709 fputs (" IOSTAT=", dumpfile);
1710 show_expr (fp->iostat);
1712 if (fp->err != NULL)
1713 fprintf (dumpfile, " ERR=%d", fp->err->value);
1717 fputs ("INQUIRE", dumpfile);
1722 fputs (" UNIT=", dumpfile);
1723 show_expr (i->unit);
1727 fputs (" FILE=", dumpfile);
1728 show_expr (i->file);
1733 fputs (" IOMSG=", dumpfile);
1734 show_expr (i->iomsg);
1738 fputs (" IOSTAT=", dumpfile);
1739 show_expr (i->iostat);
1743 fputs (" EXIST=", dumpfile);
1744 show_expr (i->exist);
1748 fputs (" OPENED=", dumpfile);
1749 show_expr (i->opened);
1753 fputs (" NUMBER=", dumpfile);
1754 show_expr (i->number);
1758 fputs (" NAMED=", dumpfile);
1759 show_expr (i->named);
1763 fputs (" NAME=", dumpfile);
1764 show_expr (i->name);
1768 fputs (" ACCESS=", dumpfile);
1769 show_expr (i->access);
1773 fputs (" SEQUENTIAL=", dumpfile);
1774 show_expr (i->sequential);
1779 fputs (" DIRECT=", dumpfile);
1780 show_expr (i->direct);
1784 fputs (" FORM=", dumpfile);
1785 show_expr (i->form);
1789 fputs (" FORMATTED", dumpfile);
1790 show_expr (i->formatted);
1794 fputs (" UNFORMATTED=", dumpfile);
1795 show_expr (i->unformatted);
1799 fputs (" RECL=", dumpfile);
1800 show_expr (i->recl);
1804 fputs (" NEXTREC=", dumpfile);
1805 show_expr (i->nextrec);
1809 fputs (" BLANK=", dumpfile);
1810 show_expr (i->blank);
1814 fputs (" POSITION=", dumpfile);
1815 show_expr (i->position);
1819 fputs (" ACTION=", dumpfile);
1820 show_expr (i->action);
1824 fputs (" READ=", dumpfile);
1825 show_expr (i->read);
1829 fputs (" WRITE=", dumpfile);
1830 show_expr (i->write);
1834 fputs (" READWRITE=", dumpfile);
1835 show_expr (i->readwrite);
1839 fputs (" DELIM=", dumpfile);
1840 show_expr (i->delim);
1844 fputs (" PAD=", dumpfile);
1849 fputs (" CONVERT=", dumpfile);
1850 show_expr (i->convert);
1852 if (i->asynchronous)
1854 fputs (" ASYNCHRONOUS=", dumpfile);
1855 show_expr (i->asynchronous);
1859 fputs (" DECIMAL=", dumpfile);
1860 show_expr (i->decimal);
1864 fputs (" ENCODING=", dumpfile);
1865 show_expr (i->encoding);
1869 fputs (" PENDING=", dumpfile);
1870 show_expr (i->pending);
1874 fputs (" ROUND=", dumpfile);
1875 show_expr (i->round);
1879 fputs (" SIGN=", dumpfile);
1880 show_expr (i->sign);
1884 fputs (" SIZE=", dumpfile);
1885 show_expr (i->size);
1889 fputs (" ID=", dumpfile);
1894 fprintf (dumpfile, " ERR=%d", i->err->value);
1898 fputs ("IOLENGTH ", dumpfile);
1899 show_expr (c->expr1);
1904 fputs ("READ", dumpfile);
1908 fputs ("WRITE", dumpfile);
1914 fputs (" UNIT=", dumpfile);
1915 show_expr (dt->io_unit);
1918 if (dt->format_expr)
1920 fputs (" FMT=", dumpfile);
1921 show_expr (dt->format_expr);
1924 if (dt->format_label != NULL)
1925 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1927 fprintf (dumpfile, " NML=%s", dt->namelist->name);
1931 fputs (" IOMSG=", dumpfile);
1932 show_expr (dt->iomsg);
1936 fputs (" IOSTAT=", dumpfile);
1937 show_expr (dt->iostat);
1941 fputs (" SIZE=", dumpfile);
1942 show_expr (dt->size);
1946 fputs (" REC=", dumpfile);
1947 show_expr (dt->rec);
1951 fputs (" ADVANCE=", dumpfile);
1952 show_expr (dt->advance);
1956 fputs (" ID=", dumpfile);
1961 fputs (" POS=", dumpfile);
1962 show_expr (dt->pos);
1964 if (dt->asynchronous)
1966 fputs (" ASYNCHRONOUS=", dumpfile);
1967 show_expr (dt->asynchronous);
1971 fputs (" BLANK=", dumpfile);
1972 show_expr (dt->blank);
1976 fputs (" DECIMAL=", dumpfile);
1977 show_expr (dt->decimal);
1981 fputs (" DELIM=", dumpfile);
1982 show_expr (dt->delim);
1986 fputs (" PAD=", dumpfile);
1987 show_expr (dt->pad);
1991 fputs (" ROUND=", dumpfile);
1992 show_expr (dt->round);
1996 fputs (" SIGN=", dumpfile);
1997 show_expr (dt->sign);
2001 fputc ('\n', dumpfile);
2002 for (c = c->block->next; c; c = c->next)
2003 show_code_node (level + (c->next != NULL), c);
2007 fputs ("TRANSFER ", dumpfile);
2008 show_expr (c->expr1);
2012 fputs ("DT_END", dumpfile);
2015 if (dt->err != NULL)
2016 fprintf (dumpfile, " ERR=%d", dt->err->value);
2017 if (dt->end != NULL)
2018 fprintf (dumpfile, " END=%d", dt->end->value);
2019 if (dt->eor != NULL)
2020 fprintf (dumpfile, " EOR=%d", dt->eor->value);
2023 case EXEC_OMP_ATOMIC:
2024 case EXEC_OMP_BARRIER:
2025 case EXEC_OMP_CRITICAL:
2026 case EXEC_OMP_FLUSH:
2028 case EXEC_OMP_MASTER:
2029 case EXEC_OMP_ORDERED:
2030 case EXEC_OMP_PARALLEL:
2031 case EXEC_OMP_PARALLEL_DO:
2032 case EXEC_OMP_PARALLEL_SECTIONS:
2033 case EXEC_OMP_PARALLEL_WORKSHARE:
2034 case EXEC_OMP_SECTIONS:
2035 case EXEC_OMP_SINGLE:
2037 case EXEC_OMP_TASKWAIT:
2038 case EXEC_OMP_WORKSHARE:
2039 show_omp_node (level, c);
2043 gfc_internal_error ("show_code_node(): Bad statement code");
2046 fputc ('\n', dumpfile);
2050 /* Show an equivalence chain. */
2053 show_equiv (gfc_equiv *eq)
2056 fputs ("Equivalence: ", dumpfile);
2059 show_expr (eq->expr);
2062 fputs (", ", dumpfile);
2067 /* Show a freakin' whole namespace. */
2070 show_namespace (gfc_namespace *ns)
2072 gfc_interface *intr;
2073 gfc_namespace *save;
2078 save = gfc_current_ns;
2082 fputs ("Namespace:", dumpfile);
2090 while (i < GFC_LETTERS - 1
2091 && gfc_compare_types(&ns->default_type[i+1],
2092 &ns->default_type[l]))
2096 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2098 fprintf (dumpfile, " %c: ", l+'A');
2100 show_typespec(&ns->default_type[l]);
2102 } while (i < GFC_LETTERS);
2104 if (ns->proc_name != NULL)
2107 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2110 gfc_current_ns = ns;
2111 gfc_traverse_symtree (ns->common_root, show_common);
2113 gfc_traverse_symtree (ns->sym_root, show_symtree);
2115 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2117 /* User operator interfaces */
2123 fprintf (dumpfile, "Operator interfaces for %s:",
2124 gfc_op2string ((gfc_intrinsic_op) op));
2126 for (; intr; intr = intr->next)
2127 fprintf (dumpfile, " %s", intr->sym->name);
2130 if (ns->uop_root != NULL)
2133 fputs ("User operators:\n", dumpfile);
2134 gfc_traverse_user_op (ns, show_uop);
2138 for (eq = ns->equiv; eq; eq = eq->next)
2141 fputc ('\n', dumpfile);
2142 fputc ('\n', dumpfile);
2144 show_code (0, ns->code);
2146 for (ns = ns->contained; ns; ns = ns->sibling)
2149 fputs ("CONTAINS\n", dumpfile);
2150 show_namespace (ns);
2154 fputc ('\n', dumpfile);
2155 gfc_current_ns = save;
2159 /* Main function for dumping a parse tree. */
2162 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2165 show_namespace (ns);