2 Copyright (C) 2003-2017 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
);
50 static void show_code (int, gfc_code
*);
53 /* Allow dumping of an expression in the debugger. */
54 void gfc_debug_expr (gfc_expr
*);
57 gfc_debug_expr (gfc_expr
*e
)
62 fputc ('\n', dumpfile
);
66 /* Allow for dumping of a piece of code in the debugger. */
67 void gfc_debug_code (gfc_code
*c
);
70 gfc_debug_code (gfc_code
*c
)
75 fputc ('\n', dumpfile
);
79 /* Do indentation for a specific level. */
82 code_indent (int level
, gfc_st_label
*label
)
87 fprintf (dumpfile
, "%-5d ", label
->value
);
89 for (i
= 0; i
< (2 * level
- (label
? 6 : 0)); i
++)
90 fputc (' ', dumpfile
);
94 /* Simple indentation at the current level. This one
95 is used to show symbols. */
100 fputc ('\n', dumpfile
);
101 code_indent (show_level
, NULL
);
105 /* Show type-specific information. */
108 show_typespec (gfc_typespec
*ts
)
110 if (ts
->type
== BT_ASSUMED
)
112 fputs ("(TYPE(*))", dumpfile
);
116 fprintf (dumpfile
, "(%s ", gfc_basic_typename (ts
->type
));
123 fprintf (dumpfile
, "%s", ts
->u
.derived
->name
);
128 show_expr (ts
->u
.cl
->length
);
129 fprintf(dumpfile
, " %d", ts
->kind
);
133 fprintf (dumpfile
, "%d", ts
->kind
);
136 if (ts
->is_c_interop
)
137 fputs (" C_INTEROP", dumpfile
);
140 fputs (" ISO_C", dumpfile
);
143 fputs (" DEFERRED", dumpfile
);
145 fputc (')', dumpfile
);
149 /* Show an actual argument list. */
152 show_actual_arglist (gfc_actual_arglist
*a
)
154 fputc ('(', dumpfile
);
156 for (; a
; a
= a
->next
)
158 fputc ('(', dumpfile
);
160 fprintf (dumpfile
, "%s = ", a
->name
);
164 fputs ("(arg not-present)", dumpfile
);
166 fputc (')', dumpfile
);
168 fputc (' ', dumpfile
);
171 fputc (')', dumpfile
);
175 /* Show a gfc_array_spec array specification structure. */
178 show_array_spec (gfc_array_spec
*as
)
185 fputs ("()", dumpfile
);
189 fprintf (dumpfile
, "(%d [%d]", as
->rank
, as
->corank
);
191 if (as
->rank
+ as
->corank
> 0 || as
->rank
== -1)
195 case AS_EXPLICIT
: c
= "AS_EXPLICIT"; break;
196 case AS_DEFERRED
: c
= "AS_DEFERRED"; break;
197 case AS_ASSUMED_SIZE
: c
= "AS_ASSUMED_SIZE"; break;
198 case AS_ASSUMED_SHAPE
: c
= "AS_ASSUMED_SHAPE"; break;
199 case AS_ASSUMED_RANK
: c
= "AS_ASSUMED_RANK"; break;
201 gfc_internal_error ("show_array_spec(): Unhandled array shape "
204 fprintf (dumpfile
, " %s ", c
);
206 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
208 show_expr (as
->lower
[i
]);
209 fputc (' ', dumpfile
);
210 show_expr (as
->upper
[i
]);
211 fputc (' ', dumpfile
);
215 fputc (')', dumpfile
);
219 /* Show a gfc_array_ref array reference structure. */
222 show_array_ref (gfc_array_ref
* ar
)
226 fputc ('(', dumpfile
);
231 fputs ("FULL", dumpfile
);
235 for (i
= 0; i
< ar
->dimen
; i
++)
237 /* There are two types of array sections: either the
238 elements are identified by an integer array ('vector'),
239 or by an index range. In the former case we only have to
240 print the start expression which contains the vector, in
241 the latter case we have to print any of lower and upper
242 bound and the stride, if they're present. */
244 if (ar
->start
[i
] != NULL
)
245 show_expr (ar
->start
[i
]);
247 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
249 fputc (':', dumpfile
);
251 if (ar
->end
[i
] != NULL
)
252 show_expr (ar
->end
[i
]);
254 if (ar
->stride
[i
] != NULL
)
256 fputc (':', dumpfile
);
257 show_expr (ar
->stride
[i
]);
261 if (i
!= ar
->dimen
- 1)
262 fputs (" , ", dumpfile
);
267 for (i
= 0; i
< ar
->dimen
; i
++)
269 show_expr (ar
->start
[i
]);
270 if (i
!= ar
->dimen
- 1)
271 fputs (" , ", dumpfile
);
276 fputs ("UNKNOWN", dumpfile
);
280 gfc_internal_error ("show_array_ref(): Unknown array reference");
283 fputc (')', dumpfile
);
287 /* Show a list of gfc_ref structures. */
290 show_ref (gfc_ref
*p
)
292 for (; p
; p
= p
->next
)
296 show_array_ref (&p
->u
.ar
);
300 fprintf (dumpfile
, " %% %s", p
->u
.c
.component
->name
);
304 fputc ('(', dumpfile
);
305 show_expr (p
->u
.ss
.start
);
306 fputc (':', dumpfile
);
307 show_expr (p
->u
.ss
.end
);
308 fputc (')', dumpfile
);
312 gfc_internal_error ("show_ref(): Bad component code");
317 /* Display a constructor. Works recursively for array constructors. */
320 show_constructor (gfc_constructor_base base
)
323 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
325 if (c
->iterator
== NULL
)
329 fputc ('(', dumpfile
);
332 fputc (' ', dumpfile
);
333 show_expr (c
->iterator
->var
);
334 fputc ('=', dumpfile
);
335 show_expr (c
->iterator
->start
);
336 fputc (',', dumpfile
);
337 show_expr (c
->iterator
->end
);
338 fputc (',', dumpfile
);
339 show_expr (c
->iterator
->step
);
341 fputc (')', dumpfile
);
344 if (gfc_constructor_next (c
) != NULL
)
345 fputs (" , ", dumpfile
);
351 show_char_const (const gfc_char_t
*c
, int length
)
355 fputc ('\'', dumpfile
);
356 for (i
= 0; i
< length
; i
++)
359 fputs ("''", dumpfile
);
361 fputs (gfc_print_wide_char (c
[i
]), dumpfile
);
363 fputc ('\'', dumpfile
);
367 /* Show a component-call expression. */
370 show_compcall (gfc_expr
* p
)
372 gcc_assert (p
->expr_type
== EXPR_COMPCALL
);
374 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
376 fprintf (dumpfile
, "%s", p
->value
.compcall
.name
);
378 show_actual_arglist (p
->value
.compcall
.actual
);
382 /* Show an expression. */
385 show_expr (gfc_expr
*p
)
392 fputs ("()", dumpfile
);
396 switch (p
->expr_type
)
399 show_char_const (p
->value
.character
.string
, p
->value
.character
.length
);
404 fprintf (dumpfile
, "%s(", p
->ts
.u
.derived
->name
);
405 show_constructor (p
->value
.constructor
);
406 fputc (')', dumpfile
);
410 fputs ("(/ ", dumpfile
);
411 show_constructor (p
->value
.constructor
);
412 fputs (" /)", dumpfile
);
418 fputs ("NULL()", dumpfile
);
425 mpz_out_str (dumpfile
, 10, p
->value
.integer
);
427 if (p
->ts
.kind
!= gfc_default_integer_kind
)
428 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
432 if (p
->value
.logical
)
433 fputs (".true.", dumpfile
);
435 fputs (".false.", dumpfile
);
439 mpfr_out_str (dumpfile
, 10, 0, p
->value
.real
, GFC_RND_MODE
);
440 if (p
->ts
.kind
!= gfc_default_real_kind
)
441 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
445 show_char_const (p
->value
.character
.string
,
446 p
->value
.character
.length
);
450 fputs ("(complex ", dumpfile
);
452 mpfr_out_str (dumpfile
, 10, 0, mpc_realref (p
->value
.complex),
454 if (p
->ts
.kind
!= gfc_default_complex_kind
)
455 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
457 fputc (' ', dumpfile
);
459 mpfr_out_str (dumpfile
, 10, 0, mpc_imagref (p
->value
.complex),
461 if (p
->ts
.kind
!= gfc_default_complex_kind
)
462 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
464 fputc (')', dumpfile
);
468 fprintf (dumpfile
, "%dH", p
->representation
.length
);
469 c
= p
->representation
.string
;
470 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
472 fputc (*c
, dumpfile
);
477 fputs ("???", dumpfile
);
481 if (p
->representation
.string
)
483 fputs (" {", dumpfile
);
484 c
= p
->representation
.string
;
485 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
487 fprintf (dumpfile
, "%.2x", (unsigned int) *c
);
488 if (i
< p
->representation
.length
- 1)
489 fputc (',', dumpfile
);
491 fputc ('}', dumpfile
);
497 if (p
->symtree
->n
.sym
->ns
&& p
->symtree
->n
.sym
->ns
->proc_name
)
498 fprintf (dumpfile
, "%s:", p
->symtree
->n
.sym
->ns
->proc_name
->name
);
499 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
504 fputc ('(', dumpfile
);
505 switch (p
->value
.op
.op
)
507 case INTRINSIC_UPLUS
:
508 fputs ("U+ ", dumpfile
);
510 case INTRINSIC_UMINUS
:
511 fputs ("U- ", dumpfile
);
514 fputs ("+ ", dumpfile
);
516 case INTRINSIC_MINUS
:
517 fputs ("- ", dumpfile
);
519 case INTRINSIC_TIMES
:
520 fputs ("* ", dumpfile
);
522 case INTRINSIC_DIVIDE
:
523 fputs ("/ ", dumpfile
);
525 case INTRINSIC_POWER
:
526 fputs ("** ", dumpfile
);
528 case INTRINSIC_CONCAT
:
529 fputs ("// ", dumpfile
);
532 fputs ("AND ", dumpfile
);
535 fputs ("OR ", dumpfile
);
538 fputs ("EQV ", dumpfile
);
541 fputs ("NEQV ", dumpfile
);
544 case INTRINSIC_EQ_OS
:
545 fputs ("= ", dumpfile
);
548 case INTRINSIC_NE_OS
:
549 fputs ("/= ", dumpfile
);
552 case INTRINSIC_GT_OS
:
553 fputs ("> ", dumpfile
);
556 case INTRINSIC_GE_OS
:
557 fputs (">= ", dumpfile
);
560 case INTRINSIC_LT_OS
:
561 fputs ("< ", dumpfile
);
564 case INTRINSIC_LE_OS
:
565 fputs ("<= ", dumpfile
);
568 fputs ("NOT ", dumpfile
);
570 case INTRINSIC_PARENTHESES
:
571 fputs ("parens ", dumpfile
);
576 ("show_expr(): Bad intrinsic in expression");
579 show_expr (p
->value
.op
.op1
);
583 fputc (' ', dumpfile
);
584 show_expr (p
->value
.op
.op2
);
587 fputc (')', dumpfile
);
591 if (p
->value
.function
.name
== NULL
)
593 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
594 if (gfc_is_proc_ptr_comp (p
))
596 fputc ('[', dumpfile
);
597 show_actual_arglist (p
->value
.function
.actual
);
598 fputc (']', dumpfile
);
602 fprintf (dumpfile
, "%s", p
->value
.function
.name
);
603 if (gfc_is_proc_ptr_comp (p
))
605 fputc ('[', dumpfile
);
606 fputc ('[', dumpfile
);
607 show_actual_arglist (p
->value
.function
.actual
);
608 fputc (']', dumpfile
);
609 fputc (']', dumpfile
);
619 gfc_internal_error ("show_expr(): Don't know how to show expr");
623 /* Show symbol attributes. The flavor and intent are followed by
624 whatever single bit attributes are present. */
627 show_attr (symbol_attribute
*attr
, const char * module
)
629 if (attr
->flavor
!= FL_UNKNOWN
)
630 fprintf (dumpfile
, "(%s ", gfc_code2string (flavors
, attr
->flavor
));
631 if (attr
->access
!= ACCESS_UNKNOWN
)
632 fprintf (dumpfile
, "%s ", gfc_code2string (access_types
, attr
->access
));
633 if (attr
->proc
!= PROC_UNKNOWN
)
634 fprintf (dumpfile
, "%s ", gfc_code2string (procedures
, attr
->proc
));
635 if (attr
->save
!= SAVE_NONE
)
636 fprintf (dumpfile
, "%s", gfc_code2string (save_status
, attr
->save
));
638 if (attr
->artificial
)
639 fputs (" ARTIFICIAL", dumpfile
);
640 if (attr
->allocatable
)
641 fputs (" ALLOCATABLE", dumpfile
);
642 if (attr
->asynchronous
)
643 fputs (" ASYNCHRONOUS", dumpfile
);
644 if (attr
->codimension
)
645 fputs (" CODIMENSION", dumpfile
);
647 fputs (" DIMENSION", dumpfile
);
648 if (attr
->contiguous
)
649 fputs (" CONTIGUOUS", dumpfile
);
651 fputs (" EXTERNAL", dumpfile
);
653 fputs (" INTRINSIC", dumpfile
);
655 fputs (" OPTIONAL", dumpfile
);
657 fputs (" POINTER", dumpfile
);
658 if (attr
->is_protected
)
659 fputs (" PROTECTED", dumpfile
);
661 fputs (" VALUE", dumpfile
);
663 fputs (" VOLATILE", dumpfile
);
664 if (attr
->threadprivate
)
665 fputs (" THREADPRIVATE", dumpfile
);
667 fputs (" TARGET", dumpfile
);
670 fputs (" DUMMY", dumpfile
);
671 if (attr
->intent
!= INTENT_UNKNOWN
)
672 fprintf (dumpfile
, "(%s)", gfc_intent_string (attr
->intent
));
676 fputs (" RESULT", dumpfile
);
678 fputs (" ENTRY", dumpfile
);
680 fputs (" BIND(C)", dumpfile
);
683 fputs (" DATA", dumpfile
);
686 fputs (" USE-ASSOC", dumpfile
);
688 fprintf (dumpfile
, "(%s)", module
);
691 if (attr
->in_namelist
)
692 fputs (" IN-NAMELIST", dumpfile
);
694 fputs (" IN-COMMON", dumpfile
);
697 fputs (" ABSTRACT", dumpfile
);
699 fputs (" FUNCTION", dumpfile
);
700 if (attr
->subroutine
)
701 fputs (" SUBROUTINE", dumpfile
);
702 if (attr
->implicit_type
)
703 fputs (" IMPLICIT-TYPE", dumpfile
);
706 fputs (" SEQUENCE", dumpfile
);
708 fputs (" ELEMENTAL", dumpfile
);
710 fputs (" PURE", dumpfile
);
712 fputs (" RECURSIVE", dumpfile
);
714 fputc (')', dumpfile
);
718 /* Show components of a derived type. */
721 show_components (gfc_symbol
*sym
)
725 for (c
= sym
->components
; c
; c
= c
->next
)
727 fprintf (dumpfile
, "(%s ", c
->name
);
728 show_typespec (&c
->ts
);
729 if (c
->attr
.allocatable
)
730 fputs (" ALLOCATABLE", dumpfile
);
732 fputs (" POINTER", dumpfile
);
733 if (c
->attr
.proc_pointer
)
734 fputs (" PPC", dumpfile
);
735 if (c
->attr
.dimension
)
736 fputs (" DIMENSION", dumpfile
);
737 fputc (' ', dumpfile
);
738 show_array_spec (c
->as
);
740 fprintf (dumpfile
, " %s", gfc_code2string (access_types
, c
->attr
.access
));
741 fputc (')', dumpfile
);
743 fputc (' ', dumpfile
);
748 /* Show the f2k_derived namespace with procedure bindings. */
751 show_typebound_proc (gfc_typebound_proc
* tb
, const char* name
)
756 fputs ("GENERIC", dumpfile
);
759 fputs ("PROCEDURE, ", dumpfile
);
761 fputs ("NOPASS", dumpfile
);
765 fprintf (dumpfile
, "PASS(%s)", tb
->pass_arg
);
767 fputs ("PASS", dumpfile
);
769 if (tb
->non_overridable
)
770 fputs (", NON_OVERRIDABLE", dumpfile
);
773 if (tb
->access
== ACCESS_PUBLIC
)
774 fputs (", PUBLIC", dumpfile
);
776 fputs (", PRIVATE", dumpfile
);
778 fprintf (dumpfile
, " :: %s => ", name
);
783 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
785 fputs (g
->specific_st
->name
, dumpfile
);
787 fputs (", ", dumpfile
);
791 fputs (tb
->u
.specific
->n
.sym
->name
, dumpfile
);
795 show_typebound_symtree (gfc_symtree
* st
)
797 gcc_assert (st
->n
.tb
);
798 show_typebound_proc (st
->n
.tb
, st
->name
);
802 show_f2k_derived (gfc_namespace
* f2k
)
808 fputs ("Procedure bindings:", dumpfile
);
811 /* Finalizer bindings. */
812 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
815 fprintf (dumpfile
, "FINAL %s", f
->proc_tree
->n
.sym
->name
);
818 /* Type-bound procedures. */
819 gfc_traverse_symtree (f2k
->tb_sym_root
, &show_typebound_symtree
);
824 fputs ("Operator bindings:", dumpfile
);
827 /* User-defined operators. */
828 gfc_traverse_symtree (f2k
->tb_uop_root
, &show_typebound_symtree
);
830 /* Intrinsic operators. */
831 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
833 show_typebound_proc (f2k
->tb_op
[op
],
834 gfc_op2string ((gfc_intrinsic_op
) op
));
840 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
841 show the interface. Information needed to reconstruct the list of
842 specific interfaces associated with a generic symbol is done within
846 show_symbol (gfc_symbol
*sym
)
848 gfc_formal_arglist
*formal
;
855 fprintf (dumpfile
, "|| symbol: '%s' ", sym
->name
);
856 len
= strlen (sym
->name
);
857 for (i
=len
; i
<12; i
++)
858 fputc(' ', dumpfile
);
863 fputs ("type spec : ", dumpfile
);
864 show_typespec (&sym
->ts
);
867 fputs ("attributes: ", dumpfile
);
868 show_attr (&sym
->attr
, sym
->module
);
873 fputs ("value: ", dumpfile
);
874 show_expr (sym
->value
);
880 fputs ("Array spec:", dumpfile
);
881 show_array_spec (sym
->as
);
887 fputs ("Generic interfaces:", dumpfile
);
888 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
889 fprintf (dumpfile
, " %s", intr
->sym
->name
);
895 fprintf (dumpfile
, "result: %s", sym
->result
->name
);
901 fputs ("components: ", dumpfile
);
902 show_components (sym
);
905 if (sym
->f2k_derived
)
909 fprintf (dumpfile
, "hash: %d", sym
->hash_value
);
910 show_f2k_derived (sym
->f2k_derived
);
916 fputs ("Formal arglist:", dumpfile
);
918 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
920 if (formal
->sym
!= NULL
)
921 fprintf (dumpfile
, " %s", formal
->sym
->name
);
923 fputs (" [Alt Return]", dumpfile
);
927 if (sym
->formal_ns
&& (sym
->formal_ns
->proc_name
!= sym
)
928 && sym
->attr
.proc
!= PROC_ST_FUNCTION
932 fputs ("Formal namespace", dumpfile
);
933 show_namespace (sym
->formal_ns
);
939 /* Show a user-defined operator. Just prints an operator
940 and the name of the associated subroutine, really. */
943 show_uop (gfc_user_op
*uop
)
948 fprintf (dumpfile
, "%s:", uop
->name
);
950 for (intr
= uop
->op
; intr
; intr
= intr
->next
)
951 fprintf (dumpfile
, " %s", intr
->sym
->name
);
955 /* Workhorse function for traversing the user operator symtree. */
958 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
965 traverse_uop (st
->left
, func
);
966 traverse_uop (st
->right
, func
);
970 /* Traverse the tree of user operator nodes. */
973 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
975 traverse_uop (ns
->uop_root
, func
);
979 /* Function to display a common block. */
982 show_common (gfc_symtree
*st
)
987 fprintf (dumpfile
, "common: /%s/ ", st
->name
);
989 s
= st
->n
.common
->head
;
992 fprintf (dumpfile
, "%s", s
->name
);
995 fputs (", ", dumpfile
);
997 fputc ('\n', dumpfile
);
1001 /* Worker function to display the symbol tree. */
1004 show_symtree (gfc_symtree
*st
)
1010 len
= strlen(st
->name
);
1011 fprintf (dumpfile
, "symtree: '%s'", st
->name
);
1013 for (i
=len
; i
<12; i
++)
1014 fputc(' ', dumpfile
);
1017 fputs( " Ambiguous", dumpfile
);
1019 if (st
->n
.sym
->ns
!= gfc_current_ns
)
1020 fprintf (dumpfile
, "|| symbol: '%s' from namespace '%s'", st
->n
.sym
->name
,
1021 st
->n
.sym
->ns
->proc_name
->name
);
1023 show_symbol (st
->n
.sym
);
1027 /******************* Show gfc_code structures **************/
1030 /* Show a list of code structures. Mutually recursive with
1031 show_code_node(). */
1034 show_code (int level
, gfc_code
*c
)
1036 for (; c
; c
= c
->next
)
1037 show_code_node (level
, c
);
1041 show_omp_namelist (int list_type
, gfc_omp_namelist
*n
)
1043 for (; n
; n
= n
->next
)
1045 if (list_type
== OMP_LIST_REDUCTION
)
1046 switch (n
->u
.reduction_op
)
1048 case OMP_REDUCTION_PLUS
:
1049 case OMP_REDUCTION_TIMES
:
1050 case OMP_REDUCTION_MINUS
:
1051 case OMP_REDUCTION_AND
:
1052 case OMP_REDUCTION_OR
:
1053 case OMP_REDUCTION_EQV
:
1054 case OMP_REDUCTION_NEQV
:
1055 fprintf (dumpfile
, "%s:",
1056 gfc_op2string ((gfc_intrinsic_op
) n
->u
.reduction_op
));
1058 case OMP_REDUCTION_MAX
: fputs ("max:", dumpfile
); break;
1059 case OMP_REDUCTION_MIN
: fputs ("min:", dumpfile
); break;
1060 case OMP_REDUCTION_IAND
: fputs ("iand:", dumpfile
); break;
1061 case OMP_REDUCTION_IOR
: fputs ("ior:", dumpfile
); break;
1062 case OMP_REDUCTION_IEOR
: fputs ("ieor:", dumpfile
); break;
1063 case OMP_REDUCTION_USER
:
1065 fprintf (dumpfile
, "%s:", n
->udr
->udr
->name
);
1069 else if (list_type
== OMP_LIST_DEPEND
)
1070 switch (n
->u
.depend_op
)
1072 case OMP_DEPEND_IN
: fputs ("in:", dumpfile
); break;
1073 case OMP_DEPEND_OUT
: fputs ("out:", dumpfile
); break;
1074 case OMP_DEPEND_INOUT
: fputs ("inout:", dumpfile
); break;
1075 case OMP_DEPEND_SINK_FIRST
:
1076 fputs ("sink:", dumpfile
);
1079 fprintf (dumpfile
, "%s", n
->sym
->name
);
1082 fputc ('+', dumpfile
);
1083 show_expr (n
->expr
);
1085 if (n
->next
== NULL
)
1087 else if (n
->next
->u
.depend_op
!= OMP_DEPEND_SINK
)
1089 fputs (") DEPEND(", dumpfile
);
1092 fputc (',', dumpfile
);
1098 else if (list_type
== OMP_LIST_MAP
)
1099 switch (n
->u
.map_op
)
1101 case OMP_MAP_ALLOC
: fputs ("alloc:", dumpfile
); break;
1102 case OMP_MAP_TO
: fputs ("to:", dumpfile
); break;
1103 case OMP_MAP_FROM
: fputs ("from:", dumpfile
); break;
1104 case OMP_MAP_TOFROM
: fputs ("tofrom:", dumpfile
); break;
1107 else if (list_type
== OMP_LIST_LINEAR
)
1108 switch (n
->u
.linear_op
)
1110 case OMP_LINEAR_REF
: fputs ("ref(", dumpfile
); break;
1111 case OMP_LINEAR_VAL
: fputs ("val(", dumpfile
); break;
1112 case OMP_LINEAR_UVAL
: fputs ("uval(", dumpfile
); break;
1115 fprintf (dumpfile
, "%s", n
->sym
->name
);
1116 if (list_type
== OMP_LIST_LINEAR
&& n
->u
.linear_op
!= OMP_LINEAR_DEFAULT
)
1117 fputc (')', dumpfile
);
1120 fputc (':', dumpfile
);
1121 show_expr (n
->expr
);
1124 fputc (',', dumpfile
);
1129 /* Show OpenMP or OpenACC clauses. */
1132 show_omp_clauses (gfc_omp_clauses
*omp_clauses
)
1136 switch (omp_clauses
->cancel
)
1138 case OMP_CANCEL_UNKNOWN
:
1140 case OMP_CANCEL_PARALLEL
:
1141 fputs (" PARALLEL", dumpfile
);
1143 case OMP_CANCEL_SECTIONS
:
1144 fputs (" SECTIONS", dumpfile
);
1147 fputs (" DO", dumpfile
);
1149 case OMP_CANCEL_TASKGROUP
:
1150 fputs (" TASKGROUP", dumpfile
);
1153 if (omp_clauses
->if_expr
)
1155 fputs (" IF(", dumpfile
);
1156 show_expr (omp_clauses
->if_expr
);
1157 fputc (')', dumpfile
);
1159 if (omp_clauses
->final_expr
)
1161 fputs (" FINAL(", dumpfile
);
1162 show_expr (omp_clauses
->final_expr
);
1163 fputc (')', dumpfile
);
1165 if (omp_clauses
->num_threads
)
1167 fputs (" NUM_THREADS(", dumpfile
);
1168 show_expr (omp_clauses
->num_threads
);
1169 fputc (')', dumpfile
);
1171 if (omp_clauses
->async
)
1173 fputs (" ASYNC", dumpfile
);
1174 if (omp_clauses
->async_expr
)
1176 fputc ('(', dumpfile
);
1177 show_expr (omp_clauses
->async_expr
);
1178 fputc (')', dumpfile
);
1181 if (omp_clauses
->num_gangs_expr
)
1183 fputs (" NUM_GANGS(", dumpfile
);
1184 show_expr (omp_clauses
->num_gangs_expr
);
1185 fputc (')', dumpfile
);
1187 if (omp_clauses
->num_workers_expr
)
1189 fputs (" NUM_WORKERS(", dumpfile
);
1190 show_expr (omp_clauses
->num_workers_expr
);
1191 fputc (')', dumpfile
);
1193 if (omp_clauses
->vector_length_expr
)
1195 fputs (" VECTOR_LENGTH(", dumpfile
);
1196 show_expr (omp_clauses
->vector_length_expr
);
1197 fputc (')', dumpfile
);
1199 if (omp_clauses
->gang
)
1201 fputs (" GANG", dumpfile
);
1202 if (omp_clauses
->gang_num_expr
|| omp_clauses
->gang_static_expr
)
1204 fputc ('(', dumpfile
);
1205 if (omp_clauses
->gang_num_expr
)
1207 fprintf (dumpfile
, "num:");
1208 show_expr (omp_clauses
->gang_num_expr
);
1210 if (omp_clauses
->gang_num_expr
&& omp_clauses
->gang_static
)
1211 fputc (',', dumpfile
);
1212 if (omp_clauses
->gang_static
)
1214 fprintf (dumpfile
, "static:");
1215 if (omp_clauses
->gang_static_expr
)
1216 show_expr (omp_clauses
->gang_static_expr
);
1218 fputc ('*', dumpfile
);
1220 fputc (')', dumpfile
);
1223 if (omp_clauses
->worker
)
1225 fputs (" WORKER", dumpfile
);
1226 if (omp_clauses
->worker_expr
)
1228 fputc ('(', dumpfile
);
1229 show_expr (omp_clauses
->worker_expr
);
1230 fputc (')', dumpfile
);
1233 if (omp_clauses
->vector
)
1235 fputs (" VECTOR", dumpfile
);
1236 if (omp_clauses
->vector_expr
)
1238 fputc ('(', dumpfile
);
1239 show_expr (omp_clauses
->vector_expr
);
1240 fputc (')', dumpfile
);
1243 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
1246 switch (omp_clauses
->sched_kind
)
1248 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
1249 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
1250 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
1251 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
1252 case OMP_SCHED_AUTO
: type
= "AUTO"; break;
1256 fputs (" SCHEDULE (", dumpfile
);
1257 if (omp_clauses
->sched_simd
)
1259 if (omp_clauses
->sched_monotonic
1260 || omp_clauses
->sched_nonmonotonic
)
1261 fputs ("SIMD, ", dumpfile
);
1263 fputs ("SIMD: ", dumpfile
);
1265 if (omp_clauses
->sched_monotonic
)
1266 fputs ("MONOTONIC: ", dumpfile
);
1267 else if (omp_clauses
->sched_nonmonotonic
)
1268 fputs ("NONMONOTONIC: ", dumpfile
);
1269 fputs (type
, dumpfile
);
1270 if (omp_clauses
->chunk_size
)
1272 fputc (',', dumpfile
);
1273 show_expr (omp_clauses
->chunk_size
);
1275 fputc (')', dumpfile
);
1277 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1280 switch (omp_clauses
->default_sharing
)
1282 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
1283 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
1284 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
1285 case OMP_DEFAULT_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1286 case OMP_DEFAULT_PRESENT
: type
= "PRESENT"; break;
1290 fprintf (dumpfile
, " DEFAULT(%s)", type
);
1292 if (omp_clauses
->tile_list
)
1294 gfc_expr_list
*list
;
1295 fputs (" TILE(", dumpfile
);
1296 for (list
= omp_clauses
->tile_list
; list
; list
= list
->next
)
1298 show_expr (list
->expr
);
1300 fputs (", ", dumpfile
);
1302 fputc (')', dumpfile
);
1304 if (omp_clauses
->wait_list
)
1306 gfc_expr_list
*list
;
1307 fputs (" WAIT(", dumpfile
);
1308 for (list
= omp_clauses
->wait_list
; list
; list
= list
->next
)
1310 show_expr (list
->expr
);
1312 fputs (", ", dumpfile
);
1314 fputc (')', dumpfile
);
1316 if (omp_clauses
->seq
)
1317 fputs (" SEQ", dumpfile
);
1318 if (omp_clauses
->independent
)
1319 fputs (" INDEPENDENT", dumpfile
);
1320 if (omp_clauses
->ordered
)
1322 if (omp_clauses
->orderedc
)
1323 fprintf (dumpfile
, " ORDERED(%d)", omp_clauses
->orderedc
);
1325 fputs (" ORDERED", dumpfile
);
1327 if (omp_clauses
->untied
)
1328 fputs (" UNTIED", dumpfile
);
1329 if (omp_clauses
->mergeable
)
1330 fputs (" MERGEABLE", dumpfile
);
1331 if (omp_clauses
->collapse
)
1332 fprintf (dumpfile
, " COLLAPSE(%d)", omp_clauses
->collapse
);
1333 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
1334 if (omp_clauses
->lists
[list_type
] != NULL
1335 && list_type
!= OMP_LIST_COPYPRIVATE
)
1337 const char *type
= NULL
;
1340 case OMP_LIST_USE_DEVICE
: type
= "USE_DEVICE"; break;
1341 case OMP_LIST_DEVICE_RESIDENT
: type
= "USE_DEVICE"; break;
1342 case OMP_LIST_CACHE
: type
= ""; break;
1343 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
1344 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1345 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
1346 case OMP_LIST_SHARED
: type
= "SHARED"; break;
1347 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
1348 case OMP_LIST_UNIFORM
: type
= "UNIFORM"; break;
1349 case OMP_LIST_ALIGNED
: type
= "ALIGNED"; break;
1350 case OMP_LIST_LINEAR
: type
= "LINEAR"; break;
1351 case OMP_LIST_REDUCTION
: type
= "REDUCTION"; break;
1352 case OMP_LIST_IS_DEVICE_PTR
: type
= "IS_DEVICE_PTR"; break;
1353 case OMP_LIST_USE_DEVICE_PTR
: type
= "USE_DEVICE_PTR"; break;
1354 case OMP_LIST_DEPEND
: type
= "DEPEND"; break;
1358 fprintf (dumpfile
, " %s(", type
);
1359 show_omp_namelist (list_type
, omp_clauses
->lists
[list_type
]);
1360 fputc (')', dumpfile
);
1362 if (omp_clauses
->safelen_expr
)
1364 fputs (" SAFELEN(", dumpfile
);
1365 show_expr (omp_clauses
->safelen_expr
);
1366 fputc (')', dumpfile
);
1368 if (omp_clauses
->simdlen_expr
)
1370 fputs (" SIMDLEN(", dumpfile
);
1371 show_expr (omp_clauses
->simdlen_expr
);
1372 fputc (')', dumpfile
);
1374 if (omp_clauses
->inbranch
)
1375 fputs (" INBRANCH", dumpfile
);
1376 if (omp_clauses
->notinbranch
)
1377 fputs (" NOTINBRANCH", dumpfile
);
1378 if (omp_clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
1381 switch (omp_clauses
->proc_bind
)
1383 case OMP_PROC_BIND_MASTER
: type
= "MASTER"; break;
1384 case OMP_PROC_BIND_SPREAD
: type
= "SPREAD"; break;
1385 case OMP_PROC_BIND_CLOSE
: type
= "CLOSE"; break;
1389 fprintf (dumpfile
, " PROC_BIND(%s)", type
);
1391 if (omp_clauses
->num_teams
)
1393 fputs (" NUM_TEAMS(", dumpfile
);
1394 show_expr (omp_clauses
->num_teams
);
1395 fputc (')', dumpfile
);
1397 if (omp_clauses
->device
)
1399 fputs (" DEVICE(", dumpfile
);
1400 show_expr (omp_clauses
->device
);
1401 fputc (')', dumpfile
);
1403 if (omp_clauses
->thread_limit
)
1405 fputs (" THREAD_LIMIT(", dumpfile
);
1406 show_expr (omp_clauses
->thread_limit
);
1407 fputc (')', dumpfile
);
1409 if (omp_clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
1411 fprintf (dumpfile
, " DIST_SCHEDULE (STATIC");
1412 if (omp_clauses
->dist_chunk_size
)
1414 fputc (',', dumpfile
);
1415 show_expr (omp_clauses
->dist_chunk_size
);
1417 fputc (')', dumpfile
);
1419 if (omp_clauses
->defaultmap
)
1420 fputs (" DEFALTMAP (TOFROM: SCALAR)", dumpfile
);
1421 if (omp_clauses
->nogroup
)
1422 fputs (" NOGROUP", dumpfile
);
1423 if (omp_clauses
->simd
)
1424 fputs (" SIMD", dumpfile
);
1425 if (omp_clauses
->threads
)
1426 fputs (" THREADS", dumpfile
);
1427 if (omp_clauses
->grainsize
)
1429 fputs (" GRAINSIZE(", dumpfile
);
1430 show_expr (omp_clauses
->grainsize
);
1431 fputc (')', dumpfile
);
1433 if (omp_clauses
->hint
)
1435 fputs (" HINT(", dumpfile
);
1436 show_expr (omp_clauses
->hint
);
1437 fputc (')', dumpfile
);
1439 if (omp_clauses
->num_tasks
)
1441 fputs (" NUM_TASKS(", dumpfile
);
1442 show_expr (omp_clauses
->num_tasks
);
1443 fputc (')', dumpfile
);
1445 if (omp_clauses
->priority
)
1447 fputs (" PRIORITY(", dumpfile
);
1448 show_expr (omp_clauses
->priority
);
1449 fputc (')', dumpfile
);
1451 for (i
= 0; i
< OMP_IF_LAST
; i
++)
1452 if (omp_clauses
->if_exprs
[i
])
1454 static const char *ifs
[] = {
1461 "TARGET ENTER DATA",
1464 fputs (" IF(", dumpfile
);
1465 fputs (ifs
[i
], dumpfile
);
1466 fputs (": ", dumpfile
);
1467 show_expr (omp_clauses
->if_exprs
[i
]);
1468 fputc (')', dumpfile
);
1470 if (omp_clauses
->depend_source
)
1471 fputs (" DEPEND(source)", dumpfile
);
1474 /* Show a single OpenMP or OpenACC directive node and everything underneath it
1478 show_omp_node (int level
, gfc_code
*c
)
1480 gfc_omp_clauses
*omp_clauses
= NULL
;
1481 const char *name
= NULL
;
1482 bool is_oacc
= false;
1486 case EXEC_OACC_PARALLEL_LOOP
:
1487 name
= "PARALLEL LOOP"; is_oacc
= true; break;
1488 case EXEC_OACC_PARALLEL
: name
= "PARALLEL"; is_oacc
= true; break;
1489 case EXEC_OACC_KERNELS_LOOP
: name
= "KERNELS LOOP"; is_oacc
= true; break;
1490 case EXEC_OACC_KERNELS
: name
= "KERNELS"; is_oacc
= true; break;
1491 case EXEC_OACC_DATA
: name
= "DATA"; is_oacc
= true; break;
1492 case EXEC_OACC_HOST_DATA
: name
= "HOST_DATA"; is_oacc
= true; break;
1493 case EXEC_OACC_LOOP
: name
= "LOOP"; is_oacc
= true; break;
1494 case EXEC_OACC_UPDATE
: name
= "UPDATE"; is_oacc
= true; break;
1495 case EXEC_OACC_WAIT
: name
= "WAIT"; is_oacc
= true; break;
1496 case EXEC_OACC_CACHE
: name
= "CACHE"; is_oacc
= true; break;
1497 case EXEC_OACC_ENTER_DATA
: name
= "ENTER DATA"; is_oacc
= true; break;
1498 case EXEC_OACC_EXIT_DATA
: name
= "EXIT DATA"; is_oacc
= true; break;
1499 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
1500 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
1501 case EXEC_OMP_CANCEL
: name
= "CANCEL"; break;
1502 case EXEC_OMP_CANCELLATION_POINT
: name
= "CANCELLATION POINT"; break;
1503 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
1504 case EXEC_OMP_DISTRIBUTE
: name
= "DISTRIBUTE"; break;
1505 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1506 name
= "DISTRIBUTE PARALLEL DO"; break;
1507 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1508 name
= "DISTRIBUTE PARALLEL DO SIMD"; break;
1509 case EXEC_OMP_DISTRIBUTE_SIMD
: name
= "DISTRIBUTE SIMD"; break;
1510 case EXEC_OMP_DO
: name
= "DO"; break;
1511 case EXEC_OMP_DO_SIMD
: name
= "DO SIMD"; break;
1512 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
1513 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
1514 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
1515 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
1516 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
1517 case EXEC_OMP_PARALLEL_DO_SIMD
: name
= "PARALLEL DO SIMD"; break;
1518 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
1519 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
1520 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
1521 case EXEC_OMP_SIMD
: name
= "SIMD"; break;
1522 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
1523 case EXEC_OMP_TARGET
: name
= "TARGET"; break;
1524 case EXEC_OMP_TARGET_DATA
: name
= "TARGET DATA"; break;
1525 case EXEC_OMP_TARGET_ENTER_DATA
: name
= "TARGET ENTER DATA"; break;
1526 case EXEC_OMP_TARGET_EXIT_DATA
: name
= "TARGET EXIT DATA"; break;
1527 case EXEC_OMP_TARGET_PARALLEL
: name
= "TARGET PARALLEL"; break;
1528 case EXEC_OMP_TARGET_PARALLEL_DO
: name
= "TARGET PARALLEL DO"; break;
1529 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
1530 name
= "TARGET_PARALLEL_DO_SIMD"; break;
1531 case EXEC_OMP_TARGET_SIMD
: name
= "TARGET SIMD"; break;
1532 case EXEC_OMP_TARGET_TEAMS
: name
= "TARGET TEAMS"; break;
1533 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1534 name
= "TARGET TEAMS DISTRIBUTE"; break;
1535 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1536 name
= "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break;
1537 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1538 name
= "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
1539 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1540 name
= "TARGET TEAMS DISTRIBUTE SIMD"; break;
1541 case EXEC_OMP_TARGET_UPDATE
: name
= "TARGET UPDATE"; break;
1542 case EXEC_OMP_TASK
: name
= "TASK"; break;
1543 case EXEC_OMP_TASKGROUP
: name
= "TASKGROUP"; break;
1544 case EXEC_OMP_TASKLOOP
: name
= "TASKLOOP"; break;
1545 case EXEC_OMP_TASKLOOP_SIMD
: name
= "TASKLOOP SIMD"; break;
1546 case EXEC_OMP_TASKWAIT
: name
= "TASKWAIT"; break;
1547 case EXEC_OMP_TASKYIELD
: name
= "TASKYIELD"; break;
1548 case EXEC_OMP_TEAMS
: name
= "TEAMS"; break;
1549 case EXEC_OMP_TEAMS_DISTRIBUTE
: name
= "TEAMS DISTRIBUTE"; break;
1550 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1551 name
= "TEAMS DISTRIBUTE PARALLEL DO"; break;
1552 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1553 name
= "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
1554 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
: name
= "TEAMS DISTRIBUTE SIMD"; break;
1555 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
1559 fprintf (dumpfile
, "!$%s %s", is_oacc
? "ACC" : "OMP", name
);
1562 case EXEC_OACC_PARALLEL_LOOP
:
1563 case EXEC_OACC_PARALLEL
:
1564 case EXEC_OACC_KERNELS_LOOP
:
1565 case EXEC_OACC_KERNELS
:
1566 case EXEC_OACC_DATA
:
1567 case EXEC_OACC_HOST_DATA
:
1568 case EXEC_OACC_LOOP
:
1569 case EXEC_OACC_UPDATE
:
1570 case EXEC_OACC_WAIT
:
1571 case EXEC_OACC_CACHE
:
1572 case EXEC_OACC_ENTER_DATA
:
1573 case EXEC_OACC_EXIT_DATA
:
1574 case EXEC_OMP_CANCEL
:
1575 case EXEC_OMP_CANCELLATION_POINT
:
1576 case EXEC_OMP_DISTRIBUTE
:
1577 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1578 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1579 case EXEC_OMP_DISTRIBUTE_SIMD
:
1581 case EXEC_OMP_DO_SIMD
:
1582 case EXEC_OMP_ORDERED
:
1583 case EXEC_OMP_PARALLEL
:
1584 case EXEC_OMP_PARALLEL_DO
:
1585 case EXEC_OMP_PARALLEL_DO_SIMD
:
1586 case EXEC_OMP_PARALLEL_SECTIONS
:
1587 case EXEC_OMP_PARALLEL_WORKSHARE
:
1588 case EXEC_OMP_SECTIONS
:
1590 case EXEC_OMP_SINGLE
:
1591 case EXEC_OMP_TARGET
:
1592 case EXEC_OMP_TARGET_DATA
:
1593 case EXEC_OMP_TARGET_ENTER_DATA
:
1594 case EXEC_OMP_TARGET_EXIT_DATA
:
1595 case EXEC_OMP_TARGET_PARALLEL
:
1596 case EXEC_OMP_TARGET_PARALLEL_DO
:
1597 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
1598 case EXEC_OMP_TARGET_SIMD
:
1599 case EXEC_OMP_TARGET_TEAMS
:
1600 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1601 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1602 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1603 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1604 case EXEC_OMP_TARGET_UPDATE
:
1606 case EXEC_OMP_TASKLOOP
:
1607 case EXEC_OMP_TASKLOOP_SIMD
:
1608 case EXEC_OMP_TEAMS
:
1609 case EXEC_OMP_TEAMS_DISTRIBUTE
:
1610 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1611 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1612 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
1613 case EXEC_OMP_WORKSHARE
:
1614 omp_clauses
= c
->ext
.omp_clauses
;
1616 case EXEC_OMP_CRITICAL
:
1617 omp_clauses
= c
->ext
.omp_clauses
;
1619 fprintf (dumpfile
, " (%s)", c
->ext
.omp_clauses
->critical_name
);
1621 case EXEC_OMP_FLUSH
:
1622 if (c
->ext
.omp_namelist
)
1624 fputs (" (", dumpfile
);
1625 show_omp_namelist (OMP_LIST_NUM
, c
->ext
.omp_namelist
);
1626 fputc (')', dumpfile
);
1629 case EXEC_OMP_BARRIER
:
1630 case EXEC_OMP_TASKWAIT
:
1631 case EXEC_OMP_TASKYIELD
:
1637 show_omp_clauses (omp_clauses
);
1638 fputc ('\n', dumpfile
);
1640 /* OpenMP and OpenACC executable directives don't have associated blocks. */
1641 if (c
->op
== EXEC_OACC_CACHE
|| c
->op
== EXEC_OACC_UPDATE
1642 || c
->op
== EXEC_OACC_ENTER_DATA
|| c
->op
== EXEC_OACC_EXIT_DATA
1643 || c
->op
== EXEC_OMP_TARGET_UPDATE
|| c
->op
== EXEC_OMP_TARGET_ENTER_DATA
1644 || c
->op
== EXEC_OMP_TARGET_EXIT_DATA
1645 || (c
->op
== EXEC_OMP_ORDERED
&& c
->block
== NULL
))
1647 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
1649 gfc_code
*d
= c
->block
;
1652 show_code (level
+ 1, d
->next
);
1653 if (d
->block
== NULL
)
1655 code_indent (level
, 0);
1656 fputs ("!$OMP SECTION\n", dumpfile
);
1661 show_code (level
+ 1, c
->block
->next
);
1662 if (c
->op
== EXEC_OMP_ATOMIC
)
1664 fputc ('\n', dumpfile
);
1665 code_indent (level
, 0);
1666 fprintf (dumpfile
, "!$%s END %s", is_oacc
? "ACC" : "OMP", name
);
1667 if (omp_clauses
!= NULL
)
1669 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
1671 fputs (" COPYPRIVATE(", dumpfile
);
1672 show_omp_namelist (OMP_LIST_COPYPRIVATE
,
1673 omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1674 fputc (')', dumpfile
);
1676 else if (omp_clauses
->nowait
)
1677 fputs (" NOWAIT", dumpfile
);
1679 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_clauses
)
1680 fprintf (dumpfile
, " (%s)", c
->ext
.omp_clauses
->critical_name
);
1684 /* Show a single code node and everything underneath it if necessary. */
1687 show_code_node (int level
, gfc_code
*c
)
1689 gfc_forall_iterator
*fa
;
1702 fputc ('\n', dumpfile
);
1703 code_indent (level
, c
->here
);
1710 case EXEC_END_PROCEDURE
:
1714 fputs ("NOP", dumpfile
);
1718 fputs ("CONTINUE", dumpfile
);
1722 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
1725 case EXEC_INIT_ASSIGN
:
1727 fputs ("ASSIGN ", dumpfile
);
1728 show_expr (c
->expr1
);
1729 fputc (' ', dumpfile
);
1730 show_expr (c
->expr2
);
1733 case EXEC_LABEL_ASSIGN
:
1734 fputs ("LABEL ASSIGN ", dumpfile
);
1735 show_expr (c
->expr1
);
1736 fprintf (dumpfile
, " %d", c
->label1
->value
);
1739 case EXEC_POINTER_ASSIGN
:
1740 fputs ("POINTER ASSIGN ", dumpfile
);
1741 show_expr (c
->expr1
);
1742 fputc (' ', dumpfile
);
1743 show_expr (c
->expr2
);
1747 fputs ("GOTO ", dumpfile
);
1749 fprintf (dumpfile
, "%d", c
->label1
->value
);
1752 show_expr (c
->expr1
);
1756 fputs (", (", dumpfile
);
1757 for (; d
; d
= d
->block
)
1759 code_indent (level
, d
->label1
);
1760 if (d
->block
!= NULL
)
1761 fputc (',', dumpfile
);
1763 fputc (')', dumpfile
);
1770 case EXEC_ASSIGN_CALL
:
1771 if (c
->resolved_sym
)
1772 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
1773 else if (c
->symtree
)
1774 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
1776 fputs ("CALL ?? ", dumpfile
);
1778 show_actual_arglist (c
->ext
.actual
);
1782 fputs ("CALL ", dumpfile
);
1783 show_compcall (c
->expr1
);
1787 fputs ("CALL ", dumpfile
);
1788 show_expr (c
->expr1
);
1789 show_actual_arglist (c
->ext
.actual
);
1793 fputs ("RETURN ", dumpfile
);
1795 show_expr (c
->expr1
);
1799 fputs ("PAUSE ", dumpfile
);
1801 if (c
->expr1
!= NULL
)
1802 show_expr (c
->expr1
);
1804 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1808 case EXEC_ERROR_STOP
:
1809 fputs ("ERROR ", dumpfile
);
1813 fputs ("STOP ", dumpfile
);
1815 if (c
->expr1
!= NULL
)
1816 show_expr (c
->expr1
);
1818 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1822 case EXEC_FAIL_IMAGE
:
1823 fputs ("FAIL IMAGE ", dumpfile
);
1827 fputs ("SYNC ALL ", dumpfile
);
1828 if (c
->expr2
!= NULL
)
1830 fputs (" stat=", dumpfile
);
1831 show_expr (c
->expr2
);
1833 if (c
->expr3
!= NULL
)
1835 fputs (" errmsg=", dumpfile
);
1836 show_expr (c
->expr3
);
1840 case EXEC_SYNC_MEMORY
:
1841 fputs ("SYNC MEMORY ", dumpfile
);
1842 if (c
->expr2
!= NULL
)
1844 fputs (" stat=", dumpfile
);
1845 show_expr (c
->expr2
);
1847 if (c
->expr3
!= NULL
)
1849 fputs (" errmsg=", dumpfile
);
1850 show_expr (c
->expr3
);
1854 case EXEC_SYNC_IMAGES
:
1855 fputs ("SYNC IMAGES image-set=", dumpfile
);
1856 if (c
->expr1
!= NULL
)
1857 show_expr (c
->expr1
);
1859 fputs ("* ", dumpfile
);
1860 if (c
->expr2
!= NULL
)
1862 fputs (" stat=", dumpfile
);
1863 show_expr (c
->expr2
);
1865 if (c
->expr3
!= NULL
)
1867 fputs (" errmsg=", dumpfile
);
1868 show_expr (c
->expr3
);
1872 case EXEC_EVENT_POST
:
1873 case EXEC_EVENT_WAIT
:
1874 if (c
->op
== EXEC_EVENT_POST
)
1875 fputs ("EVENT POST ", dumpfile
);
1877 fputs ("EVENT WAIT ", dumpfile
);
1879 fputs ("event-variable=", dumpfile
);
1880 if (c
->expr1
!= NULL
)
1881 show_expr (c
->expr1
);
1882 if (c
->expr4
!= NULL
)
1884 fputs (" until_count=", dumpfile
);
1885 show_expr (c
->expr4
);
1887 if (c
->expr2
!= NULL
)
1889 fputs (" stat=", dumpfile
);
1890 show_expr (c
->expr2
);
1892 if (c
->expr3
!= NULL
)
1894 fputs (" errmsg=", dumpfile
);
1895 show_expr (c
->expr3
);
1901 if (c
->op
== EXEC_LOCK
)
1902 fputs ("LOCK ", dumpfile
);
1904 fputs ("UNLOCK ", dumpfile
);
1906 fputs ("lock-variable=", dumpfile
);
1907 if (c
->expr1
!= NULL
)
1908 show_expr (c
->expr1
);
1909 if (c
->expr4
!= NULL
)
1911 fputs (" acquired_lock=", dumpfile
);
1912 show_expr (c
->expr4
);
1914 if (c
->expr2
!= NULL
)
1916 fputs (" stat=", dumpfile
);
1917 show_expr (c
->expr2
);
1919 if (c
->expr3
!= NULL
)
1921 fputs (" errmsg=", dumpfile
);
1922 show_expr (c
->expr3
);
1926 case EXEC_ARITHMETIC_IF
:
1927 fputs ("IF ", dumpfile
);
1928 show_expr (c
->expr1
);
1929 fprintf (dumpfile
, " %d, %d, %d",
1930 c
->label1
->value
, c
->label2
->value
, c
->label3
->value
);
1935 fputs ("IF ", dumpfile
);
1936 show_expr (d
->expr1
);
1939 show_code (level
+ 1, d
->next
);
1943 for (; d
; d
= d
->block
)
1945 code_indent (level
, 0);
1947 if (d
->expr1
== NULL
)
1948 fputs ("ELSE", dumpfile
);
1951 fputs ("ELSE IF ", dumpfile
);
1952 show_expr (d
->expr1
);
1956 show_code (level
+ 1, d
->next
);
1961 code_indent (level
, c
->label1
);
1965 fputs ("ENDIF", dumpfile
);
1970 const char* blocktype
;
1971 gfc_namespace
*saved_ns
;
1972 gfc_association_list
*alist
;
1974 if (c
->ext
.block
.assoc
)
1975 blocktype
= "ASSOCIATE";
1977 blocktype
= "BLOCK";
1979 fprintf (dumpfile
, "%s ", blocktype
);
1980 for (alist
= c
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
1982 fprintf (dumpfile
, " %s = ", alist
->name
);
1983 show_expr (alist
->target
);
1987 ns
= c
->ext
.block
.ns
;
1988 saved_ns
= gfc_current_ns
;
1989 gfc_current_ns
= ns
;
1990 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
1991 gfc_current_ns
= saved_ns
;
1992 show_code (show_level
, ns
->code
);
1995 fprintf (dumpfile
, "END %s ", blocktype
);
1999 case EXEC_END_BLOCK
:
2000 /* Only come here when there is a label on an
2001 END ASSOCIATE construct. */
2005 case EXEC_SELECT_TYPE
:
2007 if (c
->op
== EXEC_SELECT_TYPE
)
2008 fputs ("SELECT TYPE ", dumpfile
);
2010 fputs ("SELECT CASE ", dumpfile
);
2011 show_expr (c
->expr1
);
2012 fputc ('\n', dumpfile
);
2014 for (; d
; d
= d
->block
)
2016 code_indent (level
, 0);
2018 fputs ("CASE ", dumpfile
);
2019 for (cp
= d
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2021 fputc ('(', dumpfile
);
2022 show_expr (cp
->low
);
2023 fputc (' ', dumpfile
);
2024 show_expr (cp
->high
);
2025 fputc (')', dumpfile
);
2026 fputc (' ', dumpfile
);
2028 fputc ('\n', dumpfile
);
2030 show_code (level
+ 1, d
->next
);
2033 code_indent (level
, c
->label1
);
2034 fputs ("END SELECT", dumpfile
);
2038 fputs ("WHERE ", dumpfile
);
2041 show_expr (d
->expr1
);
2042 fputc ('\n', dumpfile
);
2044 show_code (level
+ 1, d
->next
);
2046 for (d
= d
->block
; d
; d
= d
->block
)
2048 code_indent (level
, 0);
2049 fputs ("ELSE WHERE ", dumpfile
);
2050 show_expr (d
->expr1
);
2051 fputc ('\n', dumpfile
);
2052 show_code (level
+ 1, d
->next
);
2055 code_indent (level
, 0);
2056 fputs ("END WHERE", dumpfile
);
2061 fputs ("FORALL ", dumpfile
);
2062 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2064 show_expr (fa
->var
);
2065 fputc (' ', dumpfile
);
2066 show_expr (fa
->start
);
2067 fputc (':', dumpfile
);
2068 show_expr (fa
->end
);
2069 fputc (':', dumpfile
);
2070 show_expr (fa
->stride
);
2072 if (fa
->next
!= NULL
)
2073 fputc (',', dumpfile
);
2076 if (c
->expr1
!= NULL
)
2078 fputc (',', dumpfile
);
2079 show_expr (c
->expr1
);
2081 fputc ('\n', dumpfile
);
2083 show_code (level
+ 1, c
->block
->next
);
2085 code_indent (level
, 0);
2086 fputs ("END FORALL", dumpfile
);
2090 fputs ("CRITICAL\n", dumpfile
);
2091 show_code (level
+ 1, c
->block
->next
);
2092 code_indent (level
, 0);
2093 fputs ("END CRITICAL", dumpfile
);
2097 fputs ("DO ", dumpfile
);
2099 fprintf (dumpfile
, " %-5d ", c
->label1
->value
);
2101 show_expr (c
->ext
.iterator
->var
);
2102 fputc ('=', dumpfile
);
2103 show_expr (c
->ext
.iterator
->start
);
2104 fputc (' ', dumpfile
);
2105 show_expr (c
->ext
.iterator
->end
);
2106 fputc (' ', dumpfile
);
2107 show_expr (c
->ext
.iterator
->step
);
2110 show_code (level
+ 1, c
->block
->next
);
2117 fputs ("END DO", dumpfile
);
2120 case EXEC_DO_CONCURRENT
:
2121 fputs ("DO CONCURRENT ", dumpfile
);
2122 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2124 show_expr (fa
->var
);
2125 fputc (' ', dumpfile
);
2126 show_expr (fa
->start
);
2127 fputc (':', dumpfile
);
2128 show_expr (fa
->end
);
2129 fputc (':', dumpfile
);
2130 show_expr (fa
->stride
);
2132 if (fa
->next
!= NULL
)
2133 fputc (',', dumpfile
);
2135 show_expr (c
->expr1
);
2137 show_code (level
+ 1, c
->block
->next
);
2138 code_indent (level
, c
->label1
);
2139 fputs ("END DO", dumpfile
);
2143 fputs ("DO WHILE ", dumpfile
);
2144 show_expr (c
->expr1
);
2145 fputc ('\n', dumpfile
);
2147 show_code (level
+ 1, c
->block
->next
);
2149 code_indent (level
, c
->label1
);
2150 fputs ("END DO", dumpfile
);
2154 fputs ("CYCLE", dumpfile
);
2156 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
2160 fputs ("EXIT", dumpfile
);
2162 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
2166 fputs ("ALLOCATE ", dumpfile
);
2169 fputs (" STAT=", dumpfile
);
2170 show_expr (c
->expr1
);
2175 fputs (" ERRMSG=", dumpfile
);
2176 show_expr (c
->expr2
);
2182 fputs (" MOLD=", dumpfile
);
2184 fputs (" SOURCE=", dumpfile
);
2185 show_expr (c
->expr3
);
2188 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
2190 fputc (' ', dumpfile
);
2191 show_expr (a
->expr
);
2196 case EXEC_DEALLOCATE
:
2197 fputs ("DEALLOCATE ", dumpfile
);
2200 fputs (" STAT=", dumpfile
);
2201 show_expr (c
->expr1
);
2206 fputs (" ERRMSG=", dumpfile
);
2207 show_expr (c
->expr2
);
2210 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
2212 fputc (' ', dumpfile
);
2213 show_expr (a
->expr
);
2219 fputs ("OPEN", dumpfile
);
2224 fputs (" UNIT=", dumpfile
);
2225 show_expr (open
->unit
);
2229 fputs (" IOMSG=", dumpfile
);
2230 show_expr (open
->iomsg
);
2234 fputs (" IOSTAT=", dumpfile
);
2235 show_expr (open
->iostat
);
2239 fputs (" FILE=", dumpfile
);
2240 show_expr (open
->file
);
2244 fputs (" STATUS=", dumpfile
);
2245 show_expr (open
->status
);
2249 fputs (" ACCESS=", dumpfile
);
2250 show_expr (open
->access
);
2254 fputs (" FORM=", dumpfile
);
2255 show_expr (open
->form
);
2259 fputs (" RECL=", dumpfile
);
2260 show_expr (open
->recl
);
2264 fputs (" BLANK=", dumpfile
);
2265 show_expr (open
->blank
);
2269 fputs (" POSITION=", dumpfile
);
2270 show_expr (open
->position
);
2274 fputs (" ACTION=", dumpfile
);
2275 show_expr (open
->action
);
2279 fputs (" DELIM=", dumpfile
);
2280 show_expr (open
->delim
);
2284 fputs (" PAD=", dumpfile
);
2285 show_expr (open
->pad
);
2289 fputs (" DECIMAL=", dumpfile
);
2290 show_expr (open
->decimal
);
2294 fputs (" ENCODING=", dumpfile
);
2295 show_expr (open
->encoding
);
2299 fputs (" ROUND=", dumpfile
);
2300 show_expr (open
->round
);
2304 fputs (" SIGN=", dumpfile
);
2305 show_expr (open
->sign
);
2309 fputs (" CONVERT=", dumpfile
);
2310 show_expr (open
->convert
);
2312 if (open
->asynchronous
)
2314 fputs (" ASYNCHRONOUS=", dumpfile
);
2315 show_expr (open
->asynchronous
);
2317 if (open
->err
!= NULL
)
2318 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
2323 fputs ("CLOSE", dumpfile
);
2324 close
= c
->ext
.close
;
2328 fputs (" UNIT=", dumpfile
);
2329 show_expr (close
->unit
);
2333 fputs (" IOMSG=", dumpfile
);
2334 show_expr (close
->iomsg
);
2338 fputs (" IOSTAT=", dumpfile
);
2339 show_expr (close
->iostat
);
2343 fputs (" STATUS=", dumpfile
);
2344 show_expr (close
->status
);
2346 if (close
->err
!= NULL
)
2347 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
2350 case EXEC_BACKSPACE
:
2351 fputs ("BACKSPACE", dumpfile
);
2355 fputs ("ENDFILE", dumpfile
);
2359 fputs ("REWIND", dumpfile
);
2363 fputs ("FLUSH", dumpfile
);
2366 fp
= c
->ext
.filepos
;
2370 fputs (" UNIT=", dumpfile
);
2371 show_expr (fp
->unit
);
2375 fputs (" IOMSG=", dumpfile
);
2376 show_expr (fp
->iomsg
);
2380 fputs (" IOSTAT=", dumpfile
);
2381 show_expr (fp
->iostat
);
2383 if (fp
->err
!= NULL
)
2384 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
2388 fputs ("INQUIRE", dumpfile
);
2393 fputs (" UNIT=", dumpfile
);
2394 show_expr (i
->unit
);
2398 fputs (" FILE=", dumpfile
);
2399 show_expr (i
->file
);
2404 fputs (" IOMSG=", dumpfile
);
2405 show_expr (i
->iomsg
);
2409 fputs (" IOSTAT=", dumpfile
);
2410 show_expr (i
->iostat
);
2414 fputs (" EXIST=", dumpfile
);
2415 show_expr (i
->exist
);
2419 fputs (" OPENED=", dumpfile
);
2420 show_expr (i
->opened
);
2424 fputs (" NUMBER=", dumpfile
);
2425 show_expr (i
->number
);
2429 fputs (" NAMED=", dumpfile
);
2430 show_expr (i
->named
);
2434 fputs (" NAME=", dumpfile
);
2435 show_expr (i
->name
);
2439 fputs (" ACCESS=", dumpfile
);
2440 show_expr (i
->access
);
2444 fputs (" SEQUENTIAL=", dumpfile
);
2445 show_expr (i
->sequential
);
2450 fputs (" DIRECT=", dumpfile
);
2451 show_expr (i
->direct
);
2455 fputs (" FORM=", dumpfile
);
2456 show_expr (i
->form
);
2460 fputs (" FORMATTED", dumpfile
);
2461 show_expr (i
->formatted
);
2465 fputs (" UNFORMATTED=", dumpfile
);
2466 show_expr (i
->unformatted
);
2470 fputs (" RECL=", dumpfile
);
2471 show_expr (i
->recl
);
2475 fputs (" NEXTREC=", dumpfile
);
2476 show_expr (i
->nextrec
);
2480 fputs (" BLANK=", dumpfile
);
2481 show_expr (i
->blank
);
2485 fputs (" POSITION=", dumpfile
);
2486 show_expr (i
->position
);
2490 fputs (" ACTION=", dumpfile
);
2491 show_expr (i
->action
);
2495 fputs (" READ=", dumpfile
);
2496 show_expr (i
->read
);
2500 fputs (" WRITE=", dumpfile
);
2501 show_expr (i
->write
);
2505 fputs (" READWRITE=", dumpfile
);
2506 show_expr (i
->readwrite
);
2510 fputs (" DELIM=", dumpfile
);
2511 show_expr (i
->delim
);
2515 fputs (" PAD=", dumpfile
);
2520 fputs (" CONVERT=", dumpfile
);
2521 show_expr (i
->convert
);
2523 if (i
->asynchronous
)
2525 fputs (" ASYNCHRONOUS=", dumpfile
);
2526 show_expr (i
->asynchronous
);
2530 fputs (" DECIMAL=", dumpfile
);
2531 show_expr (i
->decimal
);
2535 fputs (" ENCODING=", dumpfile
);
2536 show_expr (i
->encoding
);
2540 fputs (" PENDING=", dumpfile
);
2541 show_expr (i
->pending
);
2545 fputs (" ROUND=", dumpfile
);
2546 show_expr (i
->round
);
2550 fputs (" SIGN=", dumpfile
);
2551 show_expr (i
->sign
);
2555 fputs (" SIZE=", dumpfile
);
2556 show_expr (i
->size
);
2560 fputs (" ID=", dumpfile
);
2565 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
2569 fputs ("IOLENGTH ", dumpfile
);
2570 show_expr (c
->expr1
);
2575 fputs ("READ", dumpfile
);
2579 fputs ("WRITE", dumpfile
);
2585 fputs (" UNIT=", dumpfile
);
2586 show_expr (dt
->io_unit
);
2589 if (dt
->format_expr
)
2591 fputs (" FMT=", dumpfile
);
2592 show_expr (dt
->format_expr
);
2595 if (dt
->format_label
!= NULL
)
2596 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
2598 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
2602 fputs (" IOMSG=", dumpfile
);
2603 show_expr (dt
->iomsg
);
2607 fputs (" IOSTAT=", dumpfile
);
2608 show_expr (dt
->iostat
);
2612 fputs (" SIZE=", dumpfile
);
2613 show_expr (dt
->size
);
2617 fputs (" REC=", dumpfile
);
2618 show_expr (dt
->rec
);
2622 fputs (" ADVANCE=", dumpfile
);
2623 show_expr (dt
->advance
);
2627 fputs (" ID=", dumpfile
);
2632 fputs (" POS=", dumpfile
);
2633 show_expr (dt
->pos
);
2635 if (dt
->asynchronous
)
2637 fputs (" ASYNCHRONOUS=", dumpfile
);
2638 show_expr (dt
->asynchronous
);
2642 fputs (" BLANK=", dumpfile
);
2643 show_expr (dt
->blank
);
2647 fputs (" DECIMAL=", dumpfile
);
2648 show_expr (dt
->decimal
);
2652 fputs (" DELIM=", dumpfile
);
2653 show_expr (dt
->delim
);
2657 fputs (" PAD=", dumpfile
);
2658 show_expr (dt
->pad
);
2662 fputs (" ROUND=", dumpfile
);
2663 show_expr (dt
->round
);
2667 fputs (" SIGN=", dumpfile
);
2668 show_expr (dt
->sign
);
2672 for (c
= c
->block
->next
; c
; c
= c
->next
)
2673 show_code_node (level
+ (c
->next
!= NULL
), c
);
2677 fputs ("TRANSFER ", dumpfile
);
2678 show_expr (c
->expr1
);
2682 fputs ("DT_END", dumpfile
);
2685 if (dt
->err
!= NULL
)
2686 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
2687 if (dt
->end
!= NULL
)
2688 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
2689 if (dt
->eor
!= NULL
)
2690 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
2693 case EXEC_OACC_PARALLEL_LOOP
:
2694 case EXEC_OACC_PARALLEL
:
2695 case EXEC_OACC_KERNELS_LOOP
:
2696 case EXEC_OACC_KERNELS
:
2697 case EXEC_OACC_DATA
:
2698 case EXEC_OACC_HOST_DATA
:
2699 case EXEC_OACC_LOOP
:
2700 case EXEC_OACC_UPDATE
:
2701 case EXEC_OACC_WAIT
:
2702 case EXEC_OACC_CACHE
:
2703 case EXEC_OACC_ENTER_DATA
:
2704 case EXEC_OACC_EXIT_DATA
:
2705 case EXEC_OMP_ATOMIC
:
2706 case EXEC_OMP_CANCEL
:
2707 case EXEC_OMP_CANCELLATION_POINT
:
2708 case EXEC_OMP_BARRIER
:
2709 case EXEC_OMP_CRITICAL
:
2710 case EXEC_OMP_DISTRIBUTE
:
2711 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
2712 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2713 case EXEC_OMP_DISTRIBUTE_SIMD
:
2715 case EXEC_OMP_DO_SIMD
:
2716 case EXEC_OMP_FLUSH
:
2717 case EXEC_OMP_MASTER
:
2718 case EXEC_OMP_ORDERED
:
2719 case EXEC_OMP_PARALLEL
:
2720 case EXEC_OMP_PARALLEL_DO
:
2721 case EXEC_OMP_PARALLEL_DO_SIMD
:
2722 case EXEC_OMP_PARALLEL_SECTIONS
:
2723 case EXEC_OMP_PARALLEL_WORKSHARE
:
2724 case EXEC_OMP_SECTIONS
:
2726 case EXEC_OMP_SINGLE
:
2727 case EXEC_OMP_TARGET
:
2728 case EXEC_OMP_TARGET_DATA
:
2729 case EXEC_OMP_TARGET_ENTER_DATA
:
2730 case EXEC_OMP_TARGET_EXIT_DATA
:
2731 case EXEC_OMP_TARGET_PARALLEL
:
2732 case EXEC_OMP_TARGET_PARALLEL_DO
:
2733 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
2734 case EXEC_OMP_TARGET_SIMD
:
2735 case EXEC_OMP_TARGET_TEAMS
:
2736 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
2737 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2738 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2739 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2740 case EXEC_OMP_TARGET_UPDATE
:
2742 case EXEC_OMP_TASKGROUP
:
2743 case EXEC_OMP_TASKLOOP
:
2744 case EXEC_OMP_TASKLOOP_SIMD
:
2745 case EXEC_OMP_TASKWAIT
:
2746 case EXEC_OMP_TASKYIELD
:
2747 case EXEC_OMP_TEAMS
:
2748 case EXEC_OMP_TEAMS_DISTRIBUTE
:
2749 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2750 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2751 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
2752 case EXEC_OMP_WORKSHARE
:
2753 show_omp_node (level
, c
);
2757 gfc_internal_error ("show_code_node(): Bad statement code");
2762 /* Show an equivalence chain. */
2765 show_equiv (gfc_equiv
*eq
)
2768 fputs ("Equivalence: ", dumpfile
);
2771 show_expr (eq
->expr
);
2774 fputs (", ", dumpfile
);
2779 /* Show a freakin' whole namespace. */
2782 show_namespace (gfc_namespace
*ns
)
2784 gfc_interface
*intr
;
2785 gfc_namespace
*save
;
2791 save
= gfc_current_ns
;
2794 fputs ("Namespace:", dumpfile
);
2800 while (i
< GFC_LETTERS
- 1
2801 && gfc_compare_types (&ns
->default_type
[i
+1],
2802 &ns
->default_type
[l
]))
2806 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
2808 fprintf (dumpfile
, " %c: ", l
+'A');
2810 show_typespec(&ns
->default_type
[l
]);
2812 } while (i
< GFC_LETTERS
);
2814 if (ns
->proc_name
!= NULL
)
2817 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
2821 gfc_current_ns
= ns
;
2822 gfc_traverse_symtree (ns
->common_root
, show_common
);
2824 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2826 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
2828 /* User operator interfaces */
2834 fprintf (dumpfile
, "Operator interfaces for %s:",
2835 gfc_op2string ((gfc_intrinsic_op
) op
));
2837 for (; intr
; intr
= intr
->next
)
2838 fprintf (dumpfile
, " %s", intr
->sym
->name
);
2841 if (ns
->uop_root
!= NULL
)
2844 fputs ("User operators:\n", dumpfile
);
2845 gfc_traverse_user_op (ns
, show_uop
);
2848 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
2851 if (ns
->oacc_declare
)
2853 struct gfc_oacc_declare
*decl
;
2854 /* Dump !$ACC DECLARE clauses. */
2855 for (decl
= ns
->oacc_declare
; decl
; decl
= decl
->next
)
2858 fprintf (dumpfile
, "!$ACC DECLARE");
2859 show_omp_clauses (decl
->clauses
);
2863 fputc ('\n', dumpfile
);
2865 fputs ("code:", dumpfile
);
2866 show_code (show_level
, ns
->code
);
2869 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
2871 fputs ("\nCONTAINS\n", dumpfile
);
2873 show_namespace (ns
);
2877 fputc ('\n', dumpfile
);
2878 gfc_current_ns
= save
;
2882 /* Main function for dumping a parse tree. */
2885 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
2888 show_namespace (ns
);