2 Copyright (C) 2003-2021 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"
40 /* Keep track of indentation for symbol tree dumps. */
41 static int show_level
= 0;
43 /* The file handle we're dumping to is kept in a static variable. This
44 is not too cool, but it avoids a lot of passing it around. */
45 static FILE *dumpfile
;
47 /* Forward declaration of some of the functions. */
48 static void show_expr (gfc_expr
*p
);
49 static void show_code_node (int, gfc_code
*);
50 static void show_namespace (gfc_namespace
*ns
);
51 static void show_code (int, gfc_code
*);
52 static void show_symbol (gfc_symbol
*);
53 static void show_typespec (gfc_typespec
*);
54 static void show_ref (gfc_ref
*);
55 static void show_attr (symbol_attribute
*, const char *);
57 /* Allow dumping of an expression in the debugger. */
58 void gfc_debug_expr (gfc_expr
*);
60 void debug (symbol_attribute
*attr
)
64 show_attr (attr
, NULL
);
65 fputc ('\n', dumpfile
);
69 void debug (gfc_formal_arglist
*formal
)
73 for (; formal
; formal
= formal
->next
)
75 fputc ('\n', dumpfile
);
76 show_symbol (formal
->sym
);
78 fputc ('\n', dumpfile
);
82 void debug (symbol_attribute attr
)
87 void debug (gfc_expr
*e
)
94 fputc (' ', dumpfile
);
95 show_typespec (&e
->ts
);
98 fputs ("() ", dumpfile
);
100 fputc ('\n', dumpfile
);
104 void debug (gfc_typespec
*ts
)
106 FILE *tmp
= dumpfile
;
109 fputc ('\n', dumpfile
);
113 void debug (gfc_typespec ts
)
118 void debug (gfc_ref
*p
)
120 FILE *tmp
= dumpfile
;
123 fputc ('\n', dumpfile
);
128 gfc_debug_expr (gfc_expr
*e
)
130 FILE *tmp
= dumpfile
;
133 fputc ('\n', dumpfile
);
137 /* Allow for dumping of a piece of code in the debugger. */
138 void gfc_debug_code (gfc_code
*c
);
141 gfc_debug_code (gfc_code
*c
)
143 FILE *tmp
= dumpfile
;
146 fputc ('\n', dumpfile
);
150 void debug (gfc_symbol
*sym
)
152 FILE *tmp
= dumpfile
;
155 fputc ('\n', dumpfile
);
159 /* Do indentation for a specific level. */
162 code_indent (int level
, gfc_st_label
*label
)
167 fprintf (dumpfile
, "%-5d ", label
->value
);
169 for (i
= 0; i
< (2 * level
- (label
? 6 : 0)); i
++)
170 fputc (' ', dumpfile
);
174 /* Simple indentation at the current level. This one
175 is used to show symbols. */
180 fputc ('\n', dumpfile
);
181 code_indent (show_level
, NULL
);
185 /* Show type-specific information. */
188 show_typespec (gfc_typespec
*ts
)
190 if (ts
->type
== BT_ASSUMED
)
192 fputs ("(TYPE(*))", dumpfile
);
196 fprintf (dumpfile
, "(%s ", gfc_basic_typename (ts
->type
));
203 fprintf (dumpfile
, "%s", ts
->u
.derived
->name
);
208 show_expr (ts
->u
.cl
->length
);
209 fprintf(dumpfile
, " %d", ts
->kind
);
213 fprintf (dumpfile
, "%d", ts
->kind
);
216 if (ts
->is_c_interop
)
217 fputs (" C_INTEROP", dumpfile
);
220 fputs (" ISO_C", dumpfile
);
223 fputs (" DEFERRED", dumpfile
);
225 fputc (')', dumpfile
);
229 /* Show an actual argument list. */
232 show_actual_arglist (gfc_actual_arglist
*a
)
234 fputc ('(', dumpfile
);
236 for (; a
; a
= a
->next
)
238 fputc ('(', dumpfile
);
240 fprintf (dumpfile
, "%s = ", a
->name
);
244 fputs ("(arg not-present)", dumpfile
);
246 fputc (')', dumpfile
);
248 fputc (' ', dumpfile
);
251 fputc (')', dumpfile
);
255 /* Show a gfc_array_spec array specification structure. */
258 show_array_spec (gfc_array_spec
*as
)
265 fputs ("()", dumpfile
);
269 fprintf (dumpfile
, "(%d [%d]", as
->rank
, as
->corank
);
271 if (as
->rank
+ as
->corank
> 0 || as
->rank
== -1)
275 case AS_EXPLICIT
: c
= "AS_EXPLICIT"; break;
276 case AS_DEFERRED
: c
= "AS_DEFERRED"; break;
277 case AS_ASSUMED_SIZE
: c
= "AS_ASSUMED_SIZE"; break;
278 case AS_ASSUMED_SHAPE
: c
= "AS_ASSUMED_SHAPE"; break;
279 case AS_ASSUMED_RANK
: c
= "AS_ASSUMED_RANK"; break;
281 gfc_internal_error ("show_array_spec(): Unhandled array shape "
284 fprintf (dumpfile
, " %s ", c
);
286 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
288 show_expr (as
->lower
[i
]);
289 fputc (' ', dumpfile
);
290 show_expr (as
->upper
[i
]);
291 fputc (' ', dumpfile
);
295 fputc (')', dumpfile
);
299 /* Show a gfc_array_ref array reference structure. */
302 show_array_ref (gfc_array_ref
* ar
)
306 fputc ('(', dumpfile
);
311 fputs ("FULL", dumpfile
);
315 for (i
= 0; i
< ar
->dimen
; i
++)
317 /* There are two types of array sections: either the
318 elements are identified by an integer array ('vector'),
319 or by an index range. In the former case we only have to
320 print the start expression which contains the vector, in
321 the latter case we have to print any of lower and upper
322 bound and the stride, if they're present. */
324 if (ar
->start
[i
] != NULL
)
325 show_expr (ar
->start
[i
]);
327 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
329 fputc (':', dumpfile
);
331 if (ar
->end
[i
] != NULL
)
332 show_expr (ar
->end
[i
]);
334 if (ar
->stride
[i
] != NULL
)
336 fputc (':', dumpfile
);
337 show_expr (ar
->stride
[i
]);
341 if (i
!= ar
->dimen
- 1)
342 fputs (" , ", dumpfile
);
347 for (i
= 0; i
< ar
->dimen
; i
++)
349 show_expr (ar
->start
[i
]);
350 if (i
!= ar
->dimen
- 1)
351 fputs (" , ", dumpfile
);
356 fputs ("UNKNOWN", dumpfile
);
360 gfc_internal_error ("show_array_ref(): Unknown array reference");
363 fputc (')', dumpfile
);
364 if (ar
->codimen
== 0)
367 /* Show coarray part of the reference, if any. */
368 fputc ('[',dumpfile
);
369 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
371 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
373 else if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
374 fputs("THIS_IMAGE", dumpfile
);
377 show_expr (ar
->start
[i
]);
380 fputc(':', dumpfile
);
381 show_expr (ar
->end
[i
]);
384 if (i
!= ar
->dimen
+ ar
->codimen
- 1)
385 fputs (" , ", dumpfile
);
388 fputc (']',dumpfile
);
392 /* Show a list of gfc_ref structures. */
395 show_ref (gfc_ref
*p
)
397 for (; p
; p
= p
->next
)
401 show_array_ref (&p
->u
.ar
);
405 fprintf (dumpfile
, " %% %s", p
->u
.c
.component
->name
);
409 fputc ('(', dumpfile
);
410 show_expr (p
->u
.ss
.start
);
411 fputc (':', dumpfile
);
412 show_expr (p
->u
.ss
.end
);
413 fputc (')', dumpfile
);
420 fprintf (dumpfile
, " INQUIRY_KIND ");
423 fprintf (dumpfile
, " INQUIRY_LEN ");
426 fprintf (dumpfile
, " INQUIRY_RE ");
429 fprintf (dumpfile
, " INQUIRY_IM ");
434 gfc_internal_error ("show_ref(): Bad component code");
439 /* Display a constructor. Works recursively for array constructors. */
442 show_constructor (gfc_constructor_base base
)
445 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
447 if (c
->iterator
== NULL
)
451 fputc ('(', dumpfile
);
454 fputc (' ', dumpfile
);
455 show_expr (c
->iterator
->var
);
456 fputc ('=', dumpfile
);
457 show_expr (c
->iterator
->start
);
458 fputc (',', dumpfile
);
459 show_expr (c
->iterator
->end
);
460 fputc (',', dumpfile
);
461 show_expr (c
->iterator
->step
);
463 fputc (')', dumpfile
);
466 if (gfc_constructor_next (c
) != NULL
)
467 fputs (" , ", dumpfile
);
473 show_char_const (const gfc_char_t
*c
, gfc_charlen_t length
)
475 fputc ('\'', dumpfile
);
476 for (size_t i
= 0; i
< (size_t) length
; i
++)
479 fputs ("''", dumpfile
);
481 fputs (gfc_print_wide_char (c
[i
]), dumpfile
);
483 fputc ('\'', dumpfile
);
487 /* Show a component-call expression. */
490 show_compcall (gfc_expr
* p
)
492 gcc_assert (p
->expr_type
== EXPR_COMPCALL
);
494 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
496 fprintf (dumpfile
, "%s", p
->value
.compcall
.name
);
498 show_actual_arglist (p
->value
.compcall
.actual
);
502 /* Show an expression. */
505 show_expr (gfc_expr
*p
)
512 fputs ("()", dumpfile
);
516 switch (p
->expr_type
)
519 show_char_const (p
->value
.character
.string
, p
->value
.character
.length
);
524 fprintf (dumpfile
, "%s(", p
->ts
.u
.derived
->name
);
525 show_constructor (p
->value
.constructor
);
526 fputc (')', dumpfile
);
530 fputs ("(/ ", dumpfile
);
531 show_constructor (p
->value
.constructor
);
532 fputs (" /)", dumpfile
);
538 fputs ("NULL()", dumpfile
);
545 mpz_out_str (dumpfile
, 10, p
->value
.integer
);
547 if (p
->ts
.kind
!= gfc_default_integer_kind
)
548 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
552 if (p
->value
.logical
)
553 fputs (".true.", dumpfile
);
555 fputs (".false.", dumpfile
);
559 mpfr_out_str (dumpfile
, 10, 0, p
->value
.real
, GFC_RND_MODE
);
560 if (p
->ts
.kind
!= gfc_default_real_kind
)
561 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
565 show_char_const (p
->value
.character
.string
,
566 p
->value
.character
.length
);
570 fputs ("(complex ", dumpfile
);
572 mpfr_out_str (dumpfile
, 10, 0, mpc_realref (p
->value
.complex),
574 if (p
->ts
.kind
!= gfc_default_complex_kind
)
575 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
577 fputc (' ', dumpfile
);
579 mpfr_out_str (dumpfile
, 10, 0, mpc_imagref (p
->value
.complex),
581 if (p
->ts
.kind
!= gfc_default_complex_kind
)
582 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
584 fputc (')', dumpfile
);
589 fputs ("b'", dumpfile
);
590 else if (p
->boz
.rdx
== 8)
591 fputs ("o'", dumpfile
);
593 fputs ("z'", dumpfile
);
594 fprintf (dumpfile
, "%s'", p
->boz
.str
);
598 fprintf (dumpfile
, HOST_WIDE_INT_PRINT_DEC
"H",
599 p
->representation
.length
);
600 c
= p
->representation
.string
;
601 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
603 fputc (*c
, dumpfile
);
608 fputs ("???", dumpfile
);
612 if (p
->representation
.string
)
614 fputs (" {", dumpfile
);
615 c
= p
->representation
.string
;
616 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
618 fprintf (dumpfile
, "%.2x", (unsigned int) *c
);
619 if (i
< p
->representation
.length
- 1)
620 fputc (',', dumpfile
);
622 fputc ('}', dumpfile
);
628 if (p
->symtree
->n
.sym
->ns
&& p
->symtree
->n
.sym
->ns
->proc_name
)
629 fprintf (dumpfile
, "%s:", p
->symtree
->n
.sym
->ns
->proc_name
->name
);
630 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
635 fputc ('(', dumpfile
);
636 switch (p
->value
.op
.op
)
638 case INTRINSIC_UPLUS
:
639 fputs ("U+ ", dumpfile
);
641 case INTRINSIC_UMINUS
:
642 fputs ("U- ", dumpfile
);
645 fputs ("+ ", dumpfile
);
647 case INTRINSIC_MINUS
:
648 fputs ("- ", dumpfile
);
650 case INTRINSIC_TIMES
:
651 fputs ("* ", dumpfile
);
653 case INTRINSIC_DIVIDE
:
654 fputs ("/ ", dumpfile
);
656 case INTRINSIC_POWER
:
657 fputs ("** ", dumpfile
);
659 case INTRINSIC_CONCAT
:
660 fputs ("// ", dumpfile
);
663 fputs ("AND ", dumpfile
);
666 fputs ("OR ", dumpfile
);
669 fputs ("EQV ", dumpfile
);
672 fputs ("NEQV ", dumpfile
);
675 case INTRINSIC_EQ_OS
:
676 fputs ("== ", dumpfile
);
679 case INTRINSIC_NE_OS
:
680 fputs ("/= ", dumpfile
);
683 case INTRINSIC_GT_OS
:
684 fputs ("> ", dumpfile
);
687 case INTRINSIC_GE_OS
:
688 fputs (">= ", dumpfile
);
691 case INTRINSIC_LT_OS
:
692 fputs ("< ", dumpfile
);
695 case INTRINSIC_LE_OS
:
696 fputs ("<= ", dumpfile
);
699 fputs ("NOT ", dumpfile
);
701 case INTRINSIC_PARENTHESES
:
702 fputs ("parens ", dumpfile
);
707 ("show_expr(): Bad intrinsic in expression");
710 show_expr (p
->value
.op
.op1
);
714 fputc (' ', dumpfile
);
715 show_expr (p
->value
.op
.op2
);
718 fputc (')', dumpfile
);
722 if (p
->value
.function
.name
== NULL
)
724 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
725 if (gfc_is_proc_ptr_comp (p
))
727 fputc ('[', dumpfile
);
728 show_actual_arglist (p
->value
.function
.actual
);
729 fputc (']', dumpfile
);
733 fprintf (dumpfile
, "%s", p
->value
.function
.name
);
734 if (gfc_is_proc_ptr_comp (p
))
736 fputc ('[', dumpfile
);
737 fputc ('[', dumpfile
);
738 show_actual_arglist (p
->value
.function
.actual
);
739 fputc (']', dumpfile
);
740 fputc (']', dumpfile
);
750 gfc_internal_error ("show_expr(): Don't know how to show expr");
754 /* Show symbol attributes. The flavor and intent are followed by
755 whatever single bit attributes are present. */
758 show_attr (symbol_attribute
*attr
, const char * module
)
760 if (attr
->flavor
!= FL_UNKNOWN
)
762 if (attr
->flavor
== FL_DERIVED
&& attr
->pdt_template
)
763 fputs (" (PDT-TEMPLATE", dumpfile
);
765 fprintf (dumpfile
, "(%s ", gfc_code2string (flavors
, attr
->flavor
));
767 if (attr
->access
!= ACCESS_UNKNOWN
)
768 fprintf (dumpfile
, "%s ", gfc_code2string (access_types
, attr
->access
));
769 if (attr
->proc
!= PROC_UNKNOWN
)
770 fprintf (dumpfile
, "%s ", gfc_code2string (procedures
, attr
->proc
));
771 if (attr
->save
!= SAVE_NONE
)
772 fprintf (dumpfile
, "%s", gfc_code2string (save_status
, attr
->save
));
774 if (attr
->artificial
)
775 fputs (" ARTIFICIAL", dumpfile
);
776 if (attr
->allocatable
)
777 fputs (" ALLOCATABLE", dumpfile
);
778 if (attr
->asynchronous
)
779 fputs (" ASYNCHRONOUS", dumpfile
);
780 if (attr
->codimension
)
781 fputs (" CODIMENSION", dumpfile
);
783 fputs (" DIMENSION", dumpfile
);
784 if (attr
->contiguous
)
785 fputs (" CONTIGUOUS", dumpfile
);
787 fputs (" EXTERNAL", dumpfile
);
789 fputs (" INTRINSIC", dumpfile
);
791 fputs (" OPTIONAL", dumpfile
);
793 fputs (" KIND", dumpfile
);
795 fputs (" LEN", dumpfile
);
797 fputs (" POINTER", dumpfile
);
798 if (attr
->subref_array_pointer
)
799 fputs (" SUBREF-ARRAY-POINTER", dumpfile
);
800 if (attr
->cray_pointer
)
801 fputs (" CRAY-POINTER", dumpfile
);
802 if (attr
->cray_pointee
)
803 fputs (" CRAY-POINTEE", dumpfile
);
804 if (attr
->is_protected
)
805 fputs (" PROTECTED", dumpfile
);
807 fputs (" VALUE", dumpfile
);
809 fputs (" VOLATILE", dumpfile
);
810 if (attr
->threadprivate
)
811 fputs (" THREADPRIVATE", dumpfile
);
813 fputs (" TARGET", dumpfile
);
816 fputs (" DUMMY", dumpfile
);
817 if (attr
->intent
!= INTENT_UNKNOWN
)
818 fprintf (dumpfile
, "(%s)", gfc_intent_string (attr
->intent
));
822 fputs (" RESULT", dumpfile
);
824 fputs (" ENTRY", dumpfile
);
825 if (attr
->entry_master
)
826 fputs (" ENTRY-MASTER", dumpfile
);
827 if (attr
->mixed_entry_master
)
828 fputs (" MIXED-ENTRY-MASTER", dumpfile
);
830 fputs (" BIND(C)", dumpfile
);
833 fputs (" DATA", dumpfile
);
836 fputs (" USE-ASSOC", dumpfile
);
838 fprintf (dumpfile
, "(%s)", module
);
841 if (attr
->in_namelist
)
842 fputs (" IN-NAMELIST", dumpfile
);
844 fputs (" IN-COMMON", dumpfile
);
847 fputs (" ABSTRACT", dumpfile
);
849 fputs (" FUNCTION", dumpfile
);
850 if (attr
->subroutine
)
851 fputs (" SUBROUTINE", dumpfile
);
852 if (attr
->implicit_type
)
853 fputs (" IMPLICIT-TYPE", dumpfile
);
856 fputs (" SEQUENCE", dumpfile
);
857 if (attr
->alloc_comp
)
858 fputs (" ALLOC-COMP", dumpfile
);
859 if (attr
->pointer_comp
)
860 fputs (" POINTER-COMP", dumpfile
);
861 if (attr
->proc_pointer_comp
)
862 fputs (" PROC-POINTER-COMP", dumpfile
);
863 if (attr
->private_comp
)
864 fputs (" PRIVATE-COMP", dumpfile
);
866 fputs (" ZERO-COMP", dumpfile
);
867 if (attr
->coarray_comp
)
868 fputs (" COARRAY-COMP", dumpfile
);
870 fputs (" LOCK-COMP", dumpfile
);
871 if (attr
->event_comp
)
872 fputs (" EVENT-COMP", dumpfile
);
873 if (attr
->defined_assign_comp
)
874 fputs (" DEFINED-ASSIGNED-COMP", dumpfile
);
875 if (attr
->unlimited_polymorphic
)
876 fputs (" UNLIMITED-POLYMORPHIC", dumpfile
);
877 if (attr
->has_dtio_procs
)
878 fputs (" HAS-DTIO-PROCS", dumpfile
);
880 fputs (" CAF-TOKEN", dumpfile
);
881 if (attr
->select_type_temporary
)
882 fputs (" SELECT-TYPE-TEMPORARY", dumpfile
);
883 if (attr
->associate_var
)
884 fputs (" ASSOCIATE-VAR", dumpfile
);
886 fputs (" PDT-KIND", dumpfile
);
888 fputs (" PDT-LEN", dumpfile
);
890 fputs (" PDT-TYPE", dumpfile
);
892 fputs (" PDT-ARRAY", dumpfile
);
893 if (attr
->pdt_string
)
894 fputs (" PDT-STRING", dumpfile
);
895 if (attr
->omp_udr_artificial_var
)
896 fputs (" OMP-UDT-ARTIFICIAL-VAR", dumpfile
);
897 if (attr
->omp_declare_target
)
898 fputs (" OMP-DECLARE-TARGET", dumpfile
);
899 if (attr
->omp_declare_target_link
)
900 fputs (" OMP-DECLARE-TARGET-LINK", dumpfile
);
902 fputs (" ELEMENTAL", dumpfile
);
904 fputs (" PURE", dumpfile
);
905 if (attr
->implicit_pure
)
906 fputs (" IMPLICIT-PURE", dumpfile
);
908 fputs (" RECURSIVE", dumpfile
);
909 if (attr
->unmaskable
)
910 fputs (" UNMASKABKE", dumpfile
);
912 fputs (" MASKED", dumpfile
);
914 fputs (" CONTAINED", dumpfile
);
916 fputs (" MOD-PROC", dumpfile
);
917 if (attr
->module_procedure
)
918 fputs (" MODULE-PROCEDURE", dumpfile
);
919 if (attr
->public_used
)
920 fputs (" PUBLIC_USED", dumpfile
);
921 if (attr
->array_outer_dependency
)
922 fputs (" ARRAY-OUTER-DEPENDENCY", dumpfile
);
924 fputs (" NORETURN", dumpfile
);
925 if (attr
->always_explicit
)
926 fputs (" ALWAYS-EXPLICIT", dumpfile
);
927 if (attr
->is_main_program
)
928 fputs (" IS-MAIN-PROGRAM", dumpfile
);
929 if (attr
->oacc_routine_nohost
)
930 fputs (" OACC-ROUTINE-NOHOST", dumpfile
);
932 /* FIXME: Still missing are oacc_routine_lop and ext_attr. */
933 fputc (')', dumpfile
);
937 /* Show components of a derived type. */
940 show_components (gfc_symbol
*sym
)
944 for (c
= sym
->components
; c
; c
= c
->next
)
947 fprintf (dumpfile
, "(%s ", c
->name
);
948 show_typespec (&c
->ts
);
951 fputs (" kind_expr: ", dumpfile
);
952 show_expr (c
->kind_expr
);
956 fputs ("PDT parameters", dumpfile
);
957 show_actual_arglist (c
->param_list
);
960 if (c
->attr
.allocatable
)
961 fputs (" ALLOCATABLE", dumpfile
);
962 if (c
->attr
.pdt_kind
)
963 fputs (" KIND", dumpfile
);
965 fputs (" LEN", dumpfile
);
967 fputs (" POINTER", dumpfile
);
968 if (c
->attr
.proc_pointer
)
969 fputs (" PPC", dumpfile
);
970 if (c
->attr
.dimension
)
971 fputs (" DIMENSION", dumpfile
);
972 fputc (' ', dumpfile
);
973 show_array_spec (c
->as
);
975 fprintf (dumpfile
, " %s", gfc_code2string (access_types
, c
->attr
.access
));
976 fputc (')', dumpfile
);
978 fputc (' ', dumpfile
);
983 /* Show the f2k_derived namespace with procedure bindings. */
986 show_typebound_proc (gfc_typebound_proc
* tb
, const char* name
)
991 fputs ("GENERIC", dumpfile
);
994 fputs ("PROCEDURE, ", dumpfile
);
996 fputs ("NOPASS", dumpfile
);
1000 fprintf (dumpfile
, "PASS(%s)", tb
->pass_arg
);
1002 fputs ("PASS", dumpfile
);
1004 if (tb
->non_overridable
)
1005 fputs (", NON_OVERRIDABLE", dumpfile
);
1008 if (tb
->access
== ACCESS_PUBLIC
)
1009 fputs (", PUBLIC", dumpfile
);
1011 fputs (", PRIVATE", dumpfile
);
1013 fprintf (dumpfile
, " :: %s => ", name
);
1018 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
1020 fputs (g
->specific_st
->name
, dumpfile
);
1022 fputs (", ", dumpfile
);
1026 fputs (tb
->u
.specific
->n
.sym
->name
, dumpfile
);
1030 show_typebound_symtree (gfc_symtree
* st
)
1032 gcc_assert (st
->n
.tb
);
1033 show_typebound_proc (st
->n
.tb
, st
->name
);
1037 show_f2k_derived (gfc_namespace
* f2k
)
1043 fputs ("Procedure bindings:", dumpfile
);
1046 /* Finalizer bindings. */
1047 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
1050 fprintf (dumpfile
, "FINAL %s", f
->proc_tree
->n
.sym
->name
);
1053 /* Type-bound procedures. */
1054 gfc_traverse_symtree (f2k
->tb_sym_root
, &show_typebound_symtree
);
1059 fputs ("Operator bindings:", dumpfile
);
1062 /* User-defined operators. */
1063 gfc_traverse_symtree (f2k
->tb_uop_root
, &show_typebound_symtree
);
1065 /* Intrinsic operators. */
1066 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
1068 show_typebound_proc (f2k
->tb_op
[op
],
1069 gfc_op2string ((gfc_intrinsic_op
) op
));
1075 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
1076 show the interface. Information needed to reconstruct the list of
1077 specific interfaces associated with a generic symbol is done within
1081 show_symbol (gfc_symbol
*sym
)
1083 gfc_formal_arglist
*formal
;
1084 gfc_interface
*intr
;
1090 fprintf (dumpfile
, "|| symbol: '%s' ", sym
->name
);
1091 len
= strlen (sym
->name
);
1092 for (i
=len
; i
<12; i
++)
1093 fputc(' ', dumpfile
);
1095 if (sym
->binding_label
)
1096 fprintf (dumpfile
,"|| binding_label: '%s' ", sym
->binding_label
);
1101 fputs ("type spec : ", dumpfile
);
1102 show_typespec (&sym
->ts
);
1105 fputs ("attributes: ", dumpfile
);
1106 show_attr (&sym
->attr
, sym
->module
);
1111 fputs ("value: ", dumpfile
);
1112 show_expr (sym
->value
);
1115 if (sym
->ts
.type
!= BT_CLASS
&& sym
->as
)
1118 fputs ("Array spec:", dumpfile
);
1119 show_array_spec (sym
->as
);
1121 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
1124 fputs ("Array spec:", dumpfile
);
1125 show_array_spec (CLASS_DATA (sym
)->as
);
1131 fputs ("Generic interfaces:", dumpfile
);
1132 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
1133 fprintf (dumpfile
, " %s", intr
->sym
->name
);
1139 fprintf (dumpfile
, "result: %s", sym
->result
->name
);
1142 if (sym
->components
)
1145 fputs ("components: ", dumpfile
);
1146 show_components (sym
);
1149 if (sym
->f2k_derived
)
1152 if (sym
->hash_value
)
1153 fprintf (dumpfile
, "hash: %d", sym
->hash_value
);
1154 show_f2k_derived (sym
->f2k_derived
);
1160 fputs ("Formal arglist:", dumpfile
);
1162 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
1164 if (formal
->sym
!= NULL
)
1165 fprintf (dumpfile
, " %s", formal
->sym
->name
);
1167 fputs (" [Alt Return]", dumpfile
);
1171 if (sym
->formal_ns
&& (sym
->formal_ns
->proc_name
!= sym
)
1172 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1173 && !sym
->attr
.entry
)
1176 fputs ("Formal namespace", dumpfile
);
1177 show_namespace (sym
->formal_ns
);
1180 if (sym
->attr
.flavor
== FL_VARIABLE
1184 fputs ("PDT parameters", dumpfile
);
1185 show_actual_arglist (sym
->param_list
);
1188 if (sym
->attr
.flavor
== FL_NAMELIST
)
1192 fputs ("variables : ", dumpfile
);
1193 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
1194 fprintf (dumpfile
, " %s",nl
->sym
->name
);
1201 /* Show a user-defined operator. Just prints an operator
1202 and the name of the associated subroutine, really. */
1205 show_uop (gfc_user_op
*uop
)
1207 gfc_interface
*intr
;
1210 fprintf (dumpfile
, "%s:", uop
->name
);
1212 for (intr
= uop
->op
; intr
; intr
= intr
->next
)
1213 fprintf (dumpfile
, " %s", intr
->sym
->name
);
1217 /* Workhorse function for traversing the user operator symtree. */
1220 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
1225 (*func
) (st
->n
.uop
);
1227 traverse_uop (st
->left
, func
);
1228 traverse_uop (st
->right
, func
);
1232 /* Traverse the tree of user operator nodes. */
1235 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
1237 traverse_uop (ns
->uop_root
, func
);
1241 /* Function to display a common block. */
1244 show_common (gfc_symtree
*st
)
1249 fprintf (dumpfile
, "common: /%s/ ", st
->name
);
1251 s
= st
->n
.common
->head
;
1254 fprintf (dumpfile
, "%s", s
->name
);
1257 fputs (", ", dumpfile
);
1259 fputc ('\n', dumpfile
);
1263 /* Worker function to display the symbol tree. */
1266 show_symtree (gfc_symtree
*st
)
1272 len
= strlen(st
->name
);
1273 fprintf (dumpfile
, "symtree: '%s'", st
->name
);
1275 for (i
=len
; i
<12; i
++)
1276 fputc(' ', dumpfile
);
1279 fputs( " Ambiguous", dumpfile
);
1281 if (st
->n
.sym
->ns
!= gfc_current_ns
)
1282 fprintf (dumpfile
, "|| symbol: '%s' from namespace '%s'", st
->n
.sym
->name
,
1283 st
->n
.sym
->ns
->proc_name
->name
);
1285 show_symbol (st
->n
.sym
);
1289 /******************* Show gfc_code structures **************/
1292 /* Show a list of code structures. Mutually recursive with
1293 show_code_node(). */
1296 show_code (int level
, gfc_code
*c
)
1298 for (; c
; c
= c
->next
)
1299 show_code_node (level
, c
);
1303 show_iterator (gfc_namespace
*ns
)
1305 for (gfc_symbol
*sym
= ns
->proc_name
; sym
; sym
= sym
->tlink
)
1308 if (sym
!= ns
->proc_name
)
1309 fputc (',', dumpfile
);
1310 fputs (sym
->name
, dumpfile
);
1311 fputc ('=', dumpfile
);
1312 c
= gfc_constructor_first (sym
->value
->value
.constructor
);
1313 show_expr (c
->expr
);
1314 fputc (':', dumpfile
);
1315 c
= gfc_constructor_next (c
);
1316 show_expr (c
->expr
);
1317 c
= gfc_constructor_next (c
);
1320 fputc (':', dumpfile
);
1321 show_expr (c
->expr
);
1327 show_omp_namelist (int list_type
, gfc_omp_namelist
*n
)
1329 gfc_namespace
*ns_iter
= NULL
, *ns_curr
= gfc_current_ns
;
1330 gfc_omp_namelist
*n2
= n
;
1331 for (; n
; n
= n
->next
)
1333 gfc_current_ns
= ns_curr
;
1334 if (list_type
== OMP_LIST_AFFINITY
|| list_type
== OMP_LIST_DEPEND
)
1336 gfc_current_ns
= n
->u2
.ns
? n
->u2
.ns
: ns_curr
;
1337 if (n
->u2
.ns
!= ns_iter
)
1340 fputs (list_type
== OMP_LIST_AFFINITY
1341 ? ") AFFINITY(" : ") DEPEND(", dumpfile
);
1344 fputs ("ITERATOR(", dumpfile
);
1345 show_iterator (n
->u2
.ns
);
1346 fputc (')', dumpfile
);
1347 fputc (list_type
== OMP_LIST_AFFINITY
? ':' : ',', dumpfile
);
1352 if (list_type
== OMP_LIST_REDUCTION
)
1353 switch (n
->u
.reduction_op
)
1355 case OMP_REDUCTION_PLUS
:
1356 case OMP_REDUCTION_TIMES
:
1357 case OMP_REDUCTION_MINUS
:
1358 case OMP_REDUCTION_AND
:
1359 case OMP_REDUCTION_OR
:
1360 case OMP_REDUCTION_EQV
:
1361 case OMP_REDUCTION_NEQV
:
1362 fprintf (dumpfile
, "%s:",
1363 gfc_op2string ((gfc_intrinsic_op
) n
->u
.reduction_op
));
1365 case OMP_REDUCTION_MAX
: fputs ("max:", dumpfile
); break;
1366 case OMP_REDUCTION_MIN
: fputs ("min:", dumpfile
); break;
1367 case OMP_REDUCTION_IAND
: fputs ("iand:", dumpfile
); break;
1368 case OMP_REDUCTION_IOR
: fputs ("ior:", dumpfile
); break;
1369 case OMP_REDUCTION_IEOR
: fputs ("ieor:", dumpfile
); break;
1370 case OMP_REDUCTION_USER
:
1372 fprintf (dumpfile
, "%s:", n
->u2
.udr
->udr
->name
);
1376 else if (list_type
== OMP_LIST_DEPEND
)
1377 switch (n
->u
.depend_op
)
1379 case OMP_DEPEND_IN
: fputs ("in:", dumpfile
); break;
1380 case OMP_DEPEND_OUT
: fputs ("out:", dumpfile
); break;
1381 case OMP_DEPEND_INOUT
: fputs ("inout:", dumpfile
); break;
1382 case OMP_DEPEND_DEPOBJ
: fputs ("depobj:", dumpfile
); break;
1383 case OMP_DEPEND_MUTEXINOUTSET
:
1384 fputs ("mutexinoutset:", dumpfile
);
1386 case OMP_DEPEND_SINK_FIRST
:
1387 fputs ("sink:", dumpfile
);
1390 fprintf (dumpfile
, "%s", n
->sym
->name
);
1393 fputc ('+', dumpfile
);
1394 show_expr (n
->expr
);
1396 if (n
->next
== NULL
)
1398 else if (n
->next
->u
.depend_op
!= OMP_DEPEND_SINK
)
1400 fputs (") DEPEND(", dumpfile
);
1403 fputc (',', dumpfile
);
1409 else if (list_type
== OMP_LIST_MAP
)
1410 switch (n
->u
.map_op
)
1412 case OMP_MAP_ALLOC
: fputs ("alloc:", dumpfile
); break;
1413 case OMP_MAP_TO
: fputs ("to:", dumpfile
); break;
1414 case OMP_MAP_FROM
: fputs ("from:", dumpfile
); break;
1415 case OMP_MAP_TOFROM
: fputs ("tofrom:", dumpfile
); break;
1418 else if (list_type
== OMP_LIST_LINEAR
)
1419 switch (n
->u
.linear_op
)
1421 case OMP_LINEAR_REF
: fputs ("ref(", dumpfile
); break;
1422 case OMP_LINEAR_VAL
: fputs ("val(", dumpfile
); break;
1423 case OMP_LINEAR_UVAL
: fputs ("uval(", dumpfile
); break;
1426 fprintf (dumpfile
, "%s", n
->sym
->name
);
1427 if (list_type
== OMP_LIST_LINEAR
&& n
->u
.linear_op
!= OMP_LINEAR_DEFAULT
)
1428 fputc (')', dumpfile
);
1431 fputc (':', dumpfile
);
1432 show_expr (n
->expr
);
1435 fputc (',', dumpfile
);
1437 gfc_current_ns
= ns_curr
;
1441 /* Show OpenMP or OpenACC clauses. */
1444 show_omp_clauses (gfc_omp_clauses
*omp_clauses
)
1448 switch (omp_clauses
->cancel
)
1450 case OMP_CANCEL_UNKNOWN
:
1452 case OMP_CANCEL_PARALLEL
:
1453 fputs (" PARALLEL", dumpfile
);
1455 case OMP_CANCEL_SECTIONS
:
1456 fputs (" SECTIONS", dumpfile
);
1459 fputs (" DO", dumpfile
);
1461 case OMP_CANCEL_TASKGROUP
:
1462 fputs (" TASKGROUP", dumpfile
);
1465 if (omp_clauses
->if_expr
)
1467 fputs (" IF(", dumpfile
);
1468 show_expr (omp_clauses
->if_expr
);
1469 fputc (')', dumpfile
);
1471 if (omp_clauses
->final_expr
)
1473 fputs (" FINAL(", dumpfile
);
1474 show_expr (omp_clauses
->final_expr
);
1475 fputc (')', dumpfile
);
1477 if (omp_clauses
->num_threads
)
1479 fputs (" NUM_THREADS(", dumpfile
);
1480 show_expr (omp_clauses
->num_threads
);
1481 fputc (')', dumpfile
);
1483 if (omp_clauses
->async
)
1485 fputs (" ASYNC", dumpfile
);
1486 if (omp_clauses
->async_expr
)
1488 fputc ('(', dumpfile
);
1489 show_expr (omp_clauses
->async_expr
);
1490 fputc (')', dumpfile
);
1493 if (omp_clauses
->num_gangs_expr
)
1495 fputs (" NUM_GANGS(", dumpfile
);
1496 show_expr (omp_clauses
->num_gangs_expr
);
1497 fputc (')', dumpfile
);
1499 if (omp_clauses
->num_workers_expr
)
1501 fputs (" NUM_WORKERS(", dumpfile
);
1502 show_expr (omp_clauses
->num_workers_expr
);
1503 fputc (')', dumpfile
);
1505 if (omp_clauses
->vector_length_expr
)
1507 fputs (" VECTOR_LENGTH(", dumpfile
);
1508 show_expr (omp_clauses
->vector_length_expr
);
1509 fputc (')', dumpfile
);
1511 if (omp_clauses
->gang
)
1513 fputs (" GANG", dumpfile
);
1514 if (omp_clauses
->gang_num_expr
|| omp_clauses
->gang_static_expr
)
1516 fputc ('(', dumpfile
);
1517 if (omp_clauses
->gang_num_expr
)
1519 fprintf (dumpfile
, "num:");
1520 show_expr (omp_clauses
->gang_num_expr
);
1522 if (omp_clauses
->gang_num_expr
&& omp_clauses
->gang_static
)
1523 fputc (',', dumpfile
);
1524 if (omp_clauses
->gang_static
)
1526 fprintf (dumpfile
, "static:");
1527 if (omp_clauses
->gang_static_expr
)
1528 show_expr (omp_clauses
->gang_static_expr
);
1530 fputc ('*', dumpfile
);
1532 fputc (')', dumpfile
);
1535 if (omp_clauses
->worker
)
1537 fputs (" WORKER", dumpfile
);
1538 if (omp_clauses
->worker_expr
)
1540 fputc ('(', dumpfile
);
1541 show_expr (omp_clauses
->worker_expr
);
1542 fputc (')', dumpfile
);
1545 if (omp_clauses
->vector
)
1547 fputs (" VECTOR", dumpfile
);
1548 if (omp_clauses
->vector_expr
)
1550 fputc ('(', dumpfile
);
1551 show_expr (omp_clauses
->vector_expr
);
1552 fputc (')', dumpfile
);
1555 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
1558 switch (omp_clauses
->sched_kind
)
1560 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
1561 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
1562 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
1563 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
1564 case OMP_SCHED_AUTO
: type
= "AUTO"; break;
1568 fputs (" SCHEDULE (", dumpfile
);
1569 if (omp_clauses
->sched_simd
)
1571 if (omp_clauses
->sched_monotonic
1572 || omp_clauses
->sched_nonmonotonic
)
1573 fputs ("SIMD, ", dumpfile
);
1575 fputs ("SIMD: ", dumpfile
);
1577 if (omp_clauses
->sched_monotonic
)
1578 fputs ("MONOTONIC: ", dumpfile
);
1579 else if (omp_clauses
->sched_nonmonotonic
)
1580 fputs ("NONMONOTONIC: ", dumpfile
);
1581 fputs (type
, dumpfile
);
1582 if (omp_clauses
->chunk_size
)
1584 fputc (',', dumpfile
);
1585 show_expr (omp_clauses
->chunk_size
);
1587 fputc (')', dumpfile
);
1589 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1592 switch (omp_clauses
->default_sharing
)
1594 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
1595 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
1596 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
1597 case OMP_DEFAULT_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1598 case OMP_DEFAULT_PRESENT
: type
= "PRESENT"; break;
1602 fprintf (dumpfile
, " DEFAULT(%s)", type
);
1604 if (omp_clauses
->tile_list
)
1606 gfc_expr_list
*list
;
1607 fputs (" TILE(", dumpfile
);
1608 for (list
= omp_clauses
->tile_list
; list
; list
= list
->next
)
1610 show_expr (list
->expr
);
1612 fputs (", ", dumpfile
);
1614 fputc (')', dumpfile
);
1616 if (omp_clauses
->wait_list
)
1618 gfc_expr_list
*list
;
1619 fputs (" WAIT(", dumpfile
);
1620 for (list
= omp_clauses
->wait_list
; list
; list
= list
->next
)
1622 show_expr (list
->expr
);
1624 fputs (", ", dumpfile
);
1626 fputc (')', dumpfile
);
1628 if (omp_clauses
->seq
)
1629 fputs (" SEQ", dumpfile
);
1630 if (omp_clauses
->independent
)
1631 fputs (" INDEPENDENT", dumpfile
);
1632 if (omp_clauses
->order_concurrent
)
1634 fputs (" ORDER(", dumpfile
);
1635 if (omp_clauses
->order_unconstrained
)
1636 fputs ("UNCONSTRAINED:", dumpfile
);
1637 else if (omp_clauses
->order_reproducible
)
1638 fputs ("REPRODUCIBLE:", dumpfile
);
1639 fputs ("CONCURRENT)", dumpfile
);
1641 if (omp_clauses
->ordered
)
1643 if (omp_clauses
->orderedc
)
1644 fprintf (dumpfile
, " ORDERED(%d)", omp_clauses
->orderedc
);
1646 fputs (" ORDERED", dumpfile
);
1648 if (omp_clauses
->untied
)
1649 fputs (" UNTIED", dumpfile
);
1650 if (omp_clauses
->mergeable
)
1651 fputs (" MERGEABLE", dumpfile
);
1652 if (omp_clauses
->collapse
)
1653 fprintf (dumpfile
, " COLLAPSE(%d)", omp_clauses
->collapse
);
1654 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
1655 if (omp_clauses
->lists
[list_type
] != NULL
1656 && list_type
!= OMP_LIST_COPYPRIVATE
)
1658 const char *type
= NULL
;
1661 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
1662 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1663 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
1664 case OMP_LIST_COPYPRIVATE
: type
= "COPYPRIVATE"; break;
1665 case OMP_LIST_SHARED
: type
= "SHARED"; break;
1666 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
1667 case OMP_LIST_UNIFORM
: type
= "UNIFORM"; break;
1668 case OMP_LIST_AFFINITY
: type
= "AFFINITY"; break;
1669 case OMP_LIST_ALIGNED
: type
= "ALIGNED"; break;
1670 case OMP_LIST_LINEAR
: type
= "LINEAR"; break;
1671 case OMP_LIST_DEPEND
: type
= "DEPEND"; break;
1672 case OMP_LIST_MAP
: type
= "MAP"; break;
1673 case OMP_LIST_TO
: type
= "TO"; break;
1674 case OMP_LIST_FROM
: type
= "FROM"; break;
1675 case OMP_LIST_REDUCTION
:
1676 case OMP_LIST_REDUCTION_INSCAN
:
1677 case OMP_LIST_REDUCTION_TASK
: type
= "REDUCTION"; break;
1678 case OMP_LIST_IN_REDUCTION
: type
= "IN_REDUCTION"; break;
1679 case OMP_LIST_TASK_REDUCTION
: type
= "TASK_REDUCTION"; break;
1680 case OMP_LIST_DEVICE_RESIDENT
: type
= "DEVICE_RESIDENT"; break;
1681 case OMP_LIST_LINK
: type
= "LINK"; break;
1682 case OMP_LIST_USE_DEVICE
: type
= "USE_DEVICE"; break;
1683 case OMP_LIST_CACHE
: type
= "CACHE"; break;
1684 case OMP_LIST_IS_DEVICE_PTR
: type
= "IS_DEVICE_PTR"; break;
1685 case OMP_LIST_USE_DEVICE_PTR
: type
= "USE_DEVICE_PTR"; break;
1686 case OMP_LIST_USE_DEVICE_ADDR
: type
= "USE_DEVICE_ADDR"; break;
1687 case OMP_LIST_NONTEMPORAL
: type
= "NONTEMPORAL"; break;
1688 case OMP_LIST_SCAN_IN
: type
= "INCLUSIVE"; break;
1689 case OMP_LIST_SCAN_EX
: type
= "EXCLUSIVE"; break;
1693 fprintf (dumpfile
, " %s(", type
);
1694 if (list_type
== OMP_LIST_REDUCTION_INSCAN
)
1695 fputs ("inscan, ", dumpfile
);
1696 if (list_type
== OMP_LIST_REDUCTION_TASK
)
1697 fputs ("task, ", dumpfile
);
1698 show_omp_namelist (list_type
, omp_clauses
->lists
[list_type
]);
1699 fputc (')', dumpfile
);
1701 if (omp_clauses
->safelen_expr
)
1703 fputs (" SAFELEN(", dumpfile
);
1704 show_expr (omp_clauses
->safelen_expr
);
1705 fputc (')', dumpfile
);
1707 if (omp_clauses
->simdlen_expr
)
1709 fputs (" SIMDLEN(", dumpfile
);
1710 show_expr (omp_clauses
->simdlen_expr
);
1711 fputc (')', dumpfile
);
1713 if (omp_clauses
->inbranch
)
1714 fputs (" INBRANCH", dumpfile
);
1715 if (omp_clauses
->notinbranch
)
1716 fputs (" NOTINBRANCH", dumpfile
);
1717 if (omp_clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
1720 switch (omp_clauses
->proc_bind
)
1722 case OMP_PROC_BIND_PRIMARY
: type
= "PRIMARY"; break;
1723 case OMP_PROC_BIND_MASTER
: type
= "MASTER"; break;
1724 case OMP_PROC_BIND_SPREAD
: type
= "SPREAD"; break;
1725 case OMP_PROC_BIND_CLOSE
: type
= "CLOSE"; break;
1729 fprintf (dumpfile
, " PROC_BIND(%s)", type
);
1731 if (omp_clauses
->bind
!= OMP_BIND_UNSET
)
1734 switch (omp_clauses
->bind
)
1736 case OMP_BIND_TEAMS
: type
= "TEAMS"; break;
1737 case OMP_BIND_PARALLEL
: type
= "PARALLEL"; break;
1738 case OMP_BIND_THREAD
: type
= "THREAD"; break;
1742 fprintf (dumpfile
, " BIND(%s)", type
);
1744 if (omp_clauses
->num_teams_upper
)
1746 fputs (" NUM_TEAMS(", dumpfile
);
1747 if (omp_clauses
->num_teams_lower
)
1749 show_expr (omp_clauses
->num_teams_lower
);
1750 fputc (':', dumpfile
);
1752 show_expr (omp_clauses
->num_teams_upper
);
1753 fputc (')', dumpfile
);
1755 if (omp_clauses
->device
)
1757 fputs (" DEVICE(", dumpfile
);
1758 if (omp_clauses
->ancestor
)
1759 fputs ("ANCESTOR:", dumpfile
);
1760 show_expr (omp_clauses
->device
);
1761 fputc (')', dumpfile
);
1763 if (omp_clauses
->thread_limit
)
1765 fputs (" THREAD_LIMIT(", dumpfile
);
1766 show_expr (omp_clauses
->thread_limit
);
1767 fputc (')', dumpfile
);
1769 if (omp_clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
1771 fputs (" DIST_SCHEDULE (STATIC", dumpfile
);
1772 if (omp_clauses
->dist_chunk_size
)
1774 fputc (',', dumpfile
);
1775 show_expr (omp_clauses
->dist_chunk_size
);
1777 fputc (')', dumpfile
);
1779 for (int i
= 0; i
< OMP_DEFAULTMAP_CAT_NUM
; i
++)
1781 const char *dfltmap
;
1782 if (omp_clauses
->defaultmap
[i
] == OMP_DEFAULTMAP_UNSET
)
1784 fputs (" DEFAULTMAP (", dumpfile
);
1785 switch (omp_clauses
->defaultmap
[i
])
1787 case OMP_DEFAULTMAP_ALLOC
: dfltmap
= "ALLOC"; break;
1788 case OMP_DEFAULTMAP_TO
: dfltmap
= "TO"; break;
1789 case OMP_DEFAULTMAP_FROM
: dfltmap
= "FROM"; break;
1790 case OMP_DEFAULTMAP_TOFROM
: dfltmap
= "TOFROM"; break;
1791 case OMP_DEFAULTMAP_FIRSTPRIVATE
: dfltmap
= "FIRSTPRIVATE"; break;
1792 case OMP_DEFAULTMAP_NONE
: dfltmap
= "NONE"; break;
1793 case OMP_DEFAULTMAP_DEFAULT
: dfltmap
= "DEFAULT"; break;
1794 case OMP_DEFAULTMAP_PRESENT
: dfltmap
= "PRESENT"; break;
1795 default: gcc_unreachable ();
1797 fputs (dfltmap
, dumpfile
);
1798 if (i
!= OMP_DEFAULTMAP_CAT_UNCATEGORIZED
)
1800 fputc (':', dumpfile
);
1801 switch ((enum gfc_omp_defaultmap_category
) i
)
1803 case OMP_DEFAULTMAP_CAT_SCALAR
: dfltmap
= "SCALAR"; break;
1804 case OMP_DEFAULTMAP_CAT_AGGREGATE
: dfltmap
= "AGGREGATE"; break;
1805 case OMP_DEFAULTMAP_CAT_ALLOCATABLE
: dfltmap
= "ALLOCATABLE"; break;
1806 case OMP_DEFAULTMAP_CAT_POINTER
: dfltmap
= "POINTER"; break;
1807 default: gcc_unreachable ();
1809 fputs (dfltmap
, dumpfile
);
1811 fputc (')', dumpfile
);
1813 if (omp_clauses
->weak
)
1814 fputs (" WEAK", dumpfile
);
1815 if (omp_clauses
->compare
)
1816 fputs (" COMPARE", dumpfile
);
1817 if (omp_clauses
->nogroup
)
1818 fputs (" NOGROUP", dumpfile
);
1819 if (omp_clauses
->simd
)
1820 fputs (" SIMD", dumpfile
);
1821 if (omp_clauses
->threads
)
1822 fputs (" THREADS", dumpfile
);
1823 if (omp_clauses
->grainsize
)
1825 fputs (" GRAINSIZE(", dumpfile
);
1826 if (omp_clauses
->grainsize_strict
)
1827 fputs ("strict: ", dumpfile
);
1828 show_expr (omp_clauses
->grainsize
);
1829 fputc (')', dumpfile
);
1831 if (omp_clauses
->filter
)
1833 fputs (" FILTER(", dumpfile
);
1834 show_expr (omp_clauses
->filter
);
1835 fputc (')', dumpfile
);
1837 if (omp_clauses
->hint
)
1839 fputs (" HINT(", dumpfile
);
1840 show_expr (omp_clauses
->hint
);
1841 fputc (')', dumpfile
);
1843 if (omp_clauses
->num_tasks
)
1845 fputs (" NUM_TASKS(", dumpfile
);
1846 if (omp_clauses
->num_tasks_strict
)
1847 fputs ("strict: ", dumpfile
);
1848 show_expr (omp_clauses
->num_tasks
);
1849 fputc (')', dumpfile
);
1851 if (omp_clauses
->priority
)
1853 fputs (" PRIORITY(", dumpfile
);
1854 show_expr (omp_clauses
->priority
);
1855 fputc (')', dumpfile
);
1857 if (omp_clauses
->detach
)
1859 fputs (" DETACH(", dumpfile
);
1860 show_expr (omp_clauses
->detach
);
1861 fputc (')', dumpfile
);
1863 for (i
= 0; i
< OMP_IF_LAST
; i
++)
1864 if (omp_clauses
->if_exprs
[i
])
1866 static const char *ifs
[] = {
1875 "TARGET ENTER DATA",
1878 fputs (" IF(", dumpfile
);
1879 fputs (ifs
[i
], dumpfile
);
1880 fputs (": ", dumpfile
);
1881 show_expr (omp_clauses
->if_exprs
[i
]);
1882 fputc (')', dumpfile
);
1884 if (omp_clauses
->destroy
)
1885 fputs (" DESTROY", dumpfile
);
1886 if (omp_clauses
->depend_source
)
1887 fputs (" DEPEND(source)", dumpfile
);
1888 if (omp_clauses
->capture
)
1889 fputs (" CAPTURE", dumpfile
);
1890 if (omp_clauses
->depobj_update
!= OMP_DEPEND_UNSET
)
1892 const char *deptype
;
1893 fputs (" UPDATE(", dumpfile
);
1894 switch (omp_clauses
->depobj_update
)
1896 case OMP_DEPEND_IN
: deptype
= "IN"; break;
1897 case OMP_DEPEND_OUT
: deptype
= "OUT"; break;
1898 case OMP_DEPEND_INOUT
: deptype
= "INOUT"; break;
1899 case OMP_DEPEND_MUTEXINOUTSET
: deptype
= "MUTEXINOUTSET"; break;
1900 default: gcc_unreachable ();
1902 fputs (deptype
, dumpfile
);
1903 fputc (')', dumpfile
);
1905 if (omp_clauses
->atomic_op
!= GFC_OMP_ATOMIC_UNSET
)
1907 const char *atomic_op
;
1908 switch (omp_clauses
->atomic_op
& GFC_OMP_ATOMIC_MASK
)
1910 case GFC_OMP_ATOMIC_READ
: atomic_op
= "READ"; break;
1911 case GFC_OMP_ATOMIC_WRITE
: atomic_op
= "WRITE"; break;
1912 case GFC_OMP_ATOMIC_UPDATE
: atomic_op
= "UPDATE"; break;
1913 default: gcc_unreachable ();
1915 fputc (' ', dumpfile
);
1916 fputs (atomic_op
, dumpfile
);
1918 if (omp_clauses
->memorder
!= OMP_MEMORDER_UNSET
)
1920 const char *memorder
;
1921 switch (omp_clauses
->memorder
)
1923 case OMP_MEMORDER_ACQ_REL
: memorder
= "ACQ_REL"; break;
1924 case OMP_MEMORDER_ACQUIRE
: memorder
= "AQUIRE"; break;
1925 case OMP_MEMORDER_RELAXED
: memorder
= "RELAXED"; break;
1926 case OMP_MEMORDER_RELEASE
: memorder
= "RELEASE"; break;
1927 case OMP_MEMORDER_SEQ_CST
: memorder
= "SEQ_CST"; break;
1928 default: gcc_unreachable ();
1930 fputc (' ', dumpfile
);
1931 fputs (memorder
, dumpfile
);
1933 if (omp_clauses
->fail
!= OMP_MEMORDER_UNSET
)
1935 const char *memorder
;
1936 switch (omp_clauses
->fail
)
1938 case OMP_MEMORDER_ACQUIRE
: memorder
= "AQUIRE"; break;
1939 case OMP_MEMORDER_RELAXED
: memorder
= "RELAXED"; break;
1940 case OMP_MEMORDER_SEQ_CST
: memorder
= "SEQ_CST"; break;
1941 default: gcc_unreachable ();
1943 fputs (" FAIL(", dumpfile
);
1944 fputs (memorder
, dumpfile
);
1945 putc (')', dumpfile
);
1947 if (omp_clauses
->at
!= OMP_AT_UNSET
)
1949 if (omp_clauses
->at
!= OMP_AT_COMPILATION
)
1950 fputs (" AT (COMPILATION)", dumpfile
);
1952 fputs (" AT (EXECUTION)", dumpfile
);
1954 if (omp_clauses
->severity
!= OMP_SEVERITY_UNSET
)
1956 if (omp_clauses
->severity
!= OMP_SEVERITY_FATAL
)
1957 fputs (" SEVERITY (FATAL)", dumpfile
);
1959 fputs (" SEVERITY (WARNING)", dumpfile
);
1961 if (omp_clauses
->message
)
1963 fputs (" ERROR (", dumpfile
);
1964 show_expr (omp_clauses
->message
);
1965 fputc (')', dumpfile
);
1969 /* Show a single OpenMP or OpenACC directive node and everything underneath it
1973 show_omp_node (int level
, gfc_code
*c
)
1975 gfc_omp_clauses
*omp_clauses
= NULL
;
1976 const char *name
= NULL
;
1977 bool is_oacc
= false;
1981 case EXEC_OACC_PARALLEL_LOOP
:
1982 name
= "PARALLEL LOOP"; is_oacc
= true; break;
1983 case EXEC_OACC_PARALLEL
: name
= "PARALLEL"; is_oacc
= true; break;
1984 case EXEC_OACC_KERNELS_LOOP
: name
= "KERNELS LOOP"; is_oacc
= true; break;
1985 case EXEC_OACC_KERNELS
: name
= "KERNELS"; is_oacc
= true; break;
1986 case EXEC_OACC_SERIAL_LOOP
: name
= "SERIAL LOOP"; is_oacc
= true; break;
1987 case EXEC_OACC_SERIAL
: name
= "SERIAL"; is_oacc
= true; break;
1988 case EXEC_OACC_DATA
: name
= "DATA"; is_oacc
= true; break;
1989 case EXEC_OACC_HOST_DATA
: name
= "HOST_DATA"; is_oacc
= true; break;
1990 case EXEC_OACC_LOOP
: name
= "LOOP"; is_oacc
= true; break;
1991 case EXEC_OACC_UPDATE
: name
= "UPDATE"; is_oacc
= true; break;
1992 case EXEC_OACC_WAIT
: name
= "WAIT"; is_oacc
= true; break;
1993 case EXEC_OACC_CACHE
: name
= "CACHE"; is_oacc
= true; break;
1994 case EXEC_OACC_ENTER_DATA
: name
= "ENTER DATA"; is_oacc
= true; break;
1995 case EXEC_OACC_EXIT_DATA
: name
= "EXIT DATA"; is_oacc
= true; break;
1996 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
1997 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
1998 case EXEC_OMP_CANCEL
: name
= "CANCEL"; break;
1999 case EXEC_OMP_CANCELLATION_POINT
: name
= "CANCELLATION POINT"; break;
2000 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
2001 case EXEC_OMP_DISTRIBUTE
: name
= "DISTRIBUTE"; break;
2002 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
2003 name
= "DISTRIBUTE PARALLEL DO"; break;
2004 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2005 name
= "DISTRIBUTE PARALLEL DO SIMD"; break;
2006 case EXEC_OMP_DISTRIBUTE_SIMD
: name
= "DISTRIBUTE SIMD"; break;
2007 case EXEC_OMP_DO
: name
= "DO"; break;
2008 case EXEC_OMP_DO_SIMD
: name
= "DO SIMD"; break;
2009 case EXEC_OMP_ERROR
: name
= "ERROR"; break;
2010 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
2011 case EXEC_OMP_LOOP
: name
= "LOOP"; break;
2012 case EXEC_OMP_MASKED
: name
= "MASKED"; break;
2013 case EXEC_OMP_MASKED_TASKLOOP
: name
= "MASKED TASKLOOP"; break;
2014 case EXEC_OMP_MASKED_TASKLOOP_SIMD
: name
= "MASKED TASKLOOP SIMD"; break;
2015 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
2016 case EXEC_OMP_MASTER_TASKLOOP
: name
= "MASTER TASKLOOP"; break;
2017 case EXEC_OMP_MASTER_TASKLOOP_SIMD
: name
= "MASTER TASKLOOP SIMD"; break;
2018 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
2019 case EXEC_OMP_DEPOBJ
: name
= "DEPOBJ"; break;
2020 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
2021 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
2022 case EXEC_OMP_PARALLEL_DO_SIMD
: name
= "PARALLEL DO SIMD"; break;
2023 case EXEC_OMP_PARALLEL_LOOP
: name
= "PARALLEL LOOP"; break;
2024 case EXEC_OMP_PARALLEL_MASTER
: name
= "PARALLEL MASTER"; break;
2025 case EXEC_OMP_PARALLEL_MASKED
: name
= "PARALLEL MASK"; break;
2026 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
2027 name
= "PARALLEL MASK TASKLOOP"; break;
2028 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
2029 name
= "PARALLEL MASK TASKLOOP SIMD"; break;
2030 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
2031 name
= "PARALLEL MASTER TASKLOOP"; break;
2032 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
2033 name
= "PARALLEL MASTER TASKLOOP SIMD"; break;
2034 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
2035 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
2036 case EXEC_OMP_SCAN
: name
= "SCAN"; break;
2037 case EXEC_OMP_SCOPE
: name
= "SCOPE"; break;
2038 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
2039 case EXEC_OMP_SIMD
: name
= "SIMD"; break;
2040 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
2041 case EXEC_OMP_TARGET
: name
= "TARGET"; break;
2042 case EXEC_OMP_TARGET_DATA
: name
= "TARGET DATA"; break;
2043 case EXEC_OMP_TARGET_ENTER_DATA
: name
= "TARGET ENTER DATA"; break;
2044 case EXEC_OMP_TARGET_EXIT_DATA
: name
= "TARGET EXIT DATA"; break;
2045 case EXEC_OMP_TARGET_PARALLEL
: name
= "TARGET PARALLEL"; break;
2046 case EXEC_OMP_TARGET_PARALLEL_DO
: name
= "TARGET PARALLEL DO"; break;
2047 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
2048 name
= "TARGET_PARALLEL_DO_SIMD"; break;
2049 case EXEC_OMP_TARGET_PARALLEL_LOOP
: name
= "TARGET PARALLEL LOOP"; break;
2050 case EXEC_OMP_TARGET_SIMD
: name
= "TARGET SIMD"; break;
2051 case EXEC_OMP_TARGET_TEAMS
: name
= "TARGET TEAMS"; break;
2052 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
2053 name
= "TARGET TEAMS DISTRIBUTE"; break;
2054 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2055 name
= "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break;
2056 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2057 name
= "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
2058 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2059 name
= "TARGET TEAMS DISTRIBUTE SIMD"; break;
2060 case EXEC_OMP_TARGET_TEAMS_LOOP
: name
= "TARGET TEAMS LOOP"; break;
2061 case EXEC_OMP_TARGET_UPDATE
: name
= "TARGET UPDATE"; break;
2062 case EXEC_OMP_TASK
: name
= "TASK"; break;
2063 case EXEC_OMP_TASKGROUP
: name
= "TASKGROUP"; break;
2064 case EXEC_OMP_TASKLOOP
: name
= "TASKLOOP"; break;
2065 case EXEC_OMP_TASKLOOP_SIMD
: name
= "TASKLOOP SIMD"; break;
2066 case EXEC_OMP_TASKWAIT
: name
= "TASKWAIT"; break;
2067 case EXEC_OMP_TASKYIELD
: name
= "TASKYIELD"; break;
2068 case EXEC_OMP_TEAMS
: name
= "TEAMS"; break;
2069 case EXEC_OMP_TEAMS_DISTRIBUTE
: name
= "TEAMS DISTRIBUTE"; break;
2070 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2071 name
= "TEAMS DISTRIBUTE PARALLEL DO"; break;
2072 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2073 name
= "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
2074 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
: name
= "TEAMS DISTRIBUTE SIMD"; break;
2075 case EXEC_OMP_TEAMS_LOOP
: name
= "TEAMS LOOP"; break;
2076 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
2080 fprintf (dumpfile
, "!$%s %s", is_oacc
? "ACC" : "OMP", name
);
2083 case EXEC_OACC_PARALLEL_LOOP
:
2084 case EXEC_OACC_PARALLEL
:
2085 case EXEC_OACC_KERNELS_LOOP
:
2086 case EXEC_OACC_KERNELS
:
2087 case EXEC_OACC_SERIAL_LOOP
:
2088 case EXEC_OACC_SERIAL
:
2089 case EXEC_OACC_DATA
:
2090 case EXEC_OACC_HOST_DATA
:
2091 case EXEC_OACC_LOOP
:
2092 case EXEC_OACC_UPDATE
:
2093 case EXEC_OACC_WAIT
:
2094 case EXEC_OACC_CACHE
:
2095 case EXEC_OACC_ENTER_DATA
:
2096 case EXEC_OACC_EXIT_DATA
:
2097 case EXEC_OMP_CANCEL
:
2098 case EXEC_OMP_CANCELLATION_POINT
:
2099 case EXEC_OMP_DISTRIBUTE
:
2100 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
2101 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2102 case EXEC_OMP_DISTRIBUTE_SIMD
:
2104 case EXEC_OMP_DO_SIMD
:
2105 case EXEC_OMP_ERROR
:
2107 case EXEC_OMP_ORDERED
:
2108 case EXEC_OMP_MASKED
:
2109 case EXEC_OMP_PARALLEL
:
2110 case EXEC_OMP_PARALLEL_DO
:
2111 case EXEC_OMP_PARALLEL_DO_SIMD
:
2112 case EXEC_OMP_PARALLEL_LOOP
:
2113 case EXEC_OMP_PARALLEL_MASKED
:
2114 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
2115 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
2116 case EXEC_OMP_PARALLEL_MASTER
:
2117 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
2118 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
2119 case EXEC_OMP_PARALLEL_SECTIONS
:
2120 case EXEC_OMP_PARALLEL_WORKSHARE
:
2122 case EXEC_OMP_SCOPE
:
2123 case EXEC_OMP_SECTIONS
:
2125 case EXEC_OMP_SINGLE
:
2126 case EXEC_OMP_TARGET
:
2127 case EXEC_OMP_TARGET_DATA
:
2128 case EXEC_OMP_TARGET_ENTER_DATA
:
2129 case EXEC_OMP_TARGET_EXIT_DATA
:
2130 case EXEC_OMP_TARGET_PARALLEL
:
2131 case EXEC_OMP_TARGET_PARALLEL_DO
:
2132 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
2133 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
2134 case EXEC_OMP_TARGET_SIMD
:
2135 case EXEC_OMP_TARGET_TEAMS
:
2136 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
2137 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2138 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2139 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2140 case EXEC_OMP_TARGET_TEAMS_LOOP
:
2141 case EXEC_OMP_TARGET_UPDATE
:
2143 case EXEC_OMP_TASKLOOP
:
2144 case EXEC_OMP_TASKLOOP_SIMD
:
2145 case EXEC_OMP_TEAMS
:
2146 case EXEC_OMP_TEAMS_DISTRIBUTE
:
2147 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2148 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2149 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
2150 case EXEC_OMP_TEAMS_LOOP
:
2151 case EXEC_OMP_WORKSHARE
:
2152 omp_clauses
= c
->ext
.omp_clauses
;
2154 case EXEC_OMP_CRITICAL
:
2155 omp_clauses
= c
->ext
.omp_clauses
;
2157 fprintf (dumpfile
, " (%s)", c
->ext
.omp_clauses
->critical_name
);
2159 case EXEC_OMP_DEPOBJ
:
2160 omp_clauses
= c
->ext
.omp_clauses
;
2163 fputc ('(', dumpfile
);
2164 show_expr (c
->ext
.omp_clauses
->depobj
);
2165 fputc (')', dumpfile
);
2168 case EXEC_OMP_FLUSH
:
2169 if (c
->ext
.omp_namelist
)
2171 fputs (" (", dumpfile
);
2172 show_omp_namelist (OMP_LIST_NUM
, c
->ext
.omp_namelist
);
2173 fputc (')', dumpfile
);
2176 case EXEC_OMP_BARRIER
:
2177 case EXEC_OMP_TASKWAIT
:
2178 case EXEC_OMP_TASKYIELD
:
2180 case EXEC_OACC_ATOMIC
:
2181 case EXEC_OMP_ATOMIC
:
2182 omp_clauses
= c
->block
? c
->block
->ext
.omp_clauses
: NULL
;
2188 show_omp_clauses (omp_clauses
);
2189 fputc ('\n', dumpfile
);
2191 /* OpenMP and OpenACC executable directives don't have associated blocks. */
2192 if (c
->op
== EXEC_OACC_CACHE
|| c
->op
== EXEC_OACC_UPDATE
2193 || c
->op
== EXEC_OACC_ENTER_DATA
|| c
->op
== EXEC_OACC_EXIT_DATA
2194 || c
->op
== EXEC_OMP_TARGET_UPDATE
|| c
->op
== EXEC_OMP_TARGET_ENTER_DATA
2195 || c
->op
== EXEC_OMP_TARGET_EXIT_DATA
|| c
->op
== EXEC_OMP_SCAN
2196 || c
->op
== EXEC_OMP_DEPOBJ
|| c
->op
== EXEC_OMP_ERROR
2197 || (c
->op
== EXEC_OMP_ORDERED
&& c
->block
== NULL
))
2199 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
2201 gfc_code
*d
= c
->block
;
2204 show_code (level
+ 1, d
->next
);
2205 if (d
->block
== NULL
)
2207 code_indent (level
, 0);
2208 fputs ("!$OMP SECTION\n", dumpfile
);
2213 show_code (level
+ 1, c
->block
->next
);
2214 if (c
->op
== EXEC_OMP_ATOMIC
)
2216 fputc ('\n', dumpfile
);
2217 code_indent (level
, 0);
2218 fprintf (dumpfile
, "!$%s END %s", is_oacc
? "ACC" : "OMP", name
);
2219 if (omp_clauses
!= NULL
)
2221 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
2223 fputs (" COPYPRIVATE(", dumpfile
);
2224 show_omp_namelist (OMP_LIST_COPYPRIVATE
,
2225 omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
2226 fputc (')', dumpfile
);
2228 else if (omp_clauses
->nowait
)
2229 fputs (" NOWAIT", dumpfile
);
2231 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_clauses
)
2232 fprintf (dumpfile
, " (%s)", c
->ext
.omp_clauses
->critical_name
);
2236 /* Show a single code node and everything underneath it if necessary. */
2239 show_code_node (int level
, gfc_code
*c
)
2241 gfc_forall_iterator
*fa
;
2254 fputc ('\n', dumpfile
);
2255 code_indent (level
, c
->here
);
2262 case EXEC_END_PROCEDURE
:
2266 fputs ("NOP", dumpfile
);
2270 fputs ("CONTINUE", dumpfile
);
2274 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
2277 case EXEC_INIT_ASSIGN
:
2279 fputs ("ASSIGN ", dumpfile
);
2280 show_expr (c
->expr1
);
2281 fputc (' ', dumpfile
);
2282 show_expr (c
->expr2
);
2285 case EXEC_LABEL_ASSIGN
:
2286 fputs ("LABEL ASSIGN ", dumpfile
);
2287 show_expr (c
->expr1
);
2288 fprintf (dumpfile
, " %d", c
->label1
->value
);
2291 case EXEC_POINTER_ASSIGN
:
2292 fputs ("POINTER ASSIGN ", dumpfile
);
2293 show_expr (c
->expr1
);
2294 fputc (' ', dumpfile
);
2295 show_expr (c
->expr2
);
2299 fputs ("GOTO ", dumpfile
);
2301 fprintf (dumpfile
, "%d", c
->label1
->value
);
2304 show_expr (c
->expr1
);
2308 fputs (", (", dumpfile
);
2309 for (; d
; d
= d
->block
)
2311 code_indent (level
, d
->label1
);
2312 if (d
->block
!= NULL
)
2313 fputc (',', dumpfile
);
2315 fputc (')', dumpfile
);
2322 case EXEC_ASSIGN_CALL
:
2323 if (c
->resolved_sym
)
2324 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
2325 else if (c
->symtree
)
2326 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
2328 fputs ("CALL ?? ", dumpfile
);
2330 show_actual_arglist (c
->ext
.actual
);
2334 fputs ("CALL ", dumpfile
);
2335 show_compcall (c
->expr1
);
2339 fputs ("CALL ", dumpfile
);
2340 show_expr (c
->expr1
);
2341 show_actual_arglist (c
->ext
.actual
);
2345 fputs ("RETURN ", dumpfile
);
2347 show_expr (c
->expr1
);
2351 fputs ("PAUSE ", dumpfile
);
2353 if (c
->expr1
!= NULL
)
2354 show_expr (c
->expr1
);
2356 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
2360 case EXEC_ERROR_STOP
:
2361 fputs ("ERROR ", dumpfile
);
2365 fputs ("STOP ", dumpfile
);
2367 if (c
->expr1
!= NULL
)
2368 show_expr (c
->expr1
);
2370 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
2374 case EXEC_FAIL_IMAGE
:
2375 fputs ("FAIL IMAGE ", dumpfile
);
2378 case EXEC_CHANGE_TEAM
:
2379 fputs ("CHANGE TEAM", dumpfile
);
2383 fputs ("END TEAM", dumpfile
);
2386 case EXEC_FORM_TEAM
:
2387 fputs ("FORM TEAM", dumpfile
);
2390 case EXEC_SYNC_TEAM
:
2391 fputs ("SYNC TEAM", dumpfile
);
2395 fputs ("SYNC ALL ", dumpfile
);
2396 if (c
->expr2
!= NULL
)
2398 fputs (" stat=", dumpfile
);
2399 show_expr (c
->expr2
);
2401 if (c
->expr3
!= NULL
)
2403 fputs (" errmsg=", dumpfile
);
2404 show_expr (c
->expr3
);
2408 case EXEC_SYNC_MEMORY
:
2409 fputs ("SYNC MEMORY ", dumpfile
);
2410 if (c
->expr2
!= NULL
)
2412 fputs (" stat=", dumpfile
);
2413 show_expr (c
->expr2
);
2415 if (c
->expr3
!= NULL
)
2417 fputs (" errmsg=", dumpfile
);
2418 show_expr (c
->expr3
);
2422 case EXEC_SYNC_IMAGES
:
2423 fputs ("SYNC IMAGES image-set=", dumpfile
);
2424 if (c
->expr1
!= NULL
)
2425 show_expr (c
->expr1
);
2427 fputs ("* ", dumpfile
);
2428 if (c
->expr2
!= NULL
)
2430 fputs (" stat=", dumpfile
);
2431 show_expr (c
->expr2
);
2433 if (c
->expr3
!= NULL
)
2435 fputs (" errmsg=", dumpfile
);
2436 show_expr (c
->expr3
);
2440 case EXEC_EVENT_POST
:
2441 case EXEC_EVENT_WAIT
:
2442 if (c
->op
== EXEC_EVENT_POST
)
2443 fputs ("EVENT POST ", dumpfile
);
2445 fputs ("EVENT WAIT ", dumpfile
);
2447 fputs ("event-variable=", dumpfile
);
2448 if (c
->expr1
!= NULL
)
2449 show_expr (c
->expr1
);
2450 if (c
->expr4
!= NULL
)
2452 fputs (" until_count=", dumpfile
);
2453 show_expr (c
->expr4
);
2455 if (c
->expr2
!= NULL
)
2457 fputs (" stat=", dumpfile
);
2458 show_expr (c
->expr2
);
2460 if (c
->expr3
!= NULL
)
2462 fputs (" errmsg=", dumpfile
);
2463 show_expr (c
->expr3
);
2469 if (c
->op
== EXEC_LOCK
)
2470 fputs ("LOCK ", dumpfile
);
2472 fputs ("UNLOCK ", dumpfile
);
2474 fputs ("lock-variable=", dumpfile
);
2475 if (c
->expr1
!= NULL
)
2476 show_expr (c
->expr1
);
2477 if (c
->expr4
!= NULL
)
2479 fputs (" acquired_lock=", dumpfile
);
2480 show_expr (c
->expr4
);
2482 if (c
->expr2
!= NULL
)
2484 fputs (" stat=", dumpfile
);
2485 show_expr (c
->expr2
);
2487 if (c
->expr3
!= NULL
)
2489 fputs (" errmsg=", dumpfile
);
2490 show_expr (c
->expr3
);
2494 case EXEC_ARITHMETIC_IF
:
2495 fputs ("IF ", dumpfile
);
2496 show_expr (c
->expr1
);
2497 fprintf (dumpfile
, " %d, %d, %d",
2498 c
->label1
->value
, c
->label2
->value
, c
->label3
->value
);
2503 fputs ("IF ", dumpfile
);
2504 show_expr (d
->expr1
);
2507 show_code (level
+ 1, d
->next
);
2511 for (; d
; d
= d
->block
)
2513 fputs("\n", dumpfile
);
2514 code_indent (level
, 0);
2515 if (d
->expr1
== NULL
)
2516 fputs ("ELSE", dumpfile
);
2519 fputs ("ELSE IF ", dumpfile
);
2520 show_expr (d
->expr1
);
2524 show_code (level
+ 1, d
->next
);
2529 code_indent (level
, c
->label1
);
2533 fputs ("ENDIF", dumpfile
);
2538 const char* blocktype
;
2539 gfc_namespace
*saved_ns
;
2540 gfc_association_list
*alist
;
2542 if (c
->ext
.block
.assoc
)
2543 blocktype
= "ASSOCIATE";
2545 blocktype
= "BLOCK";
2547 fprintf (dumpfile
, "%s ", blocktype
);
2548 for (alist
= c
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
2550 fprintf (dumpfile
, " %s = ", alist
->name
);
2551 show_expr (alist
->target
);
2555 ns
= c
->ext
.block
.ns
;
2556 saved_ns
= gfc_current_ns
;
2557 gfc_current_ns
= ns
;
2558 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2559 gfc_current_ns
= saved_ns
;
2560 show_code (show_level
, ns
->code
);
2563 fprintf (dumpfile
, "END %s ", blocktype
);
2567 case EXEC_END_BLOCK
:
2568 /* Only come here when there is a label on an
2569 END ASSOCIATE construct. */
2573 case EXEC_SELECT_TYPE
:
2574 case EXEC_SELECT_RANK
:
2576 fputc ('\n', dumpfile
);
2577 code_indent (level
, 0);
2578 if (c
->op
== EXEC_SELECT_RANK
)
2579 fputs ("SELECT RANK ", dumpfile
);
2580 else if (c
->op
== EXEC_SELECT_TYPE
)
2581 fputs ("SELECT TYPE ", dumpfile
);
2583 fputs ("SELECT CASE ", dumpfile
);
2584 show_expr (c
->expr1
);
2586 for (; d
; d
= d
->block
)
2588 fputc ('\n', dumpfile
);
2589 code_indent (level
, 0);
2590 fputs ("CASE ", dumpfile
);
2591 for (cp
= d
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2593 fputc ('(', dumpfile
);
2594 show_expr (cp
->low
);
2595 fputc (' ', dumpfile
);
2596 show_expr (cp
->high
);
2597 fputc (')', dumpfile
);
2598 fputc (' ', dumpfile
);
2601 show_code (level
+ 1, d
->next
);
2602 fputc ('\n', dumpfile
);
2605 code_indent (level
, c
->label1
);
2606 fputs ("END SELECT", dumpfile
);
2610 fputs ("WHERE ", dumpfile
);
2613 show_expr (d
->expr1
);
2614 fputc ('\n', dumpfile
);
2616 show_code (level
+ 1, d
->next
);
2618 for (d
= d
->block
; d
; d
= d
->block
)
2620 code_indent (level
, 0);
2621 fputs ("ELSE WHERE ", dumpfile
);
2622 show_expr (d
->expr1
);
2623 fputc ('\n', dumpfile
);
2624 show_code (level
+ 1, d
->next
);
2627 code_indent (level
, 0);
2628 fputs ("END WHERE", dumpfile
);
2633 fputs ("FORALL ", dumpfile
);
2634 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2636 show_expr (fa
->var
);
2637 fputc (' ', dumpfile
);
2638 show_expr (fa
->start
);
2639 fputc (':', dumpfile
);
2640 show_expr (fa
->end
);
2641 fputc (':', dumpfile
);
2642 show_expr (fa
->stride
);
2644 if (fa
->next
!= NULL
)
2645 fputc (',', dumpfile
);
2648 if (c
->expr1
!= NULL
)
2650 fputc (',', dumpfile
);
2651 show_expr (c
->expr1
);
2653 fputc ('\n', dumpfile
);
2655 show_code (level
+ 1, c
->block
->next
);
2657 code_indent (level
, 0);
2658 fputs ("END FORALL", dumpfile
);
2662 fputs ("CRITICAL\n", dumpfile
);
2663 show_code (level
+ 1, c
->block
->next
);
2664 code_indent (level
, 0);
2665 fputs ("END CRITICAL", dumpfile
);
2669 fputs ("DO ", dumpfile
);
2671 fprintf (dumpfile
, " %-5d ", c
->label1
->value
);
2673 show_expr (c
->ext
.iterator
->var
);
2674 fputc ('=', dumpfile
);
2675 show_expr (c
->ext
.iterator
->start
);
2676 fputc (' ', dumpfile
);
2677 show_expr (c
->ext
.iterator
->end
);
2678 fputc (' ', dumpfile
);
2679 show_expr (c
->ext
.iterator
->step
);
2682 show_code (level
+ 1, c
->block
->next
);
2689 fputs ("END DO", dumpfile
);
2692 case EXEC_DO_CONCURRENT
:
2693 fputs ("DO CONCURRENT ", dumpfile
);
2694 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2696 show_expr (fa
->var
);
2697 fputc (' ', dumpfile
);
2698 show_expr (fa
->start
);
2699 fputc (':', dumpfile
);
2700 show_expr (fa
->end
);
2701 fputc (':', dumpfile
);
2702 show_expr (fa
->stride
);
2704 if (fa
->next
!= NULL
)
2705 fputc (',', dumpfile
);
2707 show_expr (c
->expr1
);
2710 show_code (level
+ 1, c
->block
->next
);
2712 code_indent (level
, c
->label1
);
2714 fputs ("END DO", dumpfile
);
2718 fputs ("DO WHILE ", dumpfile
);
2719 show_expr (c
->expr1
);
2720 fputc ('\n', dumpfile
);
2722 show_code (level
+ 1, c
->block
->next
);
2724 code_indent (level
, c
->label1
);
2725 fputs ("END DO", dumpfile
);
2729 fputs ("CYCLE", dumpfile
);
2731 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
2735 fputs ("EXIT", dumpfile
);
2737 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
2741 fputs ("ALLOCATE ", dumpfile
);
2744 fputs (" STAT=", dumpfile
);
2745 show_expr (c
->expr1
);
2750 fputs (" ERRMSG=", dumpfile
);
2751 show_expr (c
->expr2
);
2757 fputs (" MOLD=", dumpfile
);
2759 fputs (" SOURCE=", dumpfile
);
2760 show_expr (c
->expr3
);
2763 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
2765 fputc (' ', dumpfile
);
2766 show_expr (a
->expr
);
2771 case EXEC_DEALLOCATE
:
2772 fputs ("DEALLOCATE ", dumpfile
);
2775 fputs (" STAT=", dumpfile
);
2776 show_expr (c
->expr1
);
2781 fputs (" ERRMSG=", dumpfile
);
2782 show_expr (c
->expr2
);
2785 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
2787 fputc (' ', dumpfile
);
2788 show_expr (a
->expr
);
2794 fputs ("OPEN", dumpfile
);
2799 fputs (" UNIT=", dumpfile
);
2800 show_expr (open
->unit
);
2804 fputs (" IOMSG=", dumpfile
);
2805 show_expr (open
->iomsg
);
2809 fputs (" IOSTAT=", dumpfile
);
2810 show_expr (open
->iostat
);
2814 fputs (" FILE=", dumpfile
);
2815 show_expr (open
->file
);
2819 fputs (" STATUS=", dumpfile
);
2820 show_expr (open
->status
);
2824 fputs (" ACCESS=", dumpfile
);
2825 show_expr (open
->access
);
2829 fputs (" FORM=", dumpfile
);
2830 show_expr (open
->form
);
2834 fputs (" RECL=", dumpfile
);
2835 show_expr (open
->recl
);
2839 fputs (" BLANK=", dumpfile
);
2840 show_expr (open
->blank
);
2844 fputs (" POSITION=", dumpfile
);
2845 show_expr (open
->position
);
2849 fputs (" ACTION=", dumpfile
);
2850 show_expr (open
->action
);
2854 fputs (" DELIM=", dumpfile
);
2855 show_expr (open
->delim
);
2859 fputs (" PAD=", dumpfile
);
2860 show_expr (open
->pad
);
2864 fputs (" DECIMAL=", dumpfile
);
2865 show_expr (open
->decimal
);
2869 fputs (" ENCODING=", dumpfile
);
2870 show_expr (open
->encoding
);
2874 fputs (" ROUND=", dumpfile
);
2875 show_expr (open
->round
);
2879 fputs (" SIGN=", dumpfile
);
2880 show_expr (open
->sign
);
2884 fputs (" CONVERT=", dumpfile
);
2885 show_expr (open
->convert
);
2887 if (open
->asynchronous
)
2889 fputs (" ASYNCHRONOUS=", dumpfile
);
2890 show_expr (open
->asynchronous
);
2892 if (open
->err
!= NULL
)
2893 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
2898 fputs ("CLOSE", dumpfile
);
2899 close
= c
->ext
.close
;
2903 fputs (" UNIT=", dumpfile
);
2904 show_expr (close
->unit
);
2908 fputs (" IOMSG=", dumpfile
);
2909 show_expr (close
->iomsg
);
2913 fputs (" IOSTAT=", dumpfile
);
2914 show_expr (close
->iostat
);
2918 fputs (" STATUS=", dumpfile
);
2919 show_expr (close
->status
);
2921 if (close
->err
!= NULL
)
2922 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
2925 case EXEC_BACKSPACE
:
2926 fputs ("BACKSPACE", dumpfile
);
2930 fputs ("ENDFILE", dumpfile
);
2934 fputs ("REWIND", dumpfile
);
2938 fputs ("FLUSH", dumpfile
);
2941 fp
= c
->ext
.filepos
;
2945 fputs (" UNIT=", dumpfile
);
2946 show_expr (fp
->unit
);
2950 fputs (" IOMSG=", dumpfile
);
2951 show_expr (fp
->iomsg
);
2955 fputs (" IOSTAT=", dumpfile
);
2956 show_expr (fp
->iostat
);
2958 if (fp
->err
!= NULL
)
2959 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
2963 fputs ("INQUIRE", dumpfile
);
2968 fputs (" UNIT=", dumpfile
);
2969 show_expr (i
->unit
);
2973 fputs (" FILE=", dumpfile
);
2974 show_expr (i
->file
);
2979 fputs (" IOMSG=", dumpfile
);
2980 show_expr (i
->iomsg
);
2984 fputs (" IOSTAT=", dumpfile
);
2985 show_expr (i
->iostat
);
2989 fputs (" EXIST=", dumpfile
);
2990 show_expr (i
->exist
);
2994 fputs (" OPENED=", dumpfile
);
2995 show_expr (i
->opened
);
2999 fputs (" NUMBER=", dumpfile
);
3000 show_expr (i
->number
);
3004 fputs (" NAMED=", dumpfile
);
3005 show_expr (i
->named
);
3009 fputs (" NAME=", dumpfile
);
3010 show_expr (i
->name
);
3014 fputs (" ACCESS=", dumpfile
);
3015 show_expr (i
->access
);
3019 fputs (" SEQUENTIAL=", dumpfile
);
3020 show_expr (i
->sequential
);
3025 fputs (" DIRECT=", dumpfile
);
3026 show_expr (i
->direct
);
3030 fputs (" FORM=", dumpfile
);
3031 show_expr (i
->form
);
3035 fputs (" FORMATTED", dumpfile
);
3036 show_expr (i
->formatted
);
3040 fputs (" UNFORMATTED=", dumpfile
);
3041 show_expr (i
->unformatted
);
3045 fputs (" RECL=", dumpfile
);
3046 show_expr (i
->recl
);
3050 fputs (" NEXTREC=", dumpfile
);
3051 show_expr (i
->nextrec
);
3055 fputs (" BLANK=", dumpfile
);
3056 show_expr (i
->blank
);
3060 fputs (" POSITION=", dumpfile
);
3061 show_expr (i
->position
);
3065 fputs (" ACTION=", dumpfile
);
3066 show_expr (i
->action
);
3070 fputs (" READ=", dumpfile
);
3071 show_expr (i
->read
);
3075 fputs (" WRITE=", dumpfile
);
3076 show_expr (i
->write
);
3080 fputs (" READWRITE=", dumpfile
);
3081 show_expr (i
->readwrite
);
3085 fputs (" DELIM=", dumpfile
);
3086 show_expr (i
->delim
);
3090 fputs (" PAD=", dumpfile
);
3095 fputs (" CONVERT=", dumpfile
);
3096 show_expr (i
->convert
);
3098 if (i
->asynchronous
)
3100 fputs (" ASYNCHRONOUS=", dumpfile
);
3101 show_expr (i
->asynchronous
);
3105 fputs (" DECIMAL=", dumpfile
);
3106 show_expr (i
->decimal
);
3110 fputs (" ENCODING=", dumpfile
);
3111 show_expr (i
->encoding
);
3115 fputs (" PENDING=", dumpfile
);
3116 show_expr (i
->pending
);
3120 fputs (" ROUND=", dumpfile
);
3121 show_expr (i
->round
);
3125 fputs (" SIGN=", dumpfile
);
3126 show_expr (i
->sign
);
3130 fputs (" SIZE=", dumpfile
);
3131 show_expr (i
->size
);
3135 fputs (" ID=", dumpfile
);
3140 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
3144 fputs ("IOLENGTH ", dumpfile
);
3145 show_expr (c
->expr1
);
3150 fputs ("READ", dumpfile
);
3154 fputs ("WRITE", dumpfile
);
3160 fputs (" UNIT=", dumpfile
);
3161 show_expr (dt
->io_unit
);
3164 if (dt
->format_expr
)
3166 fputs (" FMT=", dumpfile
);
3167 show_expr (dt
->format_expr
);
3170 if (dt
->format_label
!= NULL
)
3171 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
3173 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
3177 fputs (" IOMSG=", dumpfile
);
3178 show_expr (dt
->iomsg
);
3182 fputs (" IOSTAT=", dumpfile
);
3183 show_expr (dt
->iostat
);
3187 fputs (" SIZE=", dumpfile
);
3188 show_expr (dt
->size
);
3192 fputs (" REC=", dumpfile
);
3193 show_expr (dt
->rec
);
3197 fputs (" ADVANCE=", dumpfile
);
3198 show_expr (dt
->advance
);
3202 fputs (" ID=", dumpfile
);
3207 fputs (" POS=", dumpfile
);
3208 show_expr (dt
->pos
);
3210 if (dt
->asynchronous
)
3212 fputs (" ASYNCHRONOUS=", dumpfile
);
3213 show_expr (dt
->asynchronous
);
3217 fputs (" BLANK=", dumpfile
);
3218 show_expr (dt
->blank
);
3222 fputs (" DECIMAL=", dumpfile
);
3223 show_expr (dt
->decimal
);
3227 fputs (" DELIM=", dumpfile
);
3228 show_expr (dt
->delim
);
3232 fputs (" PAD=", dumpfile
);
3233 show_expr (dt
->pad
);
3237 fputs (" ROUND=", dumpfile
);
3238 show_expr (dt
->round
);
3242 fputs (" SIGN=", dumpfile
);
3243 show_expr (dt
->sign
);
3247 for (c
= c
->block
->next
; c
; c
= c
->next
)
3248 show_code_node (level
+ (c
->next
!= NULL
), c
);
3252 fputs ("TRANSFER ", dumpfile
);
3253 show_expr (c
->expr1
);
3257 fputs ("DT_END", dumpfile
);
3260 if (dt
->err
!= NULL
)
3261 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
3262 if (dt
->end
!= NULL
)
3263 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
3264 if (dt
->eor
!= NULL
)
3265 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
3269 fputs ("WAIT", dumpfile
);
3271 if (c
->ext
.wait
!= NULL
)
3273 gfc_wait
*wait
= c
->ext
.wait
;
3276 fputs (" UNIT=", dumpfile
);
3277 show_expr (wait
->unit
);
3281 fputs (" IOSTAT=", dumpfile
);
3282 show_expr (wait
->iostat
);
3286 fputs (" IOMSG=", dumpfile
);
3287 show_expr (wait
->iomsg
);
3291 fputs (" ID=", dumpfile
);
3292 show_expr (wait
->id
);
3295 fprintf (dumpfile
, " ERR=%d", wait
->err
->value
);
3297 fprintf (dumpfile
, " END=%d", wait
->end
->value
);
3299 fprintf (dumpfile
, " EOR=%d", wait
->eor
->value
);
3303 case EXEC_OACC_PARALLEL_LOOP
:
3304 case EXEC_OACC_PARALLEL
:
3305 case EXEC_OACC_KERNELS_LOOP
:
3306 case EXEC_OACC_KERNELS
:
3307 case EXEC_OACC_SERIAL_LOOP
:
3308 case EXEC_OACC_SERIAL
:
3309 case EXEC_OACC_DATA
:
3310 case EXEC_OACC_HOST_DATA
:
3311 case EXEC_OACC_LOOP
:
3312 case EXEC_OACC_UPDATE
:
3313 case EXEC_OACC_WAIT
:
3314 case EXEC_OACC_CACHE
:
3315 case EXEC_OACC_ENTER_DATA
:
3316 case EXEC_OACC_EXIT_DATA
:
3317 case EXEC_OMP_ATOMIC
:
3318 case EXEC_OMP_CANCEL
:
3319 case EXEC_OMP_CANCELLATION_POINT
:
3320 case EXEC_OMP_BARRIER
:
3321 case EXEC_OMP_CRITICAL
:
3322 case EXEC_OMP_DEPOBJ
:
3323 case EXEC_OMP_DISTRIBUTE
:
3324 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3325 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3326 case EXEC_OMP_DISTRIBUTE_SIMD
:
3328 case EXEC_OMP_DO_SIMD
:
3329 case EXEC_OMP_ERROR
:
3330 case EXEC_OMP_FLUSH
:
3332 case EXEC_OMP_MASKED
:
3333 case EXEC_OMP_MASKED_TASKLOOP
:
3334 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
3335 case EXEC_OMP_MASTER
:
3336 case EXEC_OMP_MASTER_TASKLOOP
:
3337 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
3338 case EXEC_OMP_ORDERED
:
3339 case EXEC_OMP_PARALLEL
:
3340 case EXEC_OMP_PARALLEL_DO
:
3341 case EXEC_OMP_PARALLEL_DO_SIMD
:
3342 case EXEC_OMP_PARALLEL_LOOP
:
3343 case EXEC_OMP_PARALLEL_MASKED
:
3344 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
3345 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
3346 case EXEC_OMP_PARALLEL_MASTER
:
3347 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
3348 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
3349 case EXEC_OMP_PARALLEL_SECTIONS
:
3350 case EXEC_OMP_PARALLEL_WORKSHARE
:
3352 case EXEC_OMP_SCOPE
:
3353 case EXEC_OMP_SECTIONS
:
3355 case EXEC_OMP_SINGLE
:
3356 case EXEC_OMP_TARGET
:
3357 case EXEC_OMP_TARGET_DATA
:
3358 case EXEC_OMP_TARGET_ENTER_DATA
:
3359 case EXEC_OMP_TARGET_EXIT_DATA
:
3360 case EXEC_OMP_TARGET_PARALLEL
:
3361 case EXEC_OMP_TARGET_PARALLEL_DO
:
3362 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
3363 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
3364 case EXEC_OMP_TARGET_SIMD
:
3365 case EXEC_OMP_TARGET_TEAMS
:
3366 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3367 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3368 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3369 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3370 case EXEC_OMP_TARGET_TEAMS_LOOP
:
3371 case EXEC_OMP_TARGET_UPDATE
:
3373 case EXEC_OMP_TASKGROUP
:
3374 case EXEC_OMP_TASKLOOP
:
3375 case EXEC_OMP_TASKLOOP_SIMD
:
3376 case EXEC_OMP_TASKWAIT
:
3377 case EXEC_OMP_TASKYIELD
:
3378 case EXEC_OMP_TEAMS
:
3379 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3380 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3381 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3382 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3383 case EXEC_OMP_TEAMS_LOOP
:
3384 case EXEC_OMP_WORKSHARE
:
3385 show_omp_node (level
, c
);
3389 gfc_internal_error ("show_code_node(): Bad statement code");
3394 /* Show an equivalence chain. */
3397 show_equiv (gfc_equiv
*eq
)
3400 fputs ("Equivalence: ", dumpfile
);
3403 show_expr (eq
->expr
);
3406 fputs (", ", dumpfile
);
3411 /* Show a freakin' whole namespace. */
3414 show_namespace (gfc_namespace
*ns
)
3416 gfc_interface
*intr
;
3417 gfc_namespace
*save
;
3423 save
= gfc_current_ns
;
3426 fputs ("Namespace:", dumpfile
);
3432 while (i
< GFC_LETTERS
- 1
3433 && gfc_compare_types (&ns
->default_type
[i
+1],
3434 &ns
->default_type
[l
]))
3438 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
3440 fprintf (dumpfile
, " %c: ", l
+'A');
3442 show_typespec(&ns
->default_type
[l
]);
3444 } while (i
< GFC_LETTERS
);
3446 if (ns
->proc_name
!= NULL
)
3449 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
3453 gfc_current_ns
= ns
;
3454 gfc_traverse_symtree (ns
->common_root
, show_common
);
3456 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
3458 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
3460 /* User operator interfaces */
3466 fprintf (dumpfile
, "Operator interfaces for %s:",
3467 gfc_op2string ((gfc_intrinsic_op
) op
));
3469 for (; intr
; intr
= intr
->next
)
3470 fprintf (dumpfile
, " %s", intr
->sym
->name
);
3473 if (ns
->uop_root
!= NULL
)
3476 fputs ("User operators:\n", dumpfile
);
3477 gfc_traverse_user_op (ns
, show_uop
);
3480 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
3483 if (ns
->oacc_declare
)
3485 struct gfc_oacc_declare
*decl
;
3486 /* Dump !$ACC DECLARE clauses. */
3487 for (decl
= ns
->oacc_declare
; decl
; decl
= decl
->next
)
3490 fprintf (dumpfile
, "!$ACC DECLARE");
3491 show_omp_clauses (decl
->clauses
);
3495 fputc ('\n', dumpfile
);
3497 fputs ("code:", dumpfile
);
3498 show_code (show_level
, ns
->code
);
3501 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
3503 fputs ("\nCONTAINS\n", dumpfile
);
3505 show_namespace (ns
);
3509 fputc ('\n', dumpfile
);
3510 gfc_current_ns
= save
;
3514 /* Main function for dumping a parse tree. */
3517 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
3520 show_namespace (ns
);
3523 /* This part writes BIND(C) definition for use in external C programs. */
3525 static void write_interop_decl (gfc_symbol
*);
3526 static void write_proc (gfc_symbol
*, bool);
3529 gfc_dump_c_prototypes (gfc_namespace
*ns
, FILE *file
)
3532 gfc_get_errors (NULL
, &error_count
);
3533 if (error_count
!= 0)
3536 gfc_traverse_ns (ns
, write_interop_decl
);
3539 /* Loop over all global symbols, writing out their declrations. */
3542 gfc_dump_external_c_prototypes (FILE * file
)
3546 _("/* Prototypes for external procedures generated from %s\n"
3547 " by GNU Fortran %s%s.\n\n"
3548 " Use of this interface is discouraged, consider using the\n"
3549 " BIND(C) feature of standard Fortran instead. */\n\n"),
3550 gfc_source_file
, pkgversion_string
, version_string
);
3552 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
3553 gfc_current_ns
= gfc_current_ns
->sibling
)
3555 gfc_symbol
*sym
= gfc_current_ns
->proc_name
;
3557 if (sym
== NULL
|| sym
->attr
.flavor
!= FL_PROCEDURE
3558 || sym
->attr
.is_bind_c
)
3561 write_proc (sym
, false);
3566 enum type_return
{ T_OK
=0, T_WARN
, T_ERROR
};
3568 /* Return the name of the type for later output. Both function pointers and
3569 void pointers will be mapped to void *. */
3571 static enum type_return
3572 get_c_type_name (gfc_typespec
*ts
, gfc_array_spec
*as
, const char **pre
,
3573 const char **type_name
, bool *asterisk
, const char **post
,
3576 static char post_buffer
[40];
3577 enum type_return ret
;
3583 *type_name
= "<error>";
3584 if (ts
->type
== BT_REAL
|| ts
->type
== BT_INTEGER
|| ts
->type
== BT_COMPLEX
)
3586 if (ts
->is_c_interop
&& ts
->interop_kind
)
3591 for (int i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
3593 if (c_interop_kinds_table
[i
].f90_type
== ts
->type
3594 && c_interop_kinds_table
[i
].value
== ts
->kind
)
3596 *type_name
= c_interop_kinds_table
[i
].name
+ 2;
3597 if (strcmp (*type_name
, "signed_char") == 0)
3598 *type_name
= "signed char";
3599 else if (strcmp (*type_name
, "size_t") == 0)
3600 *type_name
= "ssize_t";
3601 else if (strcmp (*type_name
, "float_complex") == 0)
3602 *type_name
= "__GFORTRAN_FLOAT_COMPLEX";
3603 else if (strcmp (*type_name
, "double_complex") == 0)
3604 *type_name
= "__GFORTRAN_DOUBLE_COMPLEX";
3605 else if (strcmp (*type_name
, "long_double_complex") == 0)
3606 *type_name
= "__GFORTRAN_LONG_DOUBLE_COMPLEX";
3612 else if (ts
->type
== BT_LOGICAL
)
3614 if (ts
->is_c_interop
&& ts
->interop_kind
)
3616 *type_name
= "_Bool";
3621 /* Let's select an appropriate int, with a warning. */
3622 for (int i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
3624 if (c_interop_kinds_table
[i
].f90_type
== BT_INTEGER
3625 && c_interop_kinds_table
[i
].value
== ts
->kind
)
3627 *type_name
= c_interop_kinds_table
[i
].name
+ 2;
3633 else if (ts
->type
== BT_CHARACTER
)
3635 if (ts
->is_c_interop
)
3637 *type_name
= "char";
3642 if (ts
->kind
== gfc_default_character_kind
)
3643 *type_name
= "char";
3645 /* Let's select an appropriate int. */
3646 for (int i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
3648 if (c_interop_kinds_table
[i
].f90_type
== BT_INTEGER
3649 && c_interop_kinds_table
[i
].value
== ts
->kind
)
3651 *type_name
= c_interop_kinds_table
[i
].name
+ 2;
3659 else if (ts
->type
== BT_DERIVED
)
3661 if (ts
->u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
)
3663 if (strcmp (ts
->u
.derived
->name
, "c_ptr") == 0)
3664 *type_name
= "void";
3665 else if (strcmp (ts
->u
.derived
->name
, "c_funptr") == 0)
3667 *type_name
= "int ";
3683 *type_name
= ts
->u
.derived
->name
;
3688 if (ret
!= T_ERROR
&& as
)
3692 size_ok
= spec_size (as
, &sz
);
3693 gcc_assert (size_ok
== true);
3694 gmp_snprintf (post_buffer
, sizeof(post_buffer
), "[%Zd]", sz
);
3695 *post
= post_buffer
;
3701 /* Write out a declaration. */
3703 write_decl (gfc_typespec
*ts
, gfc_array_spec
*as
, const char *sym_name
,
3704 bool func_ret
, locus
*where
, bool bind_c
)
3706 const char *pre
, *type_name
, *post
;
3708 enum type_return rok
;
3710 rok
= get_c_type_name (ts
, as
, &pre
, &type_name
, &asterisk
, &post
, func_ret
);
3713 gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3714 gfc_typename (ts
), where
);
3715 fprintf (dumpfile
, "/* Cannot convert '%s' to interoperable type */",
3719 fputs (type_name
, dumpfile
);
3720 fputs (pre
, dumpfile
);
3722 fputs ("*", dumpfile
);
3724 fputs (sym_name
, dumpfile
);
3725 fputs (post
, dumpfile
);
3727 if (rok
== T_WARN
&& bind_c
)
3728 fprintf (dumpfile
," /* WARNING: Converting '%s' to interoperable type */",
3732 /* Write out an interoperable type. It will be written as a typedef
3736 write_type (gfc_symbol
*sym
)
3740 fprintf (dumpfile
, "typedef struct %s {\n", sym
->name
);
3741 for (c
= sym
->components
; c
; c
= c
->next
)
3743 fputs (" ", dumpfile
);
3744 write_decl (&(c
->ts
), c
->as
, c
->name
, false, &sym
->declared_at
, true);
3745 fputs (";\n", dumpfile
);
3748 fprintf (dumpfile
, "} %s;\n", sym
->name
);
3751 /* Write out a variable. */
3754 write_variable (gfc_symbol
*sym
)
3756 const char *sym_name
;
3758 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
3760 if (sym
->binding_label
)
3761 sym_name
= sym
->binding_label
;
3763 sym_name
= sym
->name
;
3765 fputs ("extern ", dumpfile
);
3766 write_decl (&(sym
->ts
), sym
->as
, sym_name
, false, &sym
->declared_at
, true);
3767 fputs (";\n", dumpfile
);
3771 /* Write out a procedure, including its arguments. */
3773 write_proc (gfc_symbol
*sym
, bool bind_c
)
3775 const char *pre
, *type_name
, *post
;
3777 enum type_return rok
;
3778 gfc_formal_arglist
*f
;
3779 const char *sym_name
;
3780 const char *intent_in
;
3781 bool external_character
;
3783 external_character
= sym
->ts
.type
== BT_CHARACTER
&& !bind_c
;
3785 if (sym
->binding_label
)
3786 sym_name
= sym
->binding_label
;
3788 sym_name
= sym
->name
;
3790 if (sym
->ts
.type
== BT_UNKNOWN
|| external_character
)
3792 fprintf (dumpfile
, "void ");
3793 fputs (sym_name
, dumpfile
);
3796 write_decl (&(sym
->ts
), sym
->as
, sym_name
, true, &sym
->declared_at
, bind_c
);
3799 fputs ("_", dumpfile
);
3801 fputs (" (", dumpfile
);
3802 if (external_character
)
3804 fprintf (dumpfile
, "char *result_%s, size_t result_%s_len",
3805 sym_name
, sym_name
);
3807 fputs (", ", dumpfile
);
3810 for (f
= sym
->formal
; f
; f
= f
->next
)
3814 rok
= get_c_type_name (&(s
->ts
), NULL
, &pre
, &type_name
, &asterisk
,
3818 gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3819 gfc_typename (&s
->ts
), &s
->declared_at
);
3820 fprintf (dumpfile
, "/* Cannot convert '%s' to interoperable type */",
3821 gfc_typename (&s
->ts
));
3828 if (s
->attr
.intent
== INTENT_IN
&& !s
->attr
.value
)
3829 intent_in
= "const ";
3833 fputs (intent_in
, dumpfile
);
3834 fputs (type_name
, dumpfile
);
3835 fputs (pre
, dumpfile
);
3837 fputs ("*", dumpfile
);
3839 fputs (s
->name
, dumpfile
);
3840 fputs (post
, dumpfile
);
3841 if (bind_c
&& rok
== T_WARN
)
3842 fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile
);
3845 fputs(", ", dumpfile
);
3848 for (f
= sym
->formal
; f
; f
= f
->next
)
3849 if (f
->sym
->ts
.type
== BT_CHARACTER
)
3850 fprintf (dumpfile
, ", size_t %s_len", f
->sym
->name
);
3852 fputs (");\n", dumpfile
);
3856 /* Write a C-interoperable declaration as a C prototype or extern
3860 write_interop_decl (gfc_symbol
*sym
)
3862 /* Only dump bind(c) entities. */
3863 if (!sym
->attr
.is_bind_c
)
3866 /* Don't dump our iso c module. */
3867 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
3870 if (sym
->attr
.flavor
== FL_VARIABLE
)
3871 write_variable (sym
);
3872 else if (sym
->attr
.flavor
== FL_DERIVED
)
3874 else if (sym
->attr
.flavor
== FL_PROCEDURE
)
3875 write_proc (sym
, true);
3878 /* This section deals with dumping the global symbol tree. */
3880 /* Callback function for printing out the contents of the tree. */
3883 show_global_symbol (gfc_gsymbol
*gsym
, void *f_data
)
3886 out
= (FILE *) f_data
;
3889 fprintf (out
, "name=%s", gsym
->name
);
3892 fprintf (out
, ", sym_name=%s", gsym
->sym_name
);
3895 fprintf (out
, ", mod_name=%s", gsym
->mod_name
);
3897 if (gsym
->binding_label
)
3898 fprintf (out
, ", binding_label=%s", gsym
->binding_label
);
3903 /* Show all global symbols. */
3906 gfc_dump_global_symbols (FILE *f
)
3908 if (gfc_gsym_root
== NULL
)
3909 fprintf (f
, "empty\n");
3911 gfc_traverse_gsymbol (gfc_gsym_root
, show_global_symbol
, (void *) f
);
3914 /* Show an array ref. */
3916 void debug (gfc_array_ref
*ar
)
3918 FILE *tmp
= dumpfile
;
3920 show_array_ref (ar
);
3921 fputc ('\n', dumpfile
);