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
);
800 /* If this symbol is an associate-name, show its target expression. */
803 fputs (" => ", dumpfile
);
804 show_expr (sym
->assoc
->target
);
805 fputs (" ", dumpfile
);
808 show_attr (&sym
->attr
);
813 fputs ("value: ", dumpfile
);
814 show_expr (sym
->value
);
820 fputs ("Array spec:", dumpfile
);
821 show_array_spec (sym
->as
);
827 fputs ("Generic interfaces:", dumpfile
);
828 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
829 fprintf (dumpfile
, " %s", intr
->sym
->name
);
835 fprintf (dumpfile
, "result: %s", sym
->result
->name
);
841 fputs ("components: ", dumpfile
);
842 show_components (sym
);
845 if (sym
->f2k_derived
)
849 fprintf (dumpfile
, "hash: %d", sym
->hash_value
);
850 show_f2k_derived (sym
->f2k_derived
);
856 fputs ("Formal arglist:", dumpfile
);
858 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
860 if (formal
->sym
!= NULL
)
861 fprintf (dumpfile
, " %s", formal
->sym
->name
);
863 fputs (" [Alt Return]", dumpfile
);
867 if (sym
->formal_ns
&& (sym
->formal_ns
->proc_name
!= sym
))
870 fputs ("Formal namespace", dumpfile
);
871 show_namespace (sym
->formal_ns
);
874 fputc ('\n', dumpfile
);
878 /* Show a user-defined operator. Just prints an operator
879 and the name of the associated subroutine, really. */
882 show_uop (gfc_user_op
*uop
)
887 fprintf (dumpfile
, "%s:", uop
->name
);
889 for (intr
= uop
->op
; intr
; intr
= intr
->next
)
890 fprintf (dumpfile
, " %s", intr
->sym
->name
);
894 /* Workhorse function for traversing the user operator symtree. */
897 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
904 traverse_uop (st
->left
, func
);
905 traverse_uop (st
->right
, func
);
909 /* Traverse the tree of user operator nodes. */
912 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
914 traverse_uop (ns
->uop_root
, func
);
918 /* Function to display a common block. */
921 show_common (gfc_symtree
*st
)
926 fprintf (dumpfile
, "common: /%s/ ", st
->name
);
928 s
= st
->n
.common
->head
;
931 fprintf (dumpfile
, "%s", s
->name
);
934 fputs (", ", dumpfile
);
936 fputc ('\n', dumpfile
);
940 /* Worker function to display the symbol tree. */
943 show_symtree (gfc_symtree
*st
)
946 fprintf (dumpfile
, "symtree: %s Ambig %d", st
->name
, st
->ambiguous
);
948 if (st
->n
.sym
->ns
!= gfc_current_ns
)
949 fprintf (dumpfile
, " from namespace %s", st
->n
.sym
->ns
->proc_name
->name
);
951 show_symbol (st
->n
.sym
);
955 /******************* Show gfc_code structures **************/
958 /* Show a list of code structures. Mutually recursive with
962 show_code (int level
, gfc_code
*c
)
964 for (; c
; c
= c
->next
)
965 show_code_node (level
, c
);
969 show_namelist (gfc_namelist
*n
)
971 for (; n
->next
; n
= n
->next
)
972 fprintf (dumpfile
, "%s,", n
->sym
->name
);
973 fprintf (dumpfile
, "%s", n
->sym
->name
);
976 /* Show a single OpenMP directive node and everything underneath it
980 show_omp_node (int level
, gfc_code
*c
)
982 gfc_omp_clauses
*omp_clauses
= NULL
;
983 const char *name
= NULL
;
987 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
988 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
989 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
990 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
991 case EXEC_OMP_DO
: name
= "DO"; break;
992 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
993 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
994 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
995 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
996 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
997 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
998 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
999 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
1000 case EXEC_OMP_TASK
: name
= "TASK"; break;
1001 case EXEC_OMP_TASKWAIT
: name
= "TASKWAIT"; break;
1002 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
1006 fprintf (dumpfile
, "!$OMP %s", name
);
1010 case EXEC_OMP_PARALLEL
:
1011 case EXEC_OMP_PARALLEL_DO
:
1012 case EXEC_OMP_PARALLEL_SECTIONS
:
1013 case EXEC_OMP_SECTIONS
:
1014 case EXEC_OMP_SINGLE
:
1015 case EXEC_OMP_WORKSHARE
:
1016 case EXEC_OMP_PARALLEL_WORKSHARE
:
1018 omp_clauses
= c
->ext
.omp_clauses
;
1020 case EXEC_OMP_CRITICAL
:
1021 if (c
->ext
.omp_name
)
1022 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1024 case EXEC_OMP_FLUSH
:
1025 if (c
->ext
.omp_namelist
)
1027 fputs (" (", dumpfile
);
1028 show_namelist (c
->ext
.omp_namelist
);
1029 fputc (')', dumpfile
);
1032 case EXEC_OMP_BARRIER
:
1033 case EXEC_OMP_TASKWAIT
:
1042 if (omp_clauses
->if_expr
)
1044 fputs (" IF(", dumpfile
);
1045 show_expr (omp_clauses
->if_expr
);
1046 fputc (')', dumpfile
);
1048 if (omp_clauses
->num_threads
)
1050 fputs (" NUM_THREADS(", dumpfile
);
1051 show_expr (omp_clauses
->num_threads
);
1052 fputc (')', dumpfile
);
1054 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
1057 switch (omp_clauses
->sched_kind
)
1059 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
1060 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
1061 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
1062 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
1063 case OMP_SCHED_AUTO
: type
= "AUTO"; break;
1067 fprintf (dumpfile
, " SCHEDULE (%s", type
);
1068 if (omp_clauses
->chunk_size
)
1070 fputc (',', dumpfile
);
1071 show_expr (omp_clauses
->chunk_size
);
1073 fputc (')', dumpfile
);
1075 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1078 switch (omp_clauses
->default_sharing
)
1080 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
1081 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
1082 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
1083 case OMP_DEFAULT_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1087 fprintf (dumpfile
, " DEFAULT(%s)", type
);
1089 if (omp_clauses
->ordered
)
1090 fputs (" ORDERED", dumpfile
);
1091 if (omp_clauses
->untied
)
1092 fputs (" UNTIED", dumpfile
);
1093 if (omp_clauses
->collapse
)
1094 fprintf (dumpfile
, " COLLAPSE(%d)", omp_clauses
->collapse
);
1095 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
1096 if (omp_clauses
->lists
[list_type
] != NULL
1097 && list_type
!= OMP_LIST_COPYPRIVATE
)
1100 if (list_type
>= OMP_LIST_REDUCTION_FIRST
)
1104 case OMP_LIST_PLUS
: type
= "+"; break;
1105 case OMP_LIST_MULT
: type
= "*"; break;
1106 case OMP_LIST_SUB
: type
= "-"; break;
1107 case OMP_LIST_AND
: type
= ".AND."; break;
1108 case OMP_LIST_OR
: type
= ".OR."; break;
1109 case OMP_LIST_EQV
: type
= ".EQV."; break;
1110 case OMP_LIST_NEQV
: type
= ".NEQV."; break;
1111 case OMP_LIST_MAX
: type
= "MAX"; break;
1112 case OMP_LIST_MIN
: type
= "MIN"; break;
1113 case OMP_LIST_IAND
: type
= "IAND"; break;
1114 case OMP_LIST_IOR
: type
= "IOR"; break;
1115 case OMP_LIST_IEOR
: type
= "IEOR"; break;
1119 fprintf (dumpfile
, " REDUCTION(%s:", type
);
1125 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
1126 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1127 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
1128 case OMP_LIST_SHARED
: type
= "SHARED"; break;
1129 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
1133 fprintf (dumpfile
, " %s(", type
);
1135 show_namelist (omp_clauses
->lists
[list_type
]);
1136 fputc (')', dumpfile
);
1139 fputc ('\n', dumpfile
);
1140 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
1142 gfc_code
*d
= c
->block
;
1145 show_code (level
+ 1, d
->next
);
1146 if (d
->block
== NULL
)
1148 code_indent (level
, 0);
1149 fputs ("!$OMP SECTION\n", dumpfile
);
1154 show_code (level
+ 1, c
->block
->next
);
1155 if (c
->op
== EXEC_OMP_ATOMIC
)
1157 code_indent (level
, 0);
1158 fprintf (dumpfile
, "!$OMP END %s", name
);
1159 if (omp_clauses
!= NULL
)
1161 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
1163 fputs (" COPYPRIVATE(", dumpfile
);
1164 show_namelist (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1165 fputc (')', dumpfile
);
1167 else if (omp_clauses
->nowait
)
1168 fputs (" NOWAIT", dumpfile
);
1170 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_name
)
1171 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1175 /* Show a single code node and everything underneath it if necessary. */
1178 show_code_node (int level
, gfc_code
*c
)
1180 gfc_forall_iterator
*fa
;
1191 code_indent (level
, c
->here
);
1195 case EXEC_END_PROCEDURE
:
1199 fputs ("NOP", dumpfile
);
1203 fputs ("CONTINUE", dumpfile
);
1207 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
1210 case EXEC_INIT_ASSIGN
:
1212 fputs ("ASSIGN ", dumpfile
);
1213 show_expr (c
->expr1
);
1214 fputc (' ', dumpfile
);
1215 show_expr (c
->expr2
);
1218 case EXEC_LABEL_ASSIGN
:
1219 fputs ("LABEL ASSIGN ", dumpfile
);
1220 show_expr (c
->expr1
);
1221 fprintf (dumpfile
, " %d", c
->label1
->value
);
1224 case EXEC_POINTER_ASSIGN
:
1225 fputs ("POINTER ASSIGN ", dumpfile
);
1226 show_expr (c
->expr1
);
1227 fputc (' ', dumpfile
);
1228 show_expr (c
->expr2
);
1232 fputs ("GOTO ", dumpfile
);
1234 fprintf (dumpfile
, "%d", c
->label1
->value
);
1237 show_expr (c
->expr1
);
1241 fputs (", (", dumpfile
);
1242 for (; d
; d
= d
->block
)
1244 code_indent (level
, d
->label1
);
1245 if (d
->block
!= NULL
)
1246 fputc (',', dumpfile
);
1248 fputc (')', dumpfile
);
1255 case EXEC_ASSIGN_CALL
:
1256 if (c
->resolved_sym
)
1257 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
1258 else if (c
->symtree
)
1259 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
1261 fputs ("CALL ?? ", dumpfile
);
1263 show_actual_arglist (c
->ext
.actual
);
1267 fputs ("CALL ", dumpfile
);
1268 show_compcall (c
->expr1
);
1272 fputs ("CALL ", dumpfile
);
1273 show_expr (c
->expr1
);
1274 show_actual_arglist (c
->ext
.actual
);
1278 fputs ("RETURN ", dumpfile
);
1280 show_expr (c
->expr1
);
1284 fputs ("PAUSE ", dumpfile
);
1286 if (c
->expr1
!= NULL
)
1287 show_expr (c
->expr1
);
1289 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1293 case EXEC_ERROR_STOP
:
1294 fputs ("ERROR ", dumpfile
);
1298 fputs ("STOP ", dumpfile
);
1300 if (c
->expr1
!= NULL
)
1301 show_expr (c
->expr1
);
1303 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1308 fputs ("SYNC ALL ", dumpfile
);
1309 if (c
->expr2
!= NULL
)
1311 fputs (" stat=", dumpfile
);
1312 show_expr (c
->expr2
);
1314 if (c
->expr3
!= NULL
)
1316 fputs (" errmsg=", dumpfile
);
1317 show_expr (c
->expr3
);
1321 case EXEC_SYNC_MEMORY
:
1322 fputs ("SYNC MEMORY ", dumpfile
);
1323 if (c
->expr2
!= NULL
)
1325 fputs (" stat=", dumpfile
);
1326 show_expr (c
->expr2
);
1328 if (c
->expr3
!= NULL
)
1330 fputs (" errmsg=", dumpfile
);
1331 show_expr (c
->expr3
);
1335 case EXEC_SYNC_IMAGES
:
1336 fputs ("SYNC IMAGES image-set=", dumpfile
);
1337 if (c
->expr1
!= NULL
)
1338 show_expr (c
->expr1
);
1340 fputs ("* ", dumpfile
);
1341 if (c
->expr2
!= NULL
)
1343 fputs (" stat=", dumpfile
);
1344 show_expr (c
->expr2
);
1346 if (c
->expr3
!= NULL
)
1348 fputs (" errmsg=", dumpfile
);
1349 show_expr (c
->expr3
);
1353 case EXEC_ARITHMETIC_IF
:
1354 fputs ("IF ", dumpfile
);
1355 show_expr (c
->expr1
);
1356 fprintf (dumpfile
, " %d, %d, %d",
1357 c
->label1
->value
, c
->label2
->value
, c
->label3
->value
);
1362 fputs ("IF ", dumpfile
);
1363 show_expr (d
->expr1
);
1364 fputc ('\n', dumpfile
);
1365 show_code (level
+ 1, d
->next
);
1368 for (; d
; d
= d
->block
)
1370 code_indent (level
, 0);
1372 if (d
->expr1
== NULL
)
1373 fputs ("ELSE\n", dumpfile
);
1376 fputs ("ELSE IF ", dumpfile
);
1377 show_expr (d
->expr1
);
1378 fputc ('\n', dumpfile
);
1381 show_code (level
+ 1, d
->next
);
1384 code_indent (level
, c
->label1
);
1386 fputs ("ENDIF", dumpfile
);
1391 const char* blocktype
;
1392 if (c
->ext
.block
.assoc
)
1393 blocktype
= "ASSOCIATE";
1395 blocktype
= "BLOCK";
1397 fprintf (dumpfile
, "%s ", blocktype
);
1398 ns
= c
->ext
.block
.ns
;
1399 show_namespace (ns
);
1401 fprintf (dumpfile
, "END %s ", blocktype
);
1407 fputs ("SELECT CASE ", dumpfile
);
1408 show_expr (c
->expr1
);
1409 fputc ('\n', dumpfile
);
1411 for (; d
; d
= d
->block
)
1413 code_indent (level
, 0);
1415 fputs ("CASE ", dumpfile
);
1416 for (cp
= d
->ext
.case_list
; cp
; cp
= cp
->next
)
1418 fputc ('(', dumpfile
);
1419 show_expr (cp
->low
);
1420 fputc (' ', dumpfile
);
1421 show_expr (cp
->high
);
1422 fputc (')', dumpfile
);
1423 fputc (' ', dumpfile
);
1425 fputc ('\n', dumpfile
);
1427 show_code (level
+ 1, d
->next
);
1430 code_indent (level
, c
->label1
);
1431 fputs ("END SELECT", dumpfile
);
1435 fputs ("WHERE ", dumpfile
);
1438 show_expr (d
->expr1
);
1439 fputc ('\n', dumpfile
);
1441 show_code (level
+ 1, d
->next
);
1443 for (d
= d
->block
; d
; d
= d
->block
)
1445 code_indent (level
, 0);
1446 fputs ("ELSE WHERE ", dumpfile
);
1447 show_expr (d
->expr1
);
1448 fputc ('\n', dumpfile
);
1449 show_code (level
+ 1, d
->next
);
1452 code_indent (level
, 0);
1453 fputs ("END WHERE", dumpfile
);
1458 fputs ("FORALL ", dumpfile
);
1459 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1461 show_expr (fa
->var
);
1462 fputc (' ', dumpfile
);
1463 show_expr (fa
->start
);
1464 fputc (':', dumpfile
);
1465 show_expr (fa
->end
);
1466 fputc (':', dumpfile
);
1467 show_expr (fa
->stride
);
1469 if (fa
->next
!= NULL
)
1470 fputc (',', dumpfile
);
1473 if (c
->expr1
!= NULL
)
1475 fputc (',', dumpfile
);
1476 show_expr (c
->expr1
);
1478 fputc ('\n', dumpfile
);
1480 show_code (level
+ 1, c
->block
->next
);
1482 code_indent (level
, 0);
1483 fputs ("END FORALL", dumpfile
);
1487 fputs ("CRITICAL\n", dumpfile
);
1488 show_code (level
+ 1, c
->block
->next
);
1489 code_indent (level
, 0);
1490 fputs ("END CRITICAL", dumpfile
);
1494 fputs ("DO ", dumpfile
);
1496 show_expr (c
->ext
.iterator
->var
);
1497 fputc ('=', dumpfile
);
1498 show_expr (c
->ext
.iterator
->start
);
1499 fputc (' ', dumpfile
);
1500 show_expr (c
->ext
.iterator
->end
);
1501 fputc (' ', dumpfile
);
1502 show_expr (c
->ext
.iterator
->step
);
1503 fputc ('\n', dumpfile
);
1505 show_code (level
+ 1, c
->block
->next
);
1507 code_indent (level
, 0);
1508 fputs ("END DO", dumpfile
);
1512 fputs ("DO WHILE ", dumpfile
);
1513 show_expr (c
->expr1
);
1514 fputc ('\n', dumpfile
);
1516 show_code (level
+ 1, c
->block
->next
);
1518 code_indent (level
, c
->label1
);
1519 fputs ("END DO", dumpfile
);
1523 fputs ("CYCLE", dumpfile
);
1525 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1529 fputs ("EXIT", dumpfile
);
1531 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1535 fputs ("ALLOCATE ", dumpfile
);
1538 fputs (" STAT=", dumpfile
);
1539 show_expr (c
->expr1
);
1544 fputs (" ERRMSG=", dumpfile
);
1545 show_expr (c
->expr2
);
1548 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
1550 fputc (' ', dumpfile
);
1551 show_expr (a
->expr
);
1556 case EXEC_DEALLOCATE
:
1557 fputs ("DEALLOCATE ", dumpfile
);
1560 fputs (" STAT=", dumpfile
);
1561 show_expr (c
->expr1
);
1566 fputs (" ERRMSG=", dumpfile
);
1567 show_expr (c
->expr2
);
1570 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
1572 fputc (' ', dumpfile
);
1573 show_expr (a
->expr
);
1579 fputs ("OPEN", dumpfile
);
1584 fputs (" UNIT=", dumpfile
);
1585 show_expr (open
->unit
);
1589 fputs (" IOMSG=", dumpfile
);
1590 show_expr (open
->iomsg
);
1594 fputs (" IOSTAT=", dumpfile
);
1595 show_expr (open
->iostat
);
1599 fputs (" FILE=", dumpfile
);
1600 show_expr (open
->file
);
1604 fputs (" STATUS=", dumpfile
);
1605 show_expr (open
->status
);
1609 fputs (" ACCESS=", dumpfile
);
1610 show_expr (open
->access
);
1614 fputs (" FORM=", dumpfile
);
1615 show_expr (open
->form
);
1619 fputs (" RECL=", dumpfile
);
1620 show_expr (open
->recl
);
1624 fputs (" BLANK=", dumpfile
);
1625 show_expr (open
->blank
);
1629 fputs (" POSITION=", dumpfile
);
1630 show_expr (open
->position
);
1634 fputs (" ACTION=", dumpfile
);
1635 show_expr (open
->action
);
1639 fputs (" DELIM=", dumpfile
);
1640 show_expr (open
->delim
);
1644 fputs (" PAD=", dumpfile
);
1645 show_expr (open
->pad
);
1649 fputs (" DECIMAL=", dumpfile
);
1650 show_expr (open
->decimal
);
1654 fputs (" ENCODING=", dumpfile
);
1655 show_expr (open
->encoding
);
1659 fputs (" ROUND=", dumpfile
);
1660 show_expr (open
->round
);
1664 fputs (" SIGN=", dumpfile
);
1665 show_expr (open
->sign
);
1669 fputs (" CONVERT=", dumpfile
);
1670 show_expr (open
->convert
);
1672 if (open
->asynchronous
)
1674 fputs (" ASYNCHRONOUS=", dumpfile
);
1675 show_expr (open
->asynchronous
);
1677 if (open
->err
!= NULL
)
1678 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
1683 fputs ("CLOSE", dumpfile
);
1684 close
= c
->ext
.close
;
1688 fputs (" UNIT=", dumpfile
);
1689 show_expr (close
->unit
);
1693 fputs (" IOMSG=", dumpfile
);
1694 show_expr (close
->iomsg
);
1698 fputs (" IOSTAT=", dumpfile
);
1699 show_expr (close
->iostat
);
1703 fputs (" STATUS=", dumpfile
);
1704 show_expr (close
->status
);
1706 if (close
->err
!= NULL
)
1707 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
1710 case EXEC_BACKSPACE
:
1711 fputs ("BACKSPACE", dumpfile
);
1715 fputs ("ENDFILE", dumpfile
);
1719 fputs ("REWIND", dumpfile
);
1723 fputs ("FLUSH", dumpfile
);
1726 fp
= c
->ext
.filepos
;
1730 fputs (" UNIT=", dumpfile
);
1731 show_expr (fp
->unit
);
1735 fputs (" IOMSG=", dumpfile
);
1736 show_expr (fp
->iomsg
);
1740 fputs (" IOSTAT=", dumpfile
);
1741 show_expr (fp
->iostat
);
1743 if (fp
->err
!= NULL
)
1744 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
1748 fputs ("INQUIRE", dumpfile
);
1753 fputs (" UNIT=", dumpfile
);
1754 show_expr (i
->unit
);
1758 fputs (" FILE=", dumpfile
);
1759 show_expr (i
->file
);
1764 fputs (" IOMSG=", dumpfile
);
1765 show_expr (i
->iomsg
);
1769 fputs (" IOSTAT=", dumpfile
);
1770 show_expr (i
->iostat
);
1774 fputs (" EXIST=", dumpfile
);
1775 show_expr (i
->exist
);
1779 fputs (" OPENED=", dumpfile
);
1780 show_expr (i
->opened
);
1784 fputs (" NUMBER=", dumpfile
);
1785 show_expr (i
->number
);
1789 fputs (" NAMED=", dumpfile
);
1790 show_expr (i
->named
);
1794 fputs (" NAME=", dumpfile
);
1795 show_expr (i
->name
);
1799 fputs (" ACCESS=", dumpfile
);
1800 show_expr (i
->access
);
1804 fputs (" SEQUENTIAL=", dumpfile
);
1805 show_expr (i
->sequential
);
1810 fputs (" DIRECT=", dumpfile
);
1811 show_expr (i
->direct
);
1815 fputs (" FORM=", dumpfile
);
1816 show_expr (i
->form
);
1820 fputs (" FORMATTED", dumpfile
);
1821 show_expr (i
->formatted
);
1825 fputs (" UNFORMATTED=", dumpfile
);
1826 show_expr (i
->unformatted
);
1830 fputs (" RECL=", dumpfile
);
1831 show_expr (i
->recl
);
1835 fputs (" NEXTREC=", dumpfile
);
1836 show_expr (i
->nextrec
);
1840 fputs (" BLANK=", dumpfile
);
1841 show_expr (i
->blank
);
1845 fputs (" POSITION=", dumpfile
);
1846 show_expr (i
->position
);
1850 fputs (" ACTION=", dumpfile
);
1851 show_expr (i
->action
);
1855 fputs (" READ=", dumpfile
);
1856 show_expr (i
->read
);
1860 fputs (" WRITE=", dumpfile
);
1861 show_expr (i
->write
);
1865 fputs (" READWRITE=", dumpfile
);
1866 show_expr (i
->readwrite
);
1870 fputs (" DELIM=", dumpfile
);
1871 show_expr (i
->delim
);
1875 fputs (" PAD=", dumpfile
);
1880 fputs (" CONVERT=", dumpfile
);
1881 show_expr (i
->convert
);
1883 if (i
->asynchronous
)
1885 fputs (" ASYNCHRONOUS=", dumpfile
);
1886 show_expr (i
->asynchronous
);
1890 fputs (" DECIMAL=", dumpfile
);
1891 show_expr (i
->decimal
);
1895 fputs (" ENCODING=", dumpfile
);
1896 show_expr (i
->encoding
);
1900 fputs (" PENDING=", dumpfile
);
1901 show_expr (i
->pending
);
1905 fputs (" ROUND=", dumpfile
);
1906 show_expr (i
->round
);
1910 fputs (" SIGN=", dumpfile
);
1911 show_expr (i
->sign
);
1915 fputs (" SIZE=", dumpfile
);
1916 show_expr (i
->size
);
1920 fputs (" ID=", dumpfile
);
1925 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
1929 fputs ("IOLENGTH ", dumpfile
);
1930 show_expr (c
->expr1
);
1935 fputs ("READ", dumpfile
);
1939 fputs ("WRITE", dumpfile
);
1945 fputs (" UNIT=", dumpfile
);
1946 show_expr (dt
->io_unit
);
1949 if (dt
->format_expr
)
1951 fputs (" FMT=", dumpfile
);
1952 show_expr (dt
->format_expr
);
1955 if (dt
->format_label
!= NULL
)
1956 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
1958 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
1962 fputs (" IOMSG=", dumpfile
);
1963 show_expr (dt
->iomsg
);
1967 fputs (" IOSTAT=", dumpfile
);
1968 show_expr (dt
->iostat
);
1972 fputs (" SIZE=", dumpfile
);
1973 show_expr (dt
->size
);
1977 fputs (" REC=", dumpfile
);
1978 show_expr (dt
->rec
);
1982 fputs (" ADVANCE=", dumpfile
);
1983 show_expr (dt
->advance
);
1987 fputs (" ID=", dumpfile
);
1992 fputs (" POS=", dumpfile
);
1993 show_expr (dt
->pos
);
1995 if (dt
->asynchronous
)
1997 fputs (" ASYNCHRONOUS=", dumpfile
);
1998 show_expr (dt
->asynchronous
);
2002 fputs (" BLANK=", dumpfile
);
2003 show_expr (dt
->blank
);
2007 fputs (" DECIMAL=", dumpfile
);
2008 show_expr (dt
->decimal
);
2012 fputs (" DELIM=", dumpfile
);
2013 show_expr (dt
->delim
);
2017 fputs (" PAD=", dumpfile
);
2018 show_expr (dt
->pad
);
2022 fputs (" ROUND=", dumpfile
);
2023 show_expr (dt
->round
);
2027 fputs (" SIGN=", dumpfile
);
2028 show_expr (dt
->sign
);
2032 fputc ('\n', dumpfile
);
2033 for (c
= c
->block
->next
; c
; c
= c
->next
)
2034 show_code_node (level
+ (c
->next
!= NULL
), c
);
2038 fputs ("TRANSFER ", dumpfile
);
2039 show_expr (c
->expr1
);
2043 fputs ("DT_END", dumpfile
);
2046 if (dt
->err
!= NULL
)
2047 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
2048 if (dt
->end
!= NULL
)
2049 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
2050 if (dt
->eor
!= NULL
)
2051 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
2054 case EXEC_OMP_ATOMIC
:
2055 case EXEC_OMP_BARRIER
:
2056 case EXEC_OMP_CRITICAL
:
2057 case EXEC_OMP_FLUSH
:
2059 case EXEC_OMP_MASTER
:
2060 case EXEC_OMP_ORDERED
:
2061 case EXEC_OMP_PARALLEL
:
2062 case EXEC_OMP_PARALLEL_DO
:
2063 case EXEC_OMP_PARALLEL_SECTIONS
:
2064 case EXEC_OMP_PARALLEL_WORKSHARE
:
2065 case EXEC_OMP_SECTIONS
:
2066 case EXEC_OMP_SINGLE
:
2068 case EXEC_OMP_TASKWAIT
:
2069 case EXEC_OMP_WORKSHARE
:
2070 show_omp_node (level
, c
);
2074 gfc_internal_error ("show_code_node(): Bad statement code");
2077 fputc ('\n', dumpfile
);
2081 /* Show an equivalence chain. */
2084 show_equiv (gfc_equiv
*eq
)
2087 fputs ("Equivalence: ", dumpfile
);
2090 show_expr (eq
->expr
);
2093 fputs (", ", dumpfile
);
2098 /* Show a freakin' whole namespace. */
2101 show_namespace (gfc_namespace
*ns
)
2103 gfc_interface
*intr
;
2104 gfc_namespace
*save
;
2109 save
= gfc_current_ns
;
2113 fputs ("Namespace:", dumpfile
);
2121 while (i
< GFC_LETTERS
- 1
2122 && gfc_compare_types(&ns
->default_type
[i
+1],
2123 &ns
->default_type
[l
]))
2127 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
2129 fprintf (dumpfile
, " %c: ", l
+'A');
2131 show_typespec(&ns
->default_type
[l
]);
2133 } while (i
< GFC_LETTERS
);
2135 if (ns
->proc_name
!= NULL
)
2138 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
2141 gfc_current_ns
= ns
;
2142 gfc_traverse_symtree (ns
->common_root
, show_common
);
2144 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2146 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
2148 /* User operator interfaces */
2154 fprintf (dumpfile
, "Operator interfaces for %s:",
2155 gfc_op2string ((gfc_intrinsic_op
) op
));
2157 for (; intr
; intr
= intr
->next
)
2158 fprintf (dumpfile
, " %s", intr
->sym
->name
);
2161 if (ns
->uop_root
!= NULL
)
2164 fputs ("User operators:\n", dumpfile
);
2165 gfc_traverse_user_op (ns
, show_uop
);
2169 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
2172 fputc ('\n', dumpfile
);
2173 fputc ('\n', dumpfile
);
2175 show_code (show_level
, ns
->code
);
2177 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
2180 fputs ("CONTAINS\n", dumpfile
);
2181 show_namespace (ns
);
2185 fputc ('\n', dumpfile
);
2186 gfc_current_ns
= save
;
2190 /* Main function for dumping a parse tree. */
2193 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
2196 show_namespace (ns
);