2 Copyright (C) 2003-2015 Free Software Foundation, Inc.
3 Contributed by Steven Bosscher
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Actually this is just a collection of routines that used to be
23 scattered around the sources. Now that they are all in a single
24 file, almost all of them can be static, and the other files don't
25 have this mess in them.
27 As a nice side-effect, this file can act as documentation of the
28 gfc_code and gfc_expr structures and all their friends and
35 #include "coretypes.h"
37 #include "constructor.h"
39 /* Keep track of indentation for symbol tree dumps. */
40 static int show_level
= 0;
42 /* The file handle we're dumping to is kept in a static variable. This
43 is not too cool, but it avoids a lot of passing it around. */
44 static FILE *dumpfile
;
46 /* Forward declaration of some of the functions. */
47 static void show_expr (gfc_expr
*p
);
48 static void show_code_node (int, gfc_code
*);
49 static void show_namespace (gfc_namespace
*ns
);
52 /* Allow dumping of an expression in the debugger. */
53 void gfc_debug_expr (gfc_expr
*);
56 gfc_debug_expr (gfc_expr
*e
)
61 fputc ('\n', dumpfile
);
66 /* Do indentation for a specific level. */
69 code_indent (int level
, gfc_st_label
*label
)
74 fprintf (dumpfile
, "%-5d ", label
->value
);
76 for (i
= 0; i
< (2 * level
- (label
? 6 : 0)); i
++)
77 fputc (' ', dumpfile
);
81 /* Simple indentation at the current level. This one
82 is used to show symbols. */
87 fputc ('\n', dumpfile
);
88 code_indent (show_level
, NULL
);
92 /* Show type-specific information. */
95 show_typespec (gfc_typespec
*ts
)
97 if (ts
->type
== BT_ASSUMED
)
99 fputs ("(TYPE(*))", dumpfile
);
103 fprintf (dumpfile
, "(%s ", gfc_basic_typename (ts
->type
));
109 fprintf (dumpfile
, "%s", ts
->u
.derived
->name
);
114 show_expr (ts
->u
.cl
->length
);
115 fprintf(dumpfile
, " %d", ts
->kind
);
119 fprintf (dumpfile
, "%d", ts
->kind
);
123 fputc (')', dumpfile
);
127 /* Show an actual argument list. */
130 show_actual_arglist (gfc_actual_arglist
*a
)
132 fputc ('(', dumpfile
);
134 for (; a
; a
= a
->next
)
136 fputc ('(', dumpfile
);
138 fprintf (dumpfile
, "%s = ", a
->name
);
142 fputs ("(arg not-present)", dumpfile
);
144 fputc (')', dumpfile
);
146 fputc (' ', dumpfile
);
149 fputc (')', dumpfile
);
153 /* Show a gfc_array_spec array specification structure. */
156 show_array_spec (gfc_array_spec
*as
)
163 fputs ("()", dumpfile
);
167 fprintf (dumpfile
, "(%d [%d]", as
->rank
, as
->corank
);
169 if (as
->rank
+ as
->corank
> 0 || as
->rank
== -1)
173 case AS_EXPLICIT
: c
= "AS_EXPLICIT"; break;
174 case AS_DEFERRED
: c
= "AS_DEFERRED"; break;
175 case AS_ASSUMED_SIZE
: c
= "AS_ASSUMED_SIZE"; break;
176 case AS_ASSUMED_SHAPE
: c
= "AS_ASSUMED_SHAPE"; break;
177 case AS_ASSUMED_RANK
: c
= "AS_ASSUMED_RANK"; break;
179 gfc_internal_error ("show_array_spec(): Unhandled array shape "
182 fprintf (dumpfile
, " %s ", c
);
184 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
186 show_expr (as
->lower
[i
]);
187 fputc (' ', dumpfile
);
188 show_expr (as
->upper
[i
]);
189 fputc (' ', dumpfile
);
193 fputc (')', dumpfile
);
197 /* Show a gfc_array_ref array reference structure. */
200 show_array_ref (gfc_array_ref
* ar
)
204 fputc ('(', dumpfile
);
209 fputs ("FULL", dumpfile
);
213 for (i
= 0; i
< ar
->dimen
; i
++)
215 /* There are two types of array sections: either the
216 elements are identified by an integer array ('vector'),
217 or by an index range. In the former case we only have to
218 print the start expression which contains the vector, in
219 the latter case we have to print any of lower and upper
220 bound and the stride, if they're present. */
222 if (ar
->start
[i
] != NULL
)
223 show_expr (ar
->start
[i
]);
225 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
227 fputc (':', dumpfile
);
229 if (ar
->end
[i
] != NULL
)
230 show_expr (ar
->end
[i
]);
232 if (ar
->stride
[i
] != NULL
)
234 fputc (':', dumpfile
);
235 show_expr (ar
->stride
[i
]);
239 if (i
!= ar
->dimen
- 1)
240 fputs (" , ", dumpfile
);
245 for (i
= 0; i
< ar
->dimen
; i
++)
247 show_expr (ar
->start
[i
]);
248 if (i
!= ar
->dimen
- 1)
249 fputs (" , ", dumpfile
);
254 fputs ("UNKNOWN", dumpfile
);
258 gfc_internal_error ("show_array_ref(): Unknown array reference");
261 fputc (')', dumpfile
);
265 /* Show a list of gfc_ref structures. */
268 show_ref (gfc_ref
*p
)
270 for (; p
; p
= p
->next
)
274 show_array_ref (&p
->u
.ar
);
278 fprintf (dumpfile
, " %% %s", p
->u
.c
.component
->name
);
282 fputc ('(', dumpfile
);
283 show_expr (p
->u
.ss
.start
);
284 fputc (':', dumpfile
);
285 show_expr (p
->u
.ss
.end
);
286 fputc (')', dumpfile
);
290 gfc_internal_error ("show_ref(): Bad component code");
295 /* Display a constructor. Works recursively for array constructors. */
298 show_constructor (gfc_constructor_base base
)
301 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
303 if (c
->iterator
== NULL
)
307 fputc ('(', dumpfile
);
310 fputc (' ', dumpfile
);
311 show_expr (c
->iterator
->var
);
312 fputc ('=', dumpfile
);
313 show_expr (c
->iterator
->start
);
314 fputc (',', dumpfile
);
315 show_expr (c
->iterator
->end
);
316 fputc (',', dumpfile
);
317 show_expr (c
->iterator
->step
);
319 fputc (')', dumpfile
);
322 if (gfc_constructor_next (c
) != NULL
)
323 fputs (" , ", dumpfile
);
329 show_char_const (const gfc_char_t
*c
, int length
)
333 fputc ('\'', dumpfile
);
334 for (i
= 0; i
< length
; i
++)
337 fputs ("''", dumpfile
);
339 fputs (gfc_print_wide_char (c
[i
]), dumpfile
);
341 fputc ('\'', dumpfile
);
345 /* Show a component-call expression. */
348 show_compcall (gfc_expr
* p
)
350 gcc_assert (p
->expr_type
== EXPR_COMPCALL
);
352 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
354 fprintf (dumpfile
, "%s", p
->value
.compcall
.name
);
356 show_actual_arglist (p
->value
.compcall
.actual
);
360 /* Show an expression. */
363 show_expr (gfc_expr
*p
)
370 fputs ("()", dumpfile
);
374 switch (p
->expr_type
)
377 show_char_const (p
->value
.character
.string
, p
->value
.character
.length
);
382 fprintf (dumpfile
, "%s(", p
->ts
.u
.derived
->name
);
383 show_constructor (p
->value
.constructor
);
384 fputc (')', dumpfile
);
388 fputs ("(/ ", dumpfile
);
389 show_constructor (p
->value
.constructor
);
390 fputs (" /)", dumpfile
);
396 fputs ("NULL()", dumpfile
);
403 mpz_out_str (stdout
, 10, p
->value
.integer
);
405 if (p
->ts
.kind
!= gfc_default_integer_kind
)
406 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
410 if (p
->value
.logical
)
411 fputs (".true.", dumpfile
);
413 fputs (".false.", dumpfile
);
417 mpfr_out_str (stdout
, 10, 0, p
->value
.real
, GFC_RND_MODE
);
418 if (p
->ts
.kind
!= gfc_default_real_kind
)
419 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
423 show_char_const (p
->value
.character
.string
,
424 p
->value
.character
.length
);
428 fputs ("(complex ", dumpfile
);
430 mpfr_out_str (stdout
, 10, 0, mpc_realref (p
->value
.complex),
432 if (p
->ts
.kind
!= gfc_default_complex_kind
)
433 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
435 fputc (' ', dumpfile
);
437 mpfr_out_str (stdout
, 10, 0, mpc_imagref (p
->value
.complex),
439 if (p
->ts
.kind
!= gfc_default_complex_kind
)
440 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
442 fputc (')', dumpfile
);
446 fprintf (dumpfile
, "%dH", p
->representation
.length
);
447 c
= p
->representation
.string
;
448 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
450 fputc (*c
, dumpfile
);
455 fputs ("???", dumpfile
);
459 if (p
->representation
.string
)
461 fputs (" {", dumpfile
);
462 c
= p
->representation
.string
;
463 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
465 fprintf (dumpfile
, "%.2x", (unsigned int) *c
);
466 if (i
< p
->representation
.length
- 1)
467 fputc (',', dumpfile
);
469 fputc ('}', dumpfile
);
475 if (p
->symtree
->n
.sym
->ns
&& p
->symtree
->n
.sym
->ns
->proc_name
)
476 fprintf (dumpfile
, "%s:", p
->symtree
->n
.sym
->ns
->proc_name
->name
);
477 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
482 fputc ('(', dumpfile
);
483 switch (p
->value
.op
.op
)
485 case INTRINSIC_UPLUS
:
486 fputs ("U+ ", dumpfile
);
488 case INTRINSIC_UMINUS
:
489 fputs ("U- ", dumpfile
);
492 fputs ("+ ", dumpfile
);
494 case INTRINSIC_MINUS
:
495 fputs ("- ", dumpfile
);
497 case INTRINSIC_TIMES
:
498 fputs ("* ", dumpfile
);
500 case INTRINSIC_DIVIDE
:
501 fputs ("/ ", dumpfile
);
503 case INTRINSIC_POWER
:
504 fputs ("** ", dumpfile
);
506 case INTRINSIC_CONCAT
:
507 fputs ("// ", dumpfile
);
510 fputs ("AND ", dumpfile
);
513 fputs ("OR ", dumpfile
);
516 fputs ("EQV ", dumpfile
);
519 fputs ("NEQV ", dumpfile
);
522 case INTRINSIC_EQ_OS
:
523 fputs ("= ", dumpfile
);
526 case INTRINSIC_NE_OS
:
527 fputs ("/= ", dumpfile
);
530 case INTRINSIC_GT_OS
:
531 fputs ("> ", dumpfile
);
534 case INTRINSIC_GE_OS
:
535 fputs (">= ", dumpfile
);
538 case INTRINSIC_LT_OS
:
539 fputs ("< ", dumpfile
);
542 case INTRINSIC_LE_OS
:
543 fputs ("<= ", dumpfile
);
546 fputs ("NOT ", dumpfile
);
548 case INTRINSIC_PARENTHESES
:
549 fputs ("parens ", dumpfile
);
554 ("show_expr(): Bad intrinsic in expression!");
557 show_expr (p
->value
.op
.op1
);
561 fputc (' ', dumpfile
);
562 show_expr (p
->value
.op
.op2
);
565 fputc (')', dumpfile
);
569 if (p
->value
.function
.name
== NULL
)
571 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
572 if (gfc_is_proc_ptr_comp (p
))
574 fputc ('[', dumpfile
);
575 show_actual_arglist (p
->value
.function
.actual
);
576 fputc (']', dumpfile
);
580 fprintf (dumpfile
, "%s", p
->value
.function
.name
);
581 if (gfc_is_proc_ptr_comp (p
))
583 fputc ('[', dumpfile
);
584 fputc ('[', dumpfile
);
585 show_actual_arglist (p
->value
.function
.actual
);
586 fputc (']', dumpfile
);
587 fputc (']', dumpfile
);
597 gfc_internal_error ("show_expr(): Don't know how to show expr");
601 /* Show symbol attributes. The flavor and intent are followed by
602 whatever single bit attributes are present. */
605 show_attr (symbol_attribute
*attr
, const char * module
)
607 if (attr
->flavor
!= FL_UNKNOWN
)
608 fprintf (dumpfile
, "(%s ", gfc_code2string (flavors
, attr
->flavor
));
609 if (attr
->access
!= ACCESS_UNKNOWN
)
610 fprintf (dumpfile
, "%s ", gfc_code2string (access_types
, attr
->access
));
611 if (attr
->proc
!= PROC_UNKNOWN
)
612 fprintf (dumpfile
, "%s ", gfc_code2string (procedures
, attr
->proc
));
613 if (attr
->save
!= SAVE_NONE
)
614 fprintf (dumpfile
, "%s", gfc_code2string (save_status
, attr
->save
));
616 if (attr
->artificial
)
617 fputs (" ARTIFICIAL", dumpfile
);
618 if (attr
->allocatable
)
619 fputs (" ALLOCATABLE", dumpfile
);
620 if (attr
->asynchronous
)
621 fputs (" ASYNCHRONOUS", dumpfile
);
622 if (attr
->codimension
)
623 fputs (" CODIMENSION", dumpfile
);
625 fputs (" DIMENSION", dumpfile
);
626 if (attr
->contiguous
)
627 fputs (" CONTIGUOUS", dumpfile
);
629 fputs (" EXTERNAL", dumpfile
);
631 fputs (" INTRINSIC", dumpfile
);
633 fputs (" OPTIONAL", dumpfile
);
635 fputs (" POINTER", dumpfile
);
636 if (attr
->is_protected
)
637 fputs (" PROTECTED", dumpfile
);
639 fputs (" VALUE", dumpfile
);
641 fputs (" VOLATILE", dumpfile
);
642 if (attr
->threadprivate
)
643 fputs (" THREADPRIVATE", dumpfile
);
645 fputs (" TARGET", dumpfile
);
648 fputs (" DUMMY", dumpfile
);
649 if (attr
->intent
!= INTENT_UNKNOWN
)
650 fprintf (dumpfile
, "(%s)", gfc_intent_string (attr
->intent
));
654 fputs (" RESULT", dumpfile
);
656 fputs (" ENTRY", dumpfile
);
658 fputs (" BIND(C)", dumpfile
);
661 fputs (" DATA", dumpfile
);
664 fputs (" USE-ASSOC", dumpfile
);
666 fprintf (dumpfile
, "(%s)", module
);
669 if (attr
->in_namelist
)
670 fputs (" IN-NAMELIST", dumpfile
);
672 fputs (" IN-COMMON", dumpfile
);
675 fputs (" ABSTRACT", dumpfile
);
677 fputs (" FUNCTION", dumpfile
);
678 if (attr
->subroutine
)
679 fputs (" SUBROUTINE", dumpfile
);
680 if (attr
->implicit_type
)
681 fputs (" IMPLICIT-TYPE", dumpfile
);
684 fputs (" SEQUENCE", dumpfile
);
686 fputs (" ELEMENTAL", dumpfile
);
688 fputs (" PURE", dumpfile
);
690 fputs (" RECURSIVE", dumpfile
);
692 fputc (')', dumpfile
);
696 /* Show components of a derived type. */
699 show_components (gfc_symbol
*sym
)
703 for (c
= sym
->components
; c
; c
= c
->next
)
705 fprintf (dumpfile
, "(%s ", c
->name
);
706 show_typespec (&c
->ts
);
707 if (c
->attr
.allocatable
)
708 fputs (" ALLOCATABLE", dumpfile
);
710 fputs (" POINTER", dumpfile
);
711 if (c
->attr
.proc_pointer
)
712 fputs (" PPC", dumpfile
);
713 if (c
->attr
.dimension
)
714 fputs (" DIMENSION", dumpfile
);
715 fputc (' ', dumpfile
);
716 show_array_spec (c
->as
);
718 fprintf (dumpfile
, " %s", gfc_code2string (access_types
, c
->attr
.access
));
719 fputc (')', dumpfile
);
721 fputc (' ', dumpfile
);
726 /* Show the f2k_derived namespace with procedure bindings. */
729 show_typebound_proc (gfc_typebound_proc
* tb
, const char* name
)
734 fputs ("GENERIC", dumpfile
);
737 fputs ("PROCEDURE, ", dumpfile
);
739 fputs ("NOPASS", dumpfile
);
743 fprintf (dumpfile
, "PASS(%s)", tb
->pass_arg
);
745 fputs ("PASS", dumpfile
);
747 if (tb
->non_overridable
)
748 fputs (", NON_OVERRIDABLE", dumpfile
);
751 if (tb
->access
== ACCESS_PUBLIC
)
752 fputs (", PUBLIC", dumpfile
);
754 fputs (", PRIVATE", dumpfile
);
756 fprintf (dumpfile
, " :: %s => ", name
);
761 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
763 fputs (g
->specific_st
->name
, dumpfile
);
765 fputs (", ", dumpfile
);
769 fputs (tb
->u
.specific
->n
.sym
->name
, dumpfile
);
773 show_typebound_symtree (gfc_symtree
* st
)
775 gcc_assert (st
->n
.tb
);
776 show_typebound_proc (st
->n
.tb
, st
->name
);
780 show_f2k_derived (gfc_namespace
* f2k
)
786 fputs ("Procedure bindings:", dumpfile
);
789 /* Finalizer bindings. */
790 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
793 fprintf (dumpfile
, "FINAL %s", f
->proc_tree
->n
.sym
->name
);
796 /* Type-bound procedures. */
797 gfc_traverse_symtree (f2k
->tb_sym_root
, &show_typebound_symtree
);
802 fputs ("Operator bindings:", dumpfile
);
805 /* User-defined operators. */
806 gfc_traverse_symtree (f2k
->tb_uop_root
, &show_typebound_symtree
);
808 /* Intrinsic operators. */
809 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
811 show_typebound_proc (f2k
->tb_op
[op
],
812 gfc_op2string ((gfc_intrinsic_op
) op
));
818 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
819 show the interface. Information needed to reconstruct the list of
820 specific interfaces associated with a generic symbol is done within
824 show_symbol (gfc_symbol
*sym
)
826 gfc_formal_arglist
*formal
;
833 fprintf (dumpfile
, "|| symbol: '%s' ", sym
->name
);
834 len
= strlen (sym
->name
);
835 for (i
=len
; i
<12; i
++)
836 fputc(' ', dumpfile
);
841 fputs ("type spec : ", dumpfile
);
842 show_typespec (&sym
->ts
);
845 fputs ("attributes: ", dumpfile
);
846 show_attr (&sym
->attr
, sym
->module
);
851 fputs ("value: ", dumpfile
);
852 show_expr (sym
->value
);
858 fputs ("Array spec:", dumpfile
);
859 show_array_spec (sym
->as
);
865 fputs ("Generic interfaces:", dumpfile
);
866 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
867 fprintf (dumpfile
, " %s", intr
->sym
->name
);
873 fprintf (dumpfile
, "result: %s", sym
->result
->name
);
879 fputs ("components: ", dumpfile
);
880 show_components (sym
);
883 if (sym
->f2k_derived
)
887 fprintf (dumpfile
, "hash: %d", sym
->hash_value
);
888 show_f2k_derived (sym
->f2k_derived
);
894 fputs ("Formal arglist:", dumpfile
);
896 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
898 if (formal
->sym
!= NULL
)
899 fprintf (dumpfile
, " %s", formal
->sym
->name
);
901 fputs (" [Alt Return]", dumpfile
);
905 if (sym
->formal_ns
&& (sym
->formal_ns
->proc_name
!= sym
)
906 && sym
->attr
.proc
!= PROC_ST_FUNCTION
910 fputs ("Formal namespace", dumpfile
);
911 show_namespace (sym
->formal_ns
);
917 /* Show a user-defined operator. Just prints an operator
918 and the name of the associated subroutine, really. */
921 show_uop (gfc_user_op
*uop
)
926 fprintf (dumpfile
, "%s:", uop
->name
);
928 for (intr
= uop
->op
; intr
; intr
= intr
->next
)
929 fprintf (dumpfile
, " %s", intr
->sym
->name
);
933 /* Workhorse function for traversing the user operator symtree. */
936 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
943 traverse_uop (st
->left
, func
);
944 traverse_uop (st
->right
, func
);
948 /* Traverse the tree of user operator nodes. */
951 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
953 traverse_uop (ns
->uop_root
, func
);
957 /* Function to display a common block. */
960 show_common (gfc_symtree
*st
)
965 fprintf (dumpfile
, "common: /%s/ ", st
->name
);
967 s
= st
->n
.common
->head
;
970 fprintf (dumpfile
, "%s", s
->name
);
973 fputs (", ", dumpfile
);
975 fputc ('\n', dumpfile
);
979 /* Worker function to display the symbol tree. */
982 show_symtree (gfc_symtree
*st
)
988 len
= strlen(st
->name
);
989 fprintf (dumpfile
, "symtree: '%s'", st
->name
);
991 for (i
=len
; i
<12; i
++)
992 fputc(' ', dumpfile
);
995 fputs( " Ambiguous", dumpfile
);
997 if (st
->n
.sym
->ns
!= gfc_current_ns
)
998 fprintf (dumpfile
, "|| symbol: '%s' from namespace '%s'", st
->n
.sym
->name
,
999 st
->n
.sym
->ns
->proc_name
->name
);
1001 show_symbol (st
->n
.sym
);
1005 /******************* Show gfc_code structures **************/
1008 /* Show a list of code structures. Mutually recursive with
1009 show_code_node(). */
1012 show_code (int level
, gfc_code
*c
)
1014 for (; c
; c
= c
->next
)
1015 show_code_node (level
, c
);
1019 show_omp_namelist (int list_type
, gfc_omp_namelist
*n
)
1021 for (; n
; n
= n
->next
)
1023 if (list_type
== OMP_LIST_REDUCTION
)
1024 switch (n
->u
.reduction_op
)
1026 case OMP_REDUCTION_PLUS
:
1027 case OMP_REDUCTION_TIMES
:
1028 case OMP_REDUCTION_MINUS
:
1029 case OMP_REDUCTION_AND
:
1030 case OMP_REDUCTION_OR
:
1031 case OMP_REDUCTION_EQV
:
1032 case OMP_REDUCTION_NEQV
:
1033 fprintf (dumpfile
, "%s:",
1034 gfc_op2string ((gfc_intrinsic_op
) n
->u
.reduction_op
));
1036 case OMP_REDUCTION_MAX
: fputs ("max:", dumpfile
); break;
1037 case OMP_REDUCTION_MIN
: fputs ("min:", dumpfile
); break;
1038 case OMP_REDUCTION_IAND
: fputs ("iand:", dumpfile
); break;
1039 case OMP_REDUCTION_IOR
: fputs ("ior:", dumpfile
); break;
1040 case OMP_REDUCTION_IEOR
: fputs ("ieor:", dumpfile
); break;
1041 case OMP_REDUCTION_USER
:
1043 fprintf (dumpfile
, "%s:", n
->udr
->udr
->name
);
1047 else if (list_type
== OMP_LIST_DEPEND
)
1048 switch (n
->u
.depend_op
)
1050 case OMP_DEPEND_IN
: fputs ("in:", dumpfile
); break;
1051 case OMP_DEPEND_OUT
: fputs ("out:", dumpfile
); break;
1052 case OMP_DEPEND_INOUT
: fputs ("inout:", dumpfile
); break;
1055 else if (list_type
== OMP_LIST_MAP
)
1056 switch (n
->u
.map_op
)
1058 case OMP_MAP_ALLOC
: fputs ("alloc:", dumpfile
); break;
1059 case OMP_MAP_TO
: fputs ("to:", dumpfile
); break;
1060 case OMP_MAP_FROM
: fputs ("from:", dumpfile
); break;
1061 case OMP_MAP_TOFROM
: fputs ("tofrom:", dumpfile
); break;
1064 fprintf (dumpfile
, "%s", n
->sym
->name
);
1067 fputc (':', dumpfile
);
1068 show_expr (n
->expr
);
1071 fputc (',', dumpfile
);
1076 /* Show OpenMP or OpenACC clauses. */
1079 show_omp_clauses (gfc_omp_clauses
*omp_clauses
)
1083 switch (omp_clauses
->cancel
)
1085 case OMP_CANCEL_UNKNOWN
:
1087 case OMP_CANCEL_PARALLEL
:
1088 fputs (" PARALLEL", dumpfile
);
1090 case OMP_CANCEL_SECTIONS
:
1091 fputs (" SECTIONS", dumpfile
);
1094 fputs (" DO", dumpfile
);
1096 case OMP_CANCEL_TASKGROUP
:
1097 fputs (" TASKGROUP", dumpfile
);
1100 if (omp_clauses
->if_expr
)
1102 fputs (" IF(", dumpfile
);
1103 show_expr (omp_clauses
->if_expr
);
1104 fputc (')', dumpfile
);
1106 if (omp_clauses
->final_expr
)
1108 fputs (" FINAL(", dumpfile
);
1109 show_expr (omp_clauses
->final_expr
);
1110 fputc (')', dumpfile
);
1112 if (omp_clauses
->num_threads
)
1114 fputs (" NUM_THREADS(", dumpfile
);
1115 show_expr (omp_clauses
->num_threads
);
1116 fputc (')', dumpfile
);
1118 if (omp_clauses
->async
)
1120 fputs (" ASYNC", dumpfile
);
1121 if (omp_clauses
->async_expr
)
1123 fputc ('(', dumpfile
);
1124 show_expr (omp_clauses
->async_expr
);
1125 fputc (')', dumpfile
);
1128 if (omp_clauses
->num_gangs_expr
)
1130 fputs (" NUM_GANGS(", dumpfile
);
1131 show_expr (omp_clauses
->num_gangs_expr
);
1132 fputc (')', dumpfile
);
1134 if (omp_clauses
->num_workers_expr
)
1136 fputs (" NUM_WORKERS(", dumpfile
);
1137 show_expr (omp_clauses
->num_workers_expr
);
1138 fputc (')', dumpfile
);
1140 if (omp_clauses
->vector_length_expr
)
1142 fputs (" VECTOR_LENGTH(", dumpfile
);
1143 show_expr (omp_clauses
->vector_length_expr
);
1144 fputc (')', dumpfile
);
1146 if (omp_clauses
->gang
)
1148 fputs (" GANG", dumpfile
);
1149 if (omp_clauses
->gang_num_expr
|| omp_clauses
->gang_static_expr
)
1151 fputc ('(', dumpfile
);
1152 if (omp_clauses
->gang_num_expr
)
1154 fprintf (dumpfile
, "num:");
1155 show_expr (omp_clauses
->gang_num_expr
);
1157 if (omp_clauses
->gang_num_expr
&& omp_clauses
->gang_static
)
1158 fputc (',', dumpfile
);
1159 if (omp_clauses
->gang_static
)
1161 fprintf (dumpfile
, "static:");
1162 if (omp_clauses
->gang_static_expr
)
1163 show_expr (omp_clauses
->gang_static_expr
);
1165 fputc ('*', dumpfile
);
1167 fputc (')', dumpfile
);
1170 if (omp_clauses
->worker
)
1172 fputs (" WORKER", dumpfile
);
1173 if (omp_clauses
->worker_expr
)
1175 fputc ('(', dumpfile
);
1176 show_expr (omp_clauses
->worker_expr
);
1177 fputc (')', dumpfile
);
1180 if (omp_clauses
->vector
)
1182 fputs (" VECTOR", dumpfile
);
1183 if (omp_clauses
->vector_expr
)
1185 fputc ('(', dumpfile
);
1186 show_expr (omp_clauses
->vector_expr
);
1187 fputc (')', dumpfile
);
1190 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
1193 switch (omp_clauses
->sched_kind
)
1195 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
1196 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
1197 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
1198 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
1199 case OMP_SCHED_AUTO
: type
= "AUTO"; break;
1203 fprintf (dumpfile
, " SCHEDULE (%s", type
);
1204 if (omp_clauses
->chunk_size
)
1206 fputc (',', dumpfile
);
1207 show_expr (omp_clauses
->chunk_size
);
1209 fputc (')', dumpfile
);
1211 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1214 switch (omp_clauses
->default_sharing
)
1216 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
1217 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
1218 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
1219 case OMP_DEFAULT_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1223 fprintf (dumpfile
, " DEFAULT(%s)", type
);
1225 if (omp_clauses
->tile_list
)
1227 gfc_expr_list
*list
;
1228 fputs (" TILE(", dumpfile
);
1229 for (list
= omp_clauses
->tile_list
; list
; list
= list
->next
)
1231 show_expr (list
->expr
);
1233 fputs (", ", dumpfile
);
1235 fputc (')', dumpfile
);
1237 if (omp_clauses
->wait_list
)
1239 gfc_expr_list
*list
;
1240 fputs (" WAIT(", dumpfile
);
1241 for (list
= omp_clauses
->wait_list
; list
; list
= list
->next
)
1243 show_expr (list
->expr
);
1245 fputs (", ", dumpfile
);
1247 fputc (')', dumpfile
);
1249 if (omp_clauses
->seq
)
1250 fputs (" SEQ", dumpfile
);
1251 if (omp_clauses
->independent
)
1252 fputs (" INDEPENDENT", dumpfile
);
1253 if (omp_clauses
->ordered
)
1254 fputs (" ORDERED", dumpfile
);
1255 if (omp_clauses
->untied
)
1256 fputs (" UNTIED", dumpfile
);
1257 if (omp_clauses
->mergeable
)
1258 fputs (" MERGEABLE", dumpfile
);
1259 if (omp_clauses
->collapse
)
1260 fprintf (dumpfile
, " COLLAPSE(%d)", omp_clauses
->collapse
);
1261 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
1262 if (omp_clauses
->lists
[list_type
] != NULL
1263 && list_type
!= OMP_LIST_COPYPRIVATE
)
1265 const char *type
= NULL
;
1268 case OMP_LIST_USE_DEVICE
: type
= "USE_DEVICE"; break;
1269 case OMP_LIST_DEVICE_RESIDENT
: type
= "USE_DEVICE"; break;
1270 case OMP_LIST_CACHE
: type
= ""; break;
1271 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
1272 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1273 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
1274 case OMP_LIST_SHARED
: type
= "SHARED"; break;
1275 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
1276 case OMP_LIST_UNIFORM
: type
= "UNIFORM"; break;
1277 case OMP_LIST_ALIGNED
: type
= "ALIGNED"; break;
1278 case OMP_LIST_LINEAR
: type
= "LINEAR"; break;
1279 case OMP_LIST_REDUCTION
: type
= "REDUCTION"; break;
1280 case OMP_LIST_DEPEND
: type
= "DEPEND"; break;
1284 fprintf (dumpfile
, " %s(", type
);
1285 show_omp_namelist (list_type
, omp_clauses
->lists
[list_type
]);
1286 fputc (')', dumpfile
);
1288 if (omp_clauses
->safelen_expr
)
1290 fputs (" SAFELEN(", dumpfile
);
1291 show_expr (omp_clauses
->safelen_expr
);
1292 fputc (')', dumpfile
);
1294 if (omp_clauses
->simdlen_expr
)
1296 fputs (" SIMDLEN(", dumpfile
);
1297 show_expr (omp_clauses
->simdlen_expr
);
1298 fputc (')', dumpfile
);
1300 if (omp_clauses
->inbranch
)
1301 fputs (" INBRANCH", dumpfile
);
1302 if (omp_clauses
->notinbranch
)
1303 fputs (" NOTINBRANCH", dumpfile
);
1304 if (omp_clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
1307 switch (omp_clauses
->proc_bind
)
1309 case OMP_PROC_BIND_MASTER
: type
= "MASTER"; break;
1310 case OMP_PROC_BIND_SPREAD
: type
= "SPREAD"; break;
1311 case OMP_PROC_BIND_CLOSE
: type
= "CLOSE"; break;
1315 fprintf (dumpfile
, " PROC_BIND(%s)", type
);
1317 if (omp_clauses
->num_teams
)
1319 fputs (" NUM_TEAMS(", dumpfile
);
1320 show_expr (omp_clauses
->num_teams
);
1321 fputc (')', dumpfile
);
1323 if (omp_clauses
->device
)
1325 fputs (" DEVICE(", dumpfile
);
1326 show_expr (omp_clauses
->device
);
1327 fputc (')', dumpfile
);
1329 if (omp_clauses
->thread_limit
)
1331 fputs (" THREAD_LIMIT(", dumpfile
);
1332 show_expr (omp_clauses
->thread_limit
);
1333 fputc (')', dumpfile
);
1335 if (omp_clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
1337 fprintf (dumpfile
, " DIST_SCHEDULE (static");
1338 if (omp_clauses
->dist_chunk_size
)
1340 fputc (',', dumpfile
);
1341 show_expr (omp_clauses
->dist_chunk_size
);
1343 fputc (')', dumpfile
);
1347 /* Show a single OpenMP or OpenACC directive node and everything underneath it
1351 show_omp_node (int level
, gfc_code
*c
)
1353 gfc_omp_clauses
*omp_clauses
= NULL
;
1354 const char *name
= NULL
;
1355 bool is_oacc
= false;
1359 case EXEC_OACC_PARALLEL_LOOP
: name
= "PARALLEL LOOP"; is_oacc
= true; break;
1360 case EXEC_OACC_PARALLEL
: name
= "PARALLEL"; is_oacc
= true; break;
1361 case EXEC_OACC_KERNELS_LOOP
: name
= "KERNELS LOOP"; is_oacc
= true; break;
1362 case EXEC_OACC_KERNELS
: name
= "KERNELS"; is_oacc
= true; break;
1363 case EXEC_OACC_DATA
: name
= "DATA"; is_oacc
= true; break;
1364 case EXEC_OACC_HOST_DATA
: name
= "HOST_DATA"; is_oacc
= true; break;
1365 case EXEC_OACC_LOOP
: name
= "LOOP"; is_oacc
= true; break;
1366 case EXEC_OACC_UPDATE
: name
= "UPDATE"; is_oacc
= true; break;
1367 case EXEC_OACC_WAIT
: name
= "WAIT"; is_oacc
= true; break;
1368 case EXEC_OACC_CACHE
: name
= "CACHE"; is_oacc
= true; break;
1369 case EXEC_OACC_ENTER_DATA
: name
= "ENTER DATA"; is_oacc
= true; break;
1370 case EXEC_OACC_EXIT_DATA
: name
= "EXIT DATA"; is_oacc
= true; break;
1371 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
1372 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
1373 case EXEC_OMP_CANCEL
: name
= "CANCEL"; break;
1374 case EXEC_OMP_CANCELLATION_POINT
: name
= "CANCELLATION POINT"; break;
1375 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
1376 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
1377 case EXEC_OMP_DO
: name
= "DO"; break;
1378 case EXEC_OMP_DO_SIMD
: name
= "DO SIMD"; break;
1379 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
1380 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
1381 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
1382 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
1383 case EXEC_OMP_PARALLEL_DO_SIMD
: name
= "PARALLEL DO SIMD"; break;
1384 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
1385 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
1386 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
1387 case EXEC_OMP_SIMD
: name
= "SIMD"; break;
1388 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
1389 case EXEC_OMP_TASK
: name
= "TASK"; break;
1390 case EXEC_OMP_TASKGROUP
: name
= "TASKGROUP"; break;
1391 case EXEC_OMP_TASKWAIT
: name
= "TASKWAIT"; break;
1392 case EXEC_OMP_TASKYIELD
: name
= "TASKYIELD"; break;
1393 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
1397 fprintf (dumpfile
, "!$%s %s", is_oacc
? "ACC" : "OMP", name
);
1400 case EXEC_OACC_PARALLEL_LOOP
:
1401 case EXEC_OACC_PARALLEL
:
1402 case EXEC_OACC_KERNELS_LOOP
:
1403 case EXEC_OACC_KERNELS
:
1404 case EXEC_OACC_DATA
:
1405 case EXEC_OACC_HOST_DATA
:
1406 case EXEC_OACC_LOOP
:
1407 case EXEC_OACC_UPDATE
:
1408 case EXEC_OACC_WAIT
:
1409 case EXEC_OACC_CACHE
:
1410 case EXEC_OACC_ENTER_DATA
:
1411 case EXEC_OACC_EXIT_DATA
:
1412 case EXEC_OMP_CANCEL
:
1413 case EXEC_OMP_CANCELLATION_POINT
:
1415 case EXEC_OMP_DO_SIMD
:
1416 case EXEC_OMP_PARALLEL
:
1417 case EXEC_OMP_PARALLEL_DO
:
1418 case EXEC_OMP_PARALLEL_DO_SIMD
:
1419 case EXEC_OMP_PARALLEL_SECTIONS
:
1420 case EXEC_OMP_SECTIONS
:
1422 case EXEC_OMP_SINGLE
:
1423 case EXEC_OMP_WORKSHARE
:
1424 case EXEC_OMP_PARALLEL_WORKSHARE
:
1426 omp_clauses
= c
->ext
.omp_clauses
;
1428 case EXEC_OMP_CRITICAL
:
1429 if (c
->ext
.omp_name
)
1430 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1432 case EXEC_OMP_FLUSH
:
1433 if (c
->ext
.omp_namelist
)
1435 fputs (" (", dumpfile
);
1436 show_omp_namelist (OMP_LIST_NUM
, c
->ext
.omp_namelist
);
1437 fputc (')', dumpfile
);
1440 case EXEC_OMP_BARRIER
:
1441 case EXEC_OMP_TASKWAIT
:
1442 case EXEC_OMP_TASKYIELD
:
1448 show_omp_clauses (omp_clauses
);
1449 fputc ('\n', dumpfile
);
1451 /* OpenACC executable directives don't have associated blocks. */
1452 if (c
->op
== EXEC_OACC_CACHE
|| c
->op
== EXEC_OACC_UPDATE
1453 || c
->op
== EXEC_OACC_ENTER_DATA
|| c
->op
== EXEC_OACC_EXIT_DATA
)
1455 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
1457 gfc_code
*d
= c
->block
;
1460 show_code (level
+ 1, d
->next
);
1461 if (d
->block
== NULL
)
1463 code_indent (level
, 0);
1464 fputs ("!$OMP SECTION\n", dumpfile
);
1469 show_code (level
+ 1, c
->block
->next
);
1470 if (c
->op
== EXEC_OMP_ATOMIC
)
1472 fputc ('\n', dumpfile
);
1473 code_indent (level
, 0);
1474 fprintf (dumpfile
, "!$%s END %s", is_oacc
? "ACC" : "OMP", name
);
1475 if (omp_clauses
!= NULL
)
1477 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
1479 fputs (" COPYPRIVATE(", dumpfile
);
1480 show_omp_namelist (OMP_LIST_COPYPRIVATE
,
1481 omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1482 fputc (')', dumpfile
);
1484 else if (omp_clauses
->nowait
)
1485 fputs (" NOWAIT", dumpfile
);
1487 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_name
)
1488 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1492 /* Show a single code node and everything underneath it if necessary. */
1495 show_code_node (int level
, gfc_code
*c
)
1497 gfc_forall_iterator
*fa
;
1510 fputc ('\n', dumpfile
);
1511 code_indent (level
, c
->here
);
1518 case EXEC_END_PROCEDURE
:
1522 fputs ("NOP", dumpfile
);
1526 fputs ("CONTINUE", dumpfile
);
1530 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
1533 case EXEC_INIT_ASSIGN
:
1535 fputs ("ASSIGN ", dumpfile
);
1536 show_expr (c
->expr1
);
1537 fputc (' ', dumpfile
);
1538 show_expr (c
->expr2
);
1541 case EXEC_LABEL_ASSIGN
:
1542 fputs ("LABEL ASSIGN ", dumpfile
);
1543 show_expr (c
->expr1
);
1544 fprintf (dumpfile
, " %d", c
->label1
->value
);
1547 case EXEC_POINTER_ASSIGN
:
1548 fputs ("POINTER ASSIGN ", dumpfile
);
1549 show_expr (c
->expr1
);
1550 fputc (' ', dumpfile
);
1551 show_expr (c
->expr2
);
1555 fputs ("GOTO ", dumpfile
);
1557 fprintf (dumpfile
, "%d", c
->label1
->value
);
1560 show_expr (c
->expr1
);
1564 fputs (", (", dumpfile
);
1565 for (; d
; d
= d
->block
)
1567 code_indent (level
, d
->label1
);
1568 if (d
->block
!= NULL
)
1569 fputc (',', dumpfile
);
1571 fputc (')', dumpfile
);
1578 case EXEC_ASSIGN_CALL
:
1579 if (c
->resolved_sym
)
1580 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
1581 else if (c
->symtree
)
1582 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
1584 fputs ("CALL ?? ", dumpfile
);
1586 show_actual_arglist (c
->ext
.actual
);
1590 fputs ("CALL ", dumpfile
);
1591 show_compcall (c
->expr1
);
1595 fputs ("CALL ", dumpfile
);
1596 show_expr (c
->expr1
);
1597 show_actual_arglist (c
->ext
.actual
);
1601 fputs ("RETURN ", dumpfile
);
1603 show_expr (c
->expr1
);
1607 fputs ("PAUSE ", dumpfile
);
1609 if (c
->expr1
!= NULL
)
1610 show_expr (c
->expr1
);
1612 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1616 case EXEC_ERROR_STOP
:
1617 fputs ("ERROR ", dumpfile
);
1621 fputs ("STOP ", dumpfile
);
1623 if (c
->expr1
!= NULL
)
1624 show_expr (c
->expr1
);
1626 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1631 fputs ("SYNC ALL ", dumpfile
);
1632 if (c
->expr2
!= NULL
)
1634 fputs (" stat=", dumpfile
);
1635 show_expr (c
->expr2
);
1637 if (c
->expr3
!= NULL
)
1639 fputs (" errmsg=", dumpfile
);
1640 show_expr (c
->expr3
);
1644 case EXEC_SYNC_MEMORY
:
1645 fputs ("SYNC MEMORY ", dumpfile
);
1646 if (c
->expr2
!= NULL
)
1648 fputs (" stat=", dumpfile
);
1649 show_expr (c
->expr2
);
1651 if (c
->expr3
!= NULL
)
1653 fputs (" errmsg=", dumpfile
);
1654 show_expr (c
->expr3
);
1658 case EXEC_SYNC_IMAGES
:
1659 fputs ("SYNC IMAGES image-set=", dumpfile
);
1660 if (c
->expr1
!= NULL
)
1661 show_expr (c
->expr1
);
1663 fputs ("* ", dumpfile
);
1664 if (c
->expr2
!= NULL
)
1666 fputs (" stat=", dumpfile
);
1667 show_expr (c
->expr2
);
1669 if (c
->expr3
!= NULL
)
1671 fputs (" errmsg=", dumpfile
);
1672 show_expr (c
->expr3
);
1676 case EXEC_EVENT_POST
:
1677 case EXEC_EVENT_WAIT
:
1678 if (c
->op
== EXEC_EVENT_POST
)
1679 fputs ("EVENT POST ", dumpfile
);
1681 fputs ("EVENT WAIT ", dumpfile
);
1683 fputs ("event-variable=", dumpfile
);
1684 if (c
->expr1
!= NULL
)
1685 show_expr (c
->expr1
);
1686 if (c
->expr4
!= NULL
)
1688 fputs (" until_count=", dumpfile
);
1689 show_expr (c
->expr4
);
1691 if (c
->expr2
!= NULL
)
1693 fputs (" stat=", dumpfile
);
1694 show_expr (c
->expr2
);
1696 if (c
->expr3
!= NULL
)
1698 fputs (" errmsg=", dumpfile
);
1699 show_expr (c
->expr3
);
1705 if (c
->op
== EXEC_LOCK
)
1706 fputs ("LOCK ", dumpfile
);
1708 fputs ("UNLOCK ", dumpfile
);
1710 fputs ("lock-variable=", dumpfile
);
1711 if (c
->expr1
!= NULL
)
1712 show_expr (c
->expr1
);
1713 if (c
->expr4
!= NULL
)
1715 fputs (" acquired_lock=", dumpfile
);
1716 show_expr (c
->expr4
);
1718 if (c
->expr2
!= NULL
)
1720 fputs (" stat=", dumpfile
);
1721 show_expr (c
->expr2
);
1723 if (c
->expr3
!= NULL
)
1725 fputs (" errmsg=", dumpfile
);
1726 show_expr (c
->expr3
);
1730 case EXEC_ARITHMETIC_IF
:
1731 fputs ("IF ", dumpfile
);
1732 show_expr (c
->expr1
);
1733 fprintf (dumpfile
, " %d, %d, %d",
1734 c
->label1
->value
, c
->label2
->value
, c
->label3
->value
);
1739 fputs ("IF ", dumpfile
);
1740 show_expr (d
->expr1
);
1743 show_code (level
+ 1, d
->next
);
1747 for (; d
; d
= d
->block
)
1749 code_indent (level
, 0);
1751 if (d
->expr1
== NULL
)
1752 fputs ("ELSE", dumpfile
);
1755 fputs ("ELSE IF ", dumpfile
);
1756 show_expr (d
->expr1
);
1760 show_code (level
+ 1, d
->next
);
1765 code_indent (level
, c
->label1
);
1769 fputs ("ENDIF", dumpfile
);
1774 const char* blocktype
;
1775 gfc_namespace
*saved_ns
;
1777 if (c
->ext
.block
.assoc
)
1778 blocktype
= "ASSOCIATE";
1780 blocktype
= "BLOCK";
1782 fprintf (dumpfile
, "%s ", blocktype
);
1784 ns
= c
->ext
.block
.ns
;
1785 saved_ns
= gfc_current_ns
;
1786 gfc_current_ns
= ns
;
1787 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
1788 gfc_current_ns
= saved_ns
;
1789 show_code (show_level
, ns
->code
);
1792 fprintf (dumpfile
, "END %s ", blocktype
);
1798 fputs ("SELECT CASE ", dumpfile
);
1799 show_expr (c
->expr1
);
1800 fputc ('\n', dumpfile
);
1802 for (; d
; d
= d
->block
)
1804 code_indent (level
, 0);
1806 fputs ("CASE ", dumpfile
);
1807 for (cp
= d
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
1809 fputc ('(', dumpfile
);
1810 show_expr (cp
->low
);
1811 fputc (' ', dumpfile
);
1812 show_expr (cp
->high
);
1813 fputc (')', dumpfile
);
1814 fputc (' ', dumpfile
);
1816 fputc ('\n', dumpfile
);
1818 show_code (level
+ 1, d
->next
);
1821 code_indent (level
, c
->label1
);
1822 fputs ("END SELECT", dumpfile
);
1826 fputs ("WHERE ", dumpfile
);
1829 show_expr (d
->expr1
);
1830 fputc ('\n', dumpfile
);
1832 show_code (level
+ 1, d
->next
);
1834 for (d
= d
->block
; d
; d
= d
->block
)
1836 code_indent (level
, 0);
1837 fputs ("ELSE WHERE ", dumpfile
);
1838 show_expr (d
->expr1
);
1839 fputc ('\n', dumpfile
);
1840 show_code (level
+ 1, d
->next
);
1843 code_indent (level
, 0);
1844 fputs ("END WHERE", dumpfile
);
1849 fputs ("FORALL ", dumpfile
);
1850 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1852 show_expr (fa
->var
);
1853 fputc (' ', dumpfile
);
1854 show_expr (fa
->start
);
1855 fputc (':', dumpfile
);
1856 show_expr (fa
->end
);
1857 fputc (':', dumpfile
);
1858 show_expr (fa
->stride
);
1860 if (fa
->next
!= NULL
)
1861 fputc (',', dumpfile
);
1864 if (c
->expr1
!= NULL
)
1866 fputc (',', dumpfile
);
1867 show_expr (c
->expr1
);
1869 fputc ('\n', dumpfile
);
1871 show_code (level
+ 1, c
->block
->next
);
1873 code_indent (level
, 0);
1874 fputs ("END FORALL", dumpfile
);
1878 fputs ("CRITICAL\n", dumpfile
);
1879 show_code (level
+ 1, c
->block
->next
);
1880 code_indent (level
, 0);
1881 fputs ("END CRITICAL", dumpfile
);
1885 fputs ("DO ", dumpfile
);
1887 fprintf (dumpfile
, " %-5d ", c
->label1
->value
);
1889 show_expr (c
->ext
.iterator
->var
);
1890 fputc ('=', dumpfile
);
1891 show_expr (c
->ext
.iterator
->start
);
1892 fputc (' ', dumpfile
);
1893 show_expr (c
->ext
.iterator
->end
);
1894 fputc (' ', dumpfile
);
1895 show_expr (c
->ext
.iterator
->step
);
1898 show_code (level
+ 1, c
->block
->next
);
1905 fputs ("END DO", dumpfile
);
1908 case EXEC_DO_CONCURRENT
:
1909 fputs ("DO CONCURRENT ", dumpfile
);
1910 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1912 show_expr (fa
->var
);
1913 fputc (' ', dumpfile
);
1914 show_expr (fa
->start
);
1915 fputc (':', dumpfile
);
1916 show_expr (fa
->end
);
1917 fputc (':', dumpfile
);
1918 show_expr (fa
->stride
);
1920 if (fa
->next
!= NULL
)
1921 fputc (',', dumpfile
);
1923 show_expr (c
->expr1
);
1925 show_code (level
+ 1, c
->block
->next
);
1926 code_indent (level
, c
->label1
);
1927 fputs ("END DO", dumpfile
);
1931 fputs ("DO WHILE ", dumpfile
);
1932 show_expr (c
->expr1
);
1933 fputc ('\n', dumpfile
);
1935 show_code (level
+ 1, c
->block
->next
);
1937 code_indent (level
, c
->label1
);
1938 fputs ("END DO", dumpfile
);
1942 fputs ("CYCLE", dumpfile
);
1944 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1948 fputs ("EXIT", dumpfile
);
1950 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1954 fputs ("ALLOCATE ", dumpfile
);
1957 fputs (" STAT=", dumpfile
);
1958 show_expr (c
->expr1
);
1963 fputs (" ERRMSG=", dumpfile
);
1964 show_expr (c
->expr2
);
1970 fputs (" MOLD=", dumpfile
);
1972 fputs (" SOURCE=", dumpfile
);
1973 show_expr (c
->expr3
);
1976 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
1978 fputc (' ', dumpfile
);
1979 show_expr (a
->expr
);
1984 case EXEC_DEALLOCATE
:
1985 fputs ("DEALLOCATE ", dumpfile
);
1988 fputs (" STAT=", dumpfile
);
1989 show_expr (c
->expr1
);
1994 fputs (" ERRMSG=", dumpfile
);
1995 show_expr (c
->expr2
);
1998 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
2000 fputc (' ', dumpfile
);
2001 show_expr (a
->expr
);
2007 fputs ("OPEN", dumpfile
);
2012 fputs (" UNIT=", dumpfile
);
2013 show_expr (open
->unit
);
2017 fputs (" IOMSG=", dumpfile
);
2018 show_expr (open
->iomsg
);
2022 fputs (" IOSTAT=", dumpfile
);
2023 show_expr (open
->iostat
);
2027 fputs (" FILE=", dumpfile
);
2028 show_expr (open
->file
);
2032 fputs (" STATUS=", dumpfile
);
2033 show_expr (open
->status
);
2037 fputs (" ACCESS=", dumpfile
);
2038 show_expr (open
->access
);
2042 fputs (" FORM=", dumpfile
);
2043 show_expr (open
->form
);
2047 fputs (" RECL=", dumpfile
);
2048 show_expr (open
->recl
);
2052 fputs (" BLANK=", dumpfile
);
2053 show_expr (open
->blank
);
2057 fputs (" POSITION=", dumpfile
);
2058 show_expr (open
->position
);
2062 fputs (" ACTION=", dumpfile
);
2063 show_expr (open
->action
);
2067 fputs (" DELIM=", dumpfile
);
2068 show_expr (open
->delim
);
2072 fputs (" PAD=", dumpfile
);
2073 show_expr (open
->pad
);
2077 fputs (" DECIMAL=", dumpfile
);
2078 show_expr (open
->decimal
);
2082 fputs (" ENCODING=", dumpfile
);
2083 show_expr (open
->encoding
);
2087 fputs (" ROUND=", dumpfile
);
2088 show_expr (open
->round
);
2092 fputs (" SIGN=", dumpfile
);
2093 show_expr (open
->sign
);
2097 fputs (" CONVERT=", dumpfile
);
2098 show_expr (open
->convert
);
2100 if (open
->asynchronous
)
2102 fputs (" ASYNCHRONOUS=", dumpfile
);
2103 show_expr (open
->asynchronous
);
2105 if (open
->err
!= NULL
)
2106 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
2111 fputs ("CLOSE", dumpfile
);
2112 close
= c
->ext
.close
;
2116 fputs (" UNIT=", dumpfile
);
2117 show_expr (close
->unit
);
2121 fputs (" IOMSG=", dumpfile
);
2122 show_expr (close
->iomsg
);
2126 fputs (" IOSTAT=", dumpfile
);
2127 show_expr (close
->iostat
);
2131 fputs (" STATUS=", dumpfile
);
2132 show_expr (close
->status
);
2134 if (close
->err
!= NULL
)
2135 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
2138 case EXEC_BACKSPACE
:
2139 fputs ("BACKSPACE", dumpfile
);
2143 fputs ("ENDFILE", dumpfile
);
2147 fputs ("REWIND", dumpfile
);
2151 fputs ("FLUSH", dumpfile
);
2154 fp
= c
->ext
.filepos
;
2158 fputs (" UNIT=", dumpfile
);
2159 show_expr (fp
->unit
);
2163 fputs (" IOMSG=", dumpfile
);
2164 show_expr (fp
->iomsg
);
2168 fputs (" IOSTAT=", dumpfile
);
2169 show_expr (fp
->iostat
);
2171 if (fp
->err
!= NULL
)
2172 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
2176 fputs ("INQUIRE", dumpfile
);
2181 fputs (" UNIT=", dumpfile
);
2182 show_expr (i
->unit
);
2186 fputs (" FILE=", dumpfile
);
2187 show_expr (i
->file
);
2192 fputs (" IOMSG=", dumpfile
);
2193 show_expr (i
->iomsg
);
2197 fputs (" IOSTAT=", dumpfile
);
2198 show_expr (i
->iostat
);
2202 fputs (" EXIST=", dumpfile
);
2203 show_expr (i
->exist
);
2207 fputs (" OPENED=", dumpfile
);
2208 show_expr (i
->opened
);
2212 fputs (" NUMBER=", dumpfile
);
2213 show_expr (i
->number
);
2217 fputs (" NAMED=", dumpfile
);
2218 show_expr (i
->named
);
2222 fputs (" NAME=", dumpfile
);
2223 show_expr (i
->name
);
2227 fputs (" ACCESS=", dumpfile
);
2228 show_expr (i
->access
);
2232 fputs (" SEQUENTIAL=", dumpfile
);
2233 show_expr (i
->sequential
);
2238 fputs (" DIRECT=", dumpfile
);
2239 show_expr (i
->direct
);
2243 fputs (" FORM=", dumpfile
);
2244 show_expr (i
->form
);
2248 fputs (" FORMATTED", dumpfile
);
2249 show_expr (i
->formatted
);
2253 fputs (" UNFORMATTED=", dumpfile
);
2254 show_expr (i
->unformatted
);
2258 fputs (" RECL=", dumpfile
);
2259 show_expr (i
->recl
);
2263 fputs (" NEXTREC=", dumpfile
);
2264 show_expr (i
->nextrec
);
2268 fputs (" BLANK=", dumpfile
);
2269 show_expr (i
->blank
);
2273 fputs (" POSITION=", dumpfile
);
2274 show_expr (i
->position
);
2278 fputs (" ACTION=", dumpfile
);
2279 show_expr (i
->action
);
2283 fputs (" READ=", dumpfile
);
2284 show_expr (i
->read
);
2288 fputs (" WRITE=", dumpfile
);
2289 show_expr (i
->write
);
2293 fputs (" READWRITE=", dumpfile
);
2294 show_expr (i
->readwrite
);
2298 fputs (" DELIM=", dumpfile
);
2299 show_expr (i
->delim
);
2303 fputs (" PAD=", dumpfile
);
2308 fputs (" CONVERT=", dumpfile
);
2309 show_expr (i
->convert
);
2311 if (i
->asynchronous
)
2313 fputs (" ASYNCHRONOUS=", dumpfile
);
2314 show_expr (i
->asynchronous
);
2318 fputs (" DECIMAL=", dumpfile
);
2319 show_expr (i
->decimal
);
2323 fputs (" ENCODING=", dumpfile
);
2324 show_expr (i
->encoding
);
2328 fputs (" PENDING=", dumpfile
);
2329 show_expr (i
->pending
);
2333 fputs (" ROUND=", dumpfile
);
2334 show_expr (i
->round
);
2338 fputs (" SIGN=", dumpfile
);
2339 show_expr (i
->sign
);
2343 fputs (" SIZE=", dumpfile
);
2344 show_expr (i
->size
);
2348 fputs (" ID=", dumpfile
);
2353 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
2357 fputs ("IOLENGTH ", dumpfile
);
2358 show_expr (c
->expr1
);
2363 fputs ("READ", dumpfile
);
2367 fputs ("WRITE", dumpfile
);
2373 fputs (" UNIT=", dumpfile
);
2374 show_expr (dt
->io_unit
);
2377 if (dt
->format_expr
)
2379 fputs (" FMT=", dumpfile
);
2380 show_expr (dt
->format_expr
);
2383 if (dt
->format_label
!= NULL
)
2384 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
2386 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
2390 fputs (" IOMSG=", dumpfile
);
2391 show_expr (dt
->iomsg
);
2395 fputs (" IOSTAT=", dumpfile
);
2396 show_expr (dt
->iostat
);
2400 fputs (" SIZE=", dumpfile
);
2401 show_expr (dt
->size
);
2405 fputs (" REC=", dumpfile
);
2406 show_expr (dt
->rec
);
2410 fputs (" ADVANCE=", dumpfile
);
2411 show_expr (dt
->advance
);
2415 fputs (" ID=", dumpfile
);
2420 fputs (" POS=", dumpfile
);
2421 show_expr (dt
->pos
);
2423 if (dt
->asynchronous
)
2425 fputs (" ASYNCHRONOUS=", dumpfile
);
2426 show_expr (dt
->asynchronous
);
2430 fputs (" BLANK=", dumpfile
);
2431 show_expr (dt
->blank
);
2435 fputs (" DECIMAL=", dumpfile
);
2436 show_expr (dt
->decimal
);
2440 fputs (" DELIM=", dumpfile
);
2441 show_expr (dt
->delim
);
2445 fputs (" PAD=", dumpfile
);
2446 show_expr (dt
->pad
);
2450 fputs (" ROUND=", dumpfile
);
2451 show_expr (dt
->round
);
2455 fputs (" SIGN=", dumpfile
);
2456 show_expr (dt
->sign
);
2460 for (c
= c
->block
->next
; c
; c
= c
->next
)
2461 show_code_node (level
+ (c
->next
!= NULL
), c
);
2465 fputs ("TRANSFER ", dumpfile
);
2466 show_expr (c
->expr1
);
2470 fputs ("DT_END", dumpfile
);
2473 if (dt
->err
!= NULL
)
2474 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
2475 if (dt
->end
!= NULL
)
2476 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
2477 if (dt
->eor
!= NULL
)
2478 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
2481 case EXEC_OACC_PARALLEL_LOOP
:
2482 case EXEC_OACC_PARALLEL
:
2483 case EXEC_OACC_KERNELS_LOOP
:
2484 case EXEC_OACC_KERNELS
:
2485 case EXEC_OACC_DATA
:
2486 case EXEC_OACC_HOST_DATA
:
2487 case EXEC_OACC_LOOP
:
2488 case EXEC_OACC_UPDATE
:
2489 case EXEC_OACC_WAIT
:
2490 case EXEC_OACC_CACHE
:
2491 case EXEC_OACC_ENTER_DATA
:
2492 case EXEC_OACC_EXIT_DATA
:
2493 case EXEC_OMP_ATOMIC
:
2494 case EXEC_OMP_CANCEL
:
2495 case EXEC_OMP_CANCELLATION_POINT
:
2496 case EXEC_OMP_BARRIER
:
2497 case EXEC_OMP_CRITICAL
:
2498 case EXEC_OMP_FLUSH
:
2500 case EXEC_OMP_DO_SIMD
:
2501 case EXEC_OMP_MASTER
:
2502 case EXEC_OMP_ORDERED
:
2503 case EXEC_OMP_PARALLEL
:
2504 case EXEC_OMP_PARALLEL_DO
:
2505 case EXEC_OMP_PARALLEL_DO_SIMD
:
2506 case EXEC_OMP_PARALLEL_SECTIONS
:
2507 case EXEC_OMP_PARALLEL_WORKSHARE
:
2508 case EXEC_OMP_SECTIONS
:
2510 case EXEC_OMP_SINGLE
:
2512 case EXEC_OMP_TASKGROUP
:
2513 case EXEC_OMP_TASKWAIT
:
2514 case EXEC_OMP_TASKYIELD
:
2515 case EXEC_OMP_WORKSHARE
:
2516 show_omp_node (level
, c
);
2520 gfc_internal_error ("show_code_node(): Bad statement code");
2525 /* Show an equivalence chain. */
2528 show_equiv (gfc_equiv
*eq
)
2531 fputs ("Equivalence: ", dumpfile
);
2534 show_expr (eq
->expr
);
2537 fputs (", ", dumpfile
);
2542 /* Show a freakin' whole namespace. */
2545 show_namespace (gfc_namespace
*ns
)
2547 gfc_interface
*intr
;
2548 gfc_namespace
*save
;
2554 save
= gfc_current_ns
;
2557 fputs ("Namespace:", dumpfile
);
2563 while (i
< GFC_LETTERS
- 1
2564 && gfc_compare_types (&ns
->default_type
[i
+1],
2565 &ns
->default_type
[l
]))
2569 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
2571 fprintf (dumpfile
, " %c: ", l
+'A');
2573 show_typespec(&ns
->default_type
[l
]);
2575 } while (i
< GFC_LETTERS
);
2577 if (ns
->proc_name
!= NULL
)
2580 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
2584 gfc_current_ns
= ns
;
2585 gfc_traverse_symtree (ns
->common_root
, show_common
);
2587 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2589 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
2591 /* User operator interfaces */
2597 fprintf (dumpfile
, "Operator interfaces for %s:",
2598 gfc_op2string ((gfc_intrinsic_op
) op
));
2600 for (; intr
; intr
= intr
->next
)
2601 fprintf (dumpfile
, " %s", intr
->sym
->name
);
2604 if (ns
->uop_root
!= NULL
)
2607 fputs ("User operators:\n", dumpfile
);
2608 gfc_traverse_user_op (ns
, show_uop
);
2611 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
2614 if (ns
->oacc_declare
)
2616 struct gfc_oacc_declare
*decl
;
2617 /* Dump !$ACC DECLARE clauses. */
2618 for (decl
= ns
->oacc_declare
; decl
; decl
= decl
->next
)
2621 fprintf (dumpfile
, "!$ACC DECLARE");
2622 show_omp_clauses (decl
->clauses
);
2626 fputc ('\n', dumpfile
);
2628 fputs ("code:", dumpfile
);
2629 show_code (show_level
, ns
->code
);
2632 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
2634 fputs ("\nCONTAINS\n", dumpfile
);
2636 show_namespace (ns
);
2640 fputc ('\n', dumpfile
);
2641 gfc_current_ns
= save
;
2645 /* Main function for dumping a parse tree. */
2648 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
2651 show_namespace (ns
);