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_omp_namelist (int list_type
, gfc_omp_namelist
*n
)
1021 for (; n
; n
= n
->next
)
1023 if (list_type
== OMP_LIST_REDUCTION
)
1024 switch (n
->u
.reduction_op
)
1026 case OMP_REDUCTION_PLUS
:
1027 case OMP_REDUCTION_TIMES
:
1028 case OMP_REDUCTION_MINUS
:
1029 case OMP_REDUCTION_AND
:
1030 case OMP_REDUCTION_OR
:
1031 case OMP_REDUCTION_EQV
:
1032 case OMP_REDUCTION_NEQV
:
1033 fprintf (dumpfile
, "%s:",
1034 gfc_op2string ((gfc_intrinsic_op
) n
->u
.reduction_op
));
1036 case OMP_REDUCTION_MAX
: fputs ("max:", dumpfile
); break;
1037 case OMP_REDUCTION_MIN
: fputs ("min:", dumpfile
); break;
1038 case OMP_REDUCTION_IAND
: fputs ("iand:", dumpfile
); break;
1039 case OMP_REDUCTION_IOR
: fputs ("ior:", dumpfile
); break;
1040 case OMP_REDUCTION_IEOR
: fputs ("ieor:", dumpfile
); break;
1041 case OMP_REDUCTION_USER
:
1043 fprintf (dumpfile
, "%s:", n
->udr
->udr
->name
);
1047 else if (list_type
== OMP_LIST_DEPEND
)
1048 switch (n
->u
.depend_op
)
1050 case OMP_DEPEND_IN
: fputs ("in:", dumpfile
); break;
1051 case OMP_DEPEND_OUT
: fputs ("out:", dumpfile
); break;
1052 case OMP_DEPEND_INOUT
: fputs ("inout:", dumpfile
); break;
1055 else if (list_type
== OMP_LIST_MAP
)
1056 switch (n
->u
.map_op
)
1058 case OMP_MAP_ALLOC
: fputs ("alloc:", dumpfile
); break;
1059 case OMP_MAP_TO
: fputs ("to:", dumpfile
); break;
1060 case OMP_MAP_FROM
: fputs ("from:", dumpfile
); break;
1061 case OMP_MAP_TOFROM
: fputs ("tofrom:", dumpfile
); break;
1064 fprintf (dumpfile
, "%s", n
->sym
->name
);
1067 fputc (':', dumpfile
);
1068 show_expr (n
->expr
);
1071 fputc (',', dumpfile
);
1075 /* Show a single OpenMP directive node and everything underneath it
1079 show_omp_node (int level
, gfc_code
*c
)
1081 gfc_omp_clauses
*omp_clauses
= NULL
;
1082 const char *name
= NULL
;
1086 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
1087 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
1088 case EXEC_OMP_CANCEL
: name
= "CANCEL"; break;
1089 case EXEC_OMP_CANCELLATION_POINT
: name
= "CANCELLATION POINT"; break;
1090 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
1091 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
1092 case EXEC_OMP_DO
: name
= "DO"; break;
1093 case EXEC_OMP_DO_SIMD
: name
= "DO SIMD"; break;
1094 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
1095 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
1096 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
1097 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
1098 case EXEC_OMP_PARALLEL_DO_SIMD
: name
= "PARALLEL DO SIMD"; break;
1099 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
1100 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
1101 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
1102 case EXEC_OMP_SIMD
: name
= "SIMD"; break;
1103 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
1104 case EXEC_OMP_TASK
: name
= "TASK"; break;
1105 case EXEC_OMP_TASKGROUP
: name
= "TASKGROUP"; break;
1106 case EXEC_OMP_TASKWAIT
: name
= "TASKWAIT"; break;
1107 case EXEC_OMP_TASKYIELD
: name
= "TASKYIELD"; break;
1108 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
1112 fprintf (dumpfile
, "!$OMP %s", name
);
1115 case EXEC_OMP_CANCEL
:
1116 case EXEC_OMP_CANCELLATION_POINT
:
1118 case EXEC_OMP_DO_SIMD
:
1119 case EXEC_OMP_PARALLEL
:
1120 case EXEC_OMP_PARALLEL_DO
:
1121 case EXEC_OMP_PARALLEL_DO_SIMD
:
1122 case EXEC_OMP_PARALLEL_SECTIONS
:
1123 case EXEC_OMP_SECTIONS
:
1125 case EXEC_OMP_SINGLE
:
1126 case EXEC_OMP_WORKSHARE
:
1127 case EXEC_OMP_PARALLEL_WORKSHARE
:
1129 omp_clauses
= c
->ext
.omp_clauses
;
1131 case EXEC_OMP_CRITICAL
:
1132 if (c
->ext
.omp_name
)
1133 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1135 case EXEC_OMP_FLUSH
:
1136 if (c
->ext
.omp_namelist
)
1138 fputs (" (", dumpfile
);
1139 show_omp_namelist (OMP_LIST_NUM
, c
->ext
.omp_namelist
);
1140 fputc (')', dumpfile
);
1143 case EXEC_OMP_BARRIER
:
1144 case EXEC_OMP_TASKWAIT
:
1145 case EXEC_OMP_TASKYIELD
:
1154 switch (omp_clauses
->cancel
)
1156 case OMP_CANCEL_UNKNOWN
:
1158 case OMP_CANCEL_PARALLEL
:
1159 fputs (" PARALLEL", dumpfile
);
1161 case OMP_CANCEL_SECTIONS
:
1162 fputs (" SECTIONS", dumpfile
);
1165 fputs (" DO", dumpfile
);
1167 case OMP_CANCEL_TASKGROUP
:
1168 fputs (" TASKGROUP", dumpfile
);
1171 if (omp_clauses
->if_expr
)
1173 fputs (" IF(", dumpfile
);
1174 show_expr (omp_clauses
->if_expr
);
1175 fputc (')', dumpfile
);
1177 if (omp_clauses
->final_expr
)
1179 fputs (" FINAL(", dumpfile
);
1180 show_expr (omp_clauses
->final_expr
);
1181 fputc (')', dumpfile
);
1183 if (omp_clauses
->num_threads
)
1185 fputs (" NUM_THREADS(", dumpfile
);
1186 show_expr (omp_clauses
->num_threads
);
1187 fputc (')', dumpfile
);
1189 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
1192 switch (omp_clauses
->sched_kind
)
1194 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
1195 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
1196 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
1197 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
1198 case OMP_SCHED_AUTO
: type
= "AUTO"; break;
1202 fprintf (dumpfile
, " SCHEDULE (%s", type
);
1203 if (omp_clauses
->chunk_size
)
1205 fputc (',', dumpfile
);
1206 show_expr (omp_clauses
->chunk_size
);
1208 fputc (')', dumpfile
);
1210 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1213 switch (omp_clauses
->default_sharing
)
1215 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
1216 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
1217 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
1218 case OMP_DEFAULT_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1222 fprintf (dumpfile
, " DEFAULT(%s)", type
);
1224 if (omp_clauses
->ordered
)
1225 fputs (" ORDERED", dumpfile
);
1226 if (omp_clauses
->untied
)
1227 fputs (" UNTIED", dumpfile
);
1228 if (omp_clauses
->mergeable
)
1229 fputs (" MERGEABLE", dumpfile
);
1230 if (omp_clauses
->collapse
)
1231 fprintf (dumpfile
, " COLLAPSE(%d)", omp_clauses
->collapse
);
1232 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
1233 if (omp_clauses
->lists
[list_type
] != NULL
1234 && list_type
!= OMP_LIST_COPYPRIVATE
)
1236 const char *type
= NULL
;
1239 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
1240 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1241 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
1242 case OMP_LIST_SHARED
: type
= "SHARED"; break;
1243 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
1244 case OMP_LIST_UNIFORM
: type
= "UNIFORM"; break;
1245 case OMP_LIST_ALIGNED
: type
= "ALIGNED"; break;
1246 case OMP_LIST_LINEAR
: type
= "LINEAR"; break;
1247 case OMP_LIST_REDUCTION
: type
= "REDUCTION"; break;
1248 case OMP_LIST_DEPEND
: type
= "DEPEND"; break;
1252 fprintf (dumpfile
, " %s(", type
);
1253 show_omp_namelist (list_type
, omp_clauses
->lists
[list_type
]);
1254 fputc (')', dumpfile
);
1256 if (omp_clauses
->safelen_expr
)
1258 fputs (" SAFELEN(", dumpfile
);
1259 show_expr (omp_clauses
->safelen_expr
);
1260 fputc (')', dumpfile
);
1262 if (omp_clauses
->simdlen_expr
)
1264 fputs (" SIMDLEN(", dumpfile
);
1265 show_expr (omp_clauses
->simdlen_expr
);
1266 fputc (')', dumpfile
);
1268 if (omp_clauses
->inbranch
)
1269 fputs (" INBRANCH", dumpfile
);
1270 if (omp_clauses
->notinbranch
)
1271 fputs (" NOTINBRANCH", dumpfile
);
1272 if (omp_clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
1275 switch (omp_clauses
->proc_bind
)
1277 case OMP_PROC_BIND_MASTER
: type
= "MASTER"; break;
1278 case OMP_PROC_BIND_SPREAD
: type
= "SPREAD"; break;
1279 case OMP_PROC_BIND_CLOSE
: type
= "CLOSE"; break;
1283 fprintf (dumpfile
, " PROC_BIND(%s)", type
);
1285 if (omp_clauses
->num_teams
)
1287 fputs (" NUM_TEAMS(", dumpfile
);
1288 show_expr (omp_clauses
->num_teams
);
1289 fputc (')', dumpfile
);
1291 if (omp_clauses
->device
)
1293 fputs (" DEVICE(", dumpfile
);
1294 show_expr (omp_clauses
->device
);
1295 fputc (')', dumpfile
);
1297 if (omp_clauses
->thread_limit
)
1299 fputs (" THREAD_LIMIT(", dumpfile
);
1300 show_expr (omp_clauses
->thread_limit
);
1301 fputc (')', dumpfile
);
1303 if (omp_clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
1305 fprintf (dumpfile
, " DIST_SCHEDULE (static");
1306 if (omp_clauses
->dist_chunk_size
)
1308 fputc (',', dumpfile
);
1309 show_expr (omp_clauses
->dist_chunk_size
);
1311 fputc (')', dumpfile
);
1314 fputc ('\n', dumpfile
);
1315 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
1317 gfc_code
*d
= c
->block
;
1320 show_code (level
+ 1, d
->next
);
1321 if (d
->block
== NULL
)
1323 code_indent (level
, 0);
1324 fputs ("!$OMP SECTION\n", dumpfile
);
1329 show_code (level
+ 1, c
->block
->next
);
1330 if (c
->op
== EXEC_OMP_ATOMIC
)
1332 fputc ('\n', dumpfile
);
1333 code_indent (level
, 0);
1334 fprintf (dumpfile
, "!$OMP END %s", name
);
1335 if (omp_clauses
!= NULL
)
1337 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
1339 fputs (" COPYPRIVATE(", dumpfile
);
1340 show_omp_namelist (OMP_LIST_COPYPRIVATE
,
1341 omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1342 fputc (')', dumpfile
);
1344 else if (omp_clauses
->nowait
)
1345 fputs (" NOWAIT", dumpfile
);
1347 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_name
)
1348 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1352 /* Show a single code node and everything underneath it if necessary. */
1355 show_code_node (int level
, gfc_code
*c
)
1357 gfc_forall_iterator
*fa
;
1370 fputc ('\n', dumpfile
);
1371 code_indent (level
, c
->here
);
1378 case EXEC_END_PROCEDURE
:
1382 fputs ("NOP", dumpfile
);
1386 fputs ("CONTINUE", dumpfile
);
1390 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
1393 case EXEC_INIT_ASSIGN
:
1395 fputs ("ASSIGN ", dumpfile
);
1396 show_expr (c
->expr1
);
1397 fputc (' ', dumpfile
);
1398 show_expr (c
->expr2
);
1401 case EXEC_LABEL_ASSIGN
:
1402 fputs ("LABEL ASSIGN ", dumpfile
);
1403 show_expr (c
->expr1
);
1404 fprintf (dumpfile
, " %d", c
->label1
->value
);
1407 case EXEC_POINTER_ASSIGN
:
1408 fputs ("POINTER ASSIGN ", dumpfile
);
1409 show_expr (c
->expr1
);
1410 fputc (' ', dumpfile
);
1411 show_expr (c
->expr2
);
1415 fputs ("GOTO ", dumpfile
);
1417 fprintf (dumpfile
, "%d", c
->label1
->value
);
1420 show_expr (c
->expr1
);
1424 fputs (", (", dumpfile
);
1425 for (; d
; d
= d
->block
)
1427 code_indent (level
, d
->label1
);
1428 if (d
->block
!= NULL
)
1429 fputc (',', dumpfile
);
1431 fputc (')', dumpfile
);
1438 case EXEC_ASSIGN_CALL
:
1439 if (c
->resolved_sym
)
1440 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
1441 else if (c
->symtree
)
1442 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
1444 fputs ("CALL ?? ", dumpfile
);
1446 show_actual_arglist (c
->ext
.actual
);
1450 fputs ("CALL ", dumpfile
);
1451 show_compcall (c
->expr1
);
1455 fputs ("CALL ", dumpfile
);
1456 show_expr (c
->expr1
);
1457 show_actual_arglist (c
->ext
.actual
);
1461 fputs ("RETURN ", dumpfile
);
1463 show_expr (c
->expr1
);
1467 fputs ("PAUSE ", dumpfile
);
1469 if (c
->expr1
!= NULL
)
1470 show_expr (c
->expr1
);
1472 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1476 case EXEC_ERROR_STOP
:
1477 fputs ("ERROR ", dumpfile
);
1481 fputs ("STOP ", dumpfile
);
1483 if (c
->expr1
!= NULL
)
1484 show_expr (c
->expr1
);
1486 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1491 fputs ("SYNC ALL ", dumpfile
);
1492 if (c
->expr2
!= NULL
)
1494 fputs (" stat=", dumpfile
);
1495 show_expr (c
->expr2
);
1497 if (c
->expr3
!= NULL
)
1499 fputs (" errmsg=", dumpfile
);
1500 show_expr (c
->expr3
);
1504 case EXEC_SYNC_MEMORY
:
1505 fputs ("SYNC MEMORY ", dumpfile
);
1506 if (c
->expr2
!= NULL
)
1508 fputs (" stat=", dumpfile
);
1509 show_expr (c
->expr2
);
1511 if (c
->expr3
!= NULL
)
1513 fputs (" errmsg=", dumpfile
);
1514 show_expr (c
->expr3
);
1518 case EXEC_SYNC_IMAGES
:
1519 fputs ("SYNC IMAGES image-set=", dumpfile
);
1520 if (c
->expr1
!= NULL
)
1521 show_expr (c
->expr1
);
1523 fputs ("* ", dumpfile
);
1524 if (c
->expr2
!= NULL
)
1526 fputs (" stat=", dumpfile
);
1527 show_expr (c
->expr2
);
1529 if (c
->expr3
!= NULL
)
1531 fputs (" errmsg=", dumpfile
);
1532 show_expr (c
->expr3
);
1538 if (c
->op
== EXEC_LOCK
)
1539 fputs ("LOCK ", dumpfile
);
1541 fputs ("UNLOCK ", dumpfile
);
1543 fputs ("lock-variable=", dumpfile
);
1544 if (c
->expr1
!= NULL
)
1545 show_expr (c
->expr1
);
1546 if (c
->expr4
!= NULL
)
1548 fputs (" acquired_lock=", dumpfile
);
1549 show_expr (c
->expr4
);
1551 if (c
->expr2
!= NULL
)
1553 fputs (" stat=", dumpfile
);
1554 show_expr (c
->expr2
);
1556 if (c
->expr3
!= NULL
)
1558 fputs (" errmsg=", dumpfile
);
1559 show_expr (c
->expr3
);
1563 case EXEC_ARITHMETIC_IF
:
1564 fputs ("IF ", dumpfile
);
1565 show_expr (c
->expr1
);
1566 fprintf (dumpfile
, " %d, %d, %d",
1567 c
->label1
->value
, c
->label2
->value
, c
->label3
->value
);
1572 fputs ("IF ", dumpfile
);
1573 show_expr (d
->expr1
);
1576 show_code (level
+ 1, d
->next
);
1580 for (; d
; d
= d
->block
)
1582 code_indent (level
, 0);
1584 if (d
->expr1
== NULL
)
1585 fputs ("ELSE", dumpfile
);
1588 fputs ("ELSE IF ", dumpfile
);
1589 show_expr (d
->expr1
);
1593 show_code (level
+ 1, d
->next
);
1598 code_indent (level
, c
->label1
);
1602 fputs ("ENDIF", dumpfile
);
1607 const char* blocktype
;
1608 gfc_namespace
*saved_ns
;
1610 if (c
->ext
.block
.assoc
)
1611 blocktype
= "ASSOCIATE";
1613 blocktype
= "BLOCK";
1615 fprintf (dumpfile
, "%s ", blocktype
);
1617 ns
= c
->ext
.block
.ns
;
1618 saved_ns
= gfc_current_ns
;
1619 gfc_current_ns
= ns
;
1620 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
1621 gfc_current_ns
= saved_ns
;
1622 show_code (show_level
, ns
->code
);
1625 fprintf (dumpfile
, "END %s ", blocktype
);
1631 fputs ("SELECT CASE ", dumpfile
);
1632 show_expr (c
->expr1
);
1633 fputc ('\n', dumpfile
);
1635 for (; d
; d
= d
->block
)
1637 code_indent (level
, 0);
1639 fputs ("CASE ", dumpfile
);
1640 for (cp
= d
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
1642 fputc ('(', dumpfile
);
1643 show_expr (cp
->low
);
1644 fputc (' ', dumpfile
);
1645 show_expr (cp
->high
);
1646 fputc (')', dumpfile
);
1647 fputc (' ', dumpfile
);
1649 fputc ('\n', dumpfile
);
1651 show_code (level
+ 1, d
->next
);
1654 code_indent (level
, c
->label1
);
1655 fputs ("END SELECT", dumpfile
);
1659 fputs ("WHERE ", dumpfile
);
1662 show_expr (d
->expr1
);
1663 fputc ('\n', dumpfile
);
1665 show_code (level
+ 1, d
->next
);
1667 for (d
= d
->block
; d
; d
= d
->block
)
1669 code_indent (level
, 0);
1670 fputs ("ELSE WHERE ", dumpfile
);
1671 show_expr (d
->expr1
);
1672 fputc ('\n', dumpfile
);
1673 show_code (level
+ 1, d
->next
);
1676 code_indent (level
, 0);
1677 fputs ("END WHERE", dumpfile
);
1682 fputs ("FORALL ", dumpfile
);
1683 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1685 show_expr (fa
->var
);
1686 fputc (' ', dumpfile
);
1687 show_expr (fa
->start
);
1688 fputc (':', dumpfile
);
1689 show_expr (fa
->end
);
1690 fputc (':', dumpfile
);
1691 show_expr (fa
->stride
);
1693 if (fa
->next
!= NULL
)
1694 fputc (',', dumpfile
);
1697 if (c
->expr1
!= NULL
)
1699 fputc (',', dumpfile
);
1700 show_expr (c
->expr1
);
1702 fputc ('\n', dumpfile
);
1704 show_code (level
+ 1, c
->block
->next
);
1706 code_indent (level
, 0);
1707 fputs ("END FORALL", dumpfile
);
1711 fputs ("CRITICAL\n", dumpfile
);
1712 show_code (level
+ 1, c
->block
->next
);
1713 code_indent (level
, 0);
1714 fputs ("END CRITICAL", dumpfile
);
1718 fputs ("DO ", dumpfile
);
1720 fprintf (dumpfile
, " %-5d ", c
->label1
->value
);
1722 show_expr (c
->ext
.iterator
->var
);
1723 fputc ('=', dumpfile
);
1724 show_expr (c
->ext
.iterator
->start
);
1725 fputc (' ', dumpfile
);
1726 show_expr (c
->ext
.iterator
->end
);
1727 fputc (' ', dumpfile
);
1728 show_expr (c
->ext
.iterator
->step
);
1731 show_code (level
+ 1, c
->block
->next
);
1738 fputs ("END DO", dumpfile
);
1741 case EXEC_DO_CONCURRENT
:
1742 fputs ("DO CONCURRENT ", dumpfile
);
1743 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1745 show_expr (fa
->var
);
1746 fputc (' ', dumpfile
);
1747 show_expr (fa
->start
);
1748 fputc (':', dumpfile
);
1749 show_expr (fa
->end
);
1750 fputc (':', dumpfile
);
1751 show_expr (fa
->stride
);
1753 if (fa
->next
!= NULL
)
1754 fputc (',', dumpfile
);
1756 show_expr (c
->expr1
);
1758 show_code (level
+ 1, c
->block
->next
);
1759 code_indent (level
, c
->label1
);
1760 fputs ("END DO", dumpfile
);
1764 fputs ("DO WHILE ", dumpfile
);
1765 show_expr (c
->expr1
);
1766 fputc ('\n', dumpfile
);
1768 show_code (level
+ 1, c
->block
->next
);
1770 code_indent (level
, c
->label1
);
1771 fputs ("END DO", dumpfile
);
1775 fputs ("CYCLE", dumpfile
);
1777 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1781 fputs ("EXIT", dumpfile
);
1783 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1787 fputs ("ALLOCATE ", dumpfile
);
1790 fputs (" STAT=", dumpfile
);
1791 show_expr (c
->expr1
);
1796 fputs (" ERRMSG=", dumpfile
);
1797 show_expr (c
->expr2
);
1803 fputs (" MOLD=", dumpfile
);
1805 fputs (" SOURCE=", dumpfile
);
1806 show_expr (c
->expr3
);
1809 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
1811 fputc (' ', dumpfile
);
1812 show_expr (a
->expr
);
1817 case EXEC_DEALLOCATE
:
1818 fputs ("DEALLOCATE ", dumpfile
);
1821 fputs (" STAT=", dumpfile
);
1822 show_expr (c
->expr1
);
1827 fputs (" ERRMSG=", dumpfile
);
1828 show_expr (c
->expr2
);
1831 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
1833 fputc (' ', dumpfile
);
1834 show_expr (a
->expr
);
1840 fputs ("OPEN", dumpfile
);
1845 fputs (" UNIT=", dumpfile
);
1846 show_expr (open
->unit
);
1850 fputs (" IOMSG=", dumpfile
);
1851 show_expr (open
->iomsg
);
1855 fputs (" IOSTAT=", dumpfile
);
1856 show_expr (open
->iostat
);
1860 fputs (" FILE=", dumpfile
);
1861 show_expr (open
->file
);
1865 fputs (" STATUS=", dumpfile
);
1866 show_expr (open
->status
);
1870 fputs (" ACCESS=", dumpfile
);
1871 show_expr (open
->access
);
1875 fputs (" FORM=", dumpfile
);
1876 show_expr (open
->form
);
1880 fputs (" RECL=", dumpfile
);
1881 show_expr (open
->recl
);
1885 fputs (" BLANK=", dumpfile
);
1886 show_expr (open
->blank
);
1890 fputs (" POSITION=", dumpfile
);
1891 show_expr (open
->position
);
1895 fputs (" ACTION=", dumpfile
);
1896 show_expr (open
->action
);
1900 fputs (" DELIM=", dumpfile
);
1901 show_expr (open
->delim
);
1905 fputs (" PAD=", dumpfile
);
1906 show_expr (open
->pad
);
1910 fputs (" DECIMAL=", dumpfile
);
1911 show_expr (open
->decimal
);
1915 fputs (" ENCODING=", dumpfile
);
1916 show_expr (open
->encoding
);
1920 fputs (" ROUND=", dumpfile
);
1921 show_expr (open
->round
);
1925 fputs (" SIGN=", dumpfile
);
1926 show_expr (open
->sign
);
1930 fputs (" CONVERT=", dumpfile
);
1931 show_expr (open
->convert
);
1933 if (open
->asynchronous
)
1935 fputs (" ASYNCHRONOUS=", dumpfile
);
1936 show_expr (open
->asynchronous
);
1938 if (open
->err
!= NULL
)
1939 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
1944 fputs ("CLOSE", dumpfile
);
1945 close
= c
->ext
.close
;
1949 fputs (" UNIT=", dumpfile
);
1950 show_expr (close
->unit
);
1954 fputs (" IOMSG=", dumpfile
);
1955 show_expr (close
->iomsg
);
1959 fputs (" IOSTAT=", dumpfile
);
1960 show_expr (close
->iostat
);
1964 fputs (" STATUS=", dumpfile
);
1965 show_expr (close
->status
);
1967 if (close
->err
!= NULL
)
1968 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
1971 case EXEC_BACKSPACE
:
1972 fputs ("BACKSPACE", dumpfile
);
1976 fputs ("ENDFILE", dumpfile
);
1980 fputs ("REWIND", dumpfile
);
1984 fputs ("FLUSH", dumpfile
);
1987 fp
= c
->ext
.filepos
;
1991 fputs (" UNIT=", dumpfile
);
1992 show_expr (fp
->unit
);
1996 fputs (" IOMSG=", dumpfile
);
1997 show_expr (fp
->iomsg
);
2001 fputs (" IOSTAT=", dumpfile
);
2002 show_expr (fp
->iostat
);
2004 if (fp
->err
!= NULL
)
2005 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
2009 fputs ("INQUIRE", dumpfile
);
2014 fputs (" UNIT=", dumpfile
);
2015 show_expr (i
->unit
);
2019 fputs (" FILE=", dumpfile
);
2020 show_expr (i
->file
);
2025 fputs (" IOMSG=", dumpfile
);
2026 show_expr (i
->iomsg
);
2030 fputs (" IOSTAT=", dumpfile
);
2031 show_expr (i
->iostat
);
2035 fputs (" EXIST=", dumpfile
);
2036 show_expr (i
->exist
);
2040 fputs (" OPENED=", dumpfile
);
2041 show_expr (i
->opened
);
2045 fputs (" NUMBER=", dumpfile
);
2046 show_expr (i
->number
);
2050 fputs (" NAMED=", dumpfile
);
2051 show_expr (i
->named
);
2055 fputs (" NAME=", dumpfile
);
2056 show_expr (i
->name
);
2060 fputs (" ACCESS=", dumpfile
);
2061 show_expr (i
->access
);
2065 fputs (" SEQUENTIAL=", dumpfile
);
2066 show_expr (i
->sequential
);
2071 fputs (" DIRECT=", dumpfile
);
2072 show_expr (i
->direct
);
2076 fputs (" FORM=", dumpfile
);
2077 show_expr (i
->form
);
2081 fputs (" FORMATTED", dumpfile
);
2082 show_expr (i
->formatted
);
2086 fputs (" UNFORMATTED=", dumpfile
);
2087 show_expr (i
->unformatted
);
2091 fputs (" RECL=", dumpfile
);
2092 show_expr (i
->recl
);
2096 fputs (" NEXTREC=", dumpfile
);
2097 show_expr (i
->nextrec
);
2101 fputs (" BLANK=", dumpfile
);
2102 show_expr (i
->blank
);
2106 fputs (" POSITION=", dumpfile
);
2107 show_expr (i
->position
);
2111 fputs (" ACTION=", dumpfile
);
2112 show_expr (i
->action
);
2116 fputs (" READ=", dumpfile
);
2117 show_expr (i
->read
);
2121 fputs (" WRITE=", dumpfile
);
2122 show_expr (i
->write
);
2126 fputs (" READWRITE=", dumpfile
);
2127 show_expr (i
->readwrite
);
2131 fputs (" DELIM=", dumpfile
);
2132 show_expr (i
->delim
);
2136 fputs (" PAD=", dumpfile
);
2141 fputs (" CONVERT=", dumpfile
);
2142 show_expr (i
->convert
);
2144 if (i
->asynchronous
)
2146 fputs (" ASYNCHRONOUS=", dumpfile
);
2147 show_expr (i
->asynchronous
);
2151 fputs (" DECIMAL=", dumpfile
);
2152 show_expr (i
->decimal
);
2156 fputs (" ENCODING=", dumpfile
);
2157 show_expr (i
->encoding
);
2161 fputs (" PENDING=", dumpfile
);
2162 show_expr (i
->pending
);
2166 fputs (" ROUND=", dumpfile
);
2167 show_expr (i
->round
);
2171 fputs (" SIGN=", dumpfile
);
2172 show_expr (i
->sign
);
2176 fputs (" SIZE=", dumpfile
);
2177 show_expr (i
->size
);
2181 fputs (" ID=", dumpfile
);
2186 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
2190 fputs ("IOLENGTH ", dumpfile
);
2191 show_expr (c
->expr1
);
2196 fputs ("READ", dumpfile
);
2200 fputs ("WRITE", dumpfile
);
2206 fputs (" UNIT=", dumpfile
);
2207 show_expr (dt
->io_unit
);
2210 if (dt
->format_expr
)
2212 fputs (" FMT=", dumpfile
);
2213 show_expr (dt
->format_expr
);
2216 if (dt
->format_label
!= NULL
)
2217 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
2219 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
2223 fputs (" IOMSG=", dumpfile
);
2224 show_expr (dt
->iomsg
);
2228 fputs (" IOSTAT=", dumpfile
);
2229 show_expr (dt
->iostat
);
2233 fputs (" SIZE=", dumpfile
);
2234 show_expr (dt
->size
);
2238 fputs (" REC=", dumpfile
);
2239 show_expr (dt
->rec
);
2243 fputs (" ADVANCE=", dumpfile
);
2244 show_expr (dt
->advance
);
2248 fputs (" ID=", dumpfile
);
2253 fputs (" POS=", dumpfile
);
2254 show_expr (dt
->pos
);
2256 if (dt
->asynchronous
)
2258 fputs (" ASYNCHRONOUS=", dumpfile
);
2259 show_expr (dt
->asynchronous
);
2263 fputs (" BLANK=", dumpfile
);
2264 show_expr (dt
->blank
);
2268 fputs (" DECIMAL=", dumpfile
);
2269 show_expr (dt
->decimal
);
2273 fputs (" DELIM=", dumpfile
);
2274 show_expr (dt
->delim
);
2278 fputs (" PAD=", dumpfile
);
2279 show_expr (dt
->pad
);
2283 fputs (" ROUND=", dumpfile
);
2284 show_expr (dt
->round
);
2288 fputs (" SIGN=", dumpfile
);
2289 show_expr (dt
->sign
);
2293 for (c
= c
->block
->next
; c
; c
= c
->next
)
2294 show_code_node (level
+ (c
->next
!= NULL
), c
);
2298 fputs ("TRANSFER ", dumpfile
);
2299 show_expr (c
->expr1
);
2303 fputs ("DT_END", dumpfile
);
2306 if (dt
->err
!= NULL
)
2307 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
2308 if (dt
->end
!= NULL
)
2309 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
2310 if (dt
->eor
!= NULL
)
2311 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
2314 case EXEC_OMP_ATOMIC
:
2315 case EXEC_OMP_CANCEL
:
2316 case EXEC_OMP_CANCELLATION_POINT
:
2317 case EXEC_OMP_BARRIER
:
2318 case EXEC_OMP_CRITICAL
:
2319 case EXEC_OMP_FLUSH
:
2321 case EXEC_OMP_DO_SIMD
:
2322 case EXEC_OMP_MASTER
:
2323 case EXEC_OMP_ORDERED
:
2324 case EXEC_OMP_PARALLEL
:
2325 case EXEC_OMP_PARALLEL_DO
:
2326 case EXEC_OMP_PARALLEL_DO_SIMD
:
2327 case EXEC_OMP_PARALLEL_SECTIONS
:
2328 case EXEC_OMP_PARALLEL_WORKSHARE
:
2329 case EXEC_OMP_SECTIONS
:
2331 case EXEC_OMP_SINGLE
:
2333 case EXEC_OMP_TASKGROUP
:
2334 case EXEC_OMP_TASKWAIT
:
2335 case EXEC_OMP_TASKYIELD
:
2336 case EXEC_OMP_WORKSHARE
:
2337 show_omp_node (level
, c
);
2341 gfc_internal_error ("show_code_node(): Bad statement code");
2346 /* Show an equivalence chain. */
2349 show_equiv (gfc_equiv
*eq
)
2352 fputs ("Equivalence: ", dumpfile
);
2355 show_expr (eq
->expr
);
2358 fputs (", ", dumpfile
);
2363 /* Show a freakin' whole namespace. */
2366 show_namespace (gfc_namespace
*ns
)
2368 gfc_interface
*intr
;
2369 gfc_namespace
*save
;
2375 save
= gfc_current_ns
;
2378 fputs ("Namespace:", dumpfile
);
2384 while (i
< GFC_LETTERS
- 1
2385 && gfc_compare_types (&ns
->default_type
[i
+1],
2386 &ns
->default_type
[l
]))
2390 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
2392 fprintf (dumpfile
, " %c: ", l
+'A');
2394 show_typespec(&ns
->default_type
[l
]);
2396 } while (i
< GFC_LETTERS
);
2398 if (ns
->proc_name
!= NULL
)
2401 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
2405 gfc_current_ns
= ns
;
2406 gfc_traverse_symtree (ns
->common_root
, show_common
);
2408 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2410 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
2412 /* User operator interfaces */
2418 fprintf (dumpfile
, "Operator interfaces for %s:",
2419 gfc_op2string ((gfc_intrinsic_op
) op
));
2421 for (; intr
; intr
= intr
->next
)
2422 fprintf (dumpfile
, " %s", intr
->sym
->name
);
2425 if (ns
->uop_root
!= NULL
)
2428 fputs ("User operators:\n", dumpfile
);
2429 gfc_traverse_user_op (ns
, show_uop
);
2432 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
2435 fputc ('\n', dumpfile
);
2437 fputs ("code:", dumpfile
);
2438 show_code (show_level
, ns
->code
);
2441 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
2443 fputs ("\nCONTAINS\n", dumpfile
);
2445 show_namespace (ns
);
2449 fputc ('\n', dumpfile
);
2450 gfc_current_ns
= save
;
2454 /* Main function for dumping a parse tree. */
2457 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
2460 show_namespace (ns
);