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
);
601 if (attr
->contiguous
)
602 fputs (" CONTIGUOUS", dumpfile
);
604 fputs (" EXTERNAL", dumpfile
);
606 fputs (" INTRINSIC", dumpfile
);
608 fputs (" OPTIONAL", dumpfile
);
610 fputs (" POINTER", dumpfile
);
611 if (attr
->is_protected
)
612 fputs (" PROTECTED", dumpfile
);
614 fputs (" VALUE", dumpfile
);
616 fputs (" VOLATILE", dumpfile
);
617 if (attr
->threadprivate
)
618 fputs (" THREADPRIVATE", dumpfile
);
620 fputs (" TARGET", dumpfile
);
622 fputs (" DUMMY", dumpfile
);
624 fputs (" RESULT", dumpfile
);
626 fputs (" ENTRY", dumpfile
);
628 fputs (" BIND(C)", dumpfile
);
631 fputs (" DATA", dumpfile
);
633 fputs (" USE-ASSOC", dumpfile
);
634 if (attr
->in_namelist
)
635 fputs (" IN-NAMELIST", dumpfile
);
637 fputs (" IN-COMMON", dumpfile
);
640 fputs (" ABSTRACT", dumpfile
);
642 fputs (" FUNCTION", dumpfile
);
643 if (attr
->subroutine
)
644 fputs (" SUBROUTINE", dumpfile
);
645 if (attr
->implicit_type
)
646 fputs (" IMPLICIT-TYPE", dumpfile
);
649 fputs (" SEQUENCE", dumpfile
);
651 fputs (" ELEMENTAL", dumpfile
);
653 fputs (" PURE", dumpfile
);
655 fputs (" RECURSIVE", dumpfile
);
657 fputc (')', dumpfile
);
661 /* Show components of a derived type. */
664 show_components (gfc_symbol
*sym
)
668 for (c
= sym
->components
; c
; c
= c
->next
)
670 fprintf (dumpfile
, "(%s ", c
->name
);
671 show_typespec (&c
->ts
);
673 fputs (" POINTER", dumpfile
);
674 if (c
->attr
.proc_pointer
)
675 fputs (" PPC", dumpfile
);
676 if (c
->attr
.dimension
)
677 fputs (" DIMENSION", dumpfile
);
678 fputc (' ', dumpfile
);
679 show_array_spec (c
->as
);
681 fprintf (dumpfile
, " %s", gfc_code2string (access_types
, c
->attr
.access
));
682 fputc (')', dumpfile
);
684 fputc (' ', dumpfile
);
689 /* Show the f2k_derived namespace with procedure bindings. */
692 show_typebound_proc (gfc_typebound_proc
* tb
, const char* name
)
697 fputs ("GENERIC", dumpfile
);
700 fputs ("PROCEDURE, ", dumpfile
);
702 fputs ("NOPASS", dumpfile
);
706 fprintf (dumpfile
, "PASS(%s)", tb
->pass_arg
);
708 fputs ("PASS", dumpfile
);
710 if (tb
->non_overridable
)
711 fputs (", NON_OVERRIDABLE", dumpfile
);
714 if (tb
->access
== ACCESS_PUBLIC
)
715 fputs (", PUBLIC", dumpfile
);
717 fputs (", PRIVATE", dumpfile
);
719 fprintf (dumpfile
, " :: %s => ", name
);
724 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
726 fputs (g
->specific_st
->name
, dumpfile
);
728 fputs (", ", dumpfile
);
732 fputs (tb
->u
.specific
->n
.sym
->name
, dumpfile
);
736 show_typebound_symtree (gfc_symtree
* st
)
738 gcc_assert (st
->n
.tb
);
739 show_typebound_proc (st
->n
.tb
, st
->name
);
743 show_f2k_derived (gfc_namespace
* f2k
)
749 fputs ("Procedure bindings:", dumpfile
);
752 /* Finalizer bindings. */
753 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
756 fprintf (dumpfile
, "FINAL %s", f
->proc_sym
->name
);
759 /* Type-bound procedures. */
760 gfc_traverse_symtree (f2k
->tb_sym_root
, &show_typebound_symtree
);
765 fputs ("Operator bindings:", dumpfile
);
768 /* User-defined operators. */
769 gfc_traverse_symtree (f2k
->tb_uop_root
, &show_typebound_symtree
);
771 /* Intrinsic operators. */
772 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
774 show_typebound_proc (f2k
->tb_op
[op
],
775 gfc_op2string ((gfc_intrinsic_op
) op
));
781 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
782 show the interface. Information needed to reconstruct the list of
783 specific interfaces associated with a generic symbol is done within
787 show_symbol (gfc_symbol
*sym
)
789 gfc_formal_arglist
*formal
;
797 fprintf (dumpfile
, "symbol %s ", sym
->name
);
798 show_typespec (&sym
->ts
);
799 show_attr (&sym
->attr
);
804 fputs ("value: ", dumpfile
);
805 show_expr (sym
->value
);
811 fputs ("Array spec:", dumpfile
);
812 show_array_spec (sym
->as
);
818 fputs ("Generic interfaces:", dumpfile
);
819 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
820 fprintf (dumpfile
, " %s", intr
->sym
->name
);
826 fprintf (dumpfile
, "result: %s", sym
->result
->name
);
832 fputs ("components: ", dumpfile
);
833 show_components (sym
);
836 if (sym
->f2k_derived
)
840 fprintf (dumpfile
, "hash: %d", sym
->hash_value
);
841 show_f2k_derived (sym
->f2k_derived
);
847 fputs ("Formal arglist:", dumpfile
);
849 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
851 if (formal
->sym
!= NULL
)
852 fprintf (dumpfile
, " %s", formal
->sym
->name
);
854 fputs (" [Alt Return]", dumpfile
);
858 if (sym
->formal_ns
&& (sym
->formal_ns
->proc_name
!= sym
))
861 fputs ("Formal namespace", dumpfile
);
862 show_namespace (sym
->formal_ns
);
865 fputc ('\n', dumpfile
);
869 /* Show a user-defined operator. Just prints an operator
870 and the name of the associated subroutine, really. */
873 show_uop (gfc_user_op
*uop
)
878 fprintf (dumpfile
, "%s:", uop
->name
);
880 for (intr
= uop
->op
; intr
; intr
= intr
->next
)
881 fprintf (dumpfile
, " %s", intr
->sym
->name
);
885 /* Workhorse function for traversing the user operator symtree. */
888 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
895 traverse_uop (st
->left
, func
);
896 traverse_uop (st
->right
, func
);
900 /* Traverse the tree of user operator nodes. */
903 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
905 traverse_uop (ns
->uop_root
, func
);
909 /* Function to display a common block. */
912 show_common (gfc_symtree
*st
)
917 fprintf (dumpfile
, "common: /%s/ ", st
->name
);
919 s
= st
->n
.common
->head
;
922 fprintf (dumpfile
, "%s", s
->name
);
925 fputs (", ", dumpfile
);
927 fputc ('\n', dumpfile
);
931 /* Worker function to display the symbol tree. */
934 show_symtree (gfc_symtree
*st
)
937 fprintf (dumpfile
, "symtree: %s Ambig %d", st
->name
, st
->ambiguous
);
939 if (st
->n
.sym
->ns
!= gfc_current_ns
)
940 fprintf (dumpfile
, " from namespace %s", st
->n
.sym
->ns
->proc_name
->name
);
942 show_symbol (st
->n
.sym
);
946 /******************* Show gfc_code structures **************/
949 /* Show a list of code structures. Mutually recursive with
953 show_code (int level
, gfc_code
*c
)
955 for (; c
; c
= c
->next
)
956 show_code_node (level
, c
);
960 show_namelist (gfc_namelist
*n
)
962 for (; n
->next
; n
= n
->next
)
963 fprintf (dumpfile
, "%s,", n
->sym
->name
);
964 fprintf (dumpfile
, "%s", n
->sym
->name
);
967 /* Show a single OpenMP directive node and everything underneath it
971 show_omp_node (int level
, gfc_code
*c
)
973 gfc_omp_clauses
*omp_clauses
= NULL
;
974 const char *name
= NULL
;
978 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
979 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
980 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
981 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
982 case EXEC_OMP_DO
: name
= "DO"; break;
983 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
984 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
985 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
986 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
987 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
988 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
989 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
990 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
991 case EXEC_OMP_TASK
: name
= "TASK"; break;
992 case EXEC_OMP_TASKWAIT
: name
= "TASKWAIT"; break;
993 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
997 fprintf (dumpfile
, "!$OMP %s", name
);
1001 case EXEC_OMP_PARALLEL
:
1002 case EXEC_OMP_PARALLEL_DO
:
1003 case EXEC_OMP_PARALLEL_SECTIONS
:
1004 case EXEC_OMP_SECTIONS
:
1005 case EXEC_OMP_SINGLE
:
1006 case EXEC_OMP_WORKSHARE
:
1007 case EXEC_OMP_PARALLEL_WORKSHARE
:
1009 omp_clauses
= c
->ext
.omp_clauses
;
1011 case EXEC_OMP_CRITICAL
:
1012 if (c
->ext
.omp_name
)
1013 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1015 case EXEC_OMP_FLUSH
:
1016 if (c
->ext
.omp_namelist
)
1018 fputs (" (", dumpfile
);
1019 show_namelist (c
->ext
.omp_namelist
);
1020 fputc (')', dumpfile
);
1023 case EXEC_OMP_BARRIER
:
1024 case EXEC_OMP_TASKWAIT
:
1033 if (omp_clauses
->if_expr
)
1035 fputs (" IF(", dumpfile
);
1036 show_expr (omp_clauses
->if_expr
);
1037 fputc (')', dumpfile
);
1039 if (omp_clauses
->num_threads
)
1041 fputs (" NUM_THREADS(", dumpfile
);
1042 show_expr (omp_clauses
->num_threads
);
1043 fputc (')', dumpfile
);
1045 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
1048 switch (omp_clauses
->sched_kind
)
1050 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
1051 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
1052 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
1053 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
1054 case OMP_SCHED_AUTO
: type
= "AUTO"; break;
1058 fprintf (dumpfile
, " SCHEDULE (%s", type
);
1059 if (omp_clauses
->chunk_size
)
1061 fputc (',', dumpfile
);
1062 show_expr (omp_clauses
->chunk_size
);
1064 fputc (')', dumpfile
);
1066 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1069 switch (omp_clauses
->default_sharing
)
1071 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
1072 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
1073 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
1074 case OMP_DEFAULT_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1078 fprintf (dumpfile
, " DEFAULT(%s)", type
);
1080 if (omp_clauses
->ordered
)
1081 fputs (" ORDERED", dumpfile
);
1082 if (omp_clauses
->untied
)
1083 fputs (" UNTIED", dumpfile
);
1084 if (omp_clauses
->collapse
)
1085 fprintf (dumpfile
, " COLLAPSE(%d)", omp_clauses
->collapse
);
1086 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
1087 if (omp_clauses
->lists
[list_type
] != NULL
1088 && list_type
!= OMP_LIST_COPYPRIVATE
)
1091 if (list_type
>= OMP_LIST_REDUCTION_FIRST
)
1095 case OMP_LIST_PLUS
: type
= "+"; break;
1096 case OMP_LIST_MULT
: type
= "*"; break;
1097 case OMP_LIST_SUB
: type
= "-"; break;
1098 case OMP_LIST_AND
: type
= ".AND."; break;
1099 case OMP_LIST_OR
: type
= ".OR."; break;
1100 case OMP_LIST_EQV
: type
= ".EQV."; break;
1101 case OMP_LIST_NEQV
: type
= ".NEQV."; break;
1102 case OMP_LIST_MAX
: type
= "MAX"; break;
1103 case OMP_LIST_MIN
: type
= "MIN"; break;
1104 case OMP_LIST_IAND
: type
= "IAND"; break;
1105 case OMP_LIST_IOR
: type
= "IOR"; break;
1106 case OMP_LIST_IEOR
: type
= "IEOR"; break;
1110 fprintf (dumpfile
, " REDUCTION(%s:", type
);
1116 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
1117 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1118 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
1119 case OMP_LIST_SHARED
: type
= "SHARED"; break;
1120 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
1124 fprintf (dumpfile
, " %s(", type
);
1126 show_namelist (omp_clauses
->lists
[list_type
]);
1127 fputc (')', dumpfile
);
1130 fputc ('\n', dumpfile
);
1131 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
1133 gfc_code
*d
= c
->block
;
1136 show_code (level
+ 1, d
->next
);
1137 if (d
->block
== NULL
)
1139 code_indent (level
, 0);
1140 fputs ("!$OMP SECTION\n", dumpfile
);
1145 show_code (level
+ 1, c
->block
->next
);
1146 if (c
->op
== EXEC_OMP_ATOMIC
)
1148 code_indent (level
, 0);
1149 fprintf (dumpfile
, "!$OMP END %s", name
);
1150 if (omp_clauses
!= NULL
)
1152 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
1154 fputs (" COPYPRIVATE(", dumpfile
);
1155 show_namelist (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1156 fputc (')', dumpfile
);
1158 else if (omp_clauses
->nowait
)
1159 fputs (" NOWAIT", dumpfile
);
1161 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_name
)
1162 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1166 /* Show a single code node and everything underneath it if necessary. */
1169 show_code_node (int level
, gfc_code
*c
)
1171 gfc_forall_iterator
*fa
;
1181 code_indent (level
, c
->here
);
1185 case EXEC_END_PROCEDURE
:
1189 fputs ("NOP", dumpfile
);
1193 fputs ("CONTINUE", dumpfile
);
1197 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
1200 case EXEC_INIT_ASSIGN
:
1202 fputs ("ASSIGN ", dumpfile
);
1203 show_expr (c
->expr1
);
1204 fputc (' ', dumpfile
);
1205 show_expr (c
->expr2
);
1208 case EXEC_LABEL_ASSIGN
:
1209 fputs ("LABEL ASSIGN ", dumpfile
);
1210 show_expr (c
->expr1
);
1211 fprintf (dumpfile
, " %d", c
->label1
->value
);
1214 case EXEC_POINTER_ASSIGN
:
1215 fputs ("POINTER ASSIGN ", dumpfile
);
1216 show_expr (c
->expr1
);
1217 fputc (' ', dumpfile
);
1218 show_expr (c
->expr2
);
1222 fputs ("GOTO ", dumpfile
);
1224 fprintf (dumpfile
, "%d", c
->label1
->value
);
1227 show_expr (c
->expr1
);
1231 fputs (", (", dumpfile
);
1232 for (; d
; d
= d
->block
)
1234 code_indent (level
, d
->label1
);
1235 if (d
->block
!= NULL
)
1236 fputc (',', dumpfile
);
1238 fputc (')', dumpfile
);
1245 case EXEC_ASSIGN_CALL
:
1246 if (c
->resolved_sym
)
1247 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
1248 else if (c
->symtree
)
1249 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
1251 fputs ("CALL ?? ", dumpfile
);
1253 show_actual_arglist (c
->ext
.actual
);
1257 fputs ("CALL ", dumpfile
);
1258 show_compcall (c
->expr1
);
1262 fputs ("CALL ", dumpfile
);
1263 show_expr (c
->expr1
);
1264 show_actual_arglist (c
->ext
.actual
);
1268 fputs ("RETURN ", dumpfile
);
1270 show_expr (c
->expr1
);
1274 fputs ("PAUSE ", dumpfile
);
1276 if (c
->expr1
!= NULL
)
1277 show_expr (c
->expr1
);
1279 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1283 case EXEC_ERROR_STOP
:
1284 fputs ("ERROR ", dumpfile
);
1288 fputs ("STOP ", dumpfile
);
1290 if (c
->expr1
!= NULL
)
1291 show_expr (c
->expr1
);
1293 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1298 fputs ("SYNC ALL ", dumpfile
);
1299 if (c
->expr2
!= NULL
)
1301 fputs (" stat=", dumpfile
);
1302 show_expr (c
->expr2
);
1304 if (c
->expr3
!= NULL
)
1306 fputs (" errmsg=", dumpfile
);
1307 show_expr (c
->expr3
);
1311 case EXEC_SYNC_MEMORY
:
1312 fputs ("SYNC MEMORY ", dumpfile
);
1313 if (c
->expr2
!= NULL
)
1315 fputs (" stat=", dumpfile
);
1316 show_expr (c
->expr2
);
1318 if (c
->expr3
!= NULL
)
1320 fputs (" errmsg=", dumpfile
);
1321 show_expr (c
->expr3
);
1325 case EXEC_SYNC_IMAGES
:
1326 fputs ("SYNC IMAGES image-set=", dumpfile
);
1327 if (c
->expr1
!= NULL
)
1328 show_expr (c
->expr1
);
1330 fputs ("* ", dumpfile
);
1331 if (c
->expr2
!= NULL
)
1333 fputs (" stat=", dumpfile
);
1334 show_expr (c
->expr2
);
1336 if (c
->expr3
!= NULL
)
1338 fputs (" errmsg=", dumpfile
);
1339 show_expr (c
->expr3
);
1343 case EXEC_ARITHMETIC_IF
:
1344 fputs ("IF ", dumpfile
);
1345 show_expr (c
->expr1
);
1346 fprintf (dumpfile
, " %d, %d, %d",
1347 c
->label1
->value
, c
->label2
->value
, c
->label3
->value
);
1352 fputs ("IF ", dumpfile
);
1353 show_expr (d
->expr1
);
1354 fputc ('\n', dumpfile
);
1355 show_code (level
+ 1, d
->next
);
1358 for (; d
; d
= d
->block
)
1360 code_indent (level
, 0);
1362 if (d
->expr1
== NULL
)
1363 fputs ("ELSE\n", dumpfile
);
1366 fputs ("ELSE IF ", dumpfile
);
1367 show_expr (d
->expr1
);
1368 fputc ('\n', dumpfile
);
1371 show_code (level
+ 1, d
->next
);
1374 code_indent (level
, c
->label1
);
1376 fputs ("ENDIF", dumpfile
);
1381 fputs ("SELECT CASE ", dumpfile
);
1382 show_expr (c
->expr1
);
1383 fputc ('\n', dumpfile
);
1385 for (; d
; d
= d
->block
)
1387 code_indent (level
, 0);
1389 fputs ("CASE ", dumpfile
);
1390 for (cp
= d
->ext
.case_list
; cp
; cp
= cp
->next
)
1392 fputc ('(', dumpfile
);
1393 show_expr (cp
->low
);
1394 fputc (' ', dumpfile
);
1395 show_expr (cp
->high
);
1396 fputc (')', dumpfile
);
1397 fputc (' ', dumpfile
);
1399 fputc ('\n', dumpfile
);
1401 show_code (level
+ 1, d
->next
);
1404 code_indent (level
, c
->label1
);
1405 fputs ("END SELECT", dumpfile
);
1409 fputs ("WHERE ", dumpfile
);
1412 show_expr (d
->expr1
);
1413 fputc ('\n', dumpfile
);
1415 show_code (level
+ 1, d
->next
);
1417 for (d
= d
->block
; d
; d
= d
->block
)
1419 code_indent (level
, 0);
1420 fputs ("ELSE WHERE ", dumpfile
);
1421 show_expr (d
->expr1
);
1422 fputc ('\n', dumpfile
);
1423 show_code (level
+ 1, d
->next
);
1426 code_indent (level
, 0);
1427 fputs ("END WHERE", dumpfile
);
1432 fputs ("FORALL ", dumpfile
);
1433 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1435 show_expr (fa
->var
);
1436 fputc (' ', dumpfile
);
1437 show_expr (fa
->start
);
1438 fputc (':', dumpfile
);
1439 show_expr (fa
->end
);
1440 fputc (':', dumpfile
);
1441 show_expr (fa
->stride
);
1443 if (fa
->next
!= NULL
)
1444 fputc (',', dumpfile
);
1447 if (c
->expr1
!= NULL
)
1449 fputc (',', dumpfile
);
1450 show_expr (c
->expr1
);
1452 fputc ('\n', dumpfile
);
1454 show_code (level
+ 1, c
->block
->next
);
1456 code_indent (level
, 0);
1457 fputs ("END FORALL", dumpfile
);
1461 fputs ("CRITICAL\n", dumpfile
);
1462 show_code (level
+ 1, c
->block
->next
);
1463 code_indent (level
, 0);
1464 fputs ("END CRITICAL", dumpfile
);
1468 fputs ("DO ", dumpfile
);
1470 show_expr (c
->ext
.iterator
->var
);
1471 fputc ('=', dumpfile
);
1472 show_expr (c
->ext
.iterator
->start
);
1473 fputc (' ', dumpfile
);
1474 show_expr (c
->ext
.iterator
->end
);
1475 fputc (' ', dumpfile
);
1476 show_expr (c
->ext
.iterator
->step
);
1477 fputc ('\n', dumpfile
);
1479 show_code (level
+ 1, c
->block
->next
);
1481 code_indent (level
, 0);
1482 fputs ("END DO", dumpfile
);
1486 fputs ("DO WHILE ", dumpfile
);
1487 show_expr (c
->expr1
);
1488 fputc ('\n', dumpfile
);
1490 show_code (level
+ 1, c
->block
->next
);
1492 code_indent (level
, c
->label1
);
1493 fputs ("END DO", dumpfile
);
1497 fputs ("CYCLE", dumpfile
);
1499 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1503 fputs ("EXIT", dumpfile
);
1505 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1509 fputs ("ALLOCATE ", dumpfile
);
1512 fputs (" STAT=", dumpfile
);
1513 show_expr (c
->expr1
);
1518 fputs (" ERRMSG=", dumpfile
);
1519 show_expr (c
->expr2
);
1522 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
1524 fputc (' ', dumpfile
);
1525 show_expr (a
->expr
);
1530 case EXEC_DEALLOCATE
:
1531 fputs ("DEALLOCATE ", dumpfile
);
1534 fputs (" STAT=", dumpfile
);
1535 show_expr (c
->expr1
);
1540 fputs (" ERRMSG=", dumpfile
);
1541 show_expr (c
->expr2
);
1544 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
1546 fputc (' ', dumpfile
);
1547 show_expr (a
->expr
);
1553 fputs ("OPEN", dumpfile
);
1558 fputs (" UNIT=", dumpfile
);
1559 show_expr (open
->unit
);
1563 fputs (" IOMSG=", dumpfile
);
1564 show_expr (open
->iomsg
);
1568 fputs (" IOSTAT=", dumpfile
);
1569 show_expr (open
->iostat
);
1573 fputs (" FILE=", dumpfile
);
1574 show_expr (open
->file
);
1578 fputs (" STATUS=", dumpfile
);
1579 show_expr (open
->status
);
1583 fputs (" ACCESS=", dumpfile
);
1584 show_expr (open
->access
);
1588 fputs (" FORM=", dumpfile
);
1589 show_expr (open
->form
);
1593 fputs (" RECL=", dumpfile
);
1594 show_expr (open
->recl
);
1598 fputs (" BLANK=", dumpfile
);
1599 show_expr (open
->blank
);
1603 fputs (" POSITION=", dumpfile
);
1604 show_expr (open
->position
);
1608 fputs (" ACTION=", dumpfile
);
1609 show_expr (open
->action
);
1613 fputs (" DELIM=", dumpfile
);
1614 show_expr (open
->delim
);
1618 fputs (" PAD=", dumpfile
);
1619 show_expr (open
->pad
);
1623 fputs (" DECIMAL=", dumpfile
);
1624 show_expr (open
->decimal
);
1628 fputs (" ENCODING=", dumpfile
);
1629 show_expr (open
->encoding
);
1633 fputs (" ROUND=", dumpfile
);
1634 show_expr (open
->round
);
1638 fputs (" SIGN=", dumpfile
);
1639 show_expr (open
->sign
);
1643 fputs (" CONVERT=", dumpfile
);
1644 show_expr (open
->convert
);
1646 if (open
->asynchronous
)
1648 fputs (" ASYNCHRONOUS=", dumpfile
);
1649 show_expr (open
->asynchronous
);
1651 if (open
->err
!= NULL
)
1652 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
1657 fputs ("CLOSE", dumpfile
);
1658 close
= c
->ext
.close
;
1662 fputs (" UNIT=", dumpfile
);
1663 show_expr (close
->unit
);
1667 fputs (" IOMSG=", dumpfile
);
1668 show_expr (close
->iomsg
);
1672 fputs (" IOSTAT=", dumpfile
);
1673 show_expr (close
->iostat
);
1677 fputs (" STATUS=", dumpfile
);
1678 show_expr (close
->status
);
1680 if (close
->err
!= NULL
)
1681 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
1684 case EXEC_BACKSPACE
:
1685 fputs ("BACKSPACE", dumpfile
);
1689 fputs ("ENDFILE", dumpfile
);
1693 fputs ("REWIND", dumpfile
);
1697 fputs ("FLUSH", dumpfile
);
1700 fp
= c
->ext
.filepos
;
1704 fputs (" UNIT=", dumpfile
);
1705 show_expr (fp
->unit
);
1709 fputs (" IOMSG=", dumpfile
);
1710 show_expr (fp
->iomsg
);
1714 fputs (" IOSTAT=", dumpfile
);
1715 show_expr (fp
->iostat
);
1717 if (fp
->err
!= NULL
)
1718 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
1722 fputs ("INQUIRE", dumpfile
);
1727 fputs (" UNIT=", dumpfile
);
1728 show_expr (i
->unit
);
1732 fputs (" FILE=", dumpfile
);
1733 show_expr (i
->file
);
1738 fputs (" IOMSG=", dumpfile
);
1739 show_expr (i
->iomsg
);
1743 fputs (" IOSTAT=", dumpfile
);
1744 show_expr (i
->iostat
);
1748 fputs (" EXIST=", dumpfile
);
1749 show_expr (i
->exist
);
1753 fputs (" OPENED=", dumpfile
);
1754 show_expr (i
->opened
);
1758 fputs (" NUMBER=", dumpfile
);
1759 show_expr (i
->number
);
1763 fputs (" NAMED=", dumpfile
);
1764 show_expr (i
->named
);
1768 fputs (" NAME=", dumpfile
);
1769 show_expr (i
->name
);
1773 fputs (" ACCESS=", dumpfile
);
1774 show_expr (i
->access
);
1778 fputs (" SEQUENTIAL=", dumpfile
);
1779 show_expr (i
->sequential
);
1784 fputs (" DIRECT=", dumpfile
);
1785 show_expr (i
->direct
);
1789 fputs (" FORM=", dumpfile
);
1790 show_expr (i
->form
);
1794 fputs (" FORMATTED", dumpfile
);
1795 show_expr (i
->formatted
);
1799 fputs (" UNFORMATTED=", dumpfile
);
1800 show_expr (i
->unformatted
);
1804 fputs (" RECL=", dumpfile
);
1805 show_expr (i
->recl
);
1809 fputs (" NEXTREC=", dumpfile
);
1810 show_expr (i
->nextrec
);
1814 fputs (" BLANK=", dumpfile
);
1815 show_expr (i
->blank
);
1819 fputs (" POSITION=", dumpfile
);
1820 show_expr (i
->position
);
1824 fputs (" ACTION=", dumpfile
);
1825 show_expr (i
->action
);
1829 fputs (" READ=", dumpfile
);
1830 show_expr (i
->read
);
1834 fputs (" WRITE=", dumpfile
);
1835 show_expr (i
->write
);
1839 fputs (" READWRITE=", dumpfile
);
1840 show_expr (i
->readwrite
);
1844 fputs (" DELIM=", dumpfile
);
1845 show_expr (i
->delim
);
1849 fputs (" PAD=", dumpfile
);
1854 fputs (" CONVERT=", dumpfile
);
1855 show_expr (i
->convert
);
1857 if (i
->asynchronous
)
1859 fputs (" ASYNCHRONOUS=", dumpfile
);
1860 show_expr (i
->asynchronous
);
1864 fputs (" DECIMAL=", dumpfile
);
1865 show_expr (i
->decimal
);
1869 fputs (" ENCODING=", dumpfile
);
1870 show_expr (i
->encoding
);
1874 fputs (" PENDING=", dumpfile
);
1875 show_expr (i
->pending
);
1879 fputs (" ROUND=", dumpfile
);
1880 show_expr (i
->round
);
1884 fputs (" SIGN=", dumpfile
);
1885 show_expr (i
->sign
);
1889 fputs (" SIZE=", dumpfile
);
1890 show_expr (i
->size
);
1894 fputs (" ID=", dumpfile
);
1899 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
1903 fputs ("IOLENGTH ", dumpfile
);
1904 show_expr (c
->expr1
);
1909 fputs ("READ", dumpfile
);
1913 fputs ("WRITE", dumpfile
);
1919 fputs (" UNIT=", dumpfile
);
1920 show_expr (dt
->io_unit
);
1923 if (dt
->format_expr
)
1925 fputs (" FMT=", dumpfile
);
1926 show_expr (dt
->format_expr
);
1929 if (dt
->format_label
!= NULL
)
1930 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
1932 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
1936 fputs (" IOMSG=", dumpfile
);
1937 show_expr (dt
->iomsg
);
1941 fputs (" IOSTAT=", dumpfile
);
1942 show_expr (dt
->iostat
);
1946 fputs (" SIZE=", dumpfile
);
1947 show_expr (dt
->size
);
1951 fputs (" REC=", dumpfile
);
1952 show_expr (dt
->rec
);
1956 fputs (" ADVANCE=", dumpfile
);
1957 show_expr (dt
->advance
);
1961 fputs (" ID=", dumpfile
);
1966 fputs (" POS=", dumpfile
);
1967 show_expr (dt
->pos
);
1969 if (dt
->asynchronous
)
1971 fputs (" ASYNCHRONOUS=", dumpfile
);
1972 show_expr (dt
->asynchronous
);
1976 fputs (" BLANK=", dumpfile
);
1977 show_expr (dt
->blank
);
1981 fputs (" DECIMAL=", dumpfile
);
1982 show_expr (dt
->decimal
);
1986 fputs (" DELIM=", dumpfile
);
1987 show_expr (dt
->delim
);
1991 fputs (" PAD=", dumpfile
);
1992 show_expr (dt
->pad
);
1996 fputs (" ROUND=", dumpfile
);
1997 show_expr (dt
->round
);
2001 fputs (" SIGN=", dumpfile
);
2002 show_expr (dt
->sign
);
2006 fputc ('\n', dumpfile
);
2007 for (c
= c
->block
->next
; c
; c
= c
->next
)
2008 show_code_node (level
+ (c
->next
!= NULL
), c
);
2012 fputs ("TRANSFER ", dumpfile
);
2013 show_expr (c
->expr1
);
2017 fputs ("DT_END", dumpfile
);
2020 if (dt
->err
!= NULL
)
2021 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
2022 if (dt
->end
!= NULL
)
2023 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
2024 if (dt
->eor
!= NULL
)
2025 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
2028 case EXEC_OMP_ATOMIC
:
2029 case EXEC_OMP_BARRIER
:
2030 case EXEC_OMP_CRITICAL
:
2031 case EXEC_OMP_FLUSH
:
2033 case EXEC_OMP_MASTER
:
2034 case EXEC_OMP_ORDERED
:
2035 case EXEC_OMP_PARALLEL
:
2036 case EXEC_OMP_PARALLEL_DO
:
2037 case EXEC_OMP_PARALLEL_SECTIONS
:
2038 case EXEC_OMP_PARALLEL_WORKSHARE
:
2039 case EXEC_OMP_SECTIONS
:
2040 case EXEC_OMP_SINGLE
:
2042 case EXEC_OMP_TASKWAIT
:
2043 case EXEC_OMP_WORKSHARE
:
2044 show_omp_node (level
, c
);
2048 gfc_internal_error ("show_code_node(): Bad statement code");
2051 fputc ('\n', dumpfile
);
2055 /* Show an equivalence chain. */
2058 show_equiv (gfc_equiv
*eq
)
2061 fputs ("Equivalence: ", dumpfile
);
2064 show_expr (eq
->expr
);
2067 fputs (", ", dumpfile
);
2072 /* Show a freakin' whole namespace. */
2075 show_namespace (gfc_namespace
*ns
)
2077 gfc_interface
*intr
;
2078 gfc_namespace
*save
;
2083 save
= gfc_current_ns
;
2087 fputs ("Namespace:", dumpfile
);
2095 while (i
< GFC_LETTERS
- 1
2096 && gfc_compare_types(&ns
->default_type
[i
+1],
2097 &ns
->default_type
[l
]))
2101 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
2103 fprintf (dumpfile
, " %c: ", l
+'A');
2105 show_typespec(&ns
->default_type
[l
]);
2107 } while (i
< GFC_LETTERS
);
2109 if (ns
->proc_name
!= NULL
)
2112 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
2115 gfc_current_ns
= ns
;
2116 gfc_traverse_symtree (ns
->common_root
, show_common
);
2118 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2120 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
2122 /* User operator interfaces */
2128 fprintf (dumpfile
, "Operator interfaces for %s:",
2129 gfc_op2string ((gfc_intrinsic_op
) op
));
2131 for (; intr
; intr
= intr
->next
)
2132 fprintf (dumpfile
, " %s", intr
->sym
->name
);
2135 if (ns
->uop_root
!= NULL
)
2138 fputs ("User operators:\n", dumpfile
);
2139 gfc_traverse_user_op (ns
, show_uop
);
2143 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
2146 fputc ('\n', dumpfile
);
2147 fputc ('\n', dumpfile
);
2149 show_code (0, ns
->code
);
2151 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
2154 fputs ("CONTAINS\n", dumpfile
);
2155 show_namespace (ns
);
2159 fputc ('\n', dumpfile
);
2160 gfc_current_ns
= save
;
2164 /* Main function for dumping a parse tree. */
2167 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
2170 show_namespace (ns
);