2 Copyright (C) 2003-2014 Free Software Foundation, Inc.
3 Contributed by Steven Bosscher
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Actually this is just a collection of routines that used to be
23 scattered around the sources. Now that they are all in a single
24 file, almost all of them can be static, and the other files don't
25 have this mess in them.
27 As a nice side-effect, this file can act as documentation of the
28 gfc_code and gfc_expr structures and all their friends and
35 #include "coretypes.h"
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 /* Allow dumping of an expression in the debugger. */
53 void gfc_debug_expr (gfc_expr
*);
56 gfc_debug_expr (gfc_expr
*e
)
61 fputc ('\n', dumpfile
);
66 /* Do indentation for a specific level. */
69 code_indent (int level
, gfc_st_label
*label
)
74 fprintf (dumpfile
, "%-5d ", label
->value
);
76 for (i
= 0; i
< (2 * level
- (label
? 6 : 0)); i
++)
77 fputc (' ', dumpfile
);
81 /* Simple indentation at the current level. This one
82 is used to show symbols. */
87 fputc ('\n', dumpfile
);
88 code_indent (show_level
, NULL
);
92 /* Show type-specific information. */
95 show_typespec (gfc_typespec
*ts
)
97 if (ts
->type
== BT_ASSUMED
)
99 fputs ("(TYPE(*))", dumpfile
);
103 fprintf (dumpfile
, "(%s ", gfc_basic_typename (ts
->type
));
109 fprintf (dumpfile
, "%s", ts
->u
.derived
->name
);
114 show_expr (ts
->u
.cl
->length
);
115 fprintf(dumpfile
, " %d", ts
->kind
);
119 fprintf (dumpfile
, "%d", ts
->kind
);
123 fputc (')', dumpfile
);
127 /* Show an actual argument list. */
130 show_actual_arglist (gfc_actual_arglist
*a
)
132 fputc ('(', dumpfile
);
134 for (; a
; a
= a
->next
)
136 fputc ('(', dumpfile
);
138 fprintf (dumpfile
, "%s = ", a
->name
);
142 fputs ("(arg not-present)", dumpfile
);
144 fputc (')', dumpfile
);
146 fputc (' ', dumpfile
);
149 fputc (')', dumpfile
);
153 /* Show a gfc_array_spec array specification structure. */
156 show_array_spec (gfc_array_spec
*as
)
163 fputs ("()", dumpfile
);
167 fprintf (dumpfile
, "(%d [%d]", as
->rank
, as
->corank
);
169 if (as
->rank
+ as
->corank
> 0 || as
->rank
== -1)
173 case AS_EXPLICIT
: c
= "AS_EXPLICIT"; break;
174 case AS_DEFERRED
: c
= "AS_DEFERRED"; break;
175 case AS_ASSUMED_SIZE
: c
= "AS_ASSUMED_SIZE"; break;
176 case AS_ASSUMED_SHAPE
: c
= "AS_ASSUMED_SHAPE"; break;
177 case AS_ASSUMED_RANK
: c
= "AS_ASSUMED_RANK"; break;
179 gfc_internal_error ("show_array_spec(): Unhandled array shape "
182 fprintf (dumpfile
, " %s ", c
);
184 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
186 show_expr (as
->lower
[i
]);
187 fputc (' ', dumpfile
);
188 show_expr (as
->upper
[i
]);
189 fputc (' ', dumpfile
);
193 fputc (')', dumpfile
);
197 /* Show a gfc_array_ref array reference structure. */
200 show_array_ref (gfc_array_ref
* ar
)
204 fputc ('(', dumpfile
);
209 fputs ("FULL", dumpfile
);
213 for (i
= 0; i
< ar
->dimen
; i
++)
215 /* There are two types of array sections: either the
216 elements are identified by an integer array ('vector'),
217 or by an index range. In the former case we only have to
218 print the start expression which contains the vector, in
219 the latter case we have to print any of lower and upper
220 bound and the stride, if they're present. */
222 if (ar
->start
[i
] != NULL
)
223 show_expr (ar
->start
[i
]);
225 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
227 fputc (':', dumpfile
);
229 if (ar
->end
[i
] != NULL
)
230 show_expr (ar
->end
[i
]);
232 if (ar
->stride
[i
] != NULL
)
234 fputc (':', dumpfile
);
235 show_expr (ar
->stride
[i
]);
239 if (i
!= ar
->dimen
- 1)
240 fputs (" , ", dumpfile
);
245 for (i
= 0; i
< ar
->dimen
; i
++)
247 show_expr (ar
->start
[i
]);
248 if (i
!= ar
->dimen
- 1)
249 fputs (" , ", dumpfile
);
254 fputs ("UNKNOWN", dumpfile
);
258 gfc_internal_error ("show_array_ref(): Unknown array reference");
261 fputc (')', dumpfile
);
265 /* Show a list of gfc_ref structures. */
268 show_ref (gfc_ref
*p
)
270 for (; p
; p
= p
->next
)
274 show_array_ref (&p
->u
.ar
);
278 fprintf (dumpfile
, " %% %s", p
->u
.c
.component
->name
);
282 fputc ('(', dumpfile
);
283 show_expr (p
->u
.ss
.start
);
284 fputc (':', dumpfile
);
285 show_expr (p
->u
.ss
.end
);
286 fputc (')', dumpfile
);
290 gfc_internal_error ("show_ref(): Bad component code");
295 /* Display a constructor. Works recursively for array constructors. */
298 show_constructor (gfc_constructor_base base
)
301 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
303 if (c
->iterator
== NULL
)
307 fputc ('(', dumpfile
);
310 fputc (' ', dumpfile
);
311 show_expr (c
->iterator
->var
);
312 fputc ('=', dumpfile
);
313 show_expr (c
->iterator
->start
);
314 fputc (',', dumpfile
);
315 show_expr (c
->iterator
->end
);
316 fputc (',', dumpfile
);
317 show_expr (c
->iterator
->step
);
319 fputc (')', dumpfile
);
322 if (gfc_constructor_next (c
) != NULL
)
323 fputs (" , ", dumpfile
);
329 show_char_const (const gfc_char_t
*c
, int length
)
333 fputc ('\'', dumpfile
);
334 for (i
= 0; i
< length
; i
++)
337 fputs ("''", dumpfile
);
339 fputs (gfc_print_wide_char (c
[i
]), dumpfile
);
341 fputc ('\'', dumpfile
);
345 /* Show a component-call expression. */
348 show_compcall (gfc_expr
* p
)
350 gcc_assert (p
->expr_type
== EXPR_COMPCALL
);
352 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
354 fprintf (dumpfile
, "%s", p
->value
.compcall
.name
);
356 show_actual_arglist (p
->value
.compcall
.actual
);
360 /* Show an expression. */
363 show_expr (gfc_expr
*p
)
370 fputs ("()", dumpfile
);
374 switch (p
->expr_type
)
377 show_char_const (p
->value
.character
.string
, p
->value
.character
.length
);
382 fprintf (dumpfile
, "%s(", p
->ts
.u
.derived
->name
);
383 show_constructor (p
->value
.constructor
);
384 fputc (')', dumpfile
);
388 fputs ("(/ ", dumpfile
);
389 show_constructor (p
->value
.constructor
);
390 fputs (" /)", dumpfile
);
396 fputs ("NULL()", dumpfile
);
403 mpz_out_str (stdout
, 10, p
->value
.integer
);
405 if (p
->ts
.kind
!= gfc_default_integer_kind
)
406 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
410 if (p
->value
.logical
)
411 fputs (".true.", dumpfile
);
413 fputs (".false.", dumpfile
);
417 mpfr_out_str (stdout
, 10, 0, p
->value
.real
, GFC_RND_MODE
);
418 if (p
->ts
.kind
!= gfc_default_real_kind
)
419 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
423 show_char_const (p
->value
.character
.string
,
424 p
->value
.character
.length
);
428 fputs ("(complex ", dumpfile
);
430 mpfr_out_str (stdout
, 10, 0, mpc_realref (p
->value
.complex),
432 if (p
->ts
.kind
!= gfc_default_complex_kind
)
433 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
435 fputc (' ', dumpfile
);
437 mpfr_out_str (stdout
, 10, 0, mpc_imagref (p
->value
.complex),
439 if (p
->ts
.kind
!= gfc_default_complex_kind
)
440 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
442 fputc (')', dumpfile
);
446 fprintf (dumpfile
, "%dH", p
->representation
.length
);
447 c
= p
->representation
.string
;
448 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
450 fputc (*c
, dumpfile
);
455 fputs ("???", dumpfile
);
459 if (p
->representation
.string
)
461 fputs (" {", dumpfile
);
462 c
= p
->representation
.string
;
463 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
465 fprintf (dumpfile
, "%.2x", (unsigned int) *c
);
466 if (i
< p
->representation
.length
- 1)
467 fputc (',', dumpfile
);
469 fputc ('}', dumpfile
);
475 if (p
->symtree
->n
.sym
->ns
&& p
->symtree
->n
.sym
->ns
->proc_name
)
476 fprintf (dumpfile
, "%s:", p
->symtree
->n
.sym
->ns
->proc_name
->name
);
477 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
482 fputc ('(', dumpfile
);
483 switch (p
->value
.op
.op
)
485 case INTRINSIC_UPLUS
:
486 fputs ("U+ ", dumpfile
);
488 case INTRINSIC_UMINUS
:
489 fputs ("U- ", dumpfile
);
492 fputs ("+ ", dumpfile
);
494 case INTRINSIC_MINUS
:
495 fputs ("- ", dumpfile
);
497 case INTRINSIC_TIMES
:
498 fputs ("* ", dumpfile
);
500 case INTRINSIC_DIVIDE
:
501 fputs ("/ ", dumpfile
);
503 case INTRINSIC_POWER
:
504 fputs ("** ", dumpfile
);
506 case INTRINSIC_CONCAT
:
507 fputs ("// ", dumpfile
);
510 fputs ("AND ", dumpfile
);
513 fputs ("OR ", dumpfile
);
516 fputs ("EQV ", dumpfile
);
519 fputs ("NEQV ", dumpfile
);
522 case INTRINSIC_EQ_OS
:
523 fputs ("= ", dumpfile
);
526 case INTRINSIC_NE_OS
:
527 fputs ("/= ", dumpfile
);
530 case INTRINSIC_GT_OS
:
531 fputs ("> ", dumpfile
);
534 case INTRINSIC_GE_OS
:
535 fputs (">= ", dumpfile
);
538 case INTRINSIC_LT_OS
:
539 fputs ("< ", dumpfile
);
542 case INTRINSIC_LE_OS
:
543 fputs ("<= ", dumpfile
);
546 fputs ("NOT ", dumpfile
);
548 case INTRINSIC_PARENTHESES
:
549 fputs ("parens ", dumpfile
);
554 ("show_expr(): Bad intrinsic in expression!");
557 show_expr (p
->value
.op
.op1
);
561 fputc (' ', dumpfile
);
562 show_expr (p
->value
.op
.op2
);
565 fputc (')', dumpfile
);
569 if (p
->value
.function
.name
== NULL
)
571 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
572 if (gfc_is_proc_ptr_comp (p
))
574 fputc ('[', dumpfile
);
575 show_actual_arglist (p
->value
.function
.actual
);
576 fputc (']', dumpfile
);
580 fprintf (dumpfile
, "%s", p
->value
.function
.name
);
581 if (gfc_is_proc_ptr_comp (p
))
583 fputc ('[', dumpfile
);
584 fputc ('[', dumpfile
);
585 show_actual_arglist (p
->value
.function
.actual
);
586 fputc (']', dumpfile
);
587 fputc (']', dumpfile
);
597 gfc_internal_error ("show_expr(): Don't know how to show expr");
601 /* Show symbol attributes. The flavor and intent are followed by
602 whatever single bit attributes are present. */
605 show_attr (symbol_attribute
*attr
, const char * module
)
607 if (attr
->flavor
!= FL_UNKNOWN
)
608 fprintf (dumpfile
, "(%s ", gfc_code2string (flavors
, attr
->flavor
));
609 if (attr
->access
!= ACCESS_UNKNOWN
)
610 fprintf (dumpfile
, "%s ", gfc_code2string (access_types
, attr
->access
));
611 if (attr
->proc
!= PROC_UNKNOWN
)
612 fprintf (dumpfile
, "%s ", gfc_code2string (procedures
, attr
->proc
));
613 if (attr
->save
!= SAVE_NONE
)
614 fprintf (dumpfile
, "%s", gfc_code2string (save_status
, attr
->save
));
616 if (attr
->artificial
)
617 fputs (" ARTIFICIAL", dumpfile
);
618 if (attr
->allocatable
)
619 fputs (" ALLOCATABLE", dumpfile
);
620 if (attr
->asynchronous
)
621 fputs (" ASYNCHRONOUS", dumpfile
);
622 if (attr
->codimension
)
623 fputs (" CODIMENSION", dumpfile
);
625 fputs (" DIMENSION", dumpfile
);
626 if (attr
->contiguous
)
627 fputs (" CONTIGUOUS", dumpfile
);
629 fputs (" EXTERNAL", dumpfile
);
631 fputs (" INTRINSIC", dumpfile
);
633 fputs (" OPTIONAL", dumpfile
);
635 fputs (" POINTER", dumpfile
);
636 if (attr
->is_protected
)
637 fputs (" PROTECTED", dumpfile
);
639 fputs (" VALUE", dumpfile
);
641 fputs (" VOLATILE", dumpfile
);
642 if (attr
->threadprivate
)
643 fputs (" THREADPRIVATE", dumpfile
);
645 fputs (" TARGET", dumpfile
);
648 fputs (" DUMMY", dumpfile
);
649 if (attr
->intent
!= INTENT_UNKNOWN
)
650 fprintf (dumpfile
, "(%s)", gfc_intent_string (attr
->intent
));
654 fputs (" RESULT", dumpfile
);
656 fputs (" ENTRY", dumpfile
);
658 fputs (" BIND(C)", dumpfile
);
661 fputs (" DATA", dumpfile
);
664 fputs (" USE-ASSOC", dumpfile
);
666 fprintf (dumpfile
, "(%s)", module
);
669 if (attr
->in_namelist
)
670 fputs (" IN-NAMELIST", dumpfile
);
672 fputs (" IN-COMMON", dumpfile
);
675 fputs (" ABSTRACT", dumpfile
);
677 fputs (" FUNCTION", dumpfile
);
678 if (attr
->subroutine
)
679 fputs (" SUBROUTINE", dumpfile
);
680 if (attr
->implicit_type
)
681 fputs (" IMPLICIT-TYPE", dumpfile
);
684 fputs (" SEQUENCE", dumpfile
);
686 fputs (" ELEMENTAL", dumpfile
);
688 fputs (" PURE", dumpfile
);
690 fputs (" RECURSIVE", dumpfile
);
692 fputc (')', dumpfile
);
696 /* Show components of a derived type. */
699 show_components (gfc_symbol
*sym
)
703 for (c
= sym
->components
; c
; c
= c
->next
)
705 fprintf (dumpfile
, "(%s ", c
->name
);
706 show_typespec (&c
->ts
);
707 if (c
->attr
.allocatable
)
708 fputs (" ALLOCATABLE", dumpfile
);
710 fputs (" POINTER", dumpfile
);
711 if (c
->attr
.proc_pointer
)
712 fputs (" PPC", dumpfile
);
713 if (c
->attr
.dimension
)
714 fputs (" DIMENSION", dumpfile
);
715 fputc (' ', dumpfile
);
716 show_array_spec (c
->as
);
718 fprintf (dumpfile
, " %s", gfc_code2string (access_types
, c
->attr
.access
));
719 fputc (')', dumpfile
);
721 fputc (' ', dumpfile
);
726 /* Show the f2k_derived namespace with procedure bindings. */
729 show_typebound_proc (gfc_typebound_proc
* tb
, const char* name
)
734 fputs ("GENERIC", dumpfile
);
737 fputs ("PROCEDURE, ", dumpfile
);
739 fputs ("NOPASS", dumpfile
);
743 fprintf (dumpfile
, "PASS(%s)", tb
->pass_arg
);
745 fputs ("PASS", dumpfile
);
747 if (tb
->non_overridable
)
748 fputs (", NON_OVERRIDABLE", dumpfile
);
751 if (tb
->access
== ACCESS_PUBLIC
)
752 fputs (", PUBLIC", dumpfile
);
754 fputs (", PRIVATE", dumpfile
);
756 fprintf (dumpfile
, " :: %s => ", name
);
761 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
763 fputs (g
->specific_st
->name
, dumpfile
);
765 fputs (", ", dumpfile
);
769 fputs (tb
->u
.specific
->n
.sym
->name
, dumpfile
);
773 show_typebound_symtree (gfc_symtree
* st
)
775 gcc_assert (st
->n
.tb
);
776 show_typebound_proc (st
->n
.tb
, st
->name
);
780 show_f2k_derived (gfc_namespace
* f2k
)
786 fputs ("Procedure bindings:", dumpfile
);
789 /* Finalizer bindings. */
790 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
793 fprintf (dumpfile
, "FINAL %s", f
->proc_tree
->n
.sym
->name
);
796 /* Type-bound procedures. */
797 gfc_traverse_symtree (f2k
->tb_sym_root
, &show_typebound_symtree
);
802 fputs ("Operator bindings:", dumpfile
);
805 /* User-defined operators. */
806 gfc_traverse_symtree (f2k
->tb_uop_root
, &show_typebound_symtree
);
808 /* Intrinsic operators. */
809 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
811 show_typebound_proc (f2k
->tb_op
[op
],
812 gfc_op2string ((gfc_intrinsic_op
) op
));
818 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
819 show the interface. Information needed to reconstruct the list of
820 specific interfaces associated with a generic symbol is done within
824 show_symbol (gfc_symbol
*sym
)
826 gfc_formal_arglist
*formal
;
833 fprintf (dumpfile
, "|| symbol: '%s' ", sym
->name
);
834 len
= strlen (sym
->name
);
835 for (i
=len
; i
<12; i
++)
836 fputc(' ', dumpfile
);
841 fputs ("type spec : ", dumpfile
);
842 show_typespec (&sym
->ts
);
845 fputs ("attributes: ", dumpfile
);
846 show_attr (&sym
->attr
, sym
->module
);
851 fputs ("value: ", dumpfile
);
852 show_expr (sym
->value
);
858 fputs ("Array spec:", dumpfile
);
859 show_array_spec (sym
->as
);
865 fputs ("Generic interfaces:", dumpfile
);
866 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
867 fprintf (dumpfile
, " %s", intr
->sym
->name
);
873 fprintf (dumpfile
, "result: %s", sym
->result
->name
);
879 fputs ("components: ", dumpfile
);
880 show_components (sym
);
883 if (sym
->f2k_derived
)
887 fprintf (dumpfile
, "hash: %d", sym
->hash_value
);
888 show_f2k_derived (sym
->f2k_derived
);
894 fputs ("Formal arglist:", dumpfile
);
896 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
898 if (formal
->sym
!= NULL
)
899 fprintf (dumpfile
, " %s", formal
->sym
->name
);
901 fputs (" [Alt Return]", dumpfile
);
905 if (sym
->formal_ns
&& (sym
->formal_ns
->proc_name
!= sym
)
906 && sym
->attr
.proc
!= PROC_ST_FUNCTION
910 fputs ("Formal namespace", dumpfile
);
911 show_namespace (sym
->formal_ns
);
917 /* Show a user-defined operator. Just prints an operator
918 and the name of the associated subroutine, really. */
921 show_uop (gfc_user_op
*uop
)
926 fprintf (dumpfile
, "%s:", uop
->name
);
928 for (intr
= uop
->op
; intr
; intr
= intr
->next
)
929 fprintf (dumpfile
, " %s", intr
->sym
->name
);
933 /* Workhorse function for traversing the user operator symtree. */
936 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
943 traverse_uop (st
->left
, func
);
944 traverse_uop (st
->right
, func
);
948 /* Traverse the tree of user operator nodes. */
951 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
953 traverse_uop (ns
->uop_root
, func
);
957 /* Function to display a common block. */
960 show_common (gfc_symtree
*st
)
965 fprintf (dumpfile
, "common: /%s/ ", st
->name
);
967 s
= st
->n
.common
->head
;
970 fprintf (dumpfile
, "%s", s
->name
);
973 fputs (", ", dumpfile
);
975 fputc ('\n', dumpfile
);
979 /* Worker function to display the symbol tree. */
982 show_symtree (gfc_symtree
*st
)
988 len
= strlen(st
->name
);
989 fprintf (dumpfile
, "symtree: '%s'", st
->name
);
991 for (i
=len
; i
<12; i
++)
992 fputc(' ', dumpfile
);
995 fputs( " Ambiguous", dumpfile
);
997 if (st
->n
.sym
->ns
!= gfc_current_ns
)
998 fprintf (dumpfile
, "|| symbol: '%s' from namespace '%s'", st
->n
.sym
->name
,
999 st
->n
.sym
->ns
->proc_name
->name
);
1001 show_symbol (st
->n
.sym
);
1005 /******************* Show gfc_code structures **************/
1008 /* Show a list of code structures. Mutually recursive with
1009 show_code_node(). */
1012 show_code (int level
, gfc_code
*c
)
1014 for (; c
; c
= c
->next
)
1015 show_code_node (level
, c
);
1019 show_namelist (gfc_namelist
*n
)
1021 for (; n
->next
; n
= n
->next
)
1022 fprintf (dumpfile
, "%s,", n
->sym
->name
);
1023 fprintf (dumpfile
, "%s", n
->sym
->name
);
1026 /* Show a single OpenMP directive node and everything underneath it
1030 show_omp_node (int level
, gfc_code
*c
)
1032 gfc_omp_clauses
*omp_clauses
= NULL
;
1033 const char *name
= NULL
;
1037 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
1038 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
1039 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
1040 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
1041 case EXEC_OMP_DO
: name
= "DO"; break;
1042 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
1043 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
1044 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
1045 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
1046 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
1047 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
1048 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
1049 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
1050 case EXEC_OMP_TASK
: name
= "TASK"; break;
1051 case EXEC_OMP_TASKWAIT
: name
= "TASKWAIT"; break;
1052 case EXEC_OMP_TASKYIELD
: name
= "TASKYIELD"; break;
1053 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
1057 fprintf (dumpfile
, "!$OMP %s", name
);
1061 case EXEC_OMP_PARALLEL
:
1062 case EXEC_OMP_PARALLEL_DO
:
1063 case EXEC_OMP_PARALLEL_SECTIONS
:
1064 case EXEC_OMP_SECTIONS
:
1065 case EXEC_OMP_SINGLE
:
1066 case EXEC_OMP_WORKSHARE
:
1067 case EXEC_OMP_PARALLEL_WORKSHARE
:
1069 omp_clauses
= c
->ext
.omp_clauses
;
1071 case EXEC_OMP_CRITICAL
:
1072 if (c
->ext
.omp_name
)
1073 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1075 case EXEC_OMP_FLUSH
:
1076 if (c
->ext
.omp_namelist
)
1078 fputs (" (", dumpfile
);
1079 show_namelist (c
->ext
.omp_namelist
);
1080 fputc (')', dumpfile
);
1083 case EXEC_OMP_BARRIER
:
1084 case EXEC_OMP_TASKWAIT
:
1085 case EXEC_OMP_TASKYIELD
:
1094 if (omp_clauses
->if_expr
)
1096 fputs (" IF(", dumpfile
);
1097 show_expr (omp_clauses
->if_expr
);
1098 fputc (')', dumpfile
);
1100 if (omp_clauses
->final_expr
)
1102 fputs (" FINAL(", dumpfile
);
1103 show_expr (omp_clauses
->final_expr
);
1104 fputc (')', dumpfile
);
1106 if (omp_clauses
->num_threads
)
1108 fputs (" NUM_THREADS(", dumpfile
);
1109 show_expr (omp_clauses
->num_threads
);
1110 fputc (')', dumpfile
);
1112 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
1115 switch (omp_clauses
->sched_kind
)
1117 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
1118 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
1119 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
1120 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
1121 case OMP_SCHED_AUTO
: type
= "AUTO"; break;
1125 fprintf (dumpfile
, " SCHEDULE (%s", type
);
1126 if (omp_clauses
->chunk_size
)
1128 fputc (',', dumpfile
);
1129 show_expr (omp_clauses
->chunk_size
);
1131 fputc (')', dumpfile
);
1133 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1136 switch (omp_clauses
->default_sharing
)
1138 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
1139 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
1140 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
1141 case OMP_DEFAULT_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1145 fprintf (dumpfile
, " DEFAULT(%s)", type
);
1147 if (omp_clauses
->ordered
)
1148 fputs (" ORDERED", dumpfile
);
1149 if (omp_clauses
->untied
)
1150 fputs (" UNTIED", dumpfile
);
1151 if (omp_clauses
->mergeable
)
1152 fputs (" MERGEABLE", dumpfile
);
1153 if (omp_clauses
->collapse
)
1154 fprintf (dumpfile
, " COLLAPSE(%d)", omp_clauses
->collapse
);
1155 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
1156 if (omp_clauses
->lists
[list_type
] != NULL
1157 && list_type
!= OMP_LIST_COPYPRIVATE
)
1160 if (list_type
>= OMP_LIST_REDUCTION_FIRST
)
1164 case OMP_LIST_PLUS
: type
= "+"; break;
1165 case OMP_LIST_MULT
: type
= "*"; break;
1166 case OMP_LIST_SUB
: type
= "-"; break;
1167 case OMP_LIST_AND
: type
= ".AND."; break;
1168 case OMP_LIST_OR
: type
= ".OR."; break;
1169 case OMP_LIST_EQV
: type
= ".EQV."; break;
1170 case OMP_LIST_NEQV
: type
= ".NEQV."; break;
1171 case OMP_LIST_MAX
: type
= "MAX"; break;
1172 case OMP_LIST_MIN
: type
= "MIN"; break;
1173 case OMP_LIST_IAND
: type
= "IAND"; break;
1174 case OMP_LIST_IOR
: type
= "IOR"; break;
1175 case OMP_LIST_IEOR
: type
= "IEOR"; break;
1179 fprintf (dumpfile
, " REDUCTION(%s:", type
);
1185 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
1186 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1187 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
1188 case OMP_LIST_SHARED
: type
= "SHARED"; break;
1189 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
1193 fprintf (dumpfile
, " %s(", type
);
1195 show_namelist (omp_clauses
->lists
[list_type
]);
1196 fputc (')', dumpfile
);
1199 fputc ('\n', dumpfile
);
1200 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
1202 gfc_code
*d
= c
->block
;
1205 show_code (level
+ 1, d
->next
);
1206 if (d
->block
== NULL
)
1208 code_indent (level
, 0);
1209 fputs ("!$OMP SECTION\n", dumpfile
);
1214 show_code (level
+ 1, c
->block
->next
);
1215 if (c
->op
== EXEC_OMP_ATOMIC
)
1217 code_indent (level
, 0);
1218 fprintf (dumpfile
, "!$OMP END %s", name
);
1219 if (omp_clauses
!= NULL
)
1221 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
1223 fputs (" COPYPRIVATE(", dumpfile
);
1224 show_namelist (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1225 fputc (')', dumpfile
);
1227 else if (omp_clauses
->nowait
)
1228 fputs (" NOWAIT", dumpfile
);
1230 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_name
)
1231 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1235 /* Show a single code node and everything underneath it if necessary. */
1238 show_code_node (int level
, gfc_code
*c
)
1240 gfc_forall_iterator
*fa
;
1253 fputc ('\n', dumpfile
);
1254 code_indent (level
, c
->here
);
1261 case EXEC_END_PROCEDURE
:
1265 fputs ("NOP", dumpfile
);
1269 fputs ("CONTINUE", dumpfile
);
1273 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
1276 case EXEC_INIT_ASSIGN
:
1278 fputs ("ASSIGN ", dumpfile
);
1279 show_expr (c
->expr1
);
1280 fputc (' ', dumpfile
);
1281 show_expr (c
->expr2
);
1284 case EXEC_LABEL_ASSIGN
:
1285 fputs ("LABEL ASSIGN ", dumpfile
);
1286 show_expr (c
->expr1
);
1287 fprintf (dumpfile
, " %d", c
->label1
->value
);
1290 case EXEC_POINTER_ASSIGN
:
1291 fputs ("POINTER ASSIGN ", dumpfile
);
1292 show_expr (c
->expr1
);
1293 fputc (' ', dumpfile
);
1294 show_expr (c
->expr2
);
1298 fputs ("GOTO ", dumpfile
);
1300 fprintf (dumpfile
, "%d", c
->label1
->value
);
1303 show_expr (c
->expr1
);
1307 fputs (", (", dumpfile
);
1308 for (; d
; d
= d
->block
)
1310 code_indent (level
, d
->label1
);
1311 if (d
->block
!= NULL
)
1312 fputc (',', dumpfile
);
1314 fputc (')', dumpfile
);
1321 case EXEC_ASSIGN_CALL
:
1322 if (c
->resolved_sym
)
1323 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
1324 else if (c
->symtree
)
1325 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
1327 fputs ("CALL ?? ", dumpfile
);
1329 show_actual_arglist (c
->ext
.actual
);
1333 fputs ("CALL ", dumpfile
);
1334 show_compcall (c
->expr1
);
1338 fputs ("CALL ", dumpfile
);
1339 show_expr (c
->expr1
);
1340 show_actual_arglist (c
->ext
.actual
);
1344 fputs ("RETURN ", dumpfile
);
1346 show_expr (c
->expr1
);
1350 fputs ("PAUSE ", dumpfile
);
1352 if (c
->expr1
!= NULL
)
1353 show_expr (c
->expr1
);
1355 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1359 case EXEC_ERROR_STOP
:
1360 fputs ("ERROR ", dumpfile
);
1364 fputs ("STOP ", dumpfile
);
1366 if (c
->expr1
!= NULL
)
1367 show_expr (c
->expr1
);
1369 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1374 fputs ("SYNC ALL ", dumpfile
);
1375 if (c
->expr2
!= NULL
)
1377 fputs (" stat=", dumpfile
);
1378 show_expr (c
->expr2
);
1380 if (c
->expr3
!= NULL
)
1382 fputs (" errmsg=", dumpfile
);
1383 show_expr (c
->expr3
);
1387 case EXEC_SYNC_MEMORY
:
1388 fputs ("SYNC MEMORY ", dumpfile
);
1389 if (c
->expr2
!= NULL
)
1391 fputs (" stat=", dumpfile
);
1392 show_expr (c
->expr2
);
1394 if (c
->expr3
!= NULL
)
1396 fputs (" errmsg=", dumpfile
);
1397 show_expr (c
->expr3
);
1401 case EXEC_SYNC_IMAGES
:
1402 fputs ("SYNC IMAGES image-set=", dumpfile
);
1403 if (c
->expr1
!= NULL
)
1404 show_expr (c
->expr1
);
1406 fputs ("* ", dumpfile
);
1407 if (c
->expr2
!= NULL
)
1409 fputs (" stat=", dumpfile
);
1410 show_expr (c
->expr2
);
1412 if (c
->expr3
!= NULL
)
1414 fputs (" errmsg=", dumpfile
);
1415 show_expr (c
->expr3
);
1421 if (c
->op
== EXEC_LOCK
)
1422 fputs ("LOCK ", dumpfile
);
1424 fputs ("UNLOCK ", dumpfile
);
1426 fputs ("lock-variable=", dumpfile
);
1427 if (c
->expr1
!= NULL
)
1428 show_expr (c
->expr1
);
1429 if (c
->expr4
!= NULL
)
1431 fputs (" acquired_lock=", dumpfile
);
1432 show_expr (c
->expr4
);
1434 if (c
->expr2
!= NULL
)
1436 fputs (" stat=", dumpfile
);
1437 show_expr (c
->expr2
);
1439 if (c
->expr3
!= NULL
)
1441 fputs (" errmsg=", dumpfile
);
1442 show_expr (c
->expr3
);
1446 case EXEC_ARITHMETIC_IF
:
1447 fputs ("IF ", dumpfile
);
1448 show_expr (c
->expr1
);
1449 fprintf (dumpfile
, " %d, %d, %d",
1450 c
->label1
->value
, c
->label2
->value
, c
->label3
->value
);
1455 fputs ("IF ", dumpfile
);
1456 show_expr (d
->expr1
);
1459 show_code (level
+ 1, d
->next
);
1463 for (; d
; d
= d
->block
)
1465 code_indent (level
, 0);
1467 if (d
->expr1
== NULL
)
1468 fputs ("ELSE", dumpfile
);
1471 fputs ("ELSE IF ", dumpfile
);
1472 show_expr (d
->expr1
);
1476 show_code (level
+ 1, d
->next
);
1481 code_indent (level
, c
->label1
);
1485 fputs ("ENDIF", dumpfile
);
1490 const char* blocktype
;
1491 gfc_namespace
*saved_ns
;
1493 if (c
->ext
.block
.assoc
)
1494 blocktype
= "ASSOCIATE";
1496 blocktype
= "BLOCK";
1498 fprintf (dumpfile
, "%s ", blocktype
);
1500 ns
= c
->ext
.block
.ns
;
1501 saved_ns
= gfc_current_ns
;
1502 gfc_current_ns
= ns
;
1503 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
1504 gfc_current_ns
= saved_ns
;
1505 show_code (show_level
, ns
->code
);
1508 fprintf (dumpfile
, "END %s ", blocktype
);
1514 fputs ("SELECT CASE ", dumpfile
);
1515 show_expr (c
->expr1
);
1516 fputc ('\n', dumpfile
);
1518 for (; d
; d
= d
->block
)
1520 code_indent (level
, 0);
1522 fputs ("CASE ", dumpfile
);
1523 for (cp
= d
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
1525 fputc ('(', dumpfile
);
1526 show_expr (cp
->low
);
1527 fputc (' ', dumpfile
);
1528 show_expr (cp
->high
);
1529 fputc (')', dumpfile
);
1530 fputc (' ', dumpfile
);
1532 fputc ('\n', dumpfile
);
1534 show_code (level
+ 1, d
->next
);
1537 code_indent (level
, c
->label1
);
1538 fputs ("END SELECT", dumpfile
);
1542 fputs ("WHERE ", dumpfile
);
1545 show_expr (d
->expr1
);
1546 fputc ('\n', dumpfile
);
1548 show_code (level
+ 1, d
->next
);
1550 for (d
= d
->block
; d
; d
= d
->block
)
1552 code_indent (level
, 0);
1553 fputs ("ELSE WHERE ", dumpfile
);
1554 show_expr (d
->expr1
);
1555 fputc ('\n', dumpfile
);
1556 show_code (level
+ 1, d
->next
);
1559 code_indent (level
, 0);
1560 fputs ("END WHERE", dumpfile
);
1565 fputs ("FORALL ", dumpfile
);
1566 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1568 show_expr (fa
->var
);
1569 fputc (' ', dumpfile
);
1570 show_expr (fa
->start
);
1571 fputc (':', dumpfile
);
1572 show_expr (fa
->end
);
1573 fputc (':', dumpfile
);
1574 show_expr (fa
->stride
);
1576 if (fa
->next
!= NULL
)
1577 fputc (',', dumpfile
);
1580 if (c
->expr1
!= NULL
)
1582 fputc (',', dumpfile
);
1583 show_expr (c
->expr1
);
1585 fputc ('\n', dumpfile
);
1587 show_code (level
+ 1, c
->block
->next
);
1589 code_indent (level
, 0);
1590 fputs ("END FORALL", dumpfile
);
1594 fputs ("CRITICAL\n", dumpfile
);
1595 show_code (level
+ 1, c
->block
->next
);
1596 code_indent (level
, 0);
1597 fputs ("END CRITICAL", dumpfile
);
1601 fputs ("DO ", dumpfile
);
1603 fprintf (dumpfile
, " %-5d ", c
->label1
->value
);
1605 show_expr (c
->ext
.iterator
->var
);
1606 fputc ('=', dumpfile
);
1607 show_expr (c
->ext
.iterator
->start
);
1608 fputc (' ', dumpfile
);
1609 show_expr (c
->ext
.iterator
->end
);
1610 fputc (' ', dumpfile
);
1611 show_expr (c
->ext
.iterator
->step
);
1614 show_code (level
+ 1, c
->block
->next
);
1621 fputs ("END DO", dumpfile
);
1624 case EXEC_DO_CONCURRENT
:
1625 fputs ("DO CONCURRENT ", dumpfile
);
1626 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1628 show_expr (fa
->var
);
1629 fputc (' ', dumpfile
);
1630 show_expr (fa
->start
);
1631 fputc (':', dumpfile
);
1632 show_expr (fa
->end
);
1633 fputc (':', dumpfile
);
1634 show_expr (fa
->stride
);
1636 if (fa
->next
!= NULL
)
1637 fputc (',', dumpfile
);
1639 show_expr (c
->expr1
);
1641 show_code (level
+ 1, c
->block
->next
);
1642 code_indent (level
, c
->label1
);
1643 fputs ("END DO", dumpfile
);
1647 fputs ("DO WHILE ", dumpfile
);
1648 show_expr (c
->expr1
);
1649 fputc ('\n', dumpfile
);
1651 show_code (level
+ 1, c
->block
->next
);
1653 code_indent (level
, c
->label1
);
1654 fputs ("END DO", dumpfile
);
1658 fputs ("CYCLE", dumpfile
);
1660 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1664 fputs ("EXIT", dumpfile
);
1666 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1670 fputs ("ALLOCATE ", dumpfile
);
1673 fputs (" STAT=", dumpfile
);
1674 show_expr (c
->expr1
);
1679 fputs (" ERRMSG=", dumpfile
);
1680 show_expr (c
->expr2
);
1686 fputs (" MOLD=", dumpfile
);
1688 fputs (" SOURCE=", dumpfile
);
1689 show_expr (c
->expr3
);
1692 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
1694 fputc (' ', dumpfile
);
1695 show_expr (a
->expr
);
1700 case EXEC_DEALLOCATE
:
1701 fputs ("DEALLOCATE ", dumpfile
);
1704 fputs (" STAT=", dumpfile
);
1705 show_expr (c
->expr1
);
1710 fputs (" ERRMSG=", dumpfile
);
1711 show_expr (c
->expr2
);
1714 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
1716 fputc (' ', dumpfile
);
1717 show_expr (a
->expr
);
1723 fputs ("OPEN", dumpfile
);
1728 fputs (" UNIT=", dumpfile
);
1729 show_expr (open
->unit
);
1733 fputs (" IOMSG=", dumpfile
);
1734 show_expr (open
->iomsg
);
1738 fputs (" IOSTAT=", dumpfile
);
1739 show_expr (open
->iostat
);
1743 fputs (" FILE=", dumpfile
);
1744 show_expr (open
->file
);
1748 fputs (" STATUS=", dumpfile
);
1749 show_expr (open
->status
);
1753 fputs (" ACCESS=", dumpfile
);
1754 show_expr (open
->access
);
1758 fputs (" FORM=", dumpfile
);
1759 show_expr (open
->form
);
1763 fputs (" RECL=", dumpfile
);
1764 show_expr (open
->recl
);
1768 fputs (" BLANK=", dumpfile
);
1769 show_expr (open
->blank
);
1773 fputs (" POSITION=", dumpfile
);
1774 show_expr (open
->position
);
1778 fputs (" ACTION=", dumpfile
);
1779 show_expr (open
->action
);
1783 fputs (" DELIM=", dumpfile
);
1784 show_expr (open
->delim
);
1788 fputs (" PAD=", dumpfile
);
1789 show_expr (open
->pad
);
1793 fputs (" DECIMAL=", dumpfile
);
1794 show_expr (open
->decimal
);
1798 fputs (" ENCODING=", dumpfile
);
1799 show_expr (open
->encoding
);
1803 fputs (" ROUND=", dumpfile
);
1804 show_expr (open
->round
);
1808 fputs (" SIGN=", dumpfile
);
1809 show_expr (open
->sign
);
1813 fputs (" CONVERT=", dumpfile
);
1814 show_expr (open
->convert
);
1816 if (open
->asynchronous
)
1818 fputs (" ASYNCHRONOUS=", dumpfile
);
1819 show_expr (open
->asynchronous
);
1821 if (open
->err
!= NULL
)
1822 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
1827 fputs ("CLOSE", dumpfile
);
1828 close
= c
->ext
.close
;
1832 fputs (" UNIT=", dumpfile
);
1833 show_expr (close
->unit
);
1837 fputs (" IOMSG=", dumpfile
);
1838 show_expr (close
->iomsg
);
1842 fputs (" IOSTAT=", dumpfile
);
1843 show_expr (close
->iostat
);
1847 fputs (" STATUS=", dumpfile
);
1848 show_expr (close
->status
);
1850 if (close
->err
!= NULL
)
1851 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
1854 case EXEC_BACKSPACE
:
1855 fputs ("BACKSPACE", dumpfile
);
1859 fputs ("ENDFILE", dumpfile
);
1863 fputs ("REWIND", dumpfile
);
1867 fputs ("FLUSH", dumpfile
);
1870 fp
= c
->ext
.filepos
;
1874 fputs (" UNIT=", dumpfile
);
1875 show_expr (fp
->unit
);
1879 fputs (" IOMSG=", dumpfile
);
1880 show_expr (fp
->iomsg
);
1884 fputs (" IOSTAT=", dumpfile
);
1885 show_expr (fp
->iostat
);
1887 if (fp
->err
!= NULL
)
1888 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
1892 fputs ("INQUIRE", dumpfile
);
1897 fputs (" UNIT=", dumpfile
);
1898 show_expr (i
->unit
);
1902 fputs (" FILE=", dumpfile
);
1903 show_expr (i
->file
);
1908 fputs (" IOMSG=", dumpfile
);
1909 show_expr (i
->iomsg
);
1913 fputs (" IOSTAT=", dumpfile
);
1914 show_expr (i
->iostat
);
1918 fputs (" EXIST=", dumpfile
);
1919 show_expr (i
->exist
);
1923 fputs (" OPENED=", dumpfile
);
1924 show_expr (i
->opened
);
1928 fputs (" NUMBER=", dumpfile
);
1929 show_expr (i
->number
);
1933 fputs (" NAMED=", dumpfile
);
1934 show_expr (i
->named
);
1938 fputs (" NAME=", dumpfile
);
1939 show_expr (i
->name
);
1943 fputs (" ACCESS=", dumpfile
);
1944 show_expr (i
->access
);
1948 fputs (" SEQUENTIAL=", dumpfile
);
1949 show_expr (i
->sequential
);
1954 fputs (" DIRECT=", dumpfile
);
1955 show_expr (i
->direct
);
1959 fputs (" FORM=", dumpfile
);
1960 show_expr (i
->form
);
1964 fputs (" FORMATTED", dumpfile
);
1965 show_expr (i
->formatted
);
1969 fputs (" UNFORMATTED=", dumpfile
);
1970 show_expr (i
->unformatted
);
1974 fputs (" RECL=", dumpfile
);
1975 show_expr (i
->recl
);
1979 fputs (" NEXTREC=", dumpfile
);
1980 show_expr (i
->nextrec
);
1984 fputs (" BLANK=", dumpfile
);
1985 show_expr (i
->blank
);
1989 fputs (" POSITION=", dumpfile
);
1990 show_expr (i
->position
);
1994 fputs (" ACTION=", dumpfile
);
1995 show_expr (i
->action
);
1999 fputs (" READ=", dumpfile
);
2000 show_expr (i
->read
);
2004 fputs (" WRITE=", dumpfile
);
2005 show_expr (i
->write
);
2009 fputs (" READWRITE=", dumpfile
);
2010 show_expr (i
->readwrite
);
2014 fputs (" DELIM=", dumpfile
);
2015 show_expr (i
->delim
);
2019 fputs (" PAD=", dumpfile
);
2024 fputs (" CONVERT=", dumpfile
);
2025 show_expr (i
->convert
);
2027 if (i
->asynchronous
)
2029 fputs (" ASYNCHRONOUS=", dumpfile
);
2030 show_expr (i
->asynchronous
);
2034 fputs (" DECIMAL=", dumpfile
);
2035 show_expr (i
->decimal
);
2039 fputs (" ENCODING=", dumpfile
);
2040 show_expr (i
->encoding
);
2044 fputs (" PENDING=", dumpfile
);
2045 show_expr (i
->pending
);
2049 fputs (" ROUND=", dumpfile
);
2050 show_expr (i
->round
);
2054 fputs (" SIGN=", dumpfile
);
2055 show_expr (i
->sign
);
2059 fputs (" SIZE=", dumpfile
);
2060 show_expr (i
->size
);
2064 fputs (" ID=", dumpfile
);
2069 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
2073 fputs ("IOLENGTH ", dumpfile
);
2074 show_expr (c
->expr1
);
2079 fputs ("READ", dumpfile
);
2083 fputs ("WRITE", dumpfile
);
2089 fputs (" UNIT=", dumpfile
);
2090 show_expr (dt
->io_unit
);
2093 if (dt
->format_expr
)
2095 fputs (" FMT=", dumpfile
);
2096 show_expr (dt
->format_expr
);
2099 if (dt
->format_label
!= NULL
)
2100 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
2102 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
2106 fputs (" IOMSG=", dumpfile
);
2107 show_expr (dt
->iomsg
);
2111 fputs (" IOSTAT=", dumpfile
);
2112 show_expr (dt
->iostat
);
2116 fputs (" SIZE=", dumpfile
);
2117 show_expr (dt
->size
);
2121 fputs (" REC=", dumpfile
);
2122 show_expr (dt
->rec
);
2126 fputs (" ADVANCE=", dumpfile
);
2127 show_expr (dt
->advance
);
2131 fputs (" ID=", dumpfile
);
2136 fputs (" POS=", dumpfile
);
2137 show_expr (dt
->pos
);
2139 if (dt
->asynchronous
)
2141 fputs (" ASYNCHRONOUS=", dumpfile
);
2142 show_expr (dt
->asynchronous
);
2146 fputs (" BLANK=", dumpfile
);
2147 show_expr (dt
->blank
);
2151 fputs (" DECIMAL=", dumpfile
);
2152 show_expr (dt
->decimal
);
2156 fputs (" DELIM=", dumpfile
);
2157 show_expr (dt
->delim
);
2161 fputs (" PAD=", dumpfile
);
2162 show_expr (dt
->pad
);
2166 fputs (" ROUND=", dumpfile
);
2167 show_expr (dt
->round
);
2171 fputs (" SIGN=", dumpfile
);
2172 show_expr (dt
->sign
);
2176 for (c
= c
->block
->next
; c
; c
= c
->next
)
2177 show_code_node (level
+ (c
->next
!= NULL
), c
);
2181 fputs ("TRANSFER ", dumpfile
);
2182 show_expr (c
->expr1
);
2186 fputs ("DT_END", dumpfile
);
2189 if (dt
->err
!= NULL
)
2190 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
2191 if (dt
->end
!= NULL
)
2192 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
2193 if (dt
->eor
!= NULL
)
2194 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
2197 case EXEC_OMP_ATOMIC
:
2198 case EXEC_OMP_BARRIER
:
2199 case EXEC_OMP_CRITICAL
:
2200 case EXEC_OMP_FLUSH
:
2202 case EXEC_OMP_MASTER
:
2203 case EXEC_OMP_ORDERED
:
2204 case EXEC_OMP_PARALLEL
:
2205 case EXEC_OMP_PARALLEL_DO
:
2206 case EXEC_OMP_PARALLEL_SECTIONS
:
2207 case EXEC_OMP_PARALLEL_WORKSHARE
:
2208 case EXEC_OMP_SECTIONS
:
2209 case EXEC_OMP_SINGLE
:
2211 case EXEC_OMP_TASKWAIT
:
2212 case EXEC_OMP_TASKYIELD
:
2213 case EXEC_OMP_WORKSHARE
:
2214 show_omp_node (level
, c
);
2218 gfc_internal_error ("show_code_node(): Bad statement code");
2223 /* Show an equivalence chain. */
2226 show_equiv (gfc_equiv
*eq
)
2229 fputs ("Equivalence: ", dumpfile
);
2232 show_expr (eq
->expr
);
2235 fputs (", ", dumpfile
);
2240 /* Show a freakin' whole namespace. */
2243 show_namespace (gfc_namespace
*ns
)
2245 gfc_interface
*intr
;
2246 gfc_namespace
*save
;
2252 save
= gfc_current_ns
;
2255 fputs ("Namespace:", dumpfile
);
2261 while (i
< GFC_LETTERS
- 1
2262 && gfc_compare_types (&ns
->default_type
[i
+1],
2263 &ns
->default_type
[l
]))
2267 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
2269 fprintf (dumpfile
, " %c: ", l
+'A');
2271 show_typespec(&ns
->default_type
[l
]);
2273 } while (i
< GFC_LETTERS
);
2275 if (ns
->proc_name
!= NULL
)
2278 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
2282 gfc_current_ns
= ns
;
2283 gfc_traverse_symtree (ns
->common_root
, show_common
);
2285 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2287 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
2289 /* User operator interfaces */
2295 fprintf (dumpfile
, "Operator interfaces for %s:",
2296 gfc_op2string ((gfc_intrinsic_op
) op
));
2298 for (; intr
; intr
= intr
->next
)
2299 fprintf (dumpfile
, " %s", intr
->sym
->name
);
2302 if (ns
->uop_root
!= NULL
)
2305 fputs ("User operators:\n", dumpfile
);
2306 gfc_traverse_user_op (ns
, show_uop
);
2309 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
2312 fputc ('\n', dumpfile
);
2314 fputs ("code:", dumpfile
);
2315 show_code (show_level
, ns
->code
);
2318 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
2320 fputs ("\nCONTAINS\n", dumpfile
);
2322 show_namespace (ns
);
2326 fputc ('\n', dumpfile
);
2327 gfc_current_ns
= save
;
2331 /* Main function for dumping a parse tree. */
2334 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
2337 show_namespace (ns
);