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
)
631 if (attr
->flavor
== FL_DERIVED
&& attr
->pdt_template
)
632 fputs (" (PDT template", dumpfile
);
634 fprintf (dumpfile
, "(%s ", gfc_code2string (flavors
, attr
->flavor
));
636 if (attr
->access
!= ACCESS_UNKNOWN
)
637 fprintf (dumpfile
, "%s ", gfc_code2string (access_types
, attr
->access
));
638 if (attr
->proc
!= PROC_UNKNOWN
)
639 fprintf (dumpfile
, "%s ", gfc_code2string (procedures
, attr
->proc
));
640 if (attr
->save
!= SAVE_NONE
)
641 fprintf (dumpfile
, "%s", gfc_code2string (save_status
, attr
->save
));
643 if (attr
->artificial
)
644 fputs (" ARTIFICIAL", dumpfile
);
645 if (attr
->allocatable
)
646 fputs (" ALLOCATABLE", dumpfile
);
647 if (attr
->asynchronous
)
648 fputs (" ASYNCHRONOUS", dumpfile
);
649 if (attr
->codimension
)
650 fputs (" CODIMENSION", dumpfile
);
652 fputs (" DIMENSION", dumpfile
);
653 if (attr
->contiguous
)
654 fputs (" CONTIGUOUS", dumpfile
);
656 fputs (" EXTERNAL", dumpfile
);
658 fputs (" INTRINSIC", dumpfile
);
660 fputs (" OPTIONAL", dumpfile
);
662 fputs (" KIND", dumpfile
);
664 fputs (" LEN", dumpfile
);
666 fputs (" POINTER", dumpfile
);
667 if (attr
->is_protected
)
668 fputs (" PROTECTED", dumpfile
);
670 fputs (" VALUE", dumpfile
);
672 fputs (" VOLATILE", dumpfile
);
673 if (attr
->threadprivate
)
674 fputs (" THREADPRIVATE", dumpfile
);
676 fputs (" TARGET", dumpfile
);
679 fputs (" DUMMY", dumpfile
);
680 if (attr
->intent
!= INTENT_UNKNOWN
)
681 fprintf (dumpfile
, "(%s)", gfc_intent_string (attr
->intent
));
685 fputs (" RESULT", dumpfile
);
687 fputs (" ENTRY", dumpfile
);
689 fputs (" BIND(C)", dumpfile
);
692 fputs (" DATA", dumpfile
);
695 fputs (" USE-ASSOC", dumpfile
);
697 fprintf (dumpfile
, "(%s)", module
);
700 if (attr
->in_namelist
)
701 fputs (" IN-NAMELIST", dumpfile
);
703 fputs (" IN-COMMON", dumpfile
);
706 fputs (" ABSTRACT", dumpfile
);
708 fputs (" FUNCTION", dumpfile
);
709 if (attr
->subroutine
)
710 fputs (" SUBROUTINE", dumpfile
);
711 if (attr
->implicit_type
)
712 fputs (" IMPLICIT-TYPE", dumpfile
);
715 fputs (" SEQUENCE", dumpfile
);
717 fputs (" ELEMENTAL", dumpfile
);
719 fputs (" PURE", dumpfile
);
721 fputs (" RECURSIVE", dumpfile
);
723 fputc (')', dumpfile
);
727 /* Show components of a derived type. */
730 show_components (gfc_symbol
*sym
)
734 for (c
= sym
->components
; c
; c
= c
->next
)
737 fprintf (dumpfile
, "(%s ", c
->name
);
738 show_typespec (&c
->ts
);
741 fputs (" kind_expr: ", dumpfile
);
742 show_expr (c
->kind_expr
);
746 fputs ("PDT parameters", dumpfile
);
747 show_actual_arglist (c
->param_list
);
750 if (c
->attr
.allocatable
)
751 fputs (" ALLOCATABLE", dumpfile
);
752 if (c
->attr
.pdt_kind
)
753 fputs (" KIND", dumpfile
);
755 fputs (" LEN", dumpfile
);
757 fputs (" POINTER", dumpfile
);
758 if (c
->attr
.proc_pointer
)
759 fputs (" PPC", dumpfile
);
760 if (c
->attr
.dimension
)
761 fputs (" DIMENSION", dumpfile
);
762 fputc (' ', dumpfile
);
763 show_array_spec (c
->as
);
765 fprintf (dumpfile
, " %s", gfc_code2string (access_types
, c
->attr
.access
));
766 fputc (')', dumpfile
);
768 fputc (' ', dumpfile
);
773 /* Show the f2k_derived namespace with procedure bindings. */
776 show_typebound_proc (gfc_typebound_proc
* tb
, const char* name
)
781 fputs ("GENERIC", dumpfile
);
784 fputs ("PROCEDURE, ", dumpfile
);
786 fputs ("NOPASS", dumpfile
);
790 fprintf (dumpfile
, "PASS(%s)", tb
->pass_arg
);
792 fputs ("PASS", dumpfile
);
794 if (tb
->non_overridable
)
795 fputs (", NON_OVERRIDABLE", dumpfile
);
798 if (tb
->access
== ACCESS_PUBLIC
)
799 fputs (", PUBLIC", dumpfile
);
801 fputs (", PRIVATE", dumpfile
);
803 fprintf (dumpfile
, " :: %s => ", name
);
808 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
810 fputs (g
->specific_st
->name
, dumpfile
);
812 fputs (", ", dumpfile
);
816 fputs (tb
->u
.specific
->n
.sym
->name
, dumpfile
);
820 show_typebound_symtree (gfc_symtree
* st
)
822 gcc_assert (st
->n
.tb
);
823 show_typebound_proc (st
->n
.tb
, st
->name
);
827 show_f2k_derived (gfc_namespace
* f2k
)
833 fputs ("Procedure bindings:", dumpfile
);
836 /* Finalizer bindings. */
837 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
840 fprintf (dumpfile
, "FINAL %s", f
->proc_tree
->n
.sym
->name
);
843 /* Type-bound procedures. */
844 gfc_traverse_symtree (f2k
->tb_sym_root
, &show_typebound_symtree
);
849 fputs ("Operator bindings:", dumpfile
);
852 /* User-defined operators. */
853 gfc_traverse_symtree (f2k
->tb_uop_root
, &show_typebound_symtree
);
855 /* Intrinsic operators. */
856 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
858 show_typebound_proc (f2k
->tb_op
[op
],
859 gfc_op2string ((gfc_intrinsic_op
) op
));
865 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
866 show the interface. Information needed to reconstruct the list of
867 specific interfaces associated with a generic symbol is done within
871 show_symbol (gfc_symbol
*sym
)
873 gfc_formal_arglist
*formal
;
880 fprintf (dumpfile
, "|| symbol: '%s' ", sym
->name
);
881 len
= strlen (sym
->name
);
882 for (i
=len
; i
<12; i
++)
883 fputc(' ', dumpfile
);
885 if (sym
->binding_label
)
886 fprintf (dumpfile
,"|| binding_label: '%s' ", sym
->binding_label
);
891 fputs ("type spec : ", dumpfile
);
892 show_typespec (&sym
->ts
);
895 fputs ("attributes: ", dumpfile
);
896 show_attr (&sym
->attr
, sym
->module
);
901 fputs ("value: ", dumpfile
);
902 show_expr (sym
->value
);
908 fputs ("Array spec:", dumpfile
);
909 show_array_spec (sym
->as
);
915 fputs ("Generic interfaces:", dumpfile
);
916 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
917 fprintf (dumpfile
, " %s", intr
->sym
->name
);
923 fprintf (dumpfile
, "result: %s", sym
->result
->name
);
929 fputs ("components: ", dumpfile
);
930 show_components (sym
);
933 if (sym
->f2k_derived
)
937 fprintf (dumpfile
, "hash: %d", sym
->hash_value
);
938 show_f2k_derived (sym
->f2k_derived
);
944 fputs ("Formal arglist:", dumpfile
);
946 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
948 if (formal
->sym
!= NULL
)
949 fprintf (dumpfile
, " %s", formal
->sym
->name
);
951 fputs (" [Alt Return]", dumpfile
);
955 if (sym
->formal_ns
&& (sym
->formal_ns
->proc_name
!= sym
)
956 && sym
->attr
.proc
!= PROC_ST_FUNCTION
960 fputs ("Formal namespace", dumpfile
);
961 show_namespace (sym
->formal_ns
);
964 if (sym
->attr
.flavor
== FL_VARIABLE
968 fputs ("PDT parameters", dumpfile
);
969 show_actual_arglist (sym
->param_list
);
972 if (sym
->attr
.flavor
== FL_NAMELIST
)
976 fputs ("variables : ", dumpfile
);
977 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
978 fprintf (dumpfile
, " %s",nl
->sym
->name
);
985 /* Show a user-defined operator. Just prints an operator
986 and the name of the associated subroutine, really. */
989 show_uop (gfc_user_op
*uop
)
994 fprintf (dumpfile
, "%s:", uop
->name
);
996 for (intr
= uop
->op
; intr
; intr
= intr
->next
)
997 fprintf (dumpfile
, " %s", intr
->sym
->name
);
1001 /* Workhorse function for traversing the user operator symtree. */
1004 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
1009 (*func
) (st
->n
.uop
);
1011 traverse_uop (st
->left
, func
);
1012 traverse_uop (st
->right
, func
);
1016 /* Traverse the tree of user operator nodes. */
1019 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
1021 traverse_uop (ns
->uop_root
, func
);
1025 /* Function to display a common block. */
1028 show_common (gfc_symtree
*st
)
1033 fprintf (dumpfile
, "common: /%s/ ", st
->name
);
1035 s
= st
->n
.common
->head
;
1038 fprintf (dumpfile
, "%s", s
->name
);
1041 fputs (", ", dumpfile
);
1043 fputc ('\n', dumpfile
);
1047 /* Worker function to display the symbol tree. */
1050 show_symtree (gfc_symtree
*st
)
1056 len
= strlen(st
->name
);
1057 fprintf (dumpfile
, "symtree: '%s'", st
->name
);
1059 for (i
=len
; i
<12; i
++)
1060 fputc(' ', dumpfile
);
1063 fputs( " Ambiguous", dumpfile
);
1065 if (st
->n
.sym
->ns
!= gfc_current_ns
)
1066 fprintf (dumpfile
, "|| symbol: '%s' from namespace '%s'", st
->n
.sym
->name
,
1067 st
->n
.sym
->ns
->proc_name
->name
);
1069 show_symbol (st
->n
.sym
);
1073 /******************* Show gfc_code structures **************/
1076 /* Show a list of code structures. Mutually recursive with
1077 show_code_node(). */
1080 show_code (int level
, gfc_code
*c
)
1082 for (; c
; c
= c
->next
)
1083 show_code_node (level
, c
);
1087 show_omp_namelist (int list_type
, gfc_omp_namelist
*n
)
1089 for (; n
; n
= n
->next
)
1091 if (list_type
== OMP_LIST_REDUCTION
)
1092 switch (n
->u
.reduction_op
)
1094 case OMP_REDUCTION_PLUS
:
1095 case OMP_REDUCTION_TIMES
:
1096 case OMP_REDUCTION_MINUS
:
1097 case OMP_REDUCTION_AND
:
1098 case OMP_REDUCTION_OR
:
1099 case OMP_REDUCTION_EQV
:
1100 case OMP_REDUCTION_NEQV
:
1101 fprintf (dumpfile
, "%s:",
1102 gfc_op2string ((gfc_intrinsic_op
) n
->u
.reduction_op
));
1104 case OMP_REDUCTION_MAX
: fputs ("max:", dumpfile
); break;
1105 case OMP_REDUCTION_MIN
: fputs ("min:", dumpfile
); break;
1106 case OMP_REDUCTION_IAND
: fputs ("iand:", dumpfile
); break;
1107 case OMP_REDUCTION_IOR
: fputs ("ior:", dumpfile
); break;
1108 case OMP_REDUCTION_IEOR
: fputs ("ieor:", dumpfile
); break;
1109 case OMP_REDUCTION_USER
:
1111 fprintf (dumpfile
, "%s:", n
->udr
->udr
->name
);
1115 else if (list_type
== OMP_LIST_DEPEND
)
1116 switch (n
->u
.depend_op
)
1118 case OMP_DEPEND_IN
: fputs ("in:", dumpfile
); break;
1119 case OMP_DEPEND_OUT
: fputs ("out:", dumpfile
); break;
1120 case OMP_DEPEND_INOUT
: fputs ("inout:", dumpfile
); break;
1121 case OMP_DEPEND_SINK_FIRST
:
1122 fputs ("sink:", dumpfile
);
1125 fprintf (dumpfile
, "%s", n
->sym
->name
);
1128 fputc ('+', dumpfile
);
1129 show_expr (n
->expr
);
1131 if (n
->next
== NULL
)
1133 else if (n
->next
->u
.depend_op
!= OMP_DEPEND_SINK
)
1135 fputs (") DEPEND(", dumpfile
);
1138 fputc (',', dumpfile
);
1144 else if (list_type
== OMP_LIST_MAP
)
1145 switch (n
->u
.map_op
)
1147 case OMP_MAP_ALLOC
: fputs ("alloc:", dumpfile
); break;
1148 case OMP_MAP_TO
: fputs ("to:", dumpfile
); break;
1149 case OMP_MAP_FROM
: fputs ("from:", dumpfile
); break;
1150 case OMP_MAP_TOFROM
: fputs ("tofrom:", dumpfile
); break;
1153 else if (list_type
== OMP_LIST_LINEAR
)
1154 switch (n
->u
.linear_op
)
1156 case OMP_LINEAR_REF
: fputs ("ref(", dumpfile
); break;
1157 case OMP_LINEAR_VAL
: fputs ("val(", dumpfile
); break;
1158 case OMP_LINEAR_UVAL
: fputs ("uval(", dumpfile
); break;
1161 fprintf (dumpfile
, "%s", n
->sym
->name
);
1162 if (list_type
== OMP_LIST_LINEAR
&& n
->u
.linear_op
!= OMP_LINEAR_DEFAULT
)
1163 fputc (')', dumpfile
);
1166 fputc (':', dumpfile
);
1167 show_expr (n
->expr
);
1170 fputc (',', dumpfile
);
1175 /* Show OpenMP or OpenACC clauses. */
1178 show_omp_clauses (gfc_omp_clauses
*omp_clauses
)
1182 switch (omp_clauses
->cancel
)
1184 case OMP_CANCEL_UNKNOWN
:
1186 case OMP_CANCEL_PARALLEL
:
1187 fputs (" PARALLEL", dumpfile
);
1189 case OMP_CANCEL_SECTIONS
:
1190 fputs (" SECTIONS", dumpfile
);
1193 fputs (" DO", dumpfile
);
1195 case OMP_CANCEL_TASKGROUP
:
1196 fputs (" TASKGROUP", dumpfile
);
1199 if (omp_clauses
->if_expr
)
1201 fputs (" IF(", dumpfile
);
1202 show_expr (omp_clauses
->if_expr
);
1203 fputc (')', dumpfile
);
1205 if (omp_clauses
->final_expr
)
1207 fputs (" FINAL(", dumpfile
);
1208 show_expr (omp_clauses
->final_expr
);
1209 fputc (')', dumpfile
);
1211 if (omp_clauses
->num_threads
)
1213 fputs (" NUM_THREADS(", dumpfile
);
1214 show_expr (omp_clauses
->num_threads
);
1215 fputc (')', dumpfile
);
1217 if (omp_clauses
->async
)
1219 fputs (" ASYNC", dumpfile
);
1220 if (omp_clauses
->async_expr
)
1222 fputc ('(', dumpfile
);
1223 show_expr (omp_clauses
->async_expr
);
1224 fputc (')', dumpfile
);
1227 if (omp_clauses
->num_gangs_expr
)
1229 fputs (" NUM_GANGS(", dumpfile
);
1230 show_expr (omp_clauses
->num_gangs_expr
);
1231 fputc (')', dumpfile
);
1233 if (omp_clauses
->num_workers_expr
)
1235 fputs (" NUM_WORKERS(", dumpfile
);
1236 show_expr (omp_clauses
->num_workers_expr
);
1237 fputc (')', dumpfile
);
1239 if (omp_clauses
->vector_length_expr
)
1241 fputs (" VECTOR_LENGTH(", dumpfile
);
1242 show_expr (omp_clauses
->vector_length_expr
);
1243 fputc (')', dumpfile
);
1245 if (omp_clauses
->gang
)
1247 fputs (" GANG", dumpfile
);
1248 if (omp_clauses
->gang_num_expr
|| omp_clauses
->gang_static_expr
)
1250 fputc ('(', dumpfile
);
1251 if (omp_clauses
->gang_num_expr
)
1253 fprintf (dumpfile
, "num:");
1254 show_expr (omp_clauses
->gang_num_expr
);
1256 if (omp_clauses
->gang_num_expr
&& omp_clauses
->gang_static
)
1257 fputc (',', dumpfile
);
1258 if (omp_clauses
->gang_static
)
1260 fprintf (dumpfile
, "static:");
1261 if (omp_clauses
->gang_static_expr
)
1262 show_expr (omp_clauses
->gang_static_expr
);
1264 fputc ('*', dumpfile
);
1266 fputc (')', dumpfile
);
1269 if (omp_clauses
->worker
)
1271 fputs (" WORKER", dumpfile
);
1272 if (omp_clauses
->worker_expr
)
1274 fputc ('(', dumpfile
);
1275 show_expr (omp_clauses
->worker_expr
);
1276 fputc (')', dumpfile
);
1279 if (omp_clauses
->vector
)
1281 fputs (" VECTOR", dumpfile
);
1282 if (omp_clauses
->vector_expr
)
1284 fputc ('(', dumpfile
);
1285 show_expr (omp_clauses
->vector_expr
);
1286 fputc (')', dumpfile
);
1289 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
1292 switch (omp_clauses
->sched_kind
)
1294 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
1295 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
1296 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
1297 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
1298 case OMP_SCHED_AUTO
: type
= "AUTO"; break;
1302 fputs (" SCHEDULE (", dumpfile
);
1303 if (omp_clauses
->sched_simd
)
1305 if (omp_clauses
->sched_monotonic
1306 || omp_clauses
->sched_nonmonotonic
)
1307 fputs ("SIMD, ", dumpfile
);
1309 fputs ("SIMD: ", dumpfile
);
1311 if (omp_clauses
->sched_monotonic
)
1312 fputs ("MONOTONIC: ", dumpfile
);
1313 else if (omp_clauses
->sched_nonmonotonic
)
1314 fputs ("NONMONOTONIC: ", dumpfile
);
1315 fputs (type
, dumpfile
);
1316 if (omp_clauses
->chunk_size
)
1318 fputc (',', dumpfile
);
1319 show_expr (omp_clauses
->chunk_size
);
1321 fputc (')', dumpfile
);
1323 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1326 switch (omp_clauses
->default_sharing
)
1328 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
1329 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
1330 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
1331 case OMP_DEFAULT_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1332 case OMP_DEFAULT_PRESENT
: type
= "PRESENT"; break;
1336 fprintf (dumpfile
, " DEFAULT(%s)", type
);
1338 if (omp_clauses
->tile_list
)
1340 gfc_expr_list
*list
;
1341 fputs (" TILE(", dumpfile
);
1342 for (list
= omp_clauses
->tile_list
; list
; list
= list
->next
)
1344 show_expr (list
->expr
);
1346 fputs (", ", dumpfile
);
1348 fputc (')', dumpfile
);
1350 if (omp_clauses
->wait_list
)
1352 gfc_expr_list
*list
;
1353 fputs (" WAIT(", dumpfile
);
1354 for (list
= omp_clauses
->wait_list
; list
; list
= list
->next
)
1356 show_expr (list
->expr
);
1358 fputs (", ", dumpfile
);
1360 fputc (')', dumpfile
);
1362 if (omp_clauses
->seq
)
1363 fputs (" SEQ", dumpfile
);
1364 if (omp_clauses
->independent
)
1365 fputs (" INDEPENDENT", dumpfile
);
1366 if (omp_clauses
->ordered
)
1368 if (omp_clauses
->orderedc
)
1369 fprintf (dumpfile
, " ORDERED(%d)", omp_clauses
->orderedc
);
1371 fputs (" ORDERED", dumpfile
);
1373 if (omp_clauses
->untied
)
1374 fputs (" UNTIED", dumpfile
);
1375 if (omp_clauses
->mergeable
)
1376 fputs (" MERGEABLE", dumpfile
);
1377 if (omp_clauses
->collapse
)
1378 fprintf (dumpfile
, " COLLAPSE(%d)", omp_clauses
->collapse
);
1379 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
1380 if (omp_clauses
->lists
[list_type
] != NULL
1381 && list_type
!= OMP_LIST_COPYPRIVATE
)
1383 const char *type
= NULL
;
1386 case OMP_LIST_USE_DEVICE
: type
= "USE_DEVICE"; break;
1387 case OMP_LIST_DEVICE_RESIDENT
: type
= "USE_DEVICE"; break;
1388 case OMP_LIST_CACHE
: type
= ""; break;
1389 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
1390 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1391 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
1392 case OMP_LIST_SHARED
: type
= "SHARED"; break;
1393 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
1394 case OMP_LIST_UNIFORM
: type
= "UNIFORM"; break;
1395 case OMP_LIST_ALIGNED
: type
= "ALIGNED"; break;
1396 case OMP_LIST_LINEAR
: type
= "LINEAR"; break;
1397 case OMP_LIST_REDUCTION
: type
= "REDUCTION"; break;
1398 case OMP_LIST_IS_DEVICE_PTR
: type
= "IS_DEVICE_PTR"; break;
1399 case OMP_LIST_USE_DEVICE_PTR
: type
= "USE_DEVICE_PTR"; break;
1400 case OMP_LIST_DEPEND
: type
= "DEPEND"; break;
1404 fprintf (dumpfile
, " %s(", type
);
1405 show_omp_namelist (list_type
, omp_clauses
->lists
[list_type
]);
1406 fputc (')', dumpfile
);
1408 if (omp_clauses
->safelen_expr
)
1410 fputs (" SAFELEN(", dumpfile
);
1411 show_expr (omp_clauses
->safelen_expr
);
1412 fputc (')', dumpfile
);
1414 if (omp_clauses
->simdlen_expr
)
1416 fputs (" SIMDLEN(", dumpfile
);
1417 show_expr (omp_clauses
->simdlen_expr
);
1418 fputc (')', dumpfile
);
1420 if (omp_clauses
->inbranch
)
1421 fputs (" INBRANCH", dumpfile
);
1422 if (omp_clauses
->notinbranch
)
1423 fputs (" NOTINBRANCH", dumpfile
);
1424 if (omp_clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
1427 switch (omp_clauses
->proc_bind
)
1429 case OMP_PROC_BIND_MASTER
: type
= "MASTER"; break;
1430 case OMP_PROC_BIND_SPREAD
: type
= "SPREAD"; break;
1431 case OMP_PROC_BIND_CLOSE
: type
= "CLOSE"; break;
1435 fprintf (dumpfile
, " PROC_BIND(%s)", type
);
1437 if (omp_clauses
->num_teams
)
1439 fputs (" NUM_TEAMS(", dumpfile
);
1440 show_expr (omp_clauses
->num_teams
);
1441 fputc (')', dumpfile
);
1443 if (omp_clauses
->device
)
1445 fputs (" DEVICE(", dumpfile
);
1446 show_expr (omp_clauses
->device
);
1447 fputc (')', dumpfile
);
1449 if (omp_clauses
->thread_limit
)
1451 fputs (" THREAD_LIMIT(", dumpfile
);
1452 show_expr (omp_clauses
->thread_limit
);
1453 fputc (')', dumpfile
);
1455 if (omp_clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
1457 fprintf (dumpfile
, " DIST_SCHEDULE (STATIC");
1458 if (omp_clauses
->dist_chunk_size
)
1460 fputc (',', dumpfile
);
1461 show_expr (omp_clauses
->dist_chunk_size
);
1463 fputc (')', dumpfile
);
1465 if (omp_clauses
->defaultmap
)
1466 fputs (" DEFALTMAP (TOFROM: SCALAR)", dumpfile
);
1467 if (omp_clauses
->nogroup
)
1468 fputs (" NOGROUP", dumpfile
);
1469 if (omp_clauses
->simd
)
1470 fputs (" SIMD", dumpfile
);
1471 if (omp_clauses
->threads
)
1472 fputs (" THREADS", dumpfile
);
1473 if (omp_clauses
->grainsize
)
1475 fputs (" GRAINSIZE(", dumpfile
);
1476 show_expr (omp_clauses
->grainsize
);
1477 fputc (')', dumpfile
);
1479 if (omp_clauses
->hint
)
1481 fputs (" HINT(", dumpfile
);
1482 show_expr (omp_clauses
->hint
);
1483 fputc (')', dumpfile
);
1485 if (omp_clauses
->num_tasks
)
1487 fputs (" NUM_TASKS(", dumpfile
);
1488 show_expr (omp_clauses
->num_tasks
);
1489 fputc (')', dumpfile
);
1491 if (omp_clauses
->priority
)
1493 fputs (" PRIORITY(", dumpfile
);
1494 show_expr (omp_clauses
->priority
);
1495 fputc (')', dumpfile
);
1497 for (i
= 0; i
< OMP_IF_LAST
; i
++)
1498 if (omp_clauses
->if_exprs
[i
])
1500 static const char *ifs
[] = {
1507 "TARGET ENTER DATA",
1510 fputs (" IF(", dumpfile
);
1511 fputs (ifs
[i
], dumpfile
);
1512 fputs (": ", dumpfile
);
1513 show_expr (omp_clauses
->if_exprs
[i
]);
1514 fputc (')', dumpfile
);
1516 if (omp_clauses
->depend_source
)
1517 fputs (" DEPEND(source)", dumpfile
);
1520 /* Show a single OpenMP or OpenACC directive node and everything underneath it
1524 show_omp_node (int level
, gfc_code
*c
)
1526 gfc_omp_clauses
*omp_clauses
= NULL
;
1527 const char *name
= NULL
;
1528 bool is_oacc
= false;
1532 case EXEC_OACC_PARALLEL_LOOP
:
1533 name
= "PARALLEL LOOP"; is_oacc
= true; break;
1534 case EXEC_OACC_PARALLEL
: name
= "PARALLEL"; is_oacc
= true; break;
1535 case EXEC_OACC_KERNELS_LOOP
: name
= "KERNELS LOOP"; is_oacc
= true; break;
1536 case EXEC_OACC_KERNELS
: name
= "KERNELS"; is_oacc
= true; break;
1537 case EXEC_OACC_DATA
: name
= "DATA"; is_oacc
= true; break;
1538 case EXEC_OACC_HOST_DATA
: name
= "HOST_DATA"; is_oacc
= true; break;
1539 case EXEC_OACC_LOOP
: name
= "LOOP"; is_oacc
= true; break;
1540 case EXEC_OACC_UPDATE
: name
= "UPDATE"; is_oacc
= true; break;
1541 case EXEC_OACC_WAIT
: name
= "WAIT"; is_oacc
= true; break;
1542 case EXEC_OACC_CACHE
: name
= "CACHE"; is_oacc
= true; break;
1543 case EXEC_OACC_ENTER_DATA
: name
= "ENTER DATA"; is_oacc
= true; break;
1544 case EXEC_OACC_EXIT_DATA
: name
= "EXIT DATA"; is_oacc
= true; break;
1545 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
1546 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
1547 case EXEC_OMP_CANCEL
: name
= "CANCEL"; break;
1548 case EXEC_OMP_CANCELLATION_POINT
: name
= "CANCELLATION POINT"; break;
1549 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
1550 case EXEC_OMP_DISTRIBUTE
: name
= "DISTRIBUTE"; break;
1551 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1552 name
= "DISTRIBUTE PARALLEL DO"; break;
1553 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1554 name
= "DISTRIBUTE PARALLEL DO SIMD"; break;
1555 case EXEC_OMP_DISTRIBUTE_SIMD
: name
= "DISTRIBUTE SIMD"; break;
1556 case EXEC_OMP_DO
: name
= "DO"; break;
1557 case EXEC_OMP_DO_SIMD
: name
= "DO SIMD"; break;
1558 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
1559 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
1560 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
1561 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
1562 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
1563 case EXEC_OMP_PARALLEL_DO_SIMD
: name
= "PARALLEL DO SIMD"; break;
1564 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
1565 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
1566 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
1567 case EXEC_OMP_SIMD
: name
= "SIMD"; break;
1568 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
1569 case EXEC_OMP_TARGET
: name
= "TARGET"; break;
1570 case EXEC_OMP_TARGET_DATA
: name
= "TARGET DATA"; break;
1571 case EXEC_OMP_TARGET_ENTER_DATA
: name
= "TARGET ENTER DATA"; break;
1572 case EXEC_OMP_TARGET_EXIT_DATA
: name
= "TARGET EXIT DATA"; break;
1573 case EXEC_OMP_TARGET_PARALLEL
: name
= "TARGET PARALLEL"; break;
1574 case EXEC_OMP_TARGET_PARALLEL_DO
: name
= "TARGET PARALLEL DO"; break;
1575 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
1576 name
= "TARGET_PARALLEL_DO_SIMD"; break;
1577 case EXEC_OMP_TARGET_SIMD
: name
= "TARGET SIMD"; break;
1578 case EXEC_OMP_TARGET_TEAMS
: name
= "TARGET TEAMS"; break;
1579 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1580 name
= "TARGET TEAMS DISTRIBUTE"; break;
1581 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1582 name
= "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break;
1583 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1584 name
= "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
1585 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1586 name
= "TARGET TEAMS DISTRIBUTE SIMD"; break;
1587 case EXEC_OMP_TARGET_UPDATE
: name
= "TARGET UPDATE"; break;
1588 case EXEC_OMP_TASK
: name
= "TASK"; break;
1589 case EXEC_OMP_TASKGROUP
: name
= "TASKGROUP"; break;
1590 case EXEC_OMP_TASKLOOP
: name
= "TASKLOOP"; break;
1591 case EXEC_OMP_TASKLOOP_SIMD
: name
= "TASKLOOP SIMD"; break;
1592 case EXEC_OMP_TASKWAIT
: name
= "TASKWAIT"; break;
1593 case EXEC_OMP_TASKYIELD
: name
= "TASKYIELD"; break;
1594 case EXEC_OMP_TEAMS
: name
= "TEAMS"; break;
1595 case EXEC_OMP_TEAMS_DISTRIBUTE
: name
= "TEAMS DISTRIBUTE"; break;
1596 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1597 name
= "TEAMS DISTRIBUTE PARALLEL DO"; break;
1598 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1599 name
= "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
1600 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
: name
= "TEAMS DISTRIBUTE SIMD"; break;
1601 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
1605 fprintf (dumpfile
, "!$%s %s", is_oacc
? "ACC" : "OMP", name
);
1608 case EXEC_OACC_PARALLEL_LOOP
:
1609 case EXEC_OACC_PARALLEL
:
1610 case EXEC_OACC_KERNELS_LOOP
:
1611 case EXEC_OACC_KERNELS
:
1612 case EXEC_OACC_DATA
:
1613 case EXEC_OACC_HOST_DATA
:
1614 case EXEC_OACC_LOOP
:
1615 case EXEC_OACC_UPDATE
:
1616 case EXEC_OACC_WAIT
:
1617 case EXEC_OACC_CACHE
:
1618 case EXEC_OACC_ENTER_DATA
:
1619 case EXEC_OACC_EXIT_DATA
:
1620 case EXEC_OMP_CANCEL
:
1621 case EXEC_OMP_CANCELLATION_POINT
:
1622 case EXEC_OMP_DISTRIBUTE
:
1623 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1624 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1625 case EXEC_OMP_DISTRIBUTE_SIMD
:
1627 case EXEC_OMP_DO_SIMD
:
1628 case EXEC_OMP_ORDERED
:
1629 case EXEC_OMP_PARALLEL
:
1630 case EXEC_OMP_PARALLEL_DO
:
1631 case EXEC_OMP_PARALLEL_DO_SIMD
:
1632 case EXEC_OMP_PARALLEL_SECTIONS
:
1633 case EXEC_OMP_PARALLEL_WORKSHARE
:
1634 case EXEC_OMP_SECTIONS
:
1636 case EXEC_OMP_SINGLE
:
1637 case EXEC_OMP_TARGET
:
1638 case EXEC_OMP_TARGET_DATA
:
1639 case EXEC_OMP_TARGET_ENTER_DATA
:
1640 case EXEC_OMP_TARGET_EXIT_DATA
:
1641 case EXEC_OMP_TARGET_PARALLEL
:
1642 case EXEC_OMP_TARGET_PARALLEL_DO
:
1643 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
1644 case EXEC_OMP_TARGET_SIMD
:
1645 case EXEC_OMP_TARGET_TEAMS
:
1646 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1647 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1648 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1649 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1650 case EXEC_OMP_TARGET_UPDATE
:
1652 case EXEC_OMP_TASKLOOP
:
1653 case EXEC_OMP_TASKLOOP_SIMD
:
1654 case EXEC_OMP_TEAMS
:
1655 case EXEC_OMP_TEAMS_DISTRIBUTE
:
1656 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1657 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1658 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
1659 case EXEC_OMP_WORKSHARE
:
1660 omp_clauses
= c
->ext
.omp_clauses
;
1662 case EXEC_OMP_CRITICAL
:
1663 omp_clauses
= c
->ext
.omp_clauses
;
1665 fprintf (dumpfile
, " (%s)", c
->ext
.omp_clauses
->critical_name
);
1667 case EXEC_OMP_FLUSH
:
1668 if (c
->ext
.omp_namelist
)
1670 fputs (" (", dumpfile
);
1671 show_omp_namelist (OMP_LIST_NUM
, c
->ext
.omp_namelist
);
1672 fputc (')', dumpfile
);
1675 case EXEC_OMP_BARRIER
:
1676 case EXEC_OMP_TASKWAIT
:
1677 case EXEC_OMP_TASKYIELD
:
1683 show_omp_clauses (omp_clauses
);
1684 fputc ('\n', dumpfile
);
1686 /* OpenMP and OpenACC executable directives don't have associated blocks. */
1687 if (c
->op
== EXEC_OACC_CACHE
|| c
->op
== EXEC_OACC_UPDATE
1688 || c
->op
== EXEC_OACC_ENTER_DATA
|| c
->op
== EXEC_OACC_EXIT_DATA
1689 || c
->op
== EXEC_OMP_TARGET_UPDATE
|| c
->op
== EXEC_OMP_TARGET_ENTER_DATA
1690 || c
->op
== EXEC_OMP_TARGET_EXIT_DATA
1691 || (c
->op
== EXEC_OMP_ORDERED
&& c
->block
== NULL
))
1693 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
1695 gfc_code
*d
= c
->block
;
1698 show_code (level
+ 1, d
->next
);
1699 if (d
->block
== NULL
)
1701 code_indent (level
, 0);
1702 fputs ("!$OMP SECTION\n", dumpfile
);
1707 show_code (level
+ 1, c
->block
->next
);
1708 if (c
->op
== EXEC_OMP_ATOMIC
)
1710 fputc ('\n', dumpfile
);
1711 code_indent (level
, 0);
1712 fprintf (dumpfile
, "!$%s END %s", is_oacc
? "ACC" : "OMP", name
);
1713 if (omp_clauses
!= NULL
)
1715 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
1717 fputs (" COPYPRIVATE(", dumpfile
);
1718 show_omp_namelist (OMP_LIST_COPYPRIVATE
,
1719 omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1720 fputc (')', dumpfile
);
1722 else if (omp_clauses
->nowait
)
1723 fputs (" NOWAIT", dumpfile
);
1725 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_clauses
)
1726 fprintf (dumpfile
, " (%s)", c
->ext
.omp_clauses
->critical_name
);
1730 /* Show a single code node and everything underneath it if necessary. */
1733 show_code_node (int level
, gfc_code
*c
)
1735 gfc_forall_iterator
*fa
;
1748 fputc ('\n', dumpfile
);
1749 code_indent (level
, c
->here
);
1756 case EXEC_END_PROCEDURE
:
1760 fputs ("NOP", dumpfile
);
1764 fputs ("CONTINUE", dumpfile
);
1768 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
1771 case EXEC_INIT_ASSIGN
:
1773 fputs ("ASSIGN ", dumpfile
);
1774 show_expr (c
->expr1
);
1775 fputc (' ', dumpfile
);
1776 show_expr (c
->expr2
);
1779 case EXEC_LABEL_ASSIGN
:
1780 fputs ("LABEL ASSIGN ", dumpfile
);
1781 show_expr (c
->expr1
);
1782 fprintf (dumpfile
, " %d", c
->label1
->value
);
1785 case EXEC_POINTER_ASSIGN
:
1786 fputs ("POINTER ASSIGN ", dumpfile
);
1787 show_expr (c
->expr1
);
1788 fputc (' ', dumpfile
);
1789 show_expr (c
->expr2
);
1793 fputs ("GOTO ", dumpfile
);
1795 fprintf (dumpfile
, "%d", c
->label1
->value
);
1798 show_expr (c
->expr1
);
1802 fputs (", (", dumpfile
);
1803 for (; d
; d
= d
->block
)
1805 code_indent (level
, d
->label1
);
1806 if (d
->block
!= NULL
)
1807 fputc (',', dumpfile
);
1809 fputc (')', dumpfile
);
1816 case EXEC_ASSIGN_CALL
:
1817 if (c
->resolved_sym
)
1818 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
1819 else if (c
->symtree
)
1820 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
1822 fputs ("CALL ?? ", dumpfile
);
1824 show_actual_arglist (c
->ext
.actual
);
1828 fputs ("CALL ", dumpfile
);
1829 show_compcall (c
->expr1
);
1833 fputs ("CALL ", dumpfile
);
1834 show_expr (c
->expr1
);
1835 show_actual_arglist (c
->ext
.actual
);
1839 fputs ("RETURN ", dumpfile
);
1841 show_expr (c
->expr1
);
1845 fputs ("PAUSE ", dumpfile
);
1847 if (c
->expr1
!= NULL
)
1848 show_expr (c
->expr1
);
1850 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1854 case EXEC_ERROR_STOP
:
1855 fputs ("ERROR ", dumpfile
);
1859 fputs ("STOP ", dumpfile
);
1861 if (c
->expr1
!= NULL
)
1862 show_expr (c
->expr1
);
1864 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1868 case EXEC_FAIL_IMAGE
:
1869 fputs ("FAIL IMAGE ", dumpfile
);
1873 fputs ("SYNC ALL ", dumpfile
);
1874 if (c
->expr2
!= NULL
)
1876 fputs (" stat=", dumpfile
);
1877 show_expr (c
->expr2
);
1879 if (c
->expr3
!= NULL
)
1881 fputs (" errmsg=", dumpfile
);
1882 show_expr (c
->expr3
);
1886 case EXEC_SYNC_MEMORY
:
1887 fputs ("SYNC MEMORY ", dumpfile
);
1888 if (c
->expr2
!= NULL
)
1890 fputs (" stat=", dumpfile
);
1891 show_expr (c
->expr2
);
1893 if (c
->expr3
!= NULL
)
1895 fputs (" errmsg=", dumpfile
);
1896 show_expr (c
->expr3
);
1900 case EXEC_SYNC_IMAGES
:
1901 fputs ("SYNC IMAGES image-set=", dumpfile
);
1902 if (c
->expr1
!= NULL
)
1903 show_expr (c
->expr1
);
1905 fputs ("* ", dumpfile
);
1906 if (c
->expr2
!= NULL
)
1908 fputs (" stat=", dumpfile
);
1909 show_expr (c
->expr2
);
1911 if (c
->expr3
!= NULL
)
1913 fputs (" errmsg=", dumpfile
);
1914 show_expr (c
->expr3
);
1918 case EXEC_EVENT_POST
:
1919 case EXEC_EVENT_WAIT
:
1920 if (c
->op
== EXEC_EVENT_POST
)
1921 fputs ("EVENT POST ", dumpfile
);
1923 fputs ("EVENT WAIT ", dumpfile
);
1925 fputs ("event-variable=", dumpfile
);
1926 if (c
->expr1
!= NULL
)
1927 show_expr (c
->expr1
);
1928 if (c
->expr4
!= NULL
)
1930 fputs (" until_count=", dumpfile
);
1931 show_expr (c
->expr4
);
1933 if (c
->expr2
!= NULL
)
1935 fputs (" stat=", dumpfile
);
1936 show_expr (c
->expr2
);
1938 if (c
->expr3
!= NULL
)
1940 fputs (" errmsg=", dumpfile
);
1941 show_expr (c
->expr3
);
1947 if (c
->op
== EXEC_LOCK
)
1948 fputs ("LOCK ", dumpfile
);
1950 fputs ("UNLOCK ", dumpfile
);
1952 fputs ("lock-variable=", dumpfile
);
1953 if (c
->expr1
!= NULL
)
1954 show_expr (c
->expr1
);
1955 if (c
->expr4
!= NULL
)
1957 fputs (" acquired_lock=", dumpfile
);
1958 show_expr (c
->expr4
);
1960 if (c
->expr2
!= NULL
)
1962 fputs (" stat=", dumpfile
);
1963 show_expr (c
->expr2
);
1965 if (c
->expr3
!= NULL
)
1967 fputs (" errmsg=", dumpfile
);
1968 show_expr (c
->expr3
);
1972 case EXEC_ARITHMETIC_IF
:
1973 fputs ("IF ", dumpfile
);
1974 show_expr (c
->expr1
);
1975 fprintf (dumpfile
, " %d, %d, %d",
1976 c
->label1
->value
, c
->label2
->value
, c
->label3
->value
);
1981 fputs ("IF ", dumpfile
);
1982 show_expr (d
->expr1
);
1985 show_code (level
+ 1, d
->next
);
1989 for (; d
; d
= d
->block
)
1991 fputs("\n", dumpfile
);
1992 code_indent (level
, 0);
1993 if (d
->expr1
== NULL
)
1994 fputs ("ELSE", dumpfile
);
1997 fputs ("ELSE IF ", dumpfile
);
1998 show_expr (d
->expr1
);
2002 show_code (level
+ 1, d
->next
);
2007 code_indent (level
, c
->label1
);
2011 fputs ("ENDIF", dumpfile
);
2016 const char* blocktype
;
2017 gfc_namespace
*saved_ns
;
2018 gfc_association_list
*alist
;
2020 if (c
->ext
.block
.assoc
)
2021 blocktype
= "ASSOCIATE";
2023 blocktype
= "BLOCK";
2025 fprintf (dumpfile
, "%s ", blocktype
);
2026 for (alist
= c
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
2028 fprintf (dumpfile
, " %s = ", alist
->name
);
2029 show_expr (alist
->target
);
2033 ns
= c
->ext
.block
.ns
;
2034 saved_ns
= gfc_current_ns
;
2035 gfc_current_ns
= ns
;
2036 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2037 gfc_current_ns
= saved_ns
;
2038 show_code (show_level
, ns
->code
);
2041 fprintf (dumpfile
, "END %s ", blocktype
);
2045 case EXEC_END_BLOCK
:
2046 /* Only come here when there is a label on an
2047 END ASSOCIATE construct. */
2051 case EXEC_SELECT_TYPE
:
2053 if (c
->op
== EXEC_SELECT_TYPE
)
2054 fputs ("SELECT TYPE ", dumpfile
);
2056 fputs ("SELECT CASE ", dumpfile
);
2057 show_expr (c
->expr1
);
2058 fputc ('\n', dumpfile
);
2060 for (; d
; d
= d
->block
)
2062 code_indent (level
, 0);
2064 fputs ("CASE ", dumpfile
);
2065 for (cp
= d
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2067 fputc ('(', dumpfile
);
2068 show_expr (cp
->low
);
2069 fputc (' ', dumpfile
);
2070 show_expr (cp
->high
);
2071 fputc (')', dumpfile
);
2072 fputc (' ', dumpfile
);
2074 fputc ('\n', dumpfile
);
2076 show_code (level
+ 1, d
->next
);
2079 code_indent (level
, c
->label1
);
2080 fputs ("END SELECT", dumpfile
);
2084 fputs ("WHERE ", dumpfile
);
2087 show_expr (d
->expr1
);
2088 fputc ('\n', dumpfile
);
2090 show_code (level
+ 1, d
->next
);
2092 for (d
= d
->block
; d
; d
= d
->block
)
2094 code_indent (level
, 0);
2095 fputs ("ELSE WHERE ", dumpfile
);
2096 show_expr (d
->expr1
);
2097 fputc ('\n', dumpfile
);
2098 show_code (level
+ 1, d
->next
);
2101 code_indent (level
, 0);
2102 fputs ("END WHERE", dumpfile
);
2107 fputs ("FORALL ", dumpfile
);
2108 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2110 show_expr (fa
->var
);
2111 fputc (' ', dumpfile
);
2112 show_expr (fa
->start
);
2113 fputc (':', dumpfile
);
2114 show_expr (fa
->end
);
2115 fputc (':', dumpfile
);
2116 show_expr (fa
->stride
);
2118 if (fa
->next
!= NULL
)
2119 fputc (',', dumpfile
);
2122 if (c
->expr1
!= NULL
)
2124 fputc (',', dumpfile
);
2125 show_expr (c
->expr1
);
2127 fputc ('\n', dumpfile
);
2129 show_code (level
+ 1, c
->block
->next
);
2131 code_indent (level
, 0);
2132 fputs ("END FORALL", dumpfile
);
2136 fputs ("CRITICAL\n", dumpfile
);
2137 show_code (level
+ 1, c
->block
->next
);
2138 code_indent (level
, 0);
2139 fputs ("END CRITICAL", dumpfile
);
2143 fputs ("DO ", dumpfile
);
2145 fprintf (dumpfile
, " %-5d ", c
->label1
->value
);
2147 show_expr (c
->ext
.iterator
->var
);
2148 fputc ('=', dumpfile
);
2149 show_expr (c
->ext
.iterator
->start
);
2150 fputc (' ', dumpfile
);
2151 show_expr (c
->ext
.iterator
->end
);
2152 fputc (' ', dumpfile
);
2153 show_expr (c
->ext
.iterator
->step
);
2156 show_code (level
+ 1, c
->block
->next
);
2163 fputs ("END DO", dumpfile
);
2166 case EXEC_DO_CONCURRENT
:
2167 fputs ("DO CONCURRENT ", dumpfile
);
2168 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2170 show_expr (fa
->var
);
2171 fputc (' ', dumpfile
);
2172 show_expr (fa
->start
);
2173 fputc (':', dumpfile
);
2174 show_expr (fa
->end
);
2175 fputc (':', dumpfile
);
2176 show_expr (fa
->stride
);
2178 if (fa
->next
!= NULL
)
2179 fputc (',', dumpfile
);
2181 show_expr (c
->expr1
);
2184 show_code (level
+ 1, c
->block
->next
);
2186 code_indent (level
, c
->label1
);
2188 fputs ("END DO", dumpfile
);
2192 fputs ("DO WHILE ", dumpfile
);
2193 show_expr (c
->expr1
);
2194 fputc ('\n', dumpfile
);
2196 show_code (level
+ 1, c
->block
->next
);
2198 code_indent (level
, c
->label1
);
2199 fputs ("END DO", dumpfile
);
2203 fputs ("CYCLE", dumpfile
);
2205 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
2209 fputs ("EXIT", dumpfile
);
2211 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
2215 fputs ("ALLOCATE ", dumpfile
);
2218 fputs (" STAT=", dumpfile
);
2219 show_expr (c
->expr1
);
2224 fputs (" ERRMSG=", dumpfile
);
2225 show_expr (c
->expr2
);
2231 fputs (" MOLD=", dumpfile
);
2233 fputs (" SOURCE=", dumpfile
);
2234 show_expr (c
->expr3
);
2237 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
2239 fputc (' ', dumpfile
);
2240 show_expr (a
->expr
);
2245 case EXEC_DEALLOCATE
:
2246 fputs ("DEALLOCATE ", dumpfile
);
2249 fputs (" STAT=", dumpfile
);
2250 show_expr (c
->expr1
);
2255 fputs (" ERRMSG=", dumpfile
);
2256 show_expr (c
->expr2
);
2259 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
2261 fputc (' ', dumpfile
);
2262 show_expr (a
->expr
);
2268 fputs ("OPEN", dumpfile
);
2273 fputs (" UNIT=", dumpfile
);
2274 show_expr (open
->unit
);
2278 fputs (" IOMSG=", dumpfile
);
2279 show_expr (open
->iomsg
);
2283 fputs (" IOSTAT=", dumpfile
);
2284 show_expr (open
->iostat
);
2288 fputs (" FILE=", dumpfile
);
2289 show_expr (open
->file
);
2293 fputs (" STATUS=", dumpfile
);
2294 show_expr (open
->status
);
2298 fputs (" ACCESS=", dumpfile
);
2299 show_expr (open
->access
);
2303 fputs (" FORM=", dumpfile
);
2304 show_expr (open
->form
);
2308 fputs (" RECL=", dumpfile
);
2309 show_expr (open
->recl
);
2313 fputs (" BLANK=", dumpfile
);
2314 show_expr (open
->blank
);
2318 fputs (" POSITION=", dumpfile
);
2319 show_expr (open
->position
);
2323 fputs (" ACTION=", dumpfile
);
2324 show_expr (open
->action
);
2328 fputs (" DELIM=", dumpfile
);
2329 show_expr (open
->delim
);
2333 fputs (" PAD=", dumpfile
);
2334 show_expr (open
->pad
);
2338 fputs (" DECIMAL=", dumpfile
);
2339 show_expr (open
->decimal
);
2343 fputs (" ENCODING=", dumpfile
);
2344 show_expr (open
->encoding
);
2348 fputs (" ROUND=", dumpfile
);
2349 show_expr (open
->round
);
2353 fputs (" SIGN=", dumpfile
);
2354 show_expr (open
->sign
);
2358 fputs (" CONVERT=", dumpfile
);
2359 show_expr (open
->convert
);
2361 if (open
->asynchronous
)
2363 fputs (" ASYNCHRONOUS=", dumpfile
);
2364 show_expr (open
->asynchronous
);
2366 if (open
->err
!= NULL
)
2367 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
2372 fputs ("CLOSE", dumpfile
);
2373 close
= c
->ext
.close
;
2377 fputs (" UNIT=", dumpfile
);
2378 show_expr (close
->unit
);
2382 fputs (" IOMSG=", dumpfile
);
2383 show_expr (close
->iomsg
);
2387 fputs (" IOSTAT=", dumpfile
);
2388 show_expr (close
->iostat
);
2392 fputs (" STATUS=", dumpfile
);
2393 show_expr (close
->status
);
2395 if (close
->err
!= NULL
)
2396 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
2399 case EXEC_BACKSPACE
:
2400 fputs ("BACKSPACE", dumpfile
);
2404 fputs ("ENDFILE", dumpfile
);
2408 fputs ("REWIND", dumpfile
);
2412 fputs ("FLUSH", dumpfile
);
2415 fp
= c
->ext
.filepos
;
2419 fputs (" UNIT=", dumpfile
);
2420 show_expr (fp
->unit
);
2424 fputs (" IOMSG=", dumpfile
);
2425 show_expr (fp
->iomsg
);
2429 fputs (" IOSTAT=", dumpfile
);
2430 show_expr (fp
->iostat
);
2432 if (fp
->err
!= NULL
)
2433 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
2437 fputs ("INQUIRE", dumpfile
);
2442 fputs (" UNIT=", dumpfile
);
2443 show_expr (i
->unit
);
2447 fputs (" FILE=", dumpfile
);
2448 show_expr (i
->file
);
2453 fputs (" IOMSG=", dumpfile
);
2454 show_expr (i
->iomsg
);
2458 fputs (" IOSTAT=", dumpfile
);
2459 show_expr (i
->iostat
);
2463 fputs (" EXIST=", dumpfile
);
2464 show_expr (i
->exist
);
2468 fputs (" OPENED=", dumpfile
);
2469 show_expr (i
->opened
);
2473 fputs (" NUMBER=", dumpfile
);
2474 show_expr (i
->number
);
2478 fputs (" NAMED=", dumpfile
);
2479 show_expr (i
->named
);
2483 fputs (" NAME=", dumpfile
);
2484 show_expr (i
->name
);
2488 fputs (" ACCESS=", dumpfile
);
2489 show_expr (i
->access
);
2493 fputs (" SEQUENTIAL=", dumpfile
);
2494 show_expr (i
->sequential
);
2499 fputs (" DIRECT=", dumpfile
);
2500 show_expr (i
->direct
);
2504 fputs (" FORM=", dumpfile
);
2505 show_expr (i
->form
);
2509 fputs (" FORMATTED", dumpfile
);
2510 show_expr (i
->formatted
);
2514 fputs (" UNFORMATTED=", dumpfile
);
2515 show_expr (i
->unformatted
);
2519 fputs (" RECL=", dumpfile
);
2520 show_expr (i
->recl
);
2524 fputs (" NEXTREC=", dumpfile
);
2525 show_expr (i
->nextrec
);
2529 fputs (" BLANK=", dumpfile
);
2530 show_expr (i
->blank
);
2534 fputs (" POSITION=", dumpfile
);
2535 show_expr (i
->position
);
2539 fputs (" ACTION=", dumpfile
);
2540 show_expr (i
->action
);
2544 fputs (" READ=", dumpfile
);
2545 show_expr (i
->read
);
2549 fputs (" WRITE=", dumpfile
);
2550 show_expr (i
->write
);
2554 fputs (" READWRITE=", dumpfile
);
2555 show_expr (i
->readwrite
);
2559 fputs (" DELIM=", dumpfile
);
2560 show_expr (i
->delim
);
2564 fputs (" PAD=", dumpfile
);
2569 fputs (" CONVERT=", dumpfile
);
2570 show_expr (i
->convert
);
2572 if (i
->asynchronous
)
2574 fputs (" ASYNCHRONOUS=", dumpfile
);
2575 show_expr (i
->asynchronous
);
2579 fputs (" DECIMAL=", dumpfile
);
2580 show_expr (i
->decimal
);
2584 fputs (" ENCODING=", dumpfile
);
2585 show_expr (i
->encoding
);
2589 fputs (" PENDING=", dumpfile
);
2590 show_expr (i
->pending
);
2594 fputs (" ROUND=", dumpfile
);
2595 show_expr (i
->round
);
2599 fputs (" SIGN=", dumpfile
);
2600 show_expr (i
->sign
);
2604 fputs (" SIZE=", dumpfile
);
2605 show_expr (i
->size
);
2609 fputs (" ID=", dumpfile
);
2614 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
2618 fputs ("IOLENGTH ", dumpfile
);
2619 show_expr (c
->expr1
);
2624 fputs ("READ", dumpfile
);
2628 fputs ("WRITE", dumpfile
);
2634 fputs (" UNIT=", dumpfile
);
2635 show_expr (dt
->io_unit
);
2638 if (dt
->format_expr
)
2640 fputs (" FMT=", dumpfile
);
2641 show_expr (dt
->format_expr
);
2644 if (dt
->format_label
!= NULL
)
2645 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
2647 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
2651 fputs (" IOMSG=", dumpfile
);
2652 show_expr (dt
->iomsg
);
2656 fputs (" IOSTAT=", dumpfile
);
2657 show_expr (dt
->iostat
);
2661 fputs (" SIZE=", dumpfile
);
2662 show_expr (dt
->size
);
2666 fputs (" REC=", dumpfile
);
2667 show_expr (dt
->rec
);
2671 fputs (" ADVANCE=", dumpfile
);
2672 show_expr (dt
->advance
);
2676 fputs (" ID=", dumpfile
);
2681 fputs (" POS=", dumpfile
);
2682 show_expr (dt
->pos
);
2684 if (dt
->asynchronous
)
2686 fputs (" ASYNCHRONOUS=", dumpfile
);
2687 show_expr (dt
->asynchronous
);
2691 fputs (" BLANK=", dumpfile
);
2692 show_expr (dt
->blank
);
2696 fputs (" DECIMAL=", dumpfile
);
2697 show_expr (dt
->decimal
);
2701 fputs (" DELIM=", dumpfile
);
2702 show_expr (dt
->delim
);
2706 fputs (" PAD=", dumpfile
);
2707 show_expr (dt
->pad
);
2711 fputs (" ROUND=", dumpfile
);
2712 show_expr (dt
->round
);
2716 fputs (" SIGN=", dumpfile
);
2717 show_expr (dt
->sign
);
2721 for (c
= c
->block
->next
; c
; c
= c
->next
)
2722 show_code_node (level
+ (c
->next
!= NULL
), c
);
2726 fputs ("TRANSFER ", dumpfile
);
2727 show_expr (c
->expr1
);
2731 fputs ("DT_END", dumpfile
);
2734 if (dt
->err
!= NULL
)
2735 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
2736 if (dt
->end
!= NULL
)
2737 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
2738 if (dt
->eor
!= NULL
)
2739 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
2743 fputs ("WAIT", dumpfile
);
2745 if (c
->ext
.wait
!= NULL
)
2747 gfc_wait
*wait
= c
->ext
.wait
;
2750 fputs (" UNIT=", dumpfile
);
2751 show_expr (wait
->unit
);
2755 fputs (" IOSTAT=", dumpfile
);
2756 show_expr (wait
->iostat
);
2760 fputs (" IOMSG=", dumpfile
);
2761 show_expr (wait
->iomsg
);
2765 fputs (" ID=", dumpfile
);
2766 show_expr (wait
->id
);
2769 fprintf (dumpfile
, " ERR=%d", wait
->err
->value
);
2771 fprintf (dumpfile
, " END=%d", wait
->end
->value
);
2773 fprintf (dumpfile
, " EOR=%d", wait
->eor
->value
);
2777 case EXEC_OACC_PARALLEL_LOOP
:
2778 case EXEC_OACC_PARALLEL
:
2779 case EXEC_OACC_KERNELS_LOOP
:
2780 case EXEC_OACC_KERNELS
:
2781 case EXEC_OACC_DATA
:
2782 case EXEC_OACC_HOST_DATA
:
2783 case EXEC_OACC_LOOP
:
2784 case EXEC_OACC_UPDATE
:
2785 case EXEC_OACC_WAIT
:
2786 case EXEC_OACC_CACHE
:
2787 case EXEC_OACC_ENTER_DATA
:
2788 case EXEC_OACC_EXIT_DATA
:
2789 case EXEC_OMP_ATOMIC
:
2790 case EXEC_OMP_CANCEL
:
2791 case EXEC_OMP_CANCELLATION_POINT
:
2792 case EXEC_OMP_BARRIER
:
2793 case EXEC_OMP_CRITICAL
:
2794 case EXEC_OMP_DISTRIBUTE
:
2795 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
2796 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2797 case EXEC_OMP_DISTRIBUTE_SIMD
:
2799 case EXEC_OMP_DO_SIMD
:
2800 case EXEC_OMP_FLUSH
:
2801 case EXEC_OMP_MASTER
:
2802 case EXEC_OMP_ORDERED
:
2803 case EXEC_OMP_PARALLEL
:
2804 case EXEC_OMP_PARALLEL_DO
:
2805 case EXEC_OMP_PARALLEL_DO_SIMD
:
2806 case EXEC_OMP_PARALLEL_SECTIONS
:
2807 case EXEC_OMP_PARALLEL_WORKSHARE
:
2808 case EXEC_OMP_SECTIONS
:
2810 case EXEC_OMP_SINGLE
:
2811 case EXEC_OMP_TARGET
:
2812 case EXEC_OMP_TARGET_DATA
:
2813 case EXEC_OMP_TARGET_ENTER_DATA
:
2814 case EXEC_OMP_TARGET_EXIT_DATA
:
2815 case EXEC_OMP_TARGET_PARALLEL
:
2816 case EXEC_OMP_TARGET_PARALLEL_DO
:
2817 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
2818 case EXEC_OMP_TARGET_SIMD
:
2819 case EXEC_OMP_TARGET_TEAMS
:
2820 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
2821 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2822 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2823 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2824 case EXEC_OMP_TARGET_UPDATE
:
2826 case EXEC_OMP_TASKGROUP
:
2827 case EXEC_OMP_TASKLOOP
:
2828 case EXEC_OMP_TASKLOOP_SIMD
:
2829 case EXEC_OMP_TASKWAIT
:
2830 case EXEC_OMP_TASKYIELD
:
2831 case EXEC_OMP_TEAMS
:
2832 case EXEC_OMP_TEAMS_DISTRIBUTE
:
2833 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2834 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2835 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
2836 case EXEC_OMP_WORKSHARE
:
2837 show_omp_node (level
, c
);
2841 gfc_internal_error ("show_code_node(): Bad statement code");
2846 /* Show an equivalence chain. */
2849 show_equiv (gfc_equiv
*eq
)
2852 fputs ("Equivalence: ", dumpfile
);
2855 show_expr (eq
->expr
);
2858 fputs (", ", dumpfile
);
2863 /* Show a freakin' whole namespace. */
2866 show_namespace (gfc_namespace
*ns
)
2868 gfc_interface
*intr
;
2869 gfc_namespace
*save
;
2875 save
= gfc_current_ns
;
2878 fputs ("Namespace:", dumpfile
);
2884 while (i
< GFC_LETTERS
- 1
2885 && gfc_compare_types (&ns
->default_type
[i
+1],
2886 &ns
->default_type
[l
]))
2890 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
2892 fprintf (dumpfile
, " %c: ", l
+'A');
2894 show_typespec(&ns
->default_type
[l
]);
2896 } while (i
< GFC_LETTERS
);
2898 if (ns
->proc_name
!= NULL
)
2901 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
2905 gfc_current_ns
= ns
;
2906 gfc_traverse_symtree (ns
->common_root
, show_common
);
2908 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2910 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
2912 /* User operator interfaces */
2918 fprintf (dumpfile
, "Operator interfaces for %s:",
2919 gfc_op2string ((gfc_intrinsic_op
) op
));
2921 for (; intr
; intr
= intr
->next
)
2922 fprintf (dumpfile
, " %s", intr
->sym
->name
);
2925 if (ns
->uop_root
!= NULL
)
2928 fputs ("User operators:\n", dumpfile
);
2929 gfc_traverse_user_op (ns
, show_uop
);
2932 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
2935 if (ns
->oacc_declare
)
2937 struct gfc_oacc_declare
*decl
;
2938 /* Dump !$ACC DECLARE clauses. */
2939 for (decl
= ns
->oacc_declare
; decl
; decl
= decl
->next
)
2942 fprintf (dumpfile
, "!$ACC DECLARE");
2943 show_omp_clauses (decl
->clauses
);
2947 fputc ('\n', dumpfile
);
2949 fputs ("code:", dumpfile
);
2950 show_code (show_level
, ns
->code
);
2953 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
2955 fputs ("\nCONTAINS\n", dumpfile
);
2957 show_namespace (ns
);
2961 fputc ('\n', dumpfile
);
2962 gfc_current_ns
= save
;
2966 /* Main function for dumping a parse tree. */
2969 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
2972 show_namespace (ns
);
2975 /* This part writes BIND(C) definition for use in external C programs. */
2977 static void write_interop_decl (gfc_symbol
*);
2980 gfc_dump_c_prototypes (gfc_namespace
*ns
, FILE *file
)
2983 gfc_get_errors (NULL
, &error_count
);
2984 if (error_count
!= 0)
2987 gfc_traverse_ns (ns
, write_interop_decl
);
2990 enum type_return
{ T_OK
=0, T_WARN
, T_ERROR
};
2992 /* Return the name of the type for later output. Both function pointers and
2993 void pointers will be mapped to void *. */
2995 static enum type_return
2996 get_c_type_name (gfc_typespec
*ts
, gfc_array_spec
*as
, const char **pre
,
2997 const char **type_name
, bool *asterisk
, const char **post
,
3000 static char post_buffer
[40];
3001 enum type_return ret
;
3007 *type_name
= "<error>";
3008 if (ts
->type
== BT_REAL
|| ts
->type
== BT_INTEGER
)
3011 if (ts
->is_c_interop
&& ts
->interop_kind
)
3013 *type_name
= ts
->interop_kind
->name
+ 2;
3014 if (strcmp (*type_name
, "signed_char") == 0)
3015 *type_name
= "signed char";
3016 else if (strcmp (*type_name
, "size_t") == 0)
3017 *type_name
= "ssize_t";
3023 /* The user did not specify a C interop type. Let's look through
3024 the available table and use the first one, but warn. */
3026 for (i
=0; i
<ISOCBINDING_NUMBER
; i
++)
3028 if (c_interop_kinds_table
[i
].f90_type
== ts
->type
3029 && c_interop_kinds_table
[i
].value
== ts
->kind
)
3031 *type_name
= c_interop_kinds_table
[i
].name
+ 2;
3032 if (strcmp (*type_name
, "signed_char") == 0)
3033 *type_name
= "signed char";
3034 else if (strcmp (*type_name
, "size_t") == 0)
3035 *type_name
= "ssize_t";
3043 else if (ts
->type
== BT_DERIVED
)
3045 if (ts
->u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
)
3047 if (strcmp (ts
->u
.derived
->name
, "c_ptr") == 0)
3048 *type_name
= "void";
3049 else if (strcmp (ts
->u
.derived
->name
, "c_funptr") == 0)
3051 *type_name
= "int ";
3066 *type_name
= ts
->u
.derived
->name
;
3070 if (ret
!= T_ERROR
&& as
)
3074 size_ok
= spec_size (as
, &sz
);
3075 gcc_assert (size_ok
== true);
3076 gmp_snprintf (post_buffer
, sizeof(post_buffer
), "[%Zd]", sz
);
3077 *post
= post_buffer
;
3083 /* Write out a declaration. */
3085 write_decl (gfc_typespec
*ts
, gfc_array_spec
*as
, const char *sym_name
,
3088 const char *pre
, *type_name
, *post
;
3090 enum type_return rok
;
3092 rok
= get_c_type_name (ts
, as
, &pre
, &type_name
, &asterisk
, &post
, func_ret
);
3093 gcc_assert (rok
!= T_ERROR
);
3094 fputs (type_name
, dumpfile
);
3095 fputs (pre
, dumpfile
);
3097 fputs ("*", dumpfile
);
3099 fputs (sym_name
, dumpfile
);
3100 fputs (post
, dumpfile
);
3103 fputs(" /* WARNING: non-interoperable KIND */", dumpfile
);
3106 /* Write out an interoperable type. It will be written as a typedef
3110 write_type (gfc_symbol
*sym
)
3114 fprintf (dumpfile
, "typedef struct %s {\n", sym
->name
);
3115 for (c
= sym
->components
; c
; c
= c
->next
)
3117 fputs (" ", dumpfile
);
3118 write_decl (&(c
->ts
), c
->as
, c
->name
, false);
3119 fputs (";\n", dumpfile
);
3122 fprintf (dumpfile
, "} %s;\n", sym
->name
);
3125 /* Write out a variable. */
3128 write_variable (gfc_symbol
*sym
)
3130 const char *sym_name
;
3132 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
3134 if (sym
->binding_label
)
3135 sym_name
= sym
->binding_label
;
3137 sym_name
= sym
->name
;
3139 fputs ("extern ", dumpfile
);
3140 write_decl (&(sym
->ts
), sym
->as
, sym_name
, false);
3141 fputs (";\n", dumpfile
);
3145 /* Write out a procedure, including its arguments. */
3147 write_proc (gfc_symbol
*sym
)
3149 const char *pre
, *type_name
, *post
;
3151 enum type_return rok
;
3152 gfc_formal_arglist
*f
;
3153 const char *sym_name
;
3154 const char *intent_in
;
3156 if (sym
->binding_label
)
3157 sym_name
= sym
->binding_label
;
3159 sym_name
= sym
->name
;
3161 if (sym
->ts
.type
== BT_UNKNOWN
)
3163 fprintf (dumpfile
, "void ");
3164 fputs (sym_name
, dumpfile
);
3167 write_decl (&(sym
->ts
), sym
->as
, sym
->name
, true);
3169 fputs (" (", dumpfile
);
3171 for (f
= sym
->formal
; f
; f
= f
->next
)
3175 rok
= get_c_type_name (&(s
->ts
), NULL
, &pre
, &type_name
, &asterisk
,
3177 gcc_assert (rok
!= T_ERROR
);
3182 if (s
->attr
.intent
== INTENT_IN
&& !s
->attr
.value
)
3183 intent_in
= "const ";
3187 fputs (intent_in
, dumpfile
);
3188 fputs (type_name
, dumpfile
);
3189 fputs (pre
, dumpfile
);
3191 fputs ("*", dumpfile
);
3193 fputs (s
->name
, dumpfile
);
3194 fputs (post
, dumpfile
);
3196 fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile
);
3198 fputs (f
->next
? ", " : ")", dumpfile
);
3200 fputs (";\n", dumpfile
);
3204 /* Write a C-interoperable declaration as a C prototype or extern
3208 write_interop_decl (gfc_symbol
*sym
)
3210 /* Only dump bind(c) entities. */
3211 if (!sym
->attr
.is_bind_c
)
3214 /* Don't dump our iso c module. */
3215 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
3218 if (sym
->attr
.flavor
== FL_VARIABLE
)
3219 write_variable (sym
);
3220 else if (sym
->attr
.flavor
== FL_DERIVED
)
3222 else if (sym
->attr
.flavor
== FL_PROCEDURE
)