2 Copyright (C) 2003-2016 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
));
110 fprintf (dumpfile
, "%s", ts
->u
.derived
->name
);
115 show_expr (ts
->u
.cl
->length
);
116 fprintf(dumpfile
, " %d", ts
->kind
);
120 fprintf (dumpfile
, "%d", ts
->kind
);
123 if (ts
->is_c_interop
)
124 fputs (" C_INTEROP", dumpfile
);
127 fputs (" ISO_C", dumpfile
);
130 fputs (" DEFERRED", dumpfile
);
132 fputc (')', dumpfile
);
136 /* Show an actual argument list. */
139 show_actual_arglist (gfc_actual_arglist
*a
)
141 fputc ('(', dumpfile
);
143 for (; a
; a
= a
->next
)
145 fputc ('(', dumpfile
);
147 fprintf (dumpfile
, "%s = ", a
->name
);
151 fputs ("(arg not-present)", dumpfile
);
153 fputc (')', dumpfile
);
155 fputc (' ', dumpfile
);
158 fputc (')', dumpfile
);
162 /* Show a gfc_array_spec array specification structure. */
165 show_array_spec (gfc_array_spec
*as
)
172 fputs ("()", dumpfile
);
176 fprintf (dumpfile
, "(%d [%d]", as
->rank
, as
->corank
);
178 if (as
->rank
+ as
->corank
> 0 || as
->rank
== -1)
182 case AS_EXPLICIT
: c
= "AS_EXPLICIT"; break;
183 case AS_DEFERRED
: c
= "AS_DEFERRED"; break;
184 case AS_ASSUMED_SIZE
: c
= "AS_ASSUMED_SIZE"; break;
185 case AS_ASSUMED_SHAPE
: c
= "AS_ASSUMED_SHAPE"; break;
186 case AS_ASSUMED_RANK
: c
= "AS_ASSUMED_RANK"; break;
188 gfc_internal_error ("show_array_spec(): Unhandled array shape "
191 fprintf (dumpfile
, " %s ", c
);
193 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
195 show_expr (as
->lower
[i
]);
196 fputc (' ', dumpfile
);
197 show_expr (as
->upper
[i
]);
198 fputc (' ', dumpfile
);
202 fputc (')', dumpfile
);
206 /* Show a gfc_array_ref array reference structure. */
209 show_array_ref (gfc_array_ref
* ar
)
213 fputc ('(', dumpfile
);
218 fputs ("FULL", dumpfile
);
222 for (i
= 0; i
< ar
->dimen
; i
++)
224 /* There are two types of array sections: either the
225 elements are identified by an integer array ('vector'),
226 or by an index range. In the former case we only have to
227 print the start expression which contains the vector, in
228 the latter case we have to print any of lower and upper
229 bound and the stride, if they're present. */
231 if (ar
->start
[i
] != NULL
)
232 show_expr (ar
->start
[i
]);
234 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
236 fputc (':', dumpfile
);
238 if (ar
->end
[i
] != NULL
)
239 show_expr (ar
->end
[i
]);
241 if (ar
->stride
[i
] != NULL
)
243 fputc (':', dumpfile
);
244 show_expr (ar
->stride
[i
]);
248 if (i
!= ar
->dimen
- 1)
249 fputs (" , ", dumpfile
);
254 for (i
= 0; i
< ar
->dimen
; i
++)
256 show_expr (ar
->start
[i
]);
257 if (i
!= ar
->dimen
- 1)
258 fputs (" , ", dumpfile
);
263 fputs ("UNKNOWN", dumpfile
);
267 gfc_internal_error ("show_array_ref(): Unknown array reference");
270 fputc (')', dumpfile
);
274 /* Show a list of gfc_ref structures. */
277 show_ref (gfc_ref
*p
)
279 for (; p
; p
= p
->next
)
283 show_array_ref (&p
->u
.ar
);
287 fprintf (dumpfile
, " %% %s", p
->u
.c
.component
->name
);
291 fputc ('(', dumpfile
);
292 show_expr (p
->u
.ss
.start
);
293 fputc (':', dumpfile
);
294 show_expr (p
->u
.ss
.end
);
295 fputc (')', dumpfile
);
299 gfc_internal_error ("show_ref(): Bad component code");
304 /* Display a constructor. Works recursively for array constructors. */
307 show_constructor (gfc_constructor_base base
)
310 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
312 if (c
->iterator
== NULL
)
316 fputc ('(', dumpfile
);
319 fputc (' ', dumpfile
);
320 show_expr (c
->iterator
->var
);
321 fputc ('=', dumpfile
);
322 show_expr (c
->iterator
->start
);
323 fputc (',', dumpfile
);
324 show_expr (c
->iterator
->end
);
325 fputc (',', dumpfile
);
326 show_expr (c
->iterator
->step
);
328 fputc (')', dumpfile
);
331 if (gfc_constructor_next (c
) != NULL
)
332 fputs (" , ", dumpfile
);
338 show_char_const (const gfc_char_t
*c
, int length
)
342 fputc ('\'', dumpfile
);
343 for (i
= 0; i
< length
; i
++)
346 fputs ("''", dumpfile
);
348 fputs (gfc_print_wide_char (c
[i
]), dumpfile
);
350 fputc ('\'', dumpfile
);
354 /* Show a component-call expression. */
357 show_compcall (gfc_expr
* p
)
359 gcc_assert (p
->expr_type
== EXPR_COMPCALL
);
361 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
363 fprintf (dumpfile
, "%s", p
->value
.compcall
.name
);
365 show_actual_arglist (p
->value
.compcall
.actual
);
369 /* Show an expression. */
372 show_expr (gfc_expr
*p
)
379 fputs ("()", dumpfile
);
383 switch (p
->expr_type
)
386 show_char_const (p
->value
.character
.string
, p
->value
.character
.length
);
391 fprintf (dumpfile
, "%s(", p
->ts
.u
.derived
->name
);
392 show_constructor (p
->value
.constructor
);
393 fputc (')', dumpfile
);
397 fputs ("(/ ", dumpfile
);
398 show_constructor (p
->value
.constructor
);
399 fputs (" /)", dumpfile
);
405 fputs ("NULL()", dumpfile
);
412 mpz_out_str (stdout
, 10, p
->value
.integer
);
414 if (p
->ts
.kind
!= gfc_default_integer_kind
)
415 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
419 if (p
->value
.logical
)
420 fputs (".true.", dumpfile
);
422 fputs (".false.", dumpfile
);
426 mpfr_out_str (stdout
, 10, 0, p
->value
.real
, GFC_RND_MODE
);
427 if (p
->ts
.kind
!= gfc_default_real_kind
)
428 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
432 show_char_const (p
->value
.character
.string
,
433 p
->value
.character
.length
);
437 fputs ("(complex ", dumpfile
);
439 mpfr_out_str (stdout
, 10, 0, mpc_realref (p
->value
.complex),
441 if (p
->ts
.kind
!= gfc_default_complex_kind
)
442 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
444 fputc (' ', dumpfile
);
446 mpfr_out_str (stdout
, 10, 0, mpc_imagref (p
->value
.complex),
448 if (p
->ts
.kind
!= gfc_default_complex_kind
)
449 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
451 fputc (')', dumpfile
);
455 fprintf (dumpfile
, "%dH", p
->representation
.length
);
456 c
= p
->representation
.string
;
457 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
459 fputc (*c
, dumpfile
);
464 fputs ("???", dumpfile
);
468 if (p
->representation
.string
)
470 fputs (" {", dumpfile
);
471 c
= p
->representation
.string
;
472 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
474 fprintf (dumpfile
, "%.2x", (unsigned int) *c
);
475 if (i
< p
->representation
.length
- 1)
476 fputc (',', dumpfile
);
478 fputc ('}', dumpfile
);
484 if (p
->symtree
->n
.sym
->ns
&& p
->symtree
->n
.sym
->ns
->proc_name
)
485 fprintf (dumpfile
, "%s:", p
->symtree
->n
.sym
->ns
->proc_name
->name
);
486 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
491 fputc ('(', dumpfile
);
492 switch (p
->value
.op
.op
)
494 case INTRINSIC_UPLUS
:
495 fputs ("U+ ", dumpfile
);
497 case INTRINSIC_UMINUS
:
498 fputs ("U- ", dumpfile
);
501 fputs ("+ ", dumpfile
);
503 case INTRINSIC_MINUS
:
504 fputs ("- ", dumpfile
);
506 case INTRINSIC_TIMES
:
507 fputs ("* ", dumpfile
);
509 case INTRINSIC_DIVIDE
:
510 fputs ("/ ", dumpfile
);
512 case INTRINSIC_POWER
:
513 fputs ("** ", dumpfile
);
515 case INTRINSIC_CONCAT
:
516 fputs ("// ", dumpfile
);
519 fputs ("AND ", dumpfile
);
522 fputs ("OR ", dumpfile
);
525 fputs ("EQV ", dumpfile
);
528 fputs ("NEQV ", dumpfile
);
531 case INTRINSIC_EQ_OS
:
532 fputs ("= ", dumpfile
);
535 case INTRINSIC_NE_OS
:
536 fputs ("/= ", dumpfile
);
539 case INTRINSIC_GT_OS
:
540 fputs ("> ", dumpfile
);
543 case INTRINSIC_GE_OS
:
544 fputs (">= ", dumpfile
);
547 case INTRINSIC_LT_OS
:
548 fputs ("< ", dumpfile
);
551 case INTRINSIC_LE_OS
:
552 fputs ("<= ", dumpfile
);
555 fputs ("NOT ", dumpfile
);
557 case INTRINSIC_PARENTHESES
:
558 fputs ("parens ", dumpfile
);
563 ("show_expr(): Bad intrinsic in expression!");
566 show_expr (p
->value
.op
.op1
);
570 fputc (' ', dumpfile
);
571 show_expr (p
->value
.op
.op2
);
574 fputc (')', dumpfile
);
578 if (p
->value
.function
.name
== NULL
)
580 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
581 if (gfc_is_proc_ptr_comp (p
))
583 fputc ('[', dumpfile
);
584 show_actual_arglist (p
->value
.function
.actual
);
585 fputc (']', dumpfile
);
589 fprintf (dumpfile
, "%s", p
->value
.function
.name
);
590 if (gfc_is_proc_ptr_comp (p
))
592 fputc ('[', dumpfile
);
593 fputc ('[', dumpfile
);
594 show_actual_arglist (p
->value
.function
.actual
);
595 fputc (']', dumpfile
);
596 fputc (']', dumpfile
);
606 gfc_internal_error ("show_expr(): Don't know how to show expr");
610 /* Show symbol attributes. The flavor and intent are followed by
611 whatever single bit attributes are present. */
614 show_attr (symbol_attribute
*attr
, const char * module
)
616 if (attr
->flavor
!= FL_UNKNOWN
)
617 fprintf (dumpfile
, "(%s ", gfc_code2string (flavors
, attr
->flavor
));
618 if (attr
->access
!= ACCESS_UNKNOWN
)
619 fprintf (dumpfile
, "%s ", gfc_code2string (access_types
, attr
->access
));
620 if (attr
->proc
!= PROC_UNKNOWN
)
621 fprintf (dumpfile
, "%s ", gfc_code2string (procedures
, attr
->proc
));
622 if (attr
->save
!= SAVE_NONE
)
623 fprintf (dumpfile
, "%s", gfc_code2string (save_status
, attr
->save
));
625 if (attr
->artificial
)
626 fputs (" ARTIFICIAL", dumpfile
);
627 if (attr
->allocatable
)
628 fputs (" ALLOCATABLE", dumpfile
);
629 if (attr
->asynchronous
)
630 fputs (" ASYNCHRONOUS", dumpfile
);
631 if (attr
->codimension
)
632 fputs (" CODIMENSION", dumpfile
);
634 fputs (" DIMENSION", dumpfile
);
635 if (attr
->contiguous
)
636 fputs (" CONTIGUOUS", dumpfile
);
638 fputs (" EXTERNAL", dumpfile
);
640 fputs (" INTRINSIC", dumpfile
);
642 fputs (" OPTIONAL", dumpfile
);
644 fputs (" POINTER", dumpfile
);
645 if (attr
->is_protected
)
646 fputs (" PROTECTED", dumpfile
);
648 fputs (" VALUE", dumpfile
);
650 fputs (" VOLATILE", dumpfile
);
651 if (attr
->threadprivate
)
652 fputs (" THREADPRIVATE", dumpfile
);
654 fputs (" TARGET", dumpfile
);
657 fputs (" DUMMY", dumpfile
);
658 if (attr
->intent
!= INTENT_UNKNOWN
)
659 fprintf (dumpfile
, "(%s)", gfc_intent_string (attr
->intent
));
663 fputs (" RESULT", dumpfile
);
665 fputs (" ENTRY", dumpfile
);
667 fputs (" BIND(C)", dumpfile
);
670 fputs (" DATA", dumpfile
);
673 fputs (" USE-ASSOC", dumpfile
);
675 fprintf (dumpfile
, "(%s)", module
);
678 if (attr
->in_namelist
)
679 fputs (" IN-NAMELIST", dumpfile
);
681 fputs (" IN-COMMON", dumpfile
);
684 fputs (" ABSTRACT", dumpfile
);
686 fputs (" FUNCTION", dumpfile
);
687 if (attr
->subroutine
)
688 fputs (" SUBROUTINE", dumpfile
);
689 if (attr
->implicit_type
)
690 fputs (" IMPLICIT-TYPE", dumpfile
);
693 fputs (" SEQUENCE", dumpfile
);
695 fputs (" ELEMENTAL", dumpfile
);
697 fputs (" PURE", dumpfile
);
699 fputs (" RECURSIVE", dumpfile
);
701 fputc (')', dumpfile
);
705 /* Show components of a derived type. */
708 show_components (gfc_symbol
*sym
)
712 for (c
= sym
->components
; c
; c
= c
->next
)
714 fprintf (dumpfile
, "(%s ", c
->name
);
715 show_typespec (&c
->ts
);
716 if (c
->attr
.allocatable
)
717 fputs (" ALLOCATABLE", dumpfile
);
719 fputs (" POINTER", dumpfile
);
720 if (c
->attr
.proc_pointer
)
721 fputs (" PPC", dumpfile
);
722 if (c
->attr
.dimension
)
723 fputs (" DIMENSION", dumpfile
);
724 fputc (' ', dumpfile
);
725 show_array_spec (c
->as
);
727 fprintf (dumpfile
, " %s", gfc_code2string (access_types
, c
->attr
.access
));
728 fputc (')', dumpfile
);
730 fputc (' ', dumpfile
);
735 /* Show the f2k_derived namespace with procedure bindings. */
738 show_typebound_proc (gfc_typebound_proc
* tb
, const char* name
)
743 fputs ("GENERIC", dumpfile
);
746 fputs ("PROCEDURE, ", dumpfile
);
748 fputs ("NOPASS", dumpfile
);
752 fprintf (dumpfile
, "PASS(%s)", tb
->pass_arg
);
754 fputs ("PASS", dumpfile
);
756 if (tb
->non_overridable
)
757 fputs (", NON_OVERRIDABLE", dumpfile
);
760 if (tb
->access
== ACCESS_PUBLIC
)
761 fputs (", PUBLIC", dumpfile
);
763 fputs (", PRIVATE", dumpfile
);
765 fprintf (dumpfile
, " :: %s => ", name
);
770 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
772 fputs (g
->specific_st
->name
, dumpfile
);
774 fputs (", ", dumpfile
);
778 fputs (tb
->u
.specific
->n
.sym
->name
, dumpfile
);
782 show_typebound_symtree (gfc_symtree
* st
)
784 gcc_assert (st
->n
.tb
);
785 show_typebound_proc (st
->n
.tb
, st
->name
);
789 show_f2k_derived (gfc_namespace
* f2k
)
795 fputs ("Procedure bindings:", dumpfile
);
798 /* Finalizer bindings. */
799 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
802 fprintf (dumpfile
, "FINAL %s", f
->proc_tree
->n
.sym
->name
);
805 /* Type-bound procedures. */
806 gfc_traverse_symtree (f2k
->tb_sym_root
, &show_typebound_symtree
);
811 fputs ("Operator bindings:", dumpfile
);
814 /* User-defined operators. */
815 gfc_traverse_symtree (f2k
->tb_uop_root
, &show_typebound_symtree
);
817 /* Intrinsic operators. */
818 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
820 show_typebound_proc (f2k
->tb_op
[op
],
821 gfc_op2string ((gfc_intrinsic_op
) op
));
827 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
828 show the interface. Information needed to reconstruct the list of
829 specific interfaces associated with a generic symbol is done within
833 show_symbol (gfc_symbol
*sym
)
835 gfc_formal_arglist
*formal
;
842 fprintf (dumpfile
, "|| symbol: '%s' ", sym
->name
);
843 len
= strlen (sym
->name
);
844 for (i
=len
; i
<12; i
++)
845 fputc(' ', dumpfile
);
850 fputs ("type spec : ", dumpfile
);
851 show_typespec (&sym
->ts
);
854 fputs ("attributes: ", dumpfile
);
855 show_attr (&sym
->attr
, sym
->module
);
860 fputs ("value: ", dumpfile
);
861 show_expr (sym
->value
);
867 fputs ("Array spec:", dumpfile
);
868 show_array_spec (sym
->as
);
874 fputs ("Generic interfaces:", dumpfile
);
875 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
876 fprintf (dumpfile
, " %s", intr
->sym
->name
);
882 fprintf (dumpfile
, "result: %s", sym
->result
->name
);
888 fputs ("components: ", dumpfile
);
889 show_components (sym
);
892 if (sym
->f2k_derived
)
896 fprintf (dumpfile
, "hash: %d", sym
->hash_value
);
897 show_f2k_derived (sym
->f2k_derived
);
903 fputs ("Formal arglist:", dumpfile
);
905 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
907 if (formal
->sym
!= NULL
)
908 fprintf (dumpfile
, " %s", formal
->sym
->name
);
910 fputs (" [Alt Return]", dumpfile
);
914 if (sym
->formal_ns
&& (sym
->formal_ns
->proc_name
!= sym
)
915 && sym
->attr
.proc
!= PROC_ST_FUNCTION
919 fputs ("Formal namespace", dumpfile
);
920 show_namespace (sym
->formal_ns
);
926 /* Show a user-defined operator. Just prints an operator
927 and the name of the associated subroutine, really. */
930 show_uop (gfc_user_op
*uop
)
935 fprintf (dumpfile
, "%s:", uop
->name
);
937 for (intr
= uop
->op
; intr
; intr
= intr
->next
)
938 fprintf (dumpfile
, " %s", intr
->sym
->name
);
942 /* Workhorse function for traversing the user operator symtree. */
945 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
952 traverse_uop (st
->left
, func
);
953 traverse_uop (st
->right
, func
);
957 /* Traverse the tree of user operator nodes. */
960 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
962 traverse_uop (ns
->uop_root
, func
);
966 /* Function to display a common block. */
969 show_common (gfc_symtree
*st
)
974 fprintf (dumpfile
, "common: /%s/ ", st
->name
);
976 s
= st
->n
.common
->head
;
979 fprintf (dumpfile
, "%s", s
->name
);
982 fputs (", ", dumpfile
);
984 fputc ('\n', dumpfile
);
988 /* Worker function to display the symbol tree. */
991 show_symtree (gfc_symtree
*st
)
997 len
= strlen(st
->name
);
998 fprintf (dumpfile
, "symtree: '%s'", st
->name
);
1000 for (i
=len
; i
<12; i
++)
1001 fputc(' ', dumpfile
);
1004 fputs( " Ambiguous", dumpfile
);
1006 if (st
->n
.sym
->ns
!= gfc_current_ns
)
1007 fprintf (dumpfile
, "|| symbol: '%s' from namespace '%s'", st
->n
.sym
->name
,
1008 st
->n
.sym
->ns
->proc_name
->name
);
1010 show_symbol (st
->n
.sym
);
1014 /******************* Show gfc_code structures **************/
1017 /* Show a list of code structures. Mutually recursive with
1018 show_code_node(). */
1021 show_code (int level
, gfc_code
*c
)
1023 for (; c
; c
= c
->next
)
1024 show_code_node (level
, c
);
1028 show_omp_namelist (int list_type
, gfc_omp_namelist
*n
)
1030 for (; n
; n
= n
->next
)
1032 if (list_type
== OMP_LIST_REDUCTION
)
1033 switch (n
->u
.reduction_op
)
1035 case OMP_REDUCTION_PLUS
:
1036 case OMP_REDUCTION_TIMES
:
1037 case OMP_REDUCTION_MINUS
:
1038 case OMP_REDUCTION_AND
:
1039 case OMP_REDUCTION_OR
:
1040 case OMP_REDUCTION_EQV
:
1041 case OMP_REDUCTION_NEQV
:
1042 fprintf (dumpfile
, "%s:",
1043 gfc_op2string ((gfc_intrinsic_op
) n
->u
.reduction_op
));
1045 case OMP_REDUCTION_MAX
: fputs ("max:", dumpfile
); break;
1046 case OMP_REDUCTION_MIN
: fputs ("min:", dumpfile
); break;
1047 case OMP_REDUCTION_IAND
: fputs ("iand:", dumpfile
); break;
1048 case OMP_REDUCTION_IOR
: fputs ("ior:", dumpfile
); break;
1049 case OMP_REDUCTION_IEOR
: fputs ("ieor:", dumpfile
); break;
1050 case OMP_REDUCTION_USER
:
1052 fprintf (dumpfile
, "%s:", n
->udr
->udr
->name
);
1056 else if (list_type
== OMP_LIST_DEPEND
)
1057 switch (n
->u
.depend_op
)
1059 case OMP_DEPEND_IN
: fputs ("in:", dumpfile
); break;
1060 case OMP_DEPEND_OUT
: fputs ("out:", dumpfile
); break;
1061 case OMP_DEPEND_INOUT
: fputs ("inout:", dumpfile
); break;
1064 else if (list_type
== OMP_LIST_MAP
)
1065 switch (n
->u
.map_op
)
1067 case OMP_MAP_ALLOC
: fputs ("alloc:", dumpfile
); break;
1068 case OMP_MAP_TO
: fputs ("to:", dumpfile
); break;
1069 case OMP_MAP_FROM
: fputs ("from:", dumpfile
); break;
1070 case OMP_MAP_TOFROM
: fputs ("tofrom:", dumpfile
); break;
1073 fprintf (dumpfile
, "%s", n
->sym
->name
);
1076 fputc (':', dumpfile
);
1077 show_expr (n
->expr
);
1080 fputc (',', dumpfile
);
1085 /* Show OpenMP or OpenACC clauses. */
1088 show_omp_clauses (gfc_omp_clauses
*omp_clauses
)
1092 switch (omp_clauses
->cancel
)
1094 case OMP_CANCEL_UNKNOWN
:
1096 case OMP_CANCEL_PARALLEL
:
1097 fputs (" PARALLEL", dumpfile
);
1099 case OMP_CANCEL_SECTIONS
:
1100 fputs (" SECTIONS", dumpfile
);
1103 fputs (" DO", dumpfile
);
1105 case OMP_CANCEL_TASKGROUP
:
1106 fputs (" TASKGROUP", dumpfile
);
1109 if (omp_clauses
->if_expr
)
1111 fputs (" IF(", dumpfile
);
1112 show_expr (omp_clauses
->if_expr
);
1113 fputc (')', dumpfile
);
1115 if (omp_clauses
->final_expr
)
1117 fputs (" FINAL(", dumpfile
);
1118 show_expr (omp_clauses
->final_expr
);
1119 fputc (')', dumpfile
);
1121 if (omp_clauses
->num_threads
)
1123 fputs (" NUM_THREADS(", dumpfile
);
1124 show_expr (omp_clauses
->num_threads
);
1125 fputc (')', dumpfile
);
1127 if (omp_clauses
->async
)
1129 fputs (" ASYNC", dumpfile
);
1130 if (omp_clauses
->async_expr
)
1132 fputc ('(', dumpfile
);
1133 show_expr (omp_clauses
->async_expr
);
1134 fputc (')', dumpfile
);
1137 if (omp_clauses
->num_gangs_expr
)
1139 fputs (" NUM_GANGS(", dumpfile
);
1140 show_expr (omp_clauses
->num_gangs_expr
);
1141 fputc (')', dumpfile
);
1143 if (omp_clauses
->num_workers_expr
)
1145 fputs (" NUM_WORKERS(", dumpfile
);
1146 show_expr (omp_clauses
->num_workers_expr
);
1147 fputc (')', dumpfile
);
1149 if (omp_clauses
->vector_length_expr
)
1151 fputs (" VECTOR_LENGTH(", dumpfile
);
1152 show_expr (omp_clauses
->vector_length_expr
);
1153 fputc (')', dumpfile
);
1155 if (omp_clauses
->gang
)
1157 fputs (" GANG", dumpfile
);
1158 if (omp_clauses
->gang_num_expr
|| omp_clauses
->gang_static_expr
)
1160 fputc ('(', dumpfile
);
1161 if (omp_clauses
->gang_num_expr
)
1163 fprintf (dumpfile
, "num:");
1164 show_expr (omp_clauses
->gang_num_expr
);
1166 if (omp_clauses
->gang_num_expr
&& omp_clauses
->gang_static
)
1167 fputc (',', dumpfile
);
1168 if (omp_clauses
->gang_static
)
1170 fprintf (dumpfile
, "static:");
1171 if (omp_clauses
->gang_static_expr
)
1172 show_expr (omp_clauses
->gang_static_expr
);
1174 fputc ('*', dumpfile
);
1176 fputc (')', dumpfile
);
1179 if (omp_clauses
->worker
)
1181 fputs (" WORKER", dumpfile
);
1182 if (omp_clauses
->worker_expr
)
1184 fputc ('(', dumpfile
);
1185 show_expr (omp_clauses
->worker_expr
);
1186 fputc (')', dumpfile
);
1189 if (omp_clauses
->vector
)
1191 fputs (" VECTOR", dumpfile
);
1192 if (omp_clauses
->vector_expr
)
1194 fputc ('(', dumpfile
);
1195 show_expr (omp_clauses
->vector_expr
);
1196 fputc (')', dumpfile
);
1199 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
1202 switch (omp_clauses
->sched_kind
)
1204 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
1205 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
1206 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
1207 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
1208 case OMP_SCHED_AUTO
: type
= "AUTO"; break;
1212 fprintf (dumpfile
, " SCHEDULE (%s", type
);
1213 if (omp_clauses
->chunk_size
)
1215 fputc (',', dumpfile
);
1216 show_expr (omp_clauses
->chunk_size
);
1218 fputc (')', dumpfile
);
1220 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1223 switch (omp_clauses
->default_sharing
)
1225 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
1226 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
1227 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
1228 case OMP_DEFAULT_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1232 fprintf (dumpfile
, " DEFAULT(%s)", type
);
1234 if (omp_clauses
->tile_list
)
1236 gfc_expr_list
*list
;
1237 fputs (" TILE(", dumpfile
);
1238 for (list
= omp_clauses
->tile_list
; list
; list
= list
->next
)
1240 show_expr (list
->expr
);
1242 fputs (", ", dumpfile
);
1244 fputc (')', dumpfile
);
1246 if (omp_clauses
->wait_list
)
1248 gfc_expr_list
*list
;
1249 fputs (" WAIT(", dumpfile
);
1250 for (list
= omp_clauses
->wait_list
; list
; list
= list
->next
)
1252 show_expr (list
->expr
);
1254 fputs (", ", dumpfile
);
1256 fputc (')', dumpfile
);
1258 if (omp_clauses
->seq
)
1259 fputs (" SEQ", dumpfile
);
1260 if (omp_clauses
->independent
)
1261 fputs (" INDEPENDENT", dumpfile
);
1262 if (omp_clauses
->ordered
)
1263 fputs (" ORDERED", dumpfile
);
1264 if (omp_clauses
->untied
)
1265 fputs (" UNTIED", dumpfile
);
1266 if (omp_clauses
->mergeable
)
1267 fputs (" MERGEABLE", dumpfile
);
1268 if (omp_clauses
->collapse
)
1269 fprintf (dumpfile
, " COLLAPSE(%d)", omp_clauses
->collapse
);
1270 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
1271 if (omp_clauses
->lists
[list_type
] != NULL
1272 && list_type
!= OMP_LIST_COPYPRIVATE
)
1274 const char *type
= NULL
;
1277 case OMP_LIST_USE_DEVICE
: type
= "USE_DEVICE"; break;
1278 case OMP_LIST_DEVICE_RESIDENT
: type
= "USE_DEVICE"; break;
1279 case OMP_LIST_CACHE
: type
= ""; break;
1280 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
1281 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1282 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
1283 case OMP_LIST_SHARED
: type
= "SHARED"; break;
1284 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
1285 case OMP_LIST_UNIFORM
: type
= "UNIFORM"; break;
1286 case OMP_LIST_ALIGNED
: type
= "ALIGNED"; break;
1287 case OMP_LIST_LINEAR
: type
= "LINEAR"; break;
1288 case OMP_LIST_REDUCTION
: type
= "REDUCTION"; break;
1289 case OMP_LIST_DEPEND
: type
= "DEPEND"; break;
1293 fprintf (dumpfile
, " %s(", type
);
1294 show_omp_namelist (list_type
, omp_clauses
->lists
[list_type
]);
1295 fputc (')', dumpfile
);
1297 if (omp_clauses
->safelen_expr
)
1299 fputs (" SAFELEN(", dumpfile
);
1300 show_expr (omp_clauses
->safelen_expr
);
1301 fputc (')', dumpfile
);
1303 if (omp_clauses
->simdlen_expr
)
1305 fputs (" SIMDLEN(", dumpfile
);
1306 show_expr (omp_clauses
->simdlen_expr
);
1307 fputc (')', dumpfile
);
1309 if (omp_clauses
->inbranch
)
1310 fputs (" INBRANCH", dumpfile
);
1311 if (omp_clauses
->notinbranch
)
1312 fputs (" NOTINBRANCH", dumpfile
);
1313 if (omp_clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
1316 switch (omp_clauses
->proc_bind
)
1318 case OMP_PROC_BIND_MASTER
: type
= "MASTER"; break;
1319 case OMP_PROC_BIND_SPREAD
: type
= "SPREAD"; break;
1320 case OMP_PROC_BIND_CLOSE
: type
= "CLOSE"; break;
1324 fprintf (dumpfile
, " PROC_BIND(%s)", type
);
1326 if (omp_clauses
->num_teams
)
1328 fputs (" NUM_TEAMS(", dumpfile
);
1329 show_expr (omp_clauses
->num_teams
);
1330 fputc (')', dumpfile
);
1332 if (omp_clauses
->device
)
1334 fputs (" DEVICE(", dumpfile
);
1335 show_expr (omp_clauses
->device
);
1336 fputc (')', dumpfile
);
1338 if (omp_clauses
->thread_limit
)
1340 fputs (" THREAD_LIMIT(", dumpfile
);
1341 show_expr (omp_clauses
->thread_limit
);
1342 fputc (')', dumpfile
);
1344 if (omp_clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
1346 fprintf (dumpfile
, " DIST_SCHEDULE (static");
1347 if (omp_clauses
->dist_chunk_size
)
1349 fputc (',', dumpfile
);
1350 show_expr (omp_clauses
->dist_chunk_size
);
1352 fputc (')', dumpfile
);
1356 /* Show a single OpenMP or OpenACC directive node and everything underneath it
1360 show_omp_node (int level
, gfc_code
*c
)
1362 gfc_omp_clauses
*omp_clauses
= NULL
;
1363 const char *name
= NULL
;
1364 bool is_oacc
= false;
1368 case EXEC_OACC_PARALLEL_LOOP
: name
= "PARALLEL LOOP"; is_oacc
= true; break;
1369 case EXEC_OACC_PARALLEL
: name
= "PARALLEL"; is_oacc
= true; break;
1370 case EXEC_OACC_KERNELS_LOOP
: name
= "KERNELS LOOP"; is_oacc
= true; break;
1371 case EXEC_OACC_KERNELS
: name
= "KERNELS"; is_oacc
= true; break;
1372 case EXEC_OACC_DATA
: name
= "DATA"; is_oacc
= true; break;
1373 case EXEC_OACC_HOST_DATA
: name
= "HOST_DATA"; is_oacc
= true; break;
1374 case EXEC_OACC_LOOP
: name
= "LOOP"; is_oacc
= true; break;
1375 case EXEC_OACC_UPDATE
: name
= "UPDATE"; is_oacc
= true; break;
1376 case EXEC_OACC_WAIT
: name
= "WAIT"; is_oacc
= true; break;
1377 case EXEC_OACC_CACHE
: name
= "CACHE"; is_oacc
= true; break;
1378 case EXEC_OACC_ENTER_DATA
: name
= "ENTER DATA"; is_oacc
= true; break;
1379 case EXEC_OACC_EXIT_DATA
: name
= "EXIT DATA"; is_oacc
= true; break;
1380 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
1381 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
1382 case EXEC_OMP_CANCEL
: name
= "CANCEL"; break;
1383 case EXEC_OMP_CANCELLATION_POINT
: name
= "CANCELLATION POINT"; break;
1384 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
1385 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
1386 case EXEC_OMP_DO
: name
= "DO"; break;
1387 case EXEC_OMP_DO_SIMD
: name
= "DO SIMD"; break;
1388 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
1389 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
1390 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
1391 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
1392 case EXEC_OMP_PARALLEL_DO_SIMD
: name
= "PARALLEL DO SIMD"; break;
1393 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
1394 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
1395 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
1396 case EXEC_OMP_SIMD
: name
= "SIMD"; break;
1397 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
1398 case EXEC_OMP_TASK
: name
= "TASK"; break;
1399 case EXEC_OMP_TASKGROUP
: name
= "TASKGROUP"; break;
1400 case EXEC_OMP_TASKWAIT
: name
= "TASKWAIT"; break;
1401 case EXEC_OMP_TASKYIELD
: name
= "TASKYIELD"; break;
1402 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
1406 fprintf (dumpfile
, "!$%s %s", is_oacc
? "ACC" : "OMP", name
);
1409 case EXEC_OACC_PARALLEL_LOOP
:
1410 case EXEC_OACC_PARALLEL
:
1411 case EXEC_OACC_KERNELS_LOOP
:
1412 case EXEC_OACC_KERNELS
:
1413 case EXEC_OACC_DATA
:
1414 case EXEC_OACC_HOST_DATA
:
1415 case EXEC_OACC_LOOP
:
1416 case EXEC_OACC_UPDATE
:
1417 case EXEC_OACC_WAIT
:
1418 case EXEC_OACC_CACHE
:
1419 case EXEC_OACC_ENTER_DATA
:
1420 case EXEC_OACC_EXIT_DATA
:
1421 case EXEC_OMP_CANCEL
:
1422 case EXEC_OMP_CANCELLATION_POINT
:
1424 case EXEC_OMP_DO_SIMD
:
1425 case EXEC_OMP_PARALLEL
:
1426 case EXEC_OMP_PARALLEL_DO
:
1427 case EXEC_OMP_PARALLEL_DO_SIMD
:
1428 case EXEC_OMP_PARALLEL_SECTIONS
:
1429 case EXEC_OMP_SECTIONS
:
1431 case EXEC_OMP_SINGLE
:
1432 case EXEC_OMP_WORKSHARE
:
1433 case EXEC_OMP_PARALLEL_WORKSHARE
:
1435 omp_clauses
= c
->ext
.omp_clauses
;
1437 case EXEC_OMP_CRITICAL
:
1438 if (c
->ext
.omp_name
)
1439 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1441 case EXEC_OMP_FLUSH
:
1442 if (c
->ext
.omp_namelist
)
1444 fputs (" (", dumpfile
);
1445 show_omp_namelist (OMP_LIST_NUM
, c
->ext
.omp_namelist
);
1446 fputc (')', dumpfile
);
1449 case EXEC_OMP_BARRIER
:
1450 case EXEC_OMP_TASKWAIT
:
1451 case EXEC_OMP_TASKYIELD
:
1457 show_omp_clauses (omp_clauses
);
1458 fputc ('\n', dumpfile
);
1460 /* OpenACC executable directives don't have associated blocks. */
1461 if (c
->op
== EXEC_OACC_CACHE
|| c
->op
== EXEC_OACC_UPDATE
1462 || c
->op
== EXEC_OACC_ENTER_DATA
|| c
->op
== EXEC_OACC_EXIT_DATA
)
1464 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
1466 gfc_code
*d
= c
->block
;
1469 show_code (level
+ 1, d
->next
);
1470 if (d
->block
== NULL
)
1472 code_indent (level
, 0);
1473 fputs ("!$OMP SECTION\n", dumpfile
);
1478 show_code (level
+ 1, c
->block
->next
);
1479 if (c
->op
== EXEC_OMP_ATOMIC
)
1481 fputc ('\n', dumpfile
);
1482 code_indent (level
, 0);
1483 fprintf (dumpfile
, "!$%s END %s", is_oacc
? "ACC" : "OMP", name
);
1484 if (omp_clauses
!= NULL
)
1486 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
1488 fputs (" COPYPRIVATE(", dumpfile
);
1489 show_omp_namelist (OMP_LIST_COPYPRIVATE
,
1490 omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1491 fputc (')', dumpfile
);
1493 else if (omp_clauses
->nowait
)
1494 fputs (" NOWAIT", dumpfile
);
1496 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_name
)
1497 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1501 /* Show a single code node and everything underneath it if necessary. */
1504 show_code_node (int level
, gfc_code
*c
)
1506 gfc_forall_iterator
*fa
;
1519 fputc ('\n', dumpfile
);
1520 code_indent (level
, c
->here
);
1527 case EXEC_END_PROCEDURE
:
1531 fputs ("NOP", dumpfile
);
1535 fputs ("CONTINUE", dumpfile
);
1539 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
1542 case EXEC_INIT_ASSIGN
:
1544 fputs ("ASSIGN ", dumpfile
);
1545 show_expr (c
->expr1
);
1546 fputc (' ', dumpfile
);
1547 show_expr (c
->expr2
);
1550 case EXEC_LABEL_ASSIGN
:
1551 fputs ("LABEL ASSIGN ", dumpfile
);
1552 show_expr (c
->expr1
);
1553 fprintf (dumpfile
, " %d", c
->label1
->value
);
1556 case EXEC_POINTER_ASSIGN
:
1557 fputs ("POINTER ASSIGN ", dumpfile
);
1558 show_expr (c
->expr1
);
1559 fputc (' ', dumpfile
);
1560 show_expr (c
->expr2
);
1564 fputs ("GOTO ", dumpfile
);
1566 fprintf (dumpfile
, "%d", c
->label1
->value
);
1569 show_expr (c
->expr1
);
1573 fputs (", (", dumpfile
);
1574 for (; d
; d
= d
->block
)
1576 code_indent (level
, d
->label1
);
1577 if (d
->block
!= NULL
)
1578 fputc (',', dumpfile
);
1580 fputc (')', dumpfile
);
1587 case EXEC_ASSIGN_CALL
:
1588 if (c
->resolved_sym
)
1589 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
1590 else if (c
->symtree
)
1591 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
1593 fputs ("CALL ?? ", dumpfile
);
1595 show_actual_arglist (c
->ext
.actual
);
1599 fputs ("CALL ", dumpfile
);
1600 show_compcall (c
->expr1
);
1604 fputs ("CALL ", dumpfile
);
1605 show_expr (c
->expr1
);
1606 show_actual_arglist (c
->ext
.actual
);
1610 fputs ("RETURN ", dumpfile
);
1612 show_expr (c
->expr1
);
1616 fputs ("PAUSE ", dumpfile
);
1618 if (c
->expr1
!= NULL
)
1619 show_expr (c
->expr1
);
1621 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1625 case EXEC_ERROR_STOP
:
1626 fputs ("ERROR ", dumpfile
);
1630 fputs ("STOP ", dumpfile
);
1632 if (c
->expr1
!= NULL
)
1633 show_expr (c
->expr1
);
1635 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1640 fputs ("SYNC ALL ", dumpfile
);
1641 if (c
->expr2
!= NULL
)
1643 fputs (" stat=", dumpfile
);
1644 show_expr (c
->expr2
);
1646 if (c
->expr3
!= NULL
)
1648 fputs (" errmsg=", dumpfile
);
1649 show_expr (c
->expr3
);
1653 case EXEC_SYNC_MEMORY
:
1654 fputs ("SYNC MEMORY ", dumpfile
);
1655 if (c
->expr2
!= NULL
)
1657 fputs (" stat=", dumpfile
);
1658 show_expr (c
->expr2
);
1660 if (c
->expr3
!= NULL
)
1662 fputs (" errmsg=", dumpfile
);
1663 show_expr (c
->expr3
);
1667 case EXEC_SYNC_IMAGES
:
1668 fputs ("SYNC IMAGES image-set=", dumpfile
);
1669 if (c
->expr1
!= NULL
)
1670 show_expr (c
->expr1
);
1672 fputs ("* ", dumpfile
);
1673 if (c
->expr2
!= NULL
)
1675 fputs (" stat=", dumpfile
);
1676 show_expr (c
->expr2
);
1678 if (c
->expr3
!= NULL
)
1680 fputs (" errmsg=", dumpfile
);
1681 show_expr (c
->expr3
);
1685 case EXEC_EVENT_POST
:
1686 case EXEC_EVENT_WAIT
:
1687 if (c
->op
== EXEC_EVENT_POST
)
1688 fputs ("EVENT POST ", dumpfile
);
1690 fputs ("EVENT WAIT ", dumpfile
);
1692 fputs ("event-variable=", dumpfile
);
1693 if (c
->expr1
!= NULL
)
1694 show_expr (c
->expr1
);
1695 if (c
->expr4
!= NULL
)
1697 fputs (" until_count=", dumpfile
);
1698 show_expr (c
->expr4
);
1700 if (c
->expr2
!= NULL
)
1702 fputs (" stat=", dumpfile
);
1703 show_expr (c
->expr2
);
1705 if (c
->expr3
!= NULL
)
1707 fputs (" errmsg=", dumpfile
);
1708 show_expr (c
->expr3
);
1714 if (c
->op
== EXEC_LOCK
)
1715 fputs ("LOCK ", dumpfile
);
1717 fputs ("UNLOCK ", dumpfile
);
1719 fputs ("lock-variable=", dumpfile
);
1720 if (c
->expr1
!= NULL
)
1721 show_expr (c
->expr1
);
1722 if (c
->expr4
!= NULL
)
1724 fputs (" acquired_lock=", dumpfile
);
1725 show_expr (c
->expr4
);
1727 if (c
->expr2
!= NULL
)
1729 fputs (" stat=", dumpfile
);
1730 show_expr (c
->expr2
);
1732 if (c
->expr3
!= NULL
)
1734 fputs (" errmsg=", dumpfile
);
1735 show_expr (c
->expr3
);
1739 case EXEC_ARITHMETIC_IF
:
1740 fputs ("IF ", dumpfile
);
1741 show_expr (c
->expr1
);
1742 fprintf (dumpfile
, " %d, %d, %d",
1743 c
->label1
->value
, c
->label2
->value
, c
->label3
->value
);
1748 fputs ("IF ", dumpfile
);
1749 show_expr (d
->expr1
);
1752 show_code (level
+ 1, d
->next
);
1756 for (; d
; d
= d
->block
)
1758 code_indent (level
, 0);
1760 if (d
->expr1
== NULL
)
1761 fputs ("ELSE", dumpfile
);
1764 fputs ("ELSE IF ", dumpfile
);
1765 show_expr (d
->expr1
);
1769 show_code (level
+ 1, d
->next
);
1774 code_indent (level
, c
->label1
);
1778 fputs ("ENDIF", dumpfile
);
1783 const char* blocktype
;
1784 gfc_namespace
*saved_ns
;
1785 gfc_association_list
*alist
;
1787 if (c
->ext
.block
.assoc
)
1788 blocktype
= "ASSOCIATE";
1790 blocktype
= "BLOCK";
1792 fprintf (dumpfile
, "%s ", blocktype
);
1793 for (alist
= c
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
1795 fprintf (dumpfile
, " %s = ", alist
->name
);
1796 show_expr (alist
->target
);
1800 ns
= c
->ext
.block
.ns
;
1801 saved_ns
= gfc_current_ns
;
1802 gfc_current_ns
= ns
;
1803 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
1804 gfc_current_ns
= saved_ns
;
1805 show_code (show_level
, ns
->code
);
1808 fprintf (dumpfile
, "END %s ", blocktype
);
1812 case EXEC_END_BLOCK
:
1813 /* Only come here when there is a label on an
1814 END ASSOCIATE construct. */
1818 case EXEC_SELECT_TYPE
:
1820 if (c
->op
== EXEC_SELECT_TYPE
)
1821 fputs ("SELECT TYPE", dumpfile
);
1823 fputs ("SELECT CASE ", dumpfile
);
1824 show_expr (c
->expr1
);
1825 fputc ('\n', dumpfile
);
1827 for (; d
; d
= d
->block
)
1829 code_indent (level
, 0);
1831 fputs ("CASE ", dumpfile
);
1832 for (cp
= d
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
1834 fputc ('(', dumpfile
);
1835 show_expr (cp
->low
);
1836 fputc (' ', dumpfile
);
1837 show_expr (cp
->high
);
1838 fputc (')', dumpfile
);
1839 fputc (' ', dumpfile
);
1841 fputc ('\n', dumpfile
);
1843 show_code (level
+ 1, d
->next
);
1846 code_indent (level
, c
->label1
);
1847 fputs ("END SELECT", dumpfile
);
1851 fputs ("WHERE ", dumpfile
);
1854 show_expr (d
->expr1
);
1855 fputc ('\n', dumpfile
);
1857 show_code (level
+ 1, d
->next
);
1859 for (d
= d
->block
; d
; d
= d
->block
)
1861 code_indent (level
, 0);
1862 fputs ("ELSE WHERE ", dumpfile
);
1863 show_expr (d
->expr1
);
1864 fputc ('\n', dumpfile
);
1865 show_code (level
+ 1, d
->next
);
1868 code_indent (level
, 0);
1869 fputs ("END WHERE", dumpfile
);
1874 fputs ("FORALL ", dumpfile
);
1875 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1877 show_expr (fa
->var
);
1878 fputc (' ', dumpfile
);
1879 show_expr (fa
->start
);
1880 fputc (':', dumpfile
);
1881 show_expr (fa
->end
);
1882 fputc (':', dumpfile
);
1883 show_expr (fa
->stride
);
1885 if (fa
->next
!= NULL
)
1886 fputc (',', dumpfile
);
1889 if (c
->expr1
!= NULL
)
1891 fputc (',', dumpfile
);
1892 show_expr (c
->expr1
);
1894 fputc ('\n', dumpfile
);
1896 show_code (level
+ 1, c
->block
->next
);
1898 code_indent (level
, 0);
1899 fputs ("END FORALL", dumpfile
);
1903 fputs ("CRITICAL\n", dumpfile
);
1904 show_code (level
+ 1, c
->block
->next
);
1905 code_indent (level
, 0);
1906 fputs ("END CRITICAL", dumpfile
);
1910 fputs ("DO ", dumpfile
);
1912 fprintf (dumpfile
, " %-5d ", c
->label1
->value
);
1914 show_expr (c
->ext
.iterator
->var
);
1915 fputc ('=', dumpfile
);
1916 show_expr (c
->ext
.iterator
->start
);
1917 fputc (' ', dumpfile
);
1918 show_expr (c
->ext
.iterator
->end
);
1919 fputc (' ', dumpfile
);
1920 show_expr (c
->ext
.iterator
->step
);
1923 show_code (level
+ 1, c
->block
->next
);
1930 fputs ("END DO", dumpfile
);
1933 case EXEC_DO_CONCURRENT
:
1934 fputs ("DO CONCURRENT ", dumpfile
);
1935 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1937 show_expr (fa
->var
);
1938 fputc (' ', dumpfile
);
1939 show_expr (fa
->start
);
1940 fputc (':', dumpfile
);
1941 show_expr (fa
->end
);
1942 fputc (':', dumpfile
);
1943 show_expr (fa
->stride
);
1945 if (fa
->next
!= NULL
)
1946 fputc (',', dumpfile
);
1948 show_expr (c
->expr1
);
1950 show_code (level
+ 1, c
->block
->next
);
1951 code_indent (level
, c
->label1
);
1952 fputs ("END DO", dumpfile
);
1956 fputs ("DO WHILE ", dumpfile
);
1957 show_expr (c
->expr1
);
1958 fputc ('\n', dumpfile
);
1960 show_code (level
+ 1, c
->block
->next
);
1962 code_indent (level
, c
->label1
);
1963 fputs ("END DO", dumpfile
);
1967 fputs ("CYCLE", dumpfile
);
1969 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1973 fputs ("EXIT", dumpfile
);
1975 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1979 fputs ("ALLOCATE ", dumpfile
);
1982 fputs (" STAT=", dumpfile
);
1983 show_expr (c
->expr1
);
1988 fputs (" ERRMSG=", dumpfile
);
1989 show_expr (c
->expr2
);
1995 fputs (" MOLD=", dumpfile
);
1997 fputs (" SOURCE=", dumpfile
);
1998 show_expr (c
->expr3
);
2001 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
2003 fputc (' ', dumpfile
);
2004 show_expr (a
->expr
);
2009 case EXEC_DEALLOCATE
:
2010 fputs ("DEALLOCATE ", dumpfile
);
2013 fputs (" STAT=", dumpfile
);
2014 show_expr (c
->expr1
);
2019 fputs (" ERRMSG=", dumpfile
);
2020 show_expr (c
->expr2
);
2023 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
2025 fputc (' ', dumpfile
);
2026 show_expr (a
->expr
);
2032 fputs ("OPEN", dumpfile
);
2037 fputs (" UNIT=", dumpfile
);
2038 show_expr (open
->unit
);
2042 fputs (" IOMSG=", dumpfile
);
2043 show_expr (open
->iomsg
);
2047 fputs (" IOSTAT=", dumpfile
);
2048 show_expr (open
->iostat
);
2052 fputs (" FILE=", dumpfile
);
2053 show_expr (open
->file
);
2057 fputs (" STATUS=", dumpfile
);
2058 show_expr (open
->status
);
2062 fputs (" ACCESS=", dumpfile
);
2063 show_expr (open
->access
);
2067 fputs (" FORM=", dumpfile
);
2068 show_expr (open
->form
);
2072 fputs (" RECL=", dumpfile
);
2073 show_expr (open
->recl
);
2077 fputs (" BLANK=", dumpfile
);
2078 show_expr (open
->blank
);
2082 fputs (" POSITION=", dumpfile
);
2083 show_expr (open
->position
);
2087 fputs (" ACTION=", dumpfile
);
2088 show_expr (open
->action
);
2092 fputs (" DELIM=", dumpfile
);
2093 show_expr (open
->delim
);
2097 fputs (" PAD=", dumpfile
);
2098 show_expr (open
->pad
);
2102 fputs (" DECIMAL=", dumpfile
);
2103 show_expr (open
->decimal
);
2107 fputs (" ENCODING=", dumpfile
);
2108 show_expr (open
->encoding
);
2112 fputs (" ROUND=", dumpfile
);
2113 show_expr (open
->round
);
2117 fputs (" SIGN=", dumpfile
);
2118 show_expr (open
->sign
);
2122 fputs (" CONVERT=", dumpfile
);
2123 show_expr (open
->convert
);
2125 if (open
->asynchronous
)
2127 fputs (" ASYNCHRONOUS=", dumpfile
);
2128 show_expr (open
->asynchronous
);
2130 if (open
->err
!= NULL
)
2131 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
2136 fputs ("CLOSE", dumpfile
);
2137 close
= c
->ext
.close
;
2141 fputs (" UNIT=", dumpfile
);
2142 show_expr (close
->unit
);
2146 fputs (" IOMSG=", dumpfile
);
2147 show_expr (close
->iomsg
);
2151 fputs (" IOSTAT=", dumpfile
);
2152 show_expr (close
->iostat
);
2156 fputs (" STATUS=", dumpfile
);
2157 show_expr (close
->status
);
2159 if (close
->err
!= NULL
)
2160 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
2163 case EXEC_BACKSPACE
:
2164 fputs ("BACKSPACE", dumpfile
);
2168 fputs ("ENDFILE", dumpfile
);
2172 fputs ("REWIND", dumpfile
);
2176 fputs ("FLUSH", dumpfile
);
2179 fp
= c
->ext
.filepos
;
2183 fputs (" UNIT=", dumpfile
);
2184 show_expr (fp
->unit
);
2188 fputs (" IOMSG=", dumpfile
);
2189 show_expr (fp
->iomsg
);
2193 fputs (" IOSTAT=", dumpfile
);
2194 show_expr (fp
->iostat
);
2196 if (fp
->err
!= NULL
)
2197 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
2201 fputs ("INQUIRE", dumpfile
);
2206 fputs (" UNIT=", dumpfile
);
2207 show_expr (i
->unit
);
2211 fputs (" FILE=", dumpfile
);
2212 show_expr (i
->file
);
2217 fputs (" IOMSG=", dumpfile
);
2218 show_expr (i
->iomsg
);
2222 fputs (" IOSTAT=", dumpfile
);
2223 show_expr (i
->iostat
);
2227 fputs (" EXIST=", dumpfile
);
2228 show_expr (i
->exist
);
2232 fputs (" OPENED=", dumpfile
);
2233 show_expr (i
->opened
);
2237 fputs (" NUMBER=", dumpfile
);
2238 show_expr (i
->number
);
2242 fputs (" NAMED=", dumpfile
);
2243 show_expr (i
->named
);
2247 fputs (" NAME=", dumpfile
);
2248 show_expr (i
->name
);
2252 fputs (" ACCESS=", dumpfile
);
2253 show_expr (i
->access
);
2257 fputs (" SEQUENTIAL=", dumpfile
);
2258 show_expr (i
->sequential
);
2263 fputs (" DIRECT=", dumpfile
);
2264 show_expr (i
->direct
);
2268 fputs (" FORM=", dumpfile
);
2269 show_expr (i
->form
);
2273 fputs (" FORMATTED", dumpfile
);
2274 show_expr (i
->formatted
);
2278 fputs (" UNFORMATTED=", dumpfile
);
2279 show_expr (i
->unformatted
);
2283 fputs (" RECL=", dumpfile
);
2284 show_expr (i
->recl
);
2288 fputs (" NEXTREC=", dumpfile
);
2289 show_expr (i
->nextrec
);
2293 fputs (" BLANK=", dumpfile
);
2294 show_expr (i
->blank
);
2298 fputs (" POSITION=", dumpfile
);
2299 show_expr (i
->position
);
2303 fputs (" ACTION=", dumpfile
);
2304 show_expr (i
->action
);
2308 fputs (" READ=", dumpfile
);
2309 show_expr (i
->read
);
2313 fputs (" WRITE=", dumpfile
);
2314 show_expr (i
->write
);
2318 fputs (" READWRITE=", dumpfile
);
2319 show_expr (i
->readwrite
);
2323 fputs (" DELIM=", dumpfile
);
2324 show_expr (i
->delim
);
2328 fputs (" PAD=", dumpfile
);
2333 fputs (" CONVERT=", dumpfile
);
2334 show_expr (i
->convert
);
2336 if (i
->asynchronous
)
2338 fputs (" ASYNCHRONOUS=", dumpfile
);
2339 show_expr (i
->asynchronous
);
2343 fputs (" DECIMAL=", dumpfile
);
2344 show_expr (i
->decimal
);
2348 fputs (" ENCODING=", dumpfile
);
2349 show_expr (i
->encoding
);
2353 fputs (" PENDING=", dumpfile
);
2354 show_expr (i
->pending
);
2358 fputs (" ROUND=", dumpfile
);
2359 show_expr (i
->round
);
2363 fputs (" SIGN=", dumpfile
);
2364 show_expr (i
->sign
);
2368 fputs (" SIZE=", dumpfile
);
2369 show_expr (i
->size
);
2373 fputs (" ID=", dumpfile
);
2378 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
2382 fputs ("IOLENGTH ", dumpfile
);
2383 show_expr (c
->expr1
);
2388 fputs ("READ", dumpfile
);
2392 fputs ("WRITE", dumpfile
);
2398 fputs (" UNIT=", dumpfile
);
2399 show_expr (dt
->io_unit
);
2402 if (dt
->format_expr
)
2404 fputs (" FMT=", dumpfile
);
2405 show_expr (dt
->format_expr
);
2408 if (dt
->format_label
!= NULL
)
2409 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
2411 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
2415 fputs (" IOMSG=", dumpfile
);
2416 show_expr (dt
->iomsg
);
2420 fputs (" IOSTAT=", dumpfile
);
2421 show_expr (dt
->iostat
);
2425 fputs (" SIZE=", dumpfile
);
2426 show_expr (dt
->size
);
2430 fputs (" REC=", dumpfile
);
2431 show_expr (dt
->rec
);
2435 fputs (" ADVANCE=", dumpfile
);
2436 show_expr (dt
->advance
);
2440 fputs (" ID=", dumpfile
);
2445 fputs (" POS=", dumpfile
);
2446 show_expr (dt
->pos
);
2448 if (dt
->asynchronous
)
2450 fputs (" ASYNCHRONOUS=", dumpfile
);
2451 show_expr (dt
->asynchronous
);
2455 fputs (" BLANK=", dumpfile
);
2456 show_expr (dt
->blank
);
2460 fputs (" DECIMAL=", dumpfile
);
2461 show_expr (dt
->decimal
);
2465 fputs (" DELIM=", dumpfile
);
2466 show_expr (dt
->delim
);
2470 fputs (" PAD=", dumpfile
);
2471 show_expr (dt
->pad
);
2475 fputs (" ROUND=", dumpfile
);
2476 show_expr (dt
->round
);
2480 fputs (" SIGN=", dumpfile
);
2481 show_expr (dt
->sign
);
2485 for (c
= c
->block
->next
; c
; c
= c
->next
)
2486 show_code_node (level
+ (c
->next
!= NULL
), c
);
2490 fputs ("TRANSFER ", dumpfile
);
2491 show_expr (c
->expr1
);
2495 fputs ("DT_END", dumpfile
);
2498 if (dt
->err
!= NULL
)
2499 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
2500 if (dt
->end
!= NULL
)
2501 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
2502 if (dt
->eor
!= NULL
)
2503 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
2506 case EXEC_OACC_PARALLEL_LOOP
:
2507 case EXEC_OACC_PARALLEL
:
2508 case EXEC_OACC_KERNELS_LOOP
:
2509 case EXEC_OACC_KERNELS
:
2510 case EXEC_OACC_DATA
:
2511 case EXEC_OACC_HOST_DATA
:
2512 case EXEC_OACC_LOOP
:
2513 case EXEC_OACC_UPDATE
:
2514 case EXEC_OACC_WAIT
:
2515 case EXEC_OACC_CACHE
:
2516 case EXEC_OACC_ENTER_DATA
:
2517 case EXEC_OACC_EXIT_DATA
:
2518 case EXEC_OMP_ATOMIC
:
2519 case EXEC_OMP_CANCEL
:
2520 case EXEC_OMP_CANCELLATION_POINT
:
2521 case EXEC_OMP_BARRIER
:
2522 case EXEC_OMP_CRITICAL
:
2523 case EXEC_OMP_FLUSH
:
2525 case EXEC_OMP_DO_SIMD
:
2526 case EXEC_OMP_MASTER
:
2527 case EXEC_OMP_ORDERED
:
2528 case EXEC_OMP_PARALLEL
:
2529 case EXEC_OMP_PARALLEL_DO
:
2530 case EXEC_OMP_PARALLEL_DO_SIMD
:
2531 case EXEC_OMP_PARALLEL_SECTIONS
:
2532 case EXEC_OMP_PARALLEL_WORKSHARE
:
2533 case EXEC_OMP_SECTIONS
:
2535 case EXEC_OMP_SINGLE
:
2537 case EXEC_OMP_TASKGROUP
:
2538 case EXEC_OMP_TASKWAIT
:
2539 case EXEC_OMP_TASKYIELD
:
2540 case EXEC_OMP_WORKSHARE
:
2541 show_omp_node (level
, c
);
2545 gfc_internal_error ("show_code_node(): Bad statement code");
2550 /* Show an equivalence chain. */
2553 show_equiv (gfc_equiv
*eq
)
2556 fputs ("Equivalence: ", dumpfile
);
2559 show_expr (eq
->expr
);
2562 fputs (", ", dumpfile
);
2567 /* Show a freakin' whole namespace. */
2570 show_namespace (gfc_namespace
*ns
)
2572 gfc_interface
*intr
;
2573 gfc_namespace
*save
;
2579 save
= gfc_current_ns
;
2582 fputs ("Namespace:", dumpfile
);
2588 while (i
< GFC_LETTERS
- 1
2589 && gfc_compare_types (&ns
->default_type
[i
+1],
2590 &ns
->default_type
[l
]))
2594 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
2596 fprintf (dumpfile
, " %c: ", l
+'A');
2598 show_typespec(&ns
->default_type
[l
]);
2600 } while (i
< GFC_LETTERS
);
2602 if (ns
->proc_name
!= NULL
)
2605 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
2609 gfc_current_ns
= ns
;
2610 gfc_traverse_symtree (ns
->common_root
, show_common
);
2612 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2614 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
2616 /* User operator interfaces */
2622 fprintf (dumpfile
, "Operator interfaces for %s:",
2623 gfc_op2string ((gfc_intrinsic_op
) op
));
2625 for (; intr
; intr
= intr
->next
)
2626 fprintf (dumpfile
, " %s", intr
->sym
->name
);
2629 if (ns
->uop_root
!= NULL
)
2632 fputs ("User operators:\n", dumpfile
);
2633 gfc_traverse_user_op (ns
, show_uop
);
2636 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
2639 if (ns
->oacc_declare
)
2641 struct gfc_oacc_declare
*decl
;
2642 /* Dump !$ACC DECLARE clauses. */
2643 for (decl
= ns
->oacc_declare
; decl
; decl
= decl
->next
)
2646 fprintf (dumpfile
, "!$ACC DECLARE");
2647 show_omp_clauses (decl
->clauses
);
2651 fputc ('\n', dumpfile
);
2653 fputs ("code:", dumpfile
);
2654 show_code (show_level
, ns
->code
);
2657 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
2659 fputs ("\nCONTAINS\n", dumpfile
);
2661 show_namespace (ns
);
2665 fputc ('\n', dumpfile
);
2666 gfc_current_ns
= save
;
2670 /* Main function for dumping a parse tree. */
2673 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
2676 show_namespace (ns
);