2 Copyright (C) 2003-2018 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
, gfc_charlen_t length
)
353 fputc ('\'', dumpfile
);
354 for (size_t i
= 0; i
< (size_t) length
; i
++)
357 fputs ("''", dumpfile
);
359 fputs (gfc_print_wide_char (c
[i
]), dumpfile
);
361 fputc ('\'', dumpfile
);
365 /* Show a component-call expression. */
368 show_compcall (gfc_expr
* p
)
370 gcc_assert (p
->expr_type
== EXPR_COMPCALL
);
372 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
374 fprintf (dumpfile
, "%s", p
->value
.compcall
.name
);
376 show_actual_arglist (p
->value
.compcall
.actual
);
380 /* Show an expression. */
383 show_expr (gfc_expr
*p
)
390 fputs ("()", dumpfile
);
394 switch (p
->expr_type
)
397 show_char_const (p
->value
.character
.string
, p
->value
.character
.length
);
402 fprintf (dumpfile
, "%s(", p
->ts
.u
.derived
->name
);
403 show_constructor (p
->value
.constructor
);
404 fputc (')', dumpfile
);
408 fputs ("(/ ", dumpfile
);
409 show_constructor (p
->value
.constructor
);
410 fputs (" /)", dumpfile
);
416 fputs ("NULL()", dumpfile
);
423 mpz_out_str (dumpfile
, 10, p
->value
.integer
);
425 if (p
->ts
.kind
!= gfc_default_integer_kind
)
426 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
430 if (p
->value
.logical
)
431 fputs (".true.", dumpfile
);
433 fputs (".false.", dumpfile
);
437 mpfr_out_str (dumpfile
, 10, 0, p
->value
.real
, GFC_RND_MODE
);
438 if (p
->ts
.kind
!= gfc_default_real_kind
)
439 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
443 show_char_const (p
->value
.character
.string
,
444 p
->value
.character
.length
);
448 fputs ("(complex ", dumpfile
);
450 mpfr_out_str (dumpfile
, 10, 0, mpc_realref (p
->value
.complex),
452 if (p
->ts
.kind
!= gfc_default_complex_kind
)
453 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
455 fputc (' ', dumpfile
);
457 mpfr_out_str (dumpfile
, 10, 0, mpc_imagref (p
->value
.complex),
459 if (p
->ts
.kind
!= gfc_default_complex_kind
)
460 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
462 fputc (')', dumpfile
);
466 fprintf (dumpfile
, HOST_WIDE_INT_PRINT_DEC
"H",
467 p
->representation
.length
);
468 c
= p
->representation
.string
;
469 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
471 fputc (*c
, dumpfile
);
476 fputs ("???", dumpfile
);
480 if (p
->representation
.string
)
482 fputs (" {", dumpfile
);
483 c
= p
->representation
.string
;
484 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
486 fprintf (dumpfile
, "%.2x", (unsigned int) *c
);
487 if (i
< p
->representation
.length
- 1)
488 fputc (',', dumpfile
);
490 fputc ('}', dumpfile
);
496 if (p
->symtree
->n
.sym
->ns
&& p
->symtree
->n
.sym
->ns
->proc_name
)
497 fprintf (dumpfile
, "%s:", p
->symtree
->n
.sym
->ns
->proc_name
->name
);
498 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
503 fputc ('(', dumpfile
);
504 switch (p
->value
.op
.op
)
506 case INTRINSIC_UPLUS
:
507 fputs ("U+ ", dumpfile
);
509 case INTRINSIC_UMINUS
:
510 fputs ("U- ", dumpfile
);
513 fputs ("+ ", dumpfile
);
515 case INTRINSIC_MINUS
:
516 fputs ("- ", dumpfile
);
518 case INTRINSIC_TIMES
:
519 fputs ("* ", dumpfile
);
521 case INTRINSIC_DIVIDE
:
522 fputs ("/ ", dumpfile
);
524 case INTRINSIC_POWER
:
525 fputs ("** ", dumpfile
);
527 case INTRINSIC_CONCAT
:
528 fputs ("// ", dumpfile
);
531 fputs ("AND ", dumpfile
);
534 fputs ("OR ", dumpfile
);
537 fputs ("EQV ", dumpfile
);
540 fputs ("NEQV ", dumpfile
);
543 case INTRINSIC_EQ_OS
:
544 fputs ("= ", dumpfile
);
547 case INTRINSIC_NE_OS
:
548 fputs ("/= ", dumpfile
);
551 case INTRINSIC_GT_OS
:
552 fputs ("> ", dumpfile
);
555 case INTRINSIC_GE_OS
:
556 fputs (">= ", dumpfile
);
559 case INTRINSIC_LT_OS
:
560 fputs ("< ", dumpfile
);
563 case INTRINSIC_LE_OS
:
564 fputs ("<= ", dumpfile
);
567 fputs ("NOT ", dumpfile
);
569 case INTRINSIC_PARENTHESES
:
570 fputs ("parens ", dumpfile
);
575 ("show_expr(): Bad intrinsic in expression");
578 show_expr (p
->value
.op
.op1
);
582 fputc (' ', dumpfile
);
583 show_expr (p
->value
.op
.op2
);
586 fputc (')', dumpfile
);
590 if (p
->value
.function
.name
== NULL
)
592 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
593 if (gfc_is_proc_ptr_comp (p
))
595 fputc ('[', dumpfile
);
596 show_actual_arglist (p
->value
.function
.actual
);
597 fputc (']', dumpfile
);
601 fprintf (dumpfile
, "%s", p
->value
.function
.name
);
602 if (gfc_is_proc_ptr_comp (p
))
604 fputc ('[', dumpfile
);
605 fputc ('[', dumpfile
);
606 show_actual_arglist (p
->value
.function
.actual
);
607 fputc (']', dumpfile
);
608 fputc (']', dumpfile
);
618 gfc_internal_error ("show_expr(): Don't know how to show expr");
622 /* Show symbol attributes. The flavor and intent are followed by
623 whatever single bit attributes are present. */
626 show_attr (symbol_attribute
*attr
, const char * module
)
628 if (attr
->flavor
!= FL_UNKNOWN
)
630 if (attr
->flavor
== FL_DERIVED
&& attr
->pdt_template
)
631 fputs (" (PDT template", dumpfile
);
633 fprintf (dumpfile
, "(%s ", gfc_code2string (flavors
, attr
->flavor
));
635 if (attr
->access
!= ACCESS_UNKNOWN
)
636 fprintf (dumpfile
, "%s ", gfc_code2string (access_types
, attr
->access
));
637 if (attr
->proc
!= PROC_UNKNOWN
)
638 fprintf (dumpfile
, "%s ", gfc_code2string (procedures
, attr
->proc
));
639 if (attr
->save
!= SAVE_NONE
)
640 fprintf (dumpfile
, "%s", gfc_code2string (save_status
, attr
->save
));
642 if (attr
->artificial
)
643 fputs (" ARTIFICIAL", dumpfile
);
644 if (attr
->allocatable
)
645 fputs (" ALLOCATABLE", dumpfile
);
646 if (attr
->asynchronous
)
647 fputs (" ASYNCHRONOUS", dumpfile
);
648 if (attr
->codimension
)
649 fputs (" CODIMENSION", dumpfile
);
651 fputs (" DIMENSION", dumpfile
);
652 if (attr
->contiguous
)
653 fputs (" CONTIGUOUS", dumpfile
);
655 fputs (" EXTERNAL", dumpfile
);
657 fputs (" INTRINSIC", dumpfile
);
659 fputs (" OPTIONAL", dumpfile
);
661 fputs (" KIND", dumpfile
);
663 fputs (" LEN", dumpfile
);
665 fputs (" POINTER", dumpfile
);
666 if (attr
->is_protected
)
667 fputs (" PROTECTED", dumpfile
);
669 fputs (" VALUE", dumpfile
);
671 fputs (" VOLATILE", dumpfile
);
672 if (attr
->threadprivate
)
673 fputs (" THREADPRIVATE", dumpfile
);
675 fputs (" TARGET", dumpfile
);
678 fputs (" DUMMY", dumpfile
);
679 if (attr
->intent
!= INTENT_UNKNOWN
)
680 fprintf (dumpfile
, "(%s)", gfc_intent_string (attr
->intent
));
684 fputs (" RESULT", dumpfile
);
686 fputs (" ENTRY", dumpfile
);
688 fputs (" BIND(C)", dumpfile
);
691 fputs (" DATA", dumpfile
);
694 fputs (" USE-ASSOC", dumpfile
);
696 fprintf (dumpfile
, "(%s)", module
);
699 if (attr
->in_namelist
)
700 fputs (" IN-NAMELIST", dumpfile
);
702 fputs (" IN-COMMON", dumpfile
);
705 fputs (" ABSTRACT", dumpfile
);
707 fputs (" FUNCTION", dumpfile
);
708 if (attr
->subroutine
)
709 fputs (" SUBROUTINE", dumpfile
);
710 if (attr
->implicit_type
)
711 fputs (" IMPLICIT-TYPE", dumpfile
);
714 fputs (" SEQUENCE", dumpfile
);
716 fputs (" ELEMENTAL", dumpfile
);
718 fputs (" PURE", dumpfile
);
720 fputs (" RECURSIVE", dumpfile
);
722 fputc (')', dumpfile
);
726 /* Show components of a derived type. */
729 show_components (gfc_symbol
*sym
)
733 for (c
= sym
->components
; c
; c
= c
->next
)
736 fprintf (dumpfile
, "(%s ", c
->name
);
737 show_typespec (&c
->ts
);
740 fputs (" kind_expr: ", dumpfile
);
741 show_expr (c
->kind_expr
);
745 fputs ("PDT parameters", dumpfile
);
746 show_actual_arglist (c
->param_list
);
749 if (c
->attr
.allocatable
)
750 fputs (" ALLOCATABLE", dumpfile
);
751 if (c
->attr
.pdt_kind
)
752 fputs (" KIND", dumpfile
);
754 fputs (" LEN", dumpfile
);
756 fputs (" POINTER", dumpfile
);
757 if (c
->attr
.proc_pointer
)
758 fputs (" PPC", dumpfile
);
759 if (c
->attr
.dimension
)
760 fputs (" DIMENSION", dumpfile
);
761 fputc (' ', dumpfile
);
762 show_array_spec (c
->as
);
764 fprintf (dumpfile
, " %s", gfc_code2string (access_types
, c
->attr
.access
));
765 fputc (')', dumpfile
);
767 fputc (' ', dumpfile
);
772 /* Show the f2k_derived namespace with procedure bindings. */
775 show_typebound_proc (gfc_typebound_proc
* tb
, const char* name
)
780 fputs ("GENERIC", dumpfile
);
783 fputs ("PROCEDURE, ", dumpfile
);
785 fputs ("NOPASS", dumpfile
);
789 fprintf (dumpfile
, "PASS(%s)", tb
->pass_arg
);
791 fputs ("PASS", dumpfile
);
793 if (tb
->non_overridable
)
794 fputs (", NON_OVERRIDABLE", dumpfile
);
797 if (tb
->access
== ACCESS_PUBLIC
)
798 fputs (", PUBLIC", dumpfile
);
800 fputs (", PRIVATE", dumpfile
);
802 fprintf (dumpfile
, " :: %s => ", name
);
807 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
809 fputs (g
->specific_st
->name
, dumpfile
);
811 fputs (", ", dumpfile
);
815 fputs (tb
->u
.specific
->n
.sym
->name
, dumpfile
);
819 show_typebound_symtree (gfc_symtree
* st
)
821 gcc_assert (st
->n
.tb
);
822 show_typebound_proc (st
->n
.tb
, st
->name
);
826 show_f2k_derived (gfc_namespace
* f2k
)
832 fputs ("Procedure bindings:", dumpfile
);
835 /* Finalizer bindings. */
836 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
839 fprintf (dumpfile
, "FINAL %s", f
->proc_tree
->n
.sym
->name
);
842 /* Type-bound procedures. */
843 gfc_traverse_symtree (f2k
->tb_sym_root
, &show_typebound_symtree
);
848 fputs ("Operator bindings:", dumpfile
);
851 /* User-defined operators. */
852 gfc_traverse_symtree (f2k
->tb_uop_root
, &show_typebound_symtree
);
854 /* Intrinsic operators. */
855 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
857 show_typebound_proc (f2k
->tb_op
[op
],
858 gfc_op2string ((gfc_intrinsic_op
) op
));
864 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
865 show the interface. Information needed to reconstruct the list of
866 specific interfaces associated with a generic symbol is done within
870 show_symbol (gfc_symbol
*sym
)
872 gfc_formal_arglist
*formal
;
879 fprintf (dumpfile
, "|| symbol: '%s' ", sym
->name
);
880 len
= strlen (sym
->name
);
881 for (i
=len
; i
<12; i
++)
882 fputc(' ', dumpfile
);
884 if (sym
->binding_label
)
885 fprintf (dumpfile
,"|| binding_label: '%s' ", sym
->binding_label
);
890 fputs ("type spec : ", dumpfile
);
891 show_typespec (&sym
->ts
);
894 fputs ("attributes: ", dumpfile
);
895 show_attr (&sym
->attr
, sym
->module
);
900 fputs ("value: ", dumpfile
);
901 show_expr (sym
->value
);
907 fputs ("Array spec:", dumpfile
);
908 show_array_spec (sym
->as
);
914 fputs ("Generic interfaces:", dumpfile
);
915 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
916 fprintf (dumpfile
, " %s", intr
->sym
->name
);
922 fprintf (dumpfile
, "result: %s", sym
->result
->name
);
928 fputs ("components: ", dumpfile
);
929 show_components (sym
);
932 if (sym
->f2k_derived
)
936 fprintf (dumpfile
, "hash: %d", sym
->hash_value
);
937 show_f2k_derived (sym
->f2k_derived
);
943 fputs ("Formal arglist:", dumpfile
);
945 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
947 if (formal
->sym
!= NULL
)
948 fprintf (dumpfile
, " %s", formal
->sym
->name
);
950 fputs (" [Alt Return]", dumpfile
);
954 if (sym
->formal_ns
&& (sym
->formal_ns
->proc_name
!= sym
)
955 && sym
->attr
.proc
!= PROC_ST_FUNCTION
959 fputs ("Formal namespace", dumpfile
);
960 show_namespace (sym
->formal_ns
);
963 if (sym
->attr
.flavor
== FL_VARIABLE
967 fputs ("PDT parameters", dumpfile
);
968 show_actual_arglist (sym
->param_list
);
971 if (sym
->attr
.flavor
== FL_NAMELIST
)
975 fputs ("variables : ", dumpfile
);
976 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
977 fprintf (dumpfile
, " %s",nl
->sym
->name
);
984 /* Show a user-defined operator. Just prints an operator
985 and the name of the associated subroutine, really. */
988 show_uop (gfc_user_op
*uop
)
993 fprintf (dumpfile
, "%s:", uop
->name
);
995 for (intr
= uop
->op
; intr
; intr
= intr
->next
)
996 fprintf (dumpfile
, " %s", intr
->sym
->name
);
1000 /* Workhorse function for traversing the user operator symtree. */
1003 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
1008 (*func
) (st
->n
.uop
);
1010 traverse_uop (st
->left
, func
);
1011 traverse_uop (st
->right
, func
);
1015 /* Traverse the tree of user operator nodes. */
1018 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
1020 traverse_uop (ns
->uop_root
, func
);
1024 /* Function to display a common block. */
1027 show_common (gfc_symtree
*st
)
1032 fprintf (dumpfile
, "common: /%s/ ", st
->name
);
1034 s
= st
->n
.common
->head
;
1037 fprintf (dumpfile
, "%s", s
->name
);
1040 fputs (", ", dumpfile
);
1042 fputc ('\n', dumpfile
);
1046 /* Worker function to display the symbol tree. */
1049 show_symtree (gfc_symtree
*st
)
1055 len
= strlen(st
->name
);
1056 fprintf (dumpfile
, "symtree: '%s'", st
->name
);
1058 for (i
=len
; i
<12; i
++)
1059 fputc(' ', dumpfile
);
1062 fputs( " Ambiguous", dumpfile
);
1064 if (st
->n
.sym
->ns
!= gfc_current_ns
)
1065 fprintf (dumpfile
, "|| symbol: '%s' from namespace '%s'", st
->n
.sym
->name
,
1066 st
->n
.sym
->ns
->proc_name
->name
);
1068 show_symbol (st
->n
.sym
);
1072 /******************* Show gfc_code structures **************/
1075 /* Show a list of code structures. Mutually recursive with
1076 show_code_node(). */
1079 show_code (int level
, gfc_code
*c
)
1081 for (; c
; c
= c
->next
)
1082 show_code_node (level
, c
);
1086 show_omp_namelist (int list_type
, gfc_omp_namelist
*n
)
1088 for (; n
; n
= n
->next
)
1090 if (list_type
== OMP_LIST_REDUCTION
)
1091 switch (n
->u
.reduction_op
)
1093 case OMP_REDUCTION_PLUS
:
1094 case OMP_REDUCTION_TIMES
:
1095 case OMP_REDUCTION_MINUS
:
1096 case OMP_REDUCTION_AND
:
1097 case OMP_REDUCTION_OR
:
1098 case OMP_REDUCTION_EQV
:
1099 case OMP_REDUCTION_NEQV
:
1100 fprintf (dumpfile
, "%s:",
1101 gfc_op2string ((gfc_intrinsic_op
) n
->u
.reduction_op
));
1103 case OMP_REDUCTION_MAX
: fputs ("max:", dumpfile
); break;
1104 case OMP_REDUCTION_MIN
: fputs ("min:", dumpfile
); break;
1105 case OMP_REDUCTION_IAND
: fputs ("iand:", dumpfile
); break;
1106 case OMP_REDUCTION_IOR
: fputs ("ior:", dumpfile
); break;
1107 case OMP_REDUCTION_IEOR
: fputs ("ieor:", dumpfile
); break;
1108 case OMP_REDUCTION_USER
:
1110 fprintf (dumpfile
, "%s:", n
->udr
->udr
->name
);
1114 else if (list_type
== OMP_LIST_DEPEND
)
1115 switch (n
->u
.depend_op
)
1117 case OMP_DEPEND_IN
: fputs ("in:", dumpfile
); break;
1118 case OMP_DEPEND_OUT
: fputs ("out:", dumpfile
); break;
1119 case OMP_DEPEND_INOUT
: fputs ("inout:", dumpfile
); break;
1120 case OMP_DEPEND_SINK_FIRST
:
1121 fputs ("sink:", dumpfile
);
1124 fprintf (dumpfile
, "%s", n
->sym
->name
);
1127 fputc ('+', dumpfile
);
1128 show_expr (n
->expr
);
1130 if (n
->next
== NULL
)
1132 else if (n
->next
->u
.depend_op
!= OMP_DEPEND_SINK
)
1134 fputs (") DEPEND(", dumpfile
);
1137 fputc (',', dumpfile
);
1143 else if (list_type
== OMP_LIST_MAP
)
1144 switch (n
->u
.map_op
)
1146 case OMP_MAP_ALLOC
: fputs ("alloc:", dumpfile
); break;
1147 case OMP_MAP_TO
: fputs ("to:", dumpfile
); break;
1148 case OMP_MAP_FROM
: fputs ("from:", dumpfile
); break;
1149 case OMP_MAP_TOFROM
: fputs ("tofrom:", dumpfile
); break;
1152 else if (list_type
== OMP_LIST_LINEAR
)
1153 switch (n
->u
.linear_op
)
1155 case OMP_LINEAR_REF
: fputs ("ref(", dumpfile
); break;
1156 case OMP_LINEAR_VAL
: fputs ("val(", dumpfile
); break;
1157 case OMP_LINEAR_UVAL
: fputs ("uval(", dumpfile
); break;
1160 fprintf (dumpfile
, "%s", n
->sym
->name
);
1161 if (list_type
== OMP_LIST_LINEAR
&& n
->u
.linear_op
!= OMP_LINEAR_DEFAULT
)
1162 fputc (')', dumpfile
);
1165 fputc (':', dumpfile
);
1166 show_expr (n
->expr
);
1169 fputc (',', dumpfile
);
1174 /* Show OpenMP or OpenACC clauses. */
1177 show_omp_clauses (gfc_omp_clauses
*omp_clauses
)
1181 switch (omp_clauses
->cancel
)
1183 case OMP_CANCEL_UNKNOWN
:
1185 case OMP_CANCEL_PARALLEL
:
1186 fputs (" PARALLEL", dumpfile
);
1188 case OMP_CANCEL_SECTIONS
:
1189 fputs (" SECTIONS", dumpfile
);
1192 fputs (" DO", dumpfile
);
1194 case OMP_CANCEL_TASKGROUP
:
1195 fputs (" TASKGROUP", dumpfile
);
1198 if (omp_clauses
->if_expr
)
1200 fputs (" IF(", dumpfile
);
1201 show_expr (omp_clauses
->if_expr
);
1202 fputc (')', dumpfile
);
1204 if (omp_clauses
->final_expr
)
1206 fputs (" FINAL(", dumpfile
);
1207 show_expr (omp_clauses
->final_expr
);
1208 fputc (')', dumpfile
);
1210 if (omp_clauses
->num_threads
)
1212 fputs (" NUM_THREADS(", dumpfile
);
1213 show_expr (omp_clauses
->num_threads
);
1214 fputc (')', dumpfile
);
1216 if (omp_clauses
->async
)
1218 fputs (" ASYNC", dumpfile
);
1219 if (omp_clauses
->async_expr
)
1221 fputc ('(', dumpfile
);
1222 show_expr (omp_clauses
->async_expr
);
1223 fputc (')', dumpfile
);
1226 if (omp_clauses
->num_gangs_expr
)
1228 fputs (" NUM_GANGS(", dumpfile
);
1229 show_expr (omp_clauses
->num_gangs_expr
);
1230 fputc (')', dumpfile
);
1232 if (omp_clauses
->num_workers_expr
)
1234 fputs (" NUM_WORKERS(", dumpfile
);
1235 show_expr (omp_clauses
->num_workers_expr
);
1236 fputc (')', dumpfile
);
1238 if (omp_clauses
->vector_length_expr
)
1240 fputs (" VECTOR_LENGTH(", dumpfile
);
1241 show_expr (omp_clauses
->vector_length_expr
);
1242 fputc (')', dumpfile
);
1244 if (omp_clauses
->gang
)
1246 fputs (" GANG", dumpfile
);
1247 if (omp_clauses
->gang_num_expr
|| omp_clauses
->gang_static_expr
)
1249 fputc ('(', dumpfile
);
1250 if (omp_clauses
->gang_num_expr
)
1252 fprintf (dumpfile
, "num:");
1253 show_expr (omp_clauses
->gang_num_expr
);
1255 if (omp_clauses
->gang_num_expr
&& omp_clauses
->gang_static
)
1256 fputc (',', dumpfile
);
1257 if (omp_clauses
->gang_static
)
1259 fprintf (dumpfile
, "static:");
1260 if (omp_clauses
->gang_static_expr
)
1261 show_expr (omp_clauses
->gang_static_expr
);
1263 fputc ('*', dumpfile
);
1265 fputc (')', dumpfile
);
1268 if (omp_clauses
->worker
)
1270 fputs (" WORKER", dumpfile
);
1271 if (omp_clauses
->worker_expr
)
1273 fputc ('(', dumpfile
);
1274 show_expr (omp_clauses
->worker_expr
);
1275 fputc (')', dumpfile
);
1278 if (omp_clauses
->vector
)
1280 fputs (" VECTOR", dumpfile
);
1281 if (omp_clauses
->vector_expr
)
1283 fputc ('(', dumpfile
);
1284 show_expr (omp_clauses
->vector_expr
);
1285 fputc (')', dumpfile
);
1288 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
1291 switch (omp_clauses
->sched_kind
)
1293 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
1294 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
1295 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
1296 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
1297 case OMP_SCHED_AUTO
: type
= "AUTO"; break;
1301 fputs (" SCHEDULE (", dumpfile
);
1302 if (omp_clauses
->sched_simd
)
1304 if (omp_clauses
->sched_monotonic
1305 || omp_clauses
->sched_nonmonotonic
)
1306 fputs ("SIMD, ", dumpfile
);
1308 fputs ("SIMD: ", dumpfile
);
1310 if (omp_clauses
->sched_monotonic
)
1311 fputs ("MONOTONIC: ", dumpfile
);
1312 else if (omp_clauses
->sched_nonmonotonic
)
1313 fputs ("NONMONOTONIC: ", dumpfile
);
1314 fputs (type
, dumpfile
);
1315 if (omp_clauses
->chunk_size
)
1317 fputc (',', dumpfile
);
1318 show_expr (omp_clauses
->chunk_size
);
1320 fputc (')', dumpfile
);
1322 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1325 switch (omp_clauses
->default_sharing
)
1327 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
1328 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
1329 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
1330 case OMP_DEFAULT_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1331 case OMP_DEFAULT_PRESENT
: type
= "PRESENT"; break;
1335 fprintf (dumpfile
, " DEFAULT(%s)", type
);
1337 if (omp_clauses
->tile_list
)
1339 gfc_expr_list
*list
;
1340 fputs (" TILE(", dumpfile
);
1341 for (list
= omp_clauses
->tile_list
; list
; list
= list
->next
)
1343 show_expr (list
->expr
);
1345 fputs (", ", dumpfile
);
1347 fputc (')', dumpfile
);
1349 if (omp_clauses
->wait_list
)
1351 gfc_expr_list
*list
;
1352 fputs (" WAIT(", dumpfile
);
1353 for (list
= omp_clauses
->wait_list
; list
; list
= list
->next
)
1355 show_expr (list
->expr
);
1357 fputs (", ", dumpfile
);
1359 fputc (')', dumpfile
);
1361 if (omp_clauses
->seq
)
1362 fputs (" SEQ", dumpfile
);
1363 if (omp_clauses
->independent
)
1364 fputs (" INDEPENDENT", dumpfile
);
1365 if (omp_clauses
->ordered
)
1367 if (omp_clauses
->orderedc
)
1368 fprintf (dumpfile
, " ORDERED(%d)", omp_clauses
->orderedc
);
1370 fputs (" ORDERED", dumpfile
);
1372 if (omp_clauses
->untied
)
1373 fputs (" UNTIED", dumpfile
);
1374 if (omp_clauses
->mergeable
)
1375 fputs (" MERGEABLE", dumpfile
);
1376 if (omp_clauses
->collapse
)
1377 fprintf (dumpfile
, " COLLAPSE(%d)", omp_clauses
->collapse
);
1378 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
1379 if (omp_clauses
->lists
[list_type
] != NULL
1380 && list_type
!= OMP_LIST_COPYPRIVATE
)
1382 const char *type
= NULL
;
1385 case OMP_LIST_USE_DEVICE
: type
= "USE_DEVICE"; break;
1386 case OMP_LIST_DEVICE_RESIDENT
: type
= "USE_DEVICE"; break;
1387 case OMP_LIST_CACHE
: type
= ""; break;
1388 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
1389 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1390 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
1391 case OMP_LIST_SHARED
: type
= "SHARED"; break;
1392 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
1393 case OMP_LIST_UNIFORM
: type
= "UNIFORM"; break;
1394 case OMP_LIST_ALIGNED
: type
= "ALIGNED"; break;
1395 case OMP_LIST_LINEAR
: type
= "LINEAR"; break;
1396 case OMP_LIST_REDUCTION
: type
= "REDUCTION"; break;
1397 case OMP_LIST_IS_DEVICE_PTR
: type
= "IS_DEVICE_PTR"; break;
1398 case OMP_LIST_USE_DEVICE_PTR
: type
= "USE_DEVICE_PTR"; break;
1399 case OMP_LIST_DEPEND
: type
= "DEPEND"; break;
1403 fprintf (dumpfile
, " %s(", type
);
1404 show_omp_namelist (list_type
, omp_clauses
->lists
[list_type
]);
1405 fputc (')', dumpfile
);
1407 if (omp_clauses
->safelen_expr
)
1409 fputs (" SAFELEN(", dumpfile
);
1410 show_expr (omp_clauses
->safelen_expr
);
1411 fputc (')', dumpfile
);
1413 if (omp_clauses
->simdlen_expr
)
1415 fputs (" SIMDLEN(", dumpfile
);
1416 show_expr (omp_clauses
->simdlen_expr
);
1417 fputc (')', dumpfile
);
1419 if (omp_clauses
->inbranch
)
1420 fputs (" INBRANCH", dumpfile
);
1421 if (omp_clauses
->notinbranch
)
1422 fputs (" NOTINBRANCH", dumpfile
);
1423 if (omp_clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
1426 switch (omp_clauses
->proc_bind
)
1428 case OMP_PROC_BIND_MASTER
: type
= "MASTER"; break;
1429 case OMP_PROC_BIND_SPREAD
: type
= "SPREAD"; break;
1430 case OMP_PROC_BIND_CLOSE
: type
= "CLOSE"; break;
1434 fprintf (dumpfile
, " PROC_BIND(%s)", type
);
1436 if (omp_clauses
->num_teams
)
1438 fputs (" NUM_TEAMS(", dumpfile
);
1439 show_expr (omp_clauses
->num_teams
);
1440 fputc (')', dumpfile
);
1442 if (omp_clauses
->device
)
1444 fputs (" DEVICE(", dumpfile
);
1445 show_expr (omp_clauses
->device
);
1446 fputc (')', dumpfile
);
1448 if (omp_clauses
->thread_limit
)
1450 fputs (" THREAD_LIMIT(", dumpfile
);
1451 show_expr (omp_clauses
->thread_limit
);
1452 fputc (')', dumpfile
);
1454 if (omp_clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
1456 fprintf (dumpfile
, " DIST_SCHEDULE (STATIC");
1457 if (omp_clauses
->dist_chunk_size
)
1459 fputc (',', dumpfile
);
1460 show_expr (omp_clauses
->dist_chunk_size
);
1462 fputc (')', dumpfile
);
1464 if (omp_clauses
->defaultmap
)
1465 fputs (" DEFALTMAP (TOFROM: SCALAR)", dumpfile
);
1466 if (omp_clauses
->nogroup
)
1467 fputs (" NOGROUP", dumpfile
);
1468 if (omp_clauses
->simd
)
1469 fputs (" SIMD", dumpfile
);
1470 if (omp_clauses
->threads
)
1471 fputs (" THREADS", dumpfile
);
1472 if (omp_clauses
->grainsize
)
1474 fputs (" GRAINSIZE(", dumpfile
);
1475 show_expr (omp_clauses
->grainsize
);
1476 fputc (')', dumpfile
);
1478 if (omp_clauses
->hint
)
1480 fputs (" HINT(", dumpfile
);
1481 show_expr (omp_clauses
->hint
);
1482 fputc (')', dumpfile
);
1484 if (omp_clauses
->num_tasks
)
1486 fputs (" NUM_TASKS(", dumpfile
);
1487 show_expr (omp_clauses
->num_tasks
);
1488 fputc (')', dumpfile
);
1490 if (omp_clauses
->priority
)
1492 fputs (" PRIORITY(", dumpfile
);
1493 show_expr (omp_clauses
->priority
);
1494 fputc (')', dumpfile
);
1496 for (i
= 0; i
< OMP_IF_LAST
; i
++)
1497 if (omp_clauses
->if_exprs
[i
])
1499 static const char *ifs
[] = {
1506 "TARGET ENTER DATA",
1509 fputs (" IF(", dumpfile
);
1510 fputs (ifs
[i
], dumpfile
);
1511 fputs (": ", dumpfile
);
1512 show_expr (omp_clauses
->if_exprs
[i
]);
1513 fputc (')', dumpfile
);
1515 if (omp_clauses
->depend_source
)
1516 fputs (" DEPEND(source)", dumpfile
);
1519 /* Show a single OpenMP or OpenACC directive node and everything underneath it
1523 show_omp_node (int level
, gfc_code
*c
)
1525 gfc_omp_clauses
*omp_clauses
= NULL
;
1526 const char *name
= NULL
;
1527 bool is_oacc
= false;
1531 case EXEC_OACC_PARALLEL_LOOP
:
1532 name
= "PARALLEL LOOP"; is_oacc
= true; break;
1533 case EXEC_OACC_PARALLEL
: name
= "PARALLEL"; is_oacc
= true; break;
1534 case EXEC_OACC_KERNELS_LOOP
: name
= "KERNELS LOOP"; is_oacc
= true; break;
1535 case EXEC_OACC_KERNELS
: name
= "KERNELS"; is_oacc
= true; break;
1536 case EXEC_OACC_DATA
: name
= "DATA"; is_oacc
= true; break;
1537 case EXEC_OACC_HOST_DATA
: name
= "HOST_DATA"; is_oacc
= true; break;
1538 case EXEC_OACC_LOOP
: name
= "LOOP"; is_oacc
= true; break;
1539 case EXEC_OACC_UPDATE
: name
= "UPDATE"; is_oacc
= true; break;
1540 case EXEC_OACC_WAIT
: name
= "WAIT"; is_oacc
= true; break;
1541 case EXEC_OACC_CACHE
: name
= "CACHE"; is_oacc
= true; break;
1542 case EXEC_OACC_ENTER_DATA
: name
= "ENTER DATA"; is_oacc
= true; break;
1543 case EXEC_OACC_EXIT_DATA
: name
= "EXIT DATA"; is_oacc
= true; break;
1544 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
1545 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
1546 case EXEC_OMP_CANCEL
: name
= "CANCEL"; break;
1547 case EXEC_OMP_CANCELLATION_POINT
: name
= "CANCELLATION POINT"; break;
1548 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
1549 case EXEC_OMP_DISTRIBUTE
: name
= "DISTRIBUTE"; break;
1550 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1551 name
= "DISTRIBUTE PARALLEL DO"; break;
1552 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1553 name
= "DISTRIBUTE PARALLEL DO SIMD"; break;
1554 case EXEC_OMP_DISTRIBUTE_SIMD
: name
= "DISTRIBUTE SIMD"; break;
1555 case EXEC_OMP_DO
: name
= "DO"; break;
1556 case EXEC_OMP_DO_SIMD
: name
= "DO SIMD"; break;
1557 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
1558 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
1559 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
1560 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
1561 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
1562 case EXEC_OMP_PARALLEL_DO_SIMD
: name
= "PARALLEL DO SIMD"; break;
1563 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
1564 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
1565 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
1566 case EXEC_OMP_SIMD
: name
= "SIMD"; break;
1567 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
1568 case EXEC_OMP_TARGET
: name
= "TARGET"; break;
1569 case EXEC_OMP_TARGET_DATA
: name
= "TARGET DATA"; break;
1570 case EXEC_OMP_TARGET_ENTER_DATA
: name
= "TARGET ENTER DATA"; break;
1571 case EXEC_OMP_TARGET_EXIT_DATA
: name
= "TARGET EXIT DATA"; break;
1572 case EXEC_OMP_TARGET_PARALLEL
: name
= "TARGET PARALLEL"; break;
1573 case EXEC_OMP_TARGET_PARALLEL_DO
: name
= "TARGET PARALLEL DO"; break;
1574 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
1575 name
= "TARGET_PARALLEL_DO_SIMD"; break;
1576 case EXEC_OMP_TARGET_SIMD
: name
= "TARGET SIMD"; break;
1577 case EXEC_OMP_TARGET_TEAMS
: name
= "TARGET TEAMS"; break;
1578 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1579 name
= "TARGET TEAMS DISTRIBUTE"; break;
1580 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1581 name
= "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break;
1582 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1583 name
= "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
1584 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1585 name
= "TARGET TEAMS DISTRIBUTE SIMD"; break;
1586 case EXEC_OMP_TARGET_UPDATE
: name
= "TARGET UPDATE"; break;
1587 case EXEC_OMP_TASK
: name
= "TASK"; break;
1588 case EXEC_OMP_TASKGROUP
: name
= "TASKGROUP"; break;
1589 case EXEC_OMP_TASKLOOP
: name
= "TASKLOOP"; break;
1590 case EXEC_OMP_TASKLOOP_SIMD
: name
= "TASKLOOP SIMD"; break;
1591 case EXEC_OMP_TASKWAIT
: name
= "TASKWAIT"; break;
1592 case EXEC_OMP_TASKYIELD
: name
= "TASKYIELD"; break;
1593 case EXEC_OMP_TEAMS
: name
= "TEAMS"; break;
1594 case EXEC_OMP_TEAMS_DISTRIBUTE
: name
= "TEAMS DISTRIBUTE"; break;
1595 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1596 name
= "TEAMS DISTRIBUTE PARALLEL DO"; break;
1597 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1598 name
= "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
1599 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
: name
= "TEAMS DISTRIBUTE SIMD"; break;
1600 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
1604 fprintf (dumpfile
, "!$%s %s", is_oacc
? "ACC" : "OMP", name
);
1607 case EXEC_OACC_PARALLEL_LOOP
:
1608 case EXEC_OACC_PARALLEL
:
1609 case EXEC_OACC_KERNELS_LOOP
:
1610 case EXEC_OACC_KERNELS
:
1611 case EXEC_OACC_DATA
:
1612 case EXEC_OACC_HOST_DATA
:
1613 case EXEC_OACC_LOOP
:
1614 case EXEC_OACC_UPDATE
:
1615 case EXEC_OACC_WAIT
:
1616 case EXEC_OACC_CACHE
:
1617 case EXEC_OACC_ENTER_DATA
:
1618 case EXEC_OACC_EXIT_DATA
:
1619 case EXEC_OMP_CANCEL
:
1620 case EXEC_OMP_CANCELLATION_POINT
:
1621 case EXEC_OMP_DISTRIBUTE
:
1622 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1623 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1624 case EXEC_OMP_DISTRIBUTE_SIMD
:
1626 case EXEC_OMP_DO_SIMD
:
1627 case EXEC_OMP_ORDERED
:
1628 case EXEC_OMP_PARALLEL
:
1629 case EXEC_OMP_PARALLEL_DO
:
1630 case EXEC_OMP_PARALLEL_DO_SIMD
:
1631 case EXEC_OMP_PARALLEL_SECTIONS
:
1632 case EXEC_OMP_PARALLEL_WORKSHARE
:
1633 case EXEC_OMP_SECTIONS
:
1635 case EXEC_OMP_SINGLE
:
1636 case EXEC_OMP_TARGET
:
1637 case EXEC_OMP_TARGET_DATA
:
1638 case EXEC_OMP_TARGET_ENTER_DATA
:
1639 case EXEC_OMP_TARGET_EXIT_DATA
:
1640 case EXEC_OMP_TARGET_PARALLEL
:
1641 case EXEC_OMP_TARGET_PARALLEL_DO
:
1642 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
1643 case EXEC_OMP_TARGET_SIMD
:
1644 case EXEC_OMP_TARGET_TEAMS
:
1645 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1646 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1647 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1648 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1649 case EXEC_OMP_TARGET_UPDATE
:
1651 case EXEC_OMP_TASKLOOP
:
1652 case EXEC_OMP_TASKLOOP_SIMD
:
1653 case EXEC_OMP_TEAMS
:
1654 case EXEC_OMP_TEAMS_DISTRIBUTE
:
1655 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1656 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1657 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
1658 case EXEC_OMP_WORKSHARE
:
1659 omp_clauses
= c
->ext
.omp_clauses
;
1661 case EXEC_OMP_CRITICAL
:
1662 omp_clauses
= c
->ext
.omp_clauses
;
1664 fprintf (dumpfile
, " (%s)", c
->ext
.omp_clauses
->critical_name
);
1666 case EXEC_OMP_FLUSH
:
1667 if (c
->ext
.omp_namelist
)
1669 fputs (" (", dumpfile
);
1670 show_omp_namelist (OMP_LIST_NUM
, c
->ext
.omp_namelist
);
1671 fputc (')', dumpfile
);
1674 case EXEC_OMP_BARRIER
:
1675 case EXEC_OMP_TASKWAIT
:
1676 case EXEC_OMP_TASKYIELD
:
1682 show_omp_clauses (omp_clauses
);
1683 fputc ('\n', dumpfile
);
1685 /* OpenMP and OpenACC executable directives don't have associated blocks. */
1686 if (c
->op
== EXEC_OACC_CACHE
|| c
->op
== EXEC_OACC_UPDATE
1687 || c
->op
== EXEC_OACC_ENTER_DATA
|| c
->op
== EXEC_OACC_EXIT_DATA
1688 || c
->op
== EXEC_OMP_TARGET_UPDATE
|| c
->op
== EXEC_OMP_TARGET_ENTER_DATA
1689 || c
->op
== EXEC_OMP_TARGET_EXIT_DATA
1690 || (c
->op
== EXEC_OMP_ORDERED
&& c
->block
== NULL
))
1692 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
1694 gfc_code
*d
= c
->block
;
1697 show_code (level
+ 1, d
->next
);
1698 if (d
->block
== NULL
)
1700 code_indent (level
, 0);
1701 fputs ("!$OMP SECTION\n", dumpfile
);
1706 show_code (level
+ 1, c
->block
->next
);
1707 if (c
->op
== EXEC_OMP_ATOMIC
)
1709 fputc ('\n', dumpfile
);
1710 code_indent (level
, 0);
1711 fprintf (dumpfile
, "!$%s END %s", is_oacc
? "ACC" : "OMP", name
);
1712 if (omp_clauses
!= NULL
)
1714 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
1716 fputs (" COPYPRIVATE(", dumpfile
);
1717 show_omp_namelist (OMP_LIST_COPYPRIVATE
,
1718 omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1719 fputc (')', dumpfile
);
1721 else if (omp_clauses
->nowait
)
1722 fputs (" NOWAIT", dumpfile
);
1724 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_clauses
)
1725 fprintf (dumpfile
, " (%s)", c
->ext
.omp_clauses
->critical_name
);
1729 /* Show a single code node and everything underneath it if necessary. */
1732 show_code_node (int level
, gfc_code
*c
)
1734 gfc_forall_iterator
*fa
;
1747 fputc ('\n', dumpfile
);
1748 code_indent (level
, c
->here
);
1755 case EXEC_END_PROCEDURE
:
1759 fputs ("NOP", dumpfile
);
1763 fputs ("CONTINUE", dumpfile
);
1767 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
1770 case EXEC_INIT_ASSIGN
:
1772 fputs ("ASSIGN ", dumpfile
);
1773 show_expr (c
->expr1
);
1774 fputc (' ', dumpfile
);
1775 show_expr (c
->expr2
);
1778 case EXEC_LABEL_ASSIGN
:
1779 fputs ("LABEL ASSIGN ", dumpfile
);
1780 show_expr (c
->expr1
);
1781 fprintf (dumpfile
, " %d", c
->label1
->value
);
1784 case EXEC_POINTER_ASSIGN
:
1785 fputs ("POINTER ASSIGN ", dumpfile
);
1786 show_expr (c
->expr1
);
1787 fputc (' ', dumpfile
);
1788 show_expr (c
->expr2
);
1792 fputs ("GOTO ", dumpfile
);
1794 fprintf (dumpfile
, "%d", c
->label1
->value
);
1797 show_expr (c
->expr1
);
1801 fputs (", (", dumpfile
);
1802 for (; d
; d
= d
->block
)
1804 code_indent (level
, d
->label1
);
1805 if (d
->block
!= NULL
)
1806 fputc (',', dumpfile
);
1808 fputc (')', dumpfile
);
1815 case EXEC_ASSIGN_CALL
:
1816 if (c
->resolved_sym
)
1817 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
1818 else if (c
->symtree
)
1819 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
1821 fputs ("CALL ?? ", dumpfile
);
1823 show_actual_arglist (c
->ext
.actual
);
1827 fputs ("CALL ", dumpfile
);
1828 show_compcall (c
->expr1
);
1832 fputs ("CALL ", dumpfile
);
1833 show_expr (c
->expr1
);
1834 show_actual_arglist (c
->ext
.actual
);
1838 fputs ("RETURN ", dumpfile
);
1840 show_expr (c
->expr1
);
1844 fputs ("PAUSE ", dumpfile
);
1846 if (c
->expr1
!= NULL
)
1847 show_expr (c
->expr1
);
1849 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1853 case EXEC_ERROR_STOP
:
1854 fputs ("ERROR ", dumpfile
);
1858 fputs ("STOP ", dumpfile
);
1860 if (c
->expr1
!= NULL
)
1861 show_expr (c
->expr1
);
1863 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1867 case EXEC_FAIL_IMAGE
:
1868 fputs ("FAIL IMAGE ", dumpfile
);
1871 case EXEC_CHANGE_TEAM
:
1872 fputs ("CHANGE TEAM", dumpfile
);
1876 fputs ("END TEAM", dumpfile
);
1879 case EXEC_FORM_TEAM
:
1880 fputs ("FORM TEAM", dumpfile
);
1883 case EXEC_SYNC_TEAM
:
1884 fputs ("SYNC TEAM", dumpfile
);
1888 fputs ("SYNC ALL ", dumpfile
);
1889 if (c
->expr2
!= NULL
)
1891 fputs (" stat=", dumpfile
);
1892 show_expr (c
->expr2
);
1894 if (c
->expr3
!= NULL
)
1896 fputs (" errmsg=", dumpfile
);
1897 show_expr (c
->expr3
);
1901 case EXEC_SYNC_MEMORY
:
1902 fputs ("SYNC MEMORY ", dumpfile
);
1903 if (c
->expr2
!= NULL
)
1905 fputs (" stat=", dumpfile
);
1906 show_expr (c
->expr2
);
1908 if (c
->expr3
!= NULL
)
1910 fputs (" errmsg=", dumpfile
);
1911 show_expr (c
->expr3
);
1915 case EXEC_SYNC_IMAGES
:
1916 fputs ("SYNC IMAGES image-set=", dumpfile
);
1917 if (c
->expr1
!= NULL
)
1918 show_expr (c
->expr1
);
1920 fputs ("* ", dumpfile
);
1921 if (c
->expr2
!= NULL
)
1923 fputs (" stat=", dumpfile
);
1924 show_expr (c
->expr2
);
1926 if (c
->expr3
!= NULL
)
1928 fputs (" errmsg=", dumpfile
);
1929 show_expr (c
->expr3
);
1933 case EXEC_EVENT_POST
:
1934 case EXEC_EVENT_WAIT
:
1935 if (c
->op
== EXEC_EVENT_POST
)
1936 fputs ("EVENT POST ", dumpfile
);
1938 fputs ("EVENT WAIT ", dumpfile
);
1940 fputs ("event-variable=", dumpfile
);
1941 if (c
->expr1
!= NULL
)
1942 show_expr (c
->expr1
);
1943 if (c
->expr4
!= NULL
)
1945 fputs (" until_count=", dumpfile
);
1946 show_expr (c
->expr4
);
1948 if (c
->expr2
!= NULL
)
1950 fputs (" stat=", dumpfile
);
1951 show_expr (c
->expr2
);
1953 if (c
->expr3
!= NULL
)
1955 fputs (" errmsg=", dumpfile
);
1956 show_expr (c
->expr3
);
1962 if (c
->op
== EXEC_LOCK
)
1963 fputs ("LOCK ", dumpfile
);
1965 fputs ("UNLOCK ", dumpfile
);
1967 fputs ("lock-variable=", dumpfile
);
1968 if (c
->expr1
!= NULL
)
1969 show_expr (c
->expr1
);
1970 if (c
->expr4
!= NULL
)
1972 fputs (" acquired_lock=", dumpfile
);
1973 show_expr (c
->expr4
);
1975 if (c
->expr2
!= NULL
)
1977 fputs (" stat=", dumpfile
);
1978 show_expr (c
->expr2
);
1980 if (c
->expr3
!= NULL
)
1982 fputs (" errmsg=", dumpfile
);
1983 show_expr (c
->expr3
);
1987 case EXEC_ARITHMETIC_IF
:
1988 fputs ("IF ", dumpfile
);
1989 show_expr (c
->expr1
);
1990 fprintf (dumpfile
, " %d, %d, %d",
1991 c
->label1
->value
, c
->label2
->value
, c
->label3
->value
);
1996 fputs ("IF ", dumpfile
);
1997 show_expr (d
->expr1
);
2000 show_code (level
+ 1, d
->next
);
2004 for (; d
; d
= d
->block
)
2006 fputs("\n", dumpfile
);
2007 code_indent (level
, 0);
2008 if (d
->expr1
== NULL
)
2009 fputs ("ELSE", dumpfile
);
2012 fputs ("ELSE IF ", dumpfile
);
2013 show_expr (d
->expr1
);
2017 show_code (level
+ 1, d
->next
);
2022 code_indent (level
, c
->label1
);
2026 fputs ("ENDIF", dumpfile
);
2031 const char* blocktype
;
2032 gfc_namespace
*saved_ns
;
2033 gfc_association_list
*alist
;
2035 if (c
->ext
.block
.assoc
)
2036 blocktype
= "ASSOCIATE";
2038 blocktype
= "BLOCK";
2040 fprintf (dumpfile
, "%s ", blocktype
);
2041 for (alist
= c
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
2043 fprintf (dumpfile
, " %s = ", alist
->name
);
2044 show_expr (alist
->target
);
2048 ns
= c
->ext
.block
.ns
;
2049 saved_ns
= gfc_current_ns
;
2050 gfc_current_ns
= ns
;
2051 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2052 gfc_current_ns
= saved_ns
;
2053 show_code (show_level
, ns
->code
);
2056 fprintf (dumpfile
, "END %s ", blocktype
);
2060 case EXEC_END_BLOCK
:
2061 /* Only come here when there is a label on an
2062 END ASSOCIATE construct. */
2066 case EXEC_SELECT_TYPE
:
2068 if (c
->op
== EXEC_SELECT_TYPE
)
2069 fputs ("SELECT TYPE ", dumpfile
);
2071 fputs ("SELECT CASE ", dumpfile
);
2072 show_expr (c
->expr1
);
2073 fputc ('\n', dumpfile
);
2075 for (; d
; d
= d
->block
)
2077 code_indent (level
, 0);
2079 fputs ("CASE ", dumpfile
);
2080 for (cp
= d
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2082 fputc ('(', dumpfile
);
2083 show_expr (cp
->low
);
2084 fputc (' ', dumpfile
);
2085 show_expr (cp
->high
);
2086 fputc (')', dumpfile
);
2087 fputc (' ', dumpfile
);
2089 fputc ('\n', dumpfile
);
2091 show_code (level
+ 1, d
->next
);
2094 code_indent (level
, c
->label1
);
2095 fputs ("END SELECT", dumpfile
);
2099 fputs ("WHERE ", dumpfile
);
2102 show_expr (d
->expr1
);
2103 fputc ('\n', dumpfile
);
2105 show_code (level
+ 1, d
->next
);
2107 for (d
= d
->block
; d
; d
= d
->block
)
2109 code_indent (level
, 0);
2110 fputs ("ELSE WHERE ", dumpfile
);
2111 show_expr (d
->expr1
);
2112 fputc ('\n', dumpfile
);
2113 show_code (level
+ 1, d
->next
);
2116 code_indent (level
, 0);
2117 fputs ("END WHERE", dumpfile
);
2122 fputs ("FORALL ", dumpfile
);
2123 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2125 show_expr (fa
->var
);
2126 fputc (' ', dumpfile
);
2127 show_expr (fa
->start
);
2128 fputc (':', dumpfile
);
2129 show_expr (fa
->end
);
2130 fputc (':', dumpfile
);
2131 show_expr (fa
->stride
);
2133 if (fa
->next
!= NULL
)
2134 fputc (',', dumpfile
);
2137 if (c
->expr1
!= NULL
)
2139 fputc (',', dumpfile
);
2140 show_expr (c
->expr1
);
2142 fputc ('\n', dumpfile
);
2144 show_code (level
+ 1, c
->block
->next
);
2146 code_indent (level
, 0);
2147 fputs ("END FORALL", dumpfile
);
2151 fputs ("CRITICAL\n", dumpfile
);
2152 show_code (level
+ 1, c
->block
->next
);
2153 code_indent (level
, 0);
2154 fputs ("END CRITICAL", dumpfile
);
2158 fputs ("DO ", dumpfile
);
2160 fprintf (dumpfile
, " %-5d ", c
->label1
->value
);
2162 show_expr (c
->ext
.iterator
->var
);
2163 fputc ('=', dumpfile
);
2164 show_expr (c
->ext
.iterator
->start
);
2165 fputc (' ', dumpfile
);
2166 show_expr (c
->ext
.iterator
->end
);
2167 fputc (' ', dumpfile
);
2168 show_expr (c
->ext
.iterator
->step
);
2171 show_code (level
+ 1, c
->block
->next
);
2178 fputs ("END DO", dumpfile
);
2181 case EXEC_DO_CONCURRENT
:
2182 fputs ("DO CONCURRENT ", dumpfile
);
2183 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2185 show_expr (fa
->var
);
2186 fputc (' ', dumpfile
);
2187 show_expr (fa
->start
);
2188 fputc (':', dumpfile
);
2189 show_expr (fa
->end
);
2190 fputc (':', dumpfile
);
2191 show_expr (fa
->stride
);
2193 if (fa
->next
!= NULL
)
2194 fputc (',', dumpfile
);
2196 show_expr (c
->expr1
);
2199 show_code (level
+ 1, c
->block
->next
);
2201 code_indent (level
, c
->label1
);
2203 fputs ("END DO", dumpfile
);
2207 fputs ("DO WHILE ", dumpfile
);
2208 show_expr (c
->expr1
);
2209 fputc ('\n', dumpfile
);
2211 show_code (level
+ 1, c
->block
->next
);
2213 code_indent (level
, c
->label1
);
2214 fputs ("END DO", dumpfile
);
2218 fputs ("CYCLE", dumpfile
);
2220 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
2224 fputs ("EXIT", dumpfile
);
2226 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
2230 fputs ("ALLOCATE ", dumpfile
);
2233 fputs (" STAT=", dumpfile
);
2234 show_expr (c
->expr1
);
2239 fputs (" ERRMSG=", dumpfile
);
2240 show_expr (c
->expr2
);
2246 fputs (" MOLD=", dumpfile
);
2248 fputs (" SOURCE=", dumpfile
);
2249 show_expr (c
->expr3
);
2252 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
2254 fputc (' ', dumpfile
);
2255 show_expr (a
->expr
);
2260 case EXEC_DEALLOCATE
:
2261 fputs ("DEALLOCATE ", dumpfile
);
2264 fputs (" STAT=", dumpfile
);
2265 show_expr (c
->expr1
);
2270 fputs (" ERRMSG=", dumpfile
);
2271 show_expr (c
->expr2
);
2274 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
2276 fputc (' ', dumpfile
);
2277 show_expr (a
->expr
);
2283 fputs ("OPEN", dumpfile
);
2288 fputs (" UNIT=", dumpfile
);
2289 show_expr (open
->unit
);
2293 fputs (" IOMSG=", dumpfile
);
2294 show_expr (open
->iomsg
);
2298 fputs (" IOSTAT=", dumpfile
);
2299 show_expr (open
->iostat
);
2303 fputs (" FILE=", dumpfile
);
2304 show_expr (open
->file
);
2308 fputs (" STATUS=", dumpfile
);
2309 show_expr (open
->status
);
2313 fputs (" ACCESS=", dumpfile
);
2314 show_expr (open
->access
);
2318 fputs (" FORM=", dumpfile
);
2319 show_expr (open
->form
);
2323 fputs (" RECL=", dumpfile
);
2324 show_expr (open
->recl
);
2328 fputs (" BLANK=", dumpfile
);
2329 show_expr (open
->blank
);
2333 fputs (" POSITION=", dumpfile
);
2334 show_expr (open
->position
);
2338 fputs (" ACTION=", dumpfile
);
2339 show_expr (open
->action
);
2343 fputs (" DELIM=", dumpfile
);
2344 show_expr (open
->delim
);
2348 fputs (" PAD=", dumpfile
);
2349 show_expr (open
->pad
);
2353 fputs (" DECIMAL=", dumpfile
);
2354 show_expr (open
->decimal
);
2358 fputs (" ENCODING=", dumpfile
);
2359 show_expr (open
->encoding
);
2363 fputs (" ROUND=", dumpfile
);
2364 show_expr (open
->round
);
2368 fputs (" SIGN=", dumpfile
);
2369 show_expr (open
->sign
);
2373 fputs (" CONVERT=", dumpfile
);
2374 show_expr (open
->convert
);
2376 if (open
->asynchronous
)
2378 fputs (" ASYNCHRONOUS=", dumpfile
);
2379 show_expr (open
->asynchronous
);
2381 if (open
->err
!= NULL
)
2382 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
2387 fputs ("CLOSE", dumpfile
);
2388 close
= c
->ext
.close
;
2392 fputs (" UNIT=", dumpfile
);
2393 show_expr (close
->unit
);
2397 fputs (" IOMSG=", dumpfile
);
2398 show_expr (close
->iomsg
);
2402 fputs (" IOSTAT=", dumpfile
);
2403 show_expr (close
->iostat
);
2407 fputs (" STATUS=", dumpfile
);
2408 show_expr (close
->status
);
2410 if (close
->err
!= NULL
)
2411 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
2414 case EXEC_BACKSPACE
:
2415 fputs ("BACKSPACE", dumpfile
);
2419 fputs ("ENDFILE", dumpfile
);
2423 fputs ("REWIND", dumpfile
);
2427 fputs ("FLUSH", dumpfile
);
2430 fp
= c
->ext
.filepos
;
2434 fputs (" UNIT=", dumpfile
);
2435 show_expr (fp
->unit
);
2439 fputs (" IOMSG=", dumpfile
);
2440 show_expr (fp
->iomsg
);
2444 fputs (" IOSTAT=", dumpfile
);
2445 show_expr (fp
->iostat
);
2447 if (fp
->err
!= NULL
)
2448 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
2452 fputs ("INQUIRE", dumpfile
);
2457 fputs (" UNIT=", dumpfile
);
2458 show_expr (i
->unit
);
2462 fputs (" FILE=", dumpfile
);
2463 show_expr (i
->file
);
2468 fputs (" IOMSG=", dumpfile
);
2469 show_expr (i
->iomsg
);
2473 fputs (" IOSTAT=", dumpfile
);
2474 show_expr (i
->iostat
);
2478 fputs (" EXIST=", dumpfile
);
2479 show_expr (i
->exist
);
2483 fputs (" OPENED=", dumpfile
);
2484 show_expr (i
->opened
);
2488 fputs (" NUMBER=", dumpfile
);
2489 show_expr (i
->number
);
2493 fputs (" NAMED=", dumpfile
);
2494 show_expr (i
->named
);
2498 fputs (" NAME=", dumpfile
);
2499 show_expr (i
->name
);
2503 fputs (" ACCESS=", dumpfile
);
2504 show_expr (i
->access
);
2508 fputs (" SEQUENTIAL=", dumpfile
);
2509 show_expr (i
->sequential
);
2514 fputs (" DIRECT=", dumpfile
);
2515 show_expr (i
->direct
);
2519 fputs (" FORM=", dumpfile
);
2520 show_expr (i
->form
);
2524 fputs (" FORMATTED", dumpfile
);
2525 show_expr (i
->formatted
);
2529 fputs (" UNFORMATTED=", dumpfile
);
2530 show_expr (i
->unformatted
);
2534 fputs (" RECL=", dumpfile
);
2535 show_expr (i
->recl
);
2539 fputs (" NEXTREC=", dumpfile
);
2540 show_expr (i
->nextrec
);
2544 fputs (" BLANK=", dumpfile
);
2545 show_expr (i
->blank
);
2549 fputs (" POSITION=", dumpfile
);
2550 show_expr (i
->position
);
2554 fputs (" ACTION=", dumpfile
);
2555 show_expr (i
->action
);
2559 fputs (" READ=", dumpfile
);
2560 show_expr (i
->read
);
2564 fputs (" WRITE=", dumpfile
);
2565 show_expr (i
->write
);
2569 fputs (" READWRITE=", dumpfile
);
2570 show_expr (i
->readwrite
);
2574 fputs (" DELIM=", dumpfile
);
2575 show_expr (i
->delim
);
2579 fputs (" PAD=", dumpfile
);
2584 fputs (" CONVERT=", dumpfile
);
2585 show_expr (i
->convert
);
2587 if (i
->asynchronous
)
2589 fputs (" ASYNCHRONOUS=", dumpfile
);
2590 show_expr (i
->asynchronous
);
2594 fputs (" DECIMAL=", dumpfile
);
2595 show_expr (i
->decimal
);
2599 fputs (" ENCODING=", dumpfile
);
2600 show_expr (i
->encoding
);
2604 fputs (" PENDING=", dumpfile
);
2605 show_expr (i
->pending
);
2609 fputs (" ROUND=", dumpfile
);
2610 show_expr (i
->round
);
2614 fputs (" SIGN=", dumpfile
);
2615 show_expr (i
->sign
);
2619 fputs (" SIZE=", dumpfile
);
2620 show_expr (i
->size
);
2624 fputs (" ID=", dumpfile
);
2629 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
2633 fputs ("IOLENGTH ", dumpfile
);
2634 show_expr (c
->expr1
);
2639 fputs ("READ", dumpfile
);
2643 fputs ("WRITE", dumpfile
);
2649 fputs (" UNIT=", dumpfile
);
2650 show_expr (dt
->io_unit
);
2653 if (dt
->format_expr
)
2655 fputs (" FMT=", dumpfile
);
2656 show_expr (dt
->format_expr
);
2659 if (dt
->format_label
!= NULL
)
2660 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
2662 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
2666 fputs (" IOMSG=", dumpfile
);
2667 show_expr (dt
->iomsg
);
2671 fputs (" IOSTAT=", dumpfile
);
2672 show_expr (dt
->iostat
);
2676 fputs (" SIZE=", dumpfile
);
2677 show_expr (dt
->size
);
2681 fputs (" REC=", dumpfile
);
2682 show_expr (dt
->rec
);
2686 fputs (" ADVANCE=", dumpfile
);
2687 show_expr (dt
->advance
);
2691 fputs (" ID=", dumpfile
);
2696 fputs (" POS=", dumpfile
);
2697 show_expr (dt
->pos
);
2699 if (dt
->asynchronous
)
2701 fputs (" ASYNCHRONOUS=", dumpfile
);
2702 show_expr (dt
->asynchronous
);
2706 fputs (" BLANK=", dumpfile
);
2707 show_expr (dt
->blank
);
2711 fputs (" DECIMAL=", dumpfile
);
2712 show_expr (dt
->decimal
);
2716 fputs (" DELIM=", dumpfile
);
2717 show_expr (dt
->delim
);
2721 fputs (" PAD=", dumpfile
);
2722 show_expr (dt
->pad
);
2726 fputs (" ROUND=", dumpfile
);
2727 show_expr (dt
->round
);
2731 fputs (" SIGN=", dumpfile
);
2732 show_expr (dt
->sign
);
2736 for (c
= c
->block
->next
; c
; c
= c
->next
)
2737 show_code_node (level
+ (c
->next
!= NULL
), c
);
2741 fputs ("TRANSFER ", dumpfile
);
2742 show_expr (c
->expr1
);
2746 fputs ("DT_END", dumpfile
);
2749 if (dt
->err
!= NULL
)
2750 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
2751 if (dt
->end
!= NULL
)
2752 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
2753 if (dt
->eor
!= NULL
)
2754 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
2758 fputs ("WAIT", dumpfile
);
2760 if (c
->ext
.wait
!= NULL
)
2762 gfc_wait
*wait
= c
->ext
.wait
;
2765 fputs (" UNIT=", dumpfile
);
2766 show_expr (wait
->unit
);
2770 fputs (" IOSTAT=", dumpfile
);
2771 show_expr (wait
->iostat
);
2775 fputs (" IOMSG=", dumpfile
);
2776 show_expr (wait
->iomsg
);
2780 fputs (" ID=", dumpfile
);
2781 show_expr (wait
->id
);
2784 fprintf (dumpfile
, " ERR=%d", wait
->err
->value
);
2786 fprintf (dumpfile
, " END=%d", wait
->end
->value
);
2788 fprintf (dumpfile
, " EOR=%d", wait
->eor
->value
);
2792 case EXEC_OACC_PARALLEL_LOOP
:
2793 case EXEC_OACC_PARALLEL
:
2794 case EXEC_OACC_KERNELS_LOOP
:
2795 case EXEC_OACC_KERNELS
:
2796 case EXEC_OACC_DATA
:
2797 case EXEC_OACC_HOST_DATA
:
2798 case EXEC_OACC_LOOP
:
2799 case EXEC_OACC_UPDATE
:
2800 case EXEC_OACC_WAIT
:
2801 case EXEC_OACC_CACHE
:
2802 case EXEC_OACC_ENTER_DATA
:
2803 case EXEC_OACC_EXIT_DATA
:
2804 case EXEC_OMP_ATOMIC
:
2805 case EXEC_OMP_CANCEL
:
2806 case EXEC_OMP_CANCELLATION_POINT
:
2807 case EXEC_OMP_BARRIER
:
2808 case EXEC_OMP_CRITICAL
:
2809 case EXEC_OMP_DISTRIBUTE
:
2810 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
2811 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2812 case EXEC_OMP_DISTRIBUTE_SIMD
:
2814 case EXEC_OMP_DO_SIMD
:
2815 case EXEC_OMP_FLUSH
:
2816 case EXEC_OMP_MASTER
:
2817 case EXEC_OMP_ORDERED
:
2818 case EXEC_OMP_PARALLEL
:
2819 case EXEC_OMP_PARALLEL_DO
:
2820 case EXEC_OMP_PARALLEL_DO_SIMD
:
2821 case EXEC_OMP_PARALLEL_SECTIONS
:
2822 case EXEC_OMP_PARALLEL_WORKSHARE
:
2823 case EXEC_OMP_SECTIONS
:
2825 case EXEC_OMP_SINGLE
:
2826 case EXEC_OMP_TARGET
:
2827 case EXEC_OMP_TARGET_DATA
:
2828 case EXEC_OMP_TARGET_ENTER_DATA
:
2829 case EXEC_OMP_TARGET_EXIT_DATA
:
2830 case EXEC_OMP_TARGET_PARALLEL
:
2831 case EXEC_OMP_TARGET_PARALLEL_DO
:
2832 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
2833 case EXEC_OMP_TARGET_SIMD
:
2834 case EXEC_OMP_TARGET_TEAMS
:
2835 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
2836 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2837 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2838 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2839 case EXEC_OMP_TARGET_UPDATE
:
2841 case EXEC_OMP_TASKGROUP
:
2842 case EXEC_OMP_TASKLOOP
:
2843 case EXEC_OMP_TASKLOOP_SIMD
:
2844 case EXEC_OMP_TASKWAIT
:
2845 case EXEC_OMP_TASKYIELD
:
2846 case EXEC_OMP_TEAMS
:
2847 case EXEC_OMP_TEAMS_DISTRIBUTE
:
2848 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2849 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2850 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
2851 case EXEC_OMP_WORKSHARE
:
2852 show_omp_node (level
, c
);
2856 gfc_internal_error ("show_code_node(): Bad statement code");
2861 /* Show an equivalence chain. */
2864 show_equiv (gfc_equiv
*eq
)
2867 fputs ("Equivalence: ", dumpfile
);
2870 show_expr (eq
->expr
);
2873 fputs (", ", dumpfile
);
2878 /* Show a freakin' whole namespace. */
2881 show_namespace (gfc_namespace
*ns
)
2883 gfc_interface
*intr
;
2884 gfc_namespace
*save
;
2890 save
= gfc_current_ns
;
2893 fputs ("Namespace:", dumpfile
);
2899 while (i
< GFC_LETTERS
- 1
2900 && gfc_compare_types (&ns
->default_type
[i
+1],
2901 &ns
->default_type
[l
]))
2905 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
2907 fprintf (dumpfile
, " %c: ", l
+'A');
2909 show_typespec(&ns
->default_type
[l
]);
2911 } while (i
< GFC_LETTERS
);
2913 if (ns
->proc_name
!= NULL
)
2916 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
2920 gfc_current_ns
= ns
;
2921 gfc_traverse_symtree (ns
->common_root
, show_common
);
2923 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2925 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
2927 /* User operator interfaces */
2933 fprintf (dumpfile
, "Operator interfaces for %s:",
2934 gfc_op2string ((gfc_intrinsic_op
) op
));
2936 for (; intr
; intr
= intr
->next
)
2937 fprintf (dumpfile
, " %s", intr
->sym
->name
);
2940 if (ns
->uop_root
!= NULL
)
2943 fputs ("User operators:\n", dumpfile
);
2944 gfc_traverse_user_op (ns
, show_uop
);
2947 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
2950 if (ns
->oacc_declare
)
2952 struct gfc_oacc_declare
*decl
;
2953 /* Dump !$ACC DECLARE clauses. */
2954 for (decl
= ns
->oacc_declare
; decl
; decl
= decl
->next
)
2957 fprintf (dumpfile
, "!$ACC DECLARE");
2958 show_omp_clauses (decl
->clauses
);
2962 fputc ('\n', dumpfile
);
2964 fputs ("code:", dumpfile
);
2965 show_code (show_level
, ns
->code
);
2968 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
2970 fputs ("\nCONTAINS\n", dumpfile
);
2972 show_namespace (ns
);
2976 fputc ('\n', dumpfile
);
2977 gfc_current_ns
= save
;
2981 /* Main function for dumping a parse tree. */
2984 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
2987 show_namespace (ns
);
2990 /* This part writes BIND(C) definition for use in external C programs. */
2992 static void write_interop_decl (gfc_symbol
*);
2995 gfc_dump_c_prototypes (gfc_namespace
*ns
, FILE *file
)
2998 gfc_get_errors (NULL
, &error_count
);
2999 if (error_count
!= 0)
3002 gfc_traverse_ns (ns
, write_interop_decl
);
3005 enum type_return
{ T_OK
=0, T_WARN
, T_ERROR
};
3007 /* Return the name of the type for later output. Both function pointers and
3008 void pointers will be mapped to void *. */
3010 static enum type_return
3011 get_c_type_name (gfc_typespec
*ts
, gfc_array_spec
*as
, const char **pre
,
3012 const char **type_name
, bool *asterisk
, const char **post
,
3015 static char post_buffer
[40];
3016 enum type_return ret
;
3022 *type_name
= "<error>";
3023 if (ts
->type
== BT_REAL
|| ts
->type
== BT_INTEGER
)
3025 if (ts
->is_c_interop
&& ts
->interop_kind
)
3027 *type_name
= ts
->interop_kind
->name
+ 2;
3028 if (strcmp (*type_name
, "signed_char") == 0)
3029 *type_name
= "signed char";
3030 else if (strcmp (*type_name
, "size_t") == 0)
3031 *type_name
= "ssize_t";
3037 /* The user did not specify a C interop type. Let's look through
3038 the available table and use the first one, but warn. */
3039 for (int i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
3041 if (c_interop_kinds_table
[i
].f90_type
== ts
->type
3042 && c_interop_kinds_table
[i
].value
== ts
->kind
)
3044 *type_name
= c_interop_kinds_table
[i
].name
+ 2;
3045 if (strcmp (*type_name
, "signed_char") == 0)
3046 *type_name
= "signed char";
3047 else if (strcmp (*type_name
, "size_t") == 0)
3048 *type_name
= "ssize_t";
3056 else if (ts
->type
== BT_LOGICAL
)
3058 if (ts
->is_c_interop
&& ts
->interop_kind
)
3060 *type_name
= "_Bool";
3065 /* Let's select an appropriate int, with a warning. */
3066 for (int i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
3068 if (c_interop_kinds_table
[i
].f90_type
== BT_INTEGER
3069 && c_interop_kinds_table
[i
].value
== ts
->kind
)
3071 *type_name
= c_interop_kinds_table
[i
].name
+ 2;
3077 else if (ts
->type
== BT_CHARACTER
)
3079 if (ts
->is_c_interop
)
3081 *type_name
= "char";
3086 /* Let's select an appropriate int, with a warning. */
3087 for (int i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
3089 if (c_interop_kinds_table
[i
].f90_type
== BT_INTEGER
3090 && c_interop_kinds_table
[i
].value
== ts
->kind
)
3092 *type_name
= c_interop_kinds_table
[i
].name
+ 2;
3098 else if (ts
->type
== BT_DERIVED
)
3100 if (ts
->u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
)
3102 if (strcmp (ts
->u
.derived
->name
, "c_ptr") == 0)
3103 *type_name
= "void";
3104 else if (strcmp (ts
->u
.derived
->name
, "c_funptr") == 0)
3106 *type_name
= "int ";
3121 *type_name
= ts
->u
.derived
->name
;
3125 if (ret
!= T_ERROR
&& as
)
3129 size_ok
= spec_size (as
, &sz
);
3130 gcc_assert (size_ok
== true);
3131 gmp_snprintf (post_buffer
, sizeof(post_buffer
), "[%Zd]", sz
);
3132 *post
= post_buffer
;
3138 /* Write out a declaration. */
3140 write_decl (gfc_typespec
*ts
, gfc_array_spec
*as
, const char *sym_name
,
3141 bool func_ret
, locus
*where
)
3143 const char *pre
, *type_name
, *post
;
3145 enum type_return rok
;
3147 rok
= get_c_type_name (ts
, as
, &pre
, &type_name
, &asterisk
, &post
, func_ret
);
3150 gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3151 gfc_typename (ts
), where
);
3152 fprintf (dumpfile
, "/* Cannot convert '%s' to interoperable type */",
3156 fputs (type_name
, dumpfile
);
3157 fputs (pre
, dumpfile
);
3159 fputs ("*", dumpfile
);
3161 fputs (sym_name
, dumpfile
);
3162 fputs (post
, dumpfile
);
3165 fprintf (dumpfile
," /* WARNING: Converting '%s' to interoperable type */",
3169 /* Write out an interoperable type. It will be written as a typedef
3173 write_type (gfc_symbol
*sym
)
3177 fprintf (dumpfile
, "typedef struct %s {\n", sym
->name
);
3178 for (c
= sym
->components
; c
; c
= c
->next
)
3180 fputs (" ", dumpfile
);
3181 write_decl (&(c
->ts
), c
->as
, c
->name
, false, &sym
->declared_at
);
3182 fputs (";\n", dumpfile
);
3185 fprintf (dumpfile
, "} %s;\n", sym
->name
);
3188 /* Write out a variable. */
3191 write_variable (gfc_symbol
*sym
)
3193 const char *sym_name
;
3195 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
3197 if (sym
->binding_label
)
3198 sym_name
= sym
->binding_label
;
3200 sym_name
= sym
->name
;
3202 fputs ("extern ", dumpfile
);
3203 write_decl (&(sym
->ts
), sym
->as
, sym_name
, false, &sym
->declared_at
);
3204 fputs (";\n", dumpfile
);
3208 /* Write out a procedure, including its arguments. */
3210 write_proc (gfc_symbol
*sym
)
3212 const char *pre
, *type_name
, *post
;
3214 enum type_return rok
;
3215 gfc_formal_arglist
*f
;
3216 const char *sym_name
;
3217 const char *intent_in
;
3219 if (sym
->binding_label
)
3220 sym_name
= sym
->binding_label
;
3222 sym_name
= sym
->name
;
3224 if (sym
->ts
.type
== BT_UNKNOWN
)
3226 fprintf (dumpfile
, "void ");
3227 fputs (sym_name
, dumpfile
);
3230 write_decl (&(sym
->ts
), sym
->as
, sym_name
, true, &sym
->declared_at
);
3232 fputs (" (", dumpfile
);
3234 for (f
= sym
->formal
; f
; f
= f
->next
)
3238 rok
= get_c_type_name (&(s
->ts
), NULL
, &pre
, &type_name
, &asterisk
,
3242 gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3243 gfc_typename (&s
->ts
), &s
->declared_at
);
3244 fprintf (stderr
, "/* Cannot convert '%s' to interoperable type */",
3245 gfc_typename (&s
->ts
));
3252 if (s
->attr
.intent
== INTENT_IN
&& !s
->attr
.value
)
3253 intent_in
= "const ";
3257 fputs (intent_in
, dumpfile
);
3258 fputs (type_name
, dumpfile
);
3259 fputs (pre
, dumpfile
);
3261 fputs ("*", dumpfile
);
3263 fputs (s
->name
, dumpfile
);
3264 fputs (post
, dumpfile
);
3266 fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile
);
3269 fputs(", ", dumpfile
);
3271 fputs (");\n", dumpfile
);
3275 /* Write a C-interoperable declaration as a C prototype or extern
3279 write_interop_decl (gfc_symbol
*sym
)
3281 /* Only dump bind(c) entities. */
3282 if (!sym
->attr
.is_bind_c
)
3285 /* Don't dump our iso c module. */
3286 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
3289 if (sym
->attr
.flavor
== FL_VARIABLE
)
3290 write_variable (sym
);
3291 else if (sym
->attr
.flavor
== FL_DERIVED
)
3293 else if (sym
->attr
.flavor
== FL_PROCEDURE
)