2 Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Steven Bosscher
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* Actually this is just a collection of routines that used to be
24 scattered around the sources. Now that they are all in a single
25 file, almost all of them can be static, and the other files don't
26 have this mess in them.
28 As a nice side-effect, this file can act as documentation of the
29 gfc_code and gfc_expr structures and all their friends and
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 fprintf (dumpfile
, "(%s ", gfc_basic_typename (ts
->type
));
103 fprintf (dumpfile
, "%s", ts
->u
.derived
->name
);
107 show_expr (ts
->u
.cl
->length
);
108 fprintf(dumpfile
, " %d", ts
->kind
);
112 fprintf (dumpfile
, "%d", ts
->kind
);
116 fputc (')', dumpfile
);
120 /* Show an actual argument list. */
123 show_actual_arglist (gfc_actual_arglist
*a
)
125 fputc ('(', dumpfile
);
127 for (; a
; a
= a
->next
)
129 fputc ('(', dumpfile
);
131 fprintf (dumpfile
, "%s = ", a
->name
);
135 fputs ("(arg not-present)", dumpfile
);
137 fputc (')', dumpfile
);
139 fputc (' ', dumpfile
);
142 fputc (')', dumpfile
);
146 /* Show a gfc_array_spec array specification structure. */
149 show_array_spec (gfc_array_spec
*as
)
156 fputs ("()", dumpfile
);
160 fprintf (dumpfile
, "(%d [%d]", as
->rank
, as
->corank
);
162 if (as
->rank
+ as
->corank
> 0)
166 case AS_EXPLICIT
: c
= "AS_EXPLICIT"; break;
167 case AS_DEFERRED
: c
= "AS_DEFERRED"; break;
168 case AS_ASSUMED_SIZE
: c
= "AS_ASSUMED_SIZE"; break;
169 case AS_ASSUMED_SHAPE
: c
= "AS_ASSUMED_SHAPE"; break;
171 gfc_internal_error ("show_array_spec(): Unhandled array shape "
174 fprintf (dumpfile
, " %s ", c
);
176 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
178 show_expr (as
->lower
[i
]);
179 fputc (' ', dumpfile
);
180 show_expr (as
->upper
[i
]);
181 fputc (' ', dumpfile
);
185 fputc (')', dumpfile
);
189 /* Show a gfc_array_ref array reference structure. */
192 show_array_ref (gfc_array_ref
* ar
)
196 fputc ('(', dumpfile
);
201 fputs ("FULL", dumpfile
);
205 for (i
= 0; i
< ar
->dimen
; i
++)
207 /* There are two types of array sections: either the
208 elements are identified by an integer array ('vector'),
209 or by an index range. In the former case we only have to
210 print the start expression which contains the vector, in
211 the latter case we have to print any of lower and upper
212 bound and the stride, if they're present. */
214 if (ar
->start
[i
] != NULL
)
215 show_expr (ar
->start
[i
]);
217 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
219 fputc (':', dumpfile
);
221 if (ar
->end
[i
] != NULL
)
222 show_expr (ar
->end
[i
]);
224 if (ar
->stride
[i
] != NULL
)
226 fputc (':', dumpfile
);
227 show_expr (ar
->stride
[i
]);
231 if (i
!= ar
->dimen
- 1)
232 fputs (" , ", dumpfile
);
237 for (i
= 0; i
< ar
->dimen
; i
++)
239 show_expr (ar
->start
[i
]);
240 if (i
!= ar
->dimen
- 1)
241 fputs (" , ", dumpfile
);
246 fputs ("UNKNOWN", dumpfile
);
250 gfc_internal_error ("show_array_ref(): Unknown array reference");
253 fputc (')', dumpfile
);
257 /* Show a list of gfc_ref structures. */
260 show_ref (gfc_ref
*p
)
262 for (; p
; p
= p
->next
)
266 show_array_ref (&p
->u
.ar
);
270 fprintf (dumpfile
, " %% %s", p
->u
.c
.component
->name
);
274 fputc ('(', dumpfile
);
275 show_expr (p
->u
.ss
.start
);
276 fputc (':', dumpfile
);
277 show_expr (p
->u
.ss
.end
);
278 fputc (')', dumpfile
);
282 gfc_internal_error ("show_ref(): Bad component code");
287 /* Display a constructor. Works recursively for array constructors. */
290 show_constructor (gfc_constructor_base base
)
293 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
295 if (c
->iterator
== NULL
)
299 fputc ('(', dumpfile
);
302 fputc (' ', dumpfile
);
303 show_expr (c
->iterator
->var
);
304 fputc ('=', dumpfile
);
305 show_expr (c
->iterator
->start
);
306 fputc (',', dumpfile
);
307 show_expr (c
->iterator
->end
);
308 fputc (',', dumpfile
);
309 show_expr (c
->iterator
->step
);
311 fputc (')', dumpfile
);
314 if (gfc_constructor_next (c
) != NULL
)
315 fputs (" , ", dumpfile
);
321 show_char_const (const gfc_char_t
*c
, int length
)
325 fputc ('\'', dumpfile
);
326 for (i
= 0; i
< length
; i
++)
329 fputs ("''", dumpfile
);
331 fputs (gfc_print_wide_char (c
[i
]), dumpfile
);
333 fputc ('\'', dumpfile
);
337 /* Show a component-call expression. */
340 show_compcall (gfc_expr
* p
)
342 gcc_assert (p
->expr_type
== EXPR_COMPCALL
);
344 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
346 fprintf (dumpfile
, "%s", p
->value
.compcall
.name
);
348 show_actual_arglist (p
->value
.compcall
.actual
);
352 /* Show an expression. */
355 show_expr (gfc_expr
*p
)
362 fputs ("()", dumpfile
);
366 switch (p
->expr_type
)
369 show_char_const (p
->value
.character
.string
, p
->value
.character
.length
);
374 fprintf (dumpfile
, "%s(", p
->ts
.u
.derived
->name
);
375 show_constructor (p
->value
.constructor
);
376 fputc (')', dumpfile
);
380 fputs ("(/ ", dumpfile
);
381 show_constructor (p
->value
.constructor
);
382 fputs (" /)", dumpfile
);
388 fputs ("NULL()", dumpfile
);
395 mpz_out_str (stdout
, 10, p
->value
.integer
);
397 if (p
->ts
.kind
!= gfc_default_integer_kind
)
398 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
402 if (p
->value
.logical
)
403 fputs (".true.", dumpfile
);
405 fputs (".false.", dumpfile
);
409 mpfr_out_str (stdout
, 10, 0, p
->value
.real
, GFC_RND_MODE
);
410 if (p
->ts
.kind
!= gfc_default_real_kind
)
411 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
415 show_char_const (p
->value
.character
.string
,
416 p
->value
.character
.length
);
420 fputs ("(complex ", dumpfile
);
422 mpfr_out_str (stdout
, 10, 0, mpc_realref (p
->value
.complex),
424 if (p
->ts
.kind
!= gfc_default_complex_kind
)
425 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
427 fputc (' ', dumpfile
);
429 mpfr_out_str (stdout
, 10, 0, mpc_imagref (p
->value
.complex),
431 if (p
->ts
.kind
!= gfc_default_complex_kind
)
432 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
434 fputc (')', dumpfile
);
438 fprintf (dumpfile
, "%dH", p
->representation
.length
);
439 c
= p
->representation
.string
;
440 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
442 fputc (*c
, dumpfile
);
447 fputs ("???", dumpfile
);
451 if (p
->representation
.string
)
453 fputs (" {", dumpfile
);
454 c
= p
->representation
.string
;
455 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
457 fprintf (dumpfile
, "%.2x", (unsigned int) *c
);
458 if (i
< p
->representation
.length
- 1)
459 fputc (',', dumpfile
);
461 fputc ('}', dumpfile
);
467 if (p
->symtree
->n
.sym
->ns
&& p
->symtree
->n
.sym
->ns
->proc_name
)
468 fprintf (dumpfile
, "%s:", p
->symtree
->n
.sym
->ns
->proc_name
->name
);
469 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
474 fputc ('(', dumpfile
);
475 switch (p
->value
.op
.op
)
477 case INTRINSIC_UPLUS
:
478 fputs ("U+ ", dumpfile
);
480 case INTRINSIC_UMINUS
:
481 fputs ("U- ", dumpfile
);
484 fputs ("+ ", dumpfile
);
486 case INTRINSIC_MINUS
:
487 fputs ("- ", dumpfile
);
489 case INTRINSIC_TIMES
:
490 fputs ("* ", dumpfile
);
492 case INTRINSIC_DIVIDE
:
493 fputs ("/ ", dumpfile
);
495 case INTRINSIC_POWER
:
496 fputs ("** ", dumpfile
);
498 case INTRINSIC_CONCAT
:
499 fputs ("// ", dumpfile
);
502 fputs ("AND ", dumpfile
);
505 fputs ("OR ", dumpfile
);
508 fputs ("EQV ", dumpfile
);
511 fputs ("NEQV ", dumpfile
);
514 case INTRINSIC_EQ_OS
:
515 fputs ("= ", dumpfile
);
518 case INTRINSIC_NE_OS
:
519 fputs ("/= ", dumpfile
);
522 case INTRINSIC_GT_OS
:
523 fputs ("> ", dumpfile
);
526 case INTRINSIC_GE_OS
:
527 fputs (">= ", dumpfile
);
530 case INTRINSIC_LT_OS
:
531 fputs ("< ", dumpfile
);
534 case INTRINSIC_LE_OS
:
535 fputs ("<= ", dumpfile
);
538 fputs ("NOT ", dumpfile
);
540 case INTRINSIC_PARENTHESES
:
541 fputs ("parens ", dumpfile
);
546 ("show_expr(): Bad intrinsic in expression!");
549 show_expr (p
->value
.op
.op1
);
553 fputc (' ', dumpfile
);
554 show_expr (p
->value
.op
.op2
);
557 fputc (')', dumpfile
);
561 if (p
->value
.function
.name
== NULL
)
563 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
564 if (gfc_is_proc_ptr_comp (p
, NULL
))
566 fputc ('[', dumpfile
);
567 show_actual_arglist (p
->value
.function
.actual
);
568 fputc (']', dumpfile
);
572 fprintf (dumpfile
, "%s", p
->value
.function
.name
);
573 if (gfc_is_proc_ptr_comp (p
, NULL
))
575 fputc ('[', dumpfile
);
576 fputc ('[', dumpfile
);
577 show_actual_arglist (p
->value
.function
.actual
);
578 fputc (']', dumpfile
);
579 fputc (']', dumpfile
);
589 gfc_internal_error ("show_expr(): Don't know how to show expr");
593 /* Show symbol attributes. The flavor and intent are followed by
594 whatever single bit attributes are present. */
597 show_attr (symbol_attribute
*attr
, const char * module
)
599 if (attr
->flavor
!= FL_UNKNOWN
)
600 fprintf (dumpfile
, "(%s ", gfc_code2string (flavors
, attr
->flavor
));
601 if (attr
->access
!= ACCESS_UNKNOWN
)
602 fprintf (dumpfile
, "%s ", gfc_code2string (access_types
, attr
->access
));
603 if (attr
->proc
!= PROC_UNKNOWN
)
604 fprintf (dumpfile
, "%s ", gfc_code2string (procedures
, attr
->proc
));
605 if (attr
->save
!= SAVE_NONE
)
606 fprintf (dumpfile
, "%s", gfc_code2string (save_status
, attr
->save
));
608 if (attr
->allocatable
)
609 fputs (" ALLOCATABLE", dumpfile
);
610 if (attr
->asynchronous
)
611 fputs (" ASYNCHRONOUS", dumpfile
);
612 if (attr
->codimension
)
613 fputs (" CODIMENSION", dumpfile
);
615 fputs (" DIMENSION", dumpfile
);
616 if (attr
->contiguous
)
617 fputs (" CONTIGUOUS", dumpfile
);
619 fputs (" EXTERNAL", dumpfile
);
621 fputs (" INTRINSIC", dumpfile
);
623 fputs (" OPTIONAL", dumpfile
);
625 fputs (" POINTER", dumpfile
);
626 if (attr
->is_protected
)
627 fputs (" PROTECTED", dumpfile
);
629 fputs (" VALUE", dumpfile
);
631 fputs (" VOLATILE", dumpfile
);
632 if (attr
->threadprivate
)
633 fputs (" THREADPRIVATE", dumpfile
);
635 fputs (" TARGET", dumpfile
);
638 fputs (" DUMMY", dumpfile
);
639 if (attr
->intent
!= INTENT_UNKNOWN
)
640 fprintf (dumpfile
, "(%s)", gfc_intent_string (attr
->intent
));
644 fputs (" RESULT", dumpfile
);
646 fputs (" ENTRY", dumpfile
);
648 fputs (" BIND(C)", dumpfile
);
651 fputs (" DATA", dumpfile
);
654 fputs (" USE-ASSOC", dumpfile
);
656 fprintf (dumpfile
, "(%s)", module
);
659 if (attr
->in_namelist
)
660 fputs (" IN-NAMELIST", dumpfile
);
662 fputs (" IN-COMMON", dumpfile
);
665 fputs (" ABSTRACT", dumpfile
);
667 fputs (" FUNCTION", dumpfile
);
668 if (attr
->subroutine
)
669 fputs (" SUBROUTINE", dumpfile
);
670 if (attr
->implicit_type
)
671 fputs (" IMPLICIT-TYPE", dumpfile
);
674 fputs (" SEQUENCE", dumpfile
);
676 fputs (" ELEMENTAL", dumpfile
);
678 fputs (" PURE", dumpfile
);
680 fputs (" RECURSIVE", dumpfile
);
682 fputc (')', dumpfile
);
686 /* Show components of a derived type. */
689 show_components (gfc_symbol
*sym
)
693 for (c
= sym
->components
; c
; c
= c
->next
)
695 fprintf (dumpfile
, "(%s ", c
->name
);
696 show_typespec (&c
->ts
);
697 if (c
->attr
.allocatable
)
698 fputs (" ALLOCATABLE", dumpfile
);
700 fputs (" POINTER", dumpfile
);
701 if (c
->attr
.proc_pointer
)
702 fputs (" PPC", dumpfile
);
703 if (c
->attr
.dimension
)
704 fputs (" DIMENSION", dumpfile
);
705 fputc (' ', dumpfile
);
706 show_array_spec (c
->as
);
708 fprintf (dumpfile
, " %s", gfc_code2string (access_types
, c
->attr
.access
));
709 fputc (')', dumpfile
);
711 fputc (' ', dumpfile
);
716 /* Show the f2k_derived namespace with procedure bindings. */
719 show_typebound_proc (gfc_typebound_proc
* tb
, const char* name
)
724 fputs ("GENERIC", dumpfile
);
727 fputs ("PROCEDURE, ", dumpfile
);
729 fputs ("NOPASS", dumpfile
);
733 fprintf (dumpfile
, "PASS(%s)", tb
->pass_arg
);
735 fputs ("PASS", dumpfile
);
737 if (tb
->non_overridable
)
738 fputs (", NON_OVERRIDABLE", dumpfile
);
741 if (tb
->access
== ACCESS_PUBLIC
)
742 fputs (", PUBLIC", dumpfile
);
744 fputs (", PRIVATE", dumpfile
);
746 fprintf (dumpfile
, " :: %s => ", name
);
751 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
753 fputs (g
->specific_st
->name
, dumpfile
);
755 fputs (", ", dumpfile
);
759 fputs (tb
->u
.specific
->n
.sym
->name
, dumpfile
);
763 show_typebound_symtree (gfc_symtree
* st
)
765 gcc_assert (st
->n
.tb
);
766 show_typebound_proc (st
->n
.tb
, st
->name
);
770 show_f2k_derived (gfc_namespace
* f2k
)
776 fputs ("Procedure bindings:", dumpfile
);
779 /* Finalizer bindings. */
780 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
783 fprintf (dumpfile
, "FINAL %s", f
->proc_sym
->name
);
786 /* Type-bound procedures. */
787 gfc_traverse_symtree (f2k
->tb_sym_root
, &show_typebound_symtree
);
792 fputs ("Operator bindings:", dumpfile
);
795 /* User-defined operators. */
796 gfc_traverse_symtree (f2k
->tb_uop_root
, &show_typebound_symtree
);
798 /* Intrinsic operators. */
799 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
801 show_typebound_proc (f2k
->tb_op
[op
],
802 gfc_op2string ((gfc_intrinsic_op
) op
));
808 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
809 show the interface. Information needed to reconstruct the list of
810 specific interfaces associated with a generic symbol is done within
814 show_symbol (gfc_symbol
*sym
)
816 gfc_formal_arglist
*formal
;
823 fprintf (dumpfile
, "|| symbol: '%s' ", sym
->name
);
824 len
= strlen (sym
->name
);
825 for (i
=len
; i
<12; i
++)
826 fputc(' ', dumpfile
);
831 fputs ("type spec : ", dumpfile
);
832 show_typespec (&sym
->ts
);
835 fputs ("attributes: ", dumpfile
);
836 show_attr (&sym
->attr
, sym
->module
);
841 fputs ("value: ", dumpfile
);
842 show_expr (sym
->value
);
848 fputs ("Array spec:", dumpfile
);
849 show_array_spec (sym
->as
);
855 fputs ("Generic interfaces:", dumpfile
);
856 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
857 fprintf (dumpfile
, " %s", intr
->sym
->name
);
863 fprintf (dumpfile
, "result: %s", sym
->result
->name
);
869 fputs ("components: ", dumpfile
);
870 show_components (sym
);
873 if (sym
->f2k_derived
)
877 fprintf (dumpfile
, "hash: %d", sym
->hash_value
);
878 show_f2k_derived (sym
->f2k_derived
);
884 fputs ("Formal arglist:", dumpfile
);
886 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
888 if (formal
->sym
!= NULL
)
889 fprintf (dumpfile
, " %s", formal
->sym
->name
);
891 fputs (" [Alt Return]", dumpfile
);
895 if (sym
->formal_ns
&& (sym
->formal_ns
->proc_name
!= sym
)
896 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
899 fputs ("Formal namespace", dumpfile
);
900 show_namespace (sym
->formal_ns
);
906 /* Show a user-defined operator. Just prints an operator
907 and the name of the associated subroutine, really. */
910 show_uop (gfc_user_op
*uop
)
915 fprintf (dumpfile
, "%s:", uop
->name
);
917 for (intr
= uop
->op
; intr
; intr
= intr
->next
)
918 fprintf (dumpfile
, " %s", intr
->sym
->name
);
922 /* Workhorse function for traversing the user operator symtree. */
925 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
932 traverse_uop (st
->left
, func
);
933 traverse_uop (st
->right
, func
);
937 /* Traverse the tree of user operator nodes. */
940 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
942 traverse_uop (ns
->uop_root
, func
);
946 /* Function to display a common block. */
949 show_common (gfc_symtree
*st
)
954 fprintf (dumpfile
, "common: /%s/ ", st
->name
);
956 s
= st
->n
.common
->head
;
959 fprintf (dumpfile
, "%s", s
->name
);
962 fputs (", ", dumpfile
);
964 fputc ('\n', dumpfile
);
968 /* Worker function to display the symbol tree. */
971 show_symtree (gfc_symtree
*st
)
977 len
= strlen(st
->name
);
978 fprintf (dumpfile
, "symtree: '%s'", st
->name
);
980 for (i
=len
; i
<12; i
++)
981 fputc(' ', dumpfile
);
984 fputs( " Ambiguous", dumpfile
);
986 if (st
->n
.sym
->ns
!= gfc_current_ns
)
987 fprintf (dumpfile
, "|| symbol: '%s' from namespace '%s'", st
->n
.sym
->name
,
988 st
->n
.sym
->ns
->proc_name
->name
);
990 show_symbol (st
->n
.sym
);
994 /******************* Show gfc_code structures **************/
997 /* Show a list of code structures. Mutually recursive with
1001 show_code (int level
, gfc_code
*c
)
1003 for (; c
; c
= c
->next
)
1004 show_code_node (level
, c
);
1008 show_namelist (gfc_namelist
*n
)
1010 for (; n
->next
; n
= n
->next
)
1011 fprintf (dumpfile
, "%s,", n
->sym
->name
);
1012 fprintf (dumpfile
, "%s", n
->sym
->name
);
1015 /* Show a single OpenMP directive node and everything underneath it
1019 show_omp_node (int level
, gfc_code
*c
)
1021 gfc_omp_clauses
*omp_clauses
= NULL
;
1022 const char *name
= NULL
;
1026 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
1027 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
1028 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
1029 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
1030 case EXEC_OMP_DO
: name
= "DO"; break;
1031 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
1032 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
1033 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
1034 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
1035 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
1036 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
1037 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
1038 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
1039 case EXEC_OMP_TASK
: name
= "TASK"; break;
1040 case EXEC_OMP_TASKWAIT
: name
= "TASKWAIT"; break;
1041 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
1045 fprintf (dumpfile
, "!$OMP %s", name
);
1049 case EXEC_OMP_PARALLEL
:
1050 case EXEC_OMP_PARALLEL_DO
:
1051 case EXEC_OMP_PARALLEL_SECTIONS
:
1052 case EXEC_OMP_SECTIONS
:
1053 case EXEC_OMP_SINGLE
:
1054 case EXEC_OMP_WORKSHARE
:
1055 case EXEC_OMP_PARALLEL_WORKSHARE
:
1057 omp_clauses
= c
->ext
.omp_clauses
;
1059 case EXEC_OMP_CRITICAL
:
1060 if (c
->ext
.omp_name
)
1061 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1063 case EXEC_OMP_FLUSH
:
1064 if (c
->ext
.omp_namelist
)
1066 fputs (" (", dumpfile
);
1067 show_namelist (c
->ext
.omp_namelist
);
1068 fputc (')', dumpfile
);
1071 case EXEC_OMP_BARRIER
:
1072 case EXEC_OMP_TASKWAIT
:
1081 if (omp_clauses
->if_expr
)
1083 fputs (" IF(", dumpfile
);
1084 show_expr (omp_clauses
->if_expr
);
1085 fputc (')', dumpfile
);
1087 if (omp_clauses
->num_threads
)
1089 fputs (" NUM_THREADS(", dumpfile
);
1090 show_expr (omp_clauses
->num_threads
);
1091 fputc (')', dumpfile
);
1093 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
1096 switch (omp_clauses
->sched_kind
)
1098 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
1099 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
1100 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
1101 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
1102 case OMP_SCHED_AUTO
: type
= "AUTO"; break;
1106 fprintf (dumpfile
, " SCHEDULE (%s", type
);
1107 if (omp_clauses
->chunk_size
)
1109 fputc (',', dumpfile
);
1110 show_expr (omp_clauses
->chunk_size
);
1112 fputc (')', dumpfile
);
1114 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1117 switch (omp_clauses
->default_sharing
)
1119 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
1120 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
1121 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
1122 case OMP_DEFAULT_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1126 fprintf (dumpfile
, " DEFAULT(%s)", type
);
1128 if (omp_clauses
->ordered
)
1129 fputs (" ORDERED", dumpfile
);
1130 if (omp_clauses
->untied
)
1131 fputs (" UNTIED", dumpfile
);
1132 if (omp_clauses
->collapse
)
1133 fprintf (dumpfile
, " COLLAPSE(%d)", omp_clauses
->collapse
);
1134 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
1135 if (omp_clauses
->lists
[list_type
] != NULL
1136 && list_type
!= OMP_LIST_COPYPRIVATE
)
1139 if (list_type
>= OMP_LIST_REDUCTION_FIRST
)
1143 case OMP_LIST_PLUS
: type
= "+"; break;
1144 case OMP_LIST_MULT
: type
= "*"; break;
1145 case OMP_LIST_SUB
: type
= "-"; break;
1146 case OMP_LIST_AND
: type
= ".AND."; break;
1147 case OMP_LIST_OR
: type
= ".OR."; break;
1148 case OMP_LIST_EQV
: type
= ".EQV."; break;
1149 case OMP_LIST_NEQV
: type
= ".NEQV."; break;
1150 case OMP_LIST_MAX
: type
= "MAX"; break;
1151 case OMP_LIST_MIN
: type
= "MIN"; break;
1152 case OMP_LIST_IAND
: type
= "IAND"; break;
1153 case OMP_LIST_IOR
: type
= "IOR"; break;
1154 case OMP_LIST_IEOR
: type
= "IEOR"; break;
1158 fprintf (dumpfile
, " REDUCTION(%s:", type
);
1164 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
1165 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
1166 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
1167 case OMP_LIST_SHARED
: type
= "SHARED"; break;
1168 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
1172 fprintf (dumpfile
, " %s(", type
);
1174 show_namelist (omp_clauses
->lists
[list_type
]);
1175 fputc (')', dumpfile
);
1178 fputc ('\n', dumpfile
);
1179 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
1181 gfc_code
*d
= c
->block
;
1184 show_code (level
+ 1, d
->next
);
1185 if (d
->block
== NULL
)
1187 code_indent (level
, 0);
1188 fputs ("!$OMP SECTION\n", dumpfile
);
1193 show_code (level
+ 1, c
->block
->next
);
1194 if (c
->op
== EXEC_OMP_ATOMIC
)
1196 code_indent (level
, 0);
1197 fprintf (dumpfile
, "!$OMP END %s", name
);
1198 if (omp_clauses
!= NULL
)
1200 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
1202 fputs (" COPYPRIVATE(", dumpfile
);
1203 show_namelist (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1204 fputc (')', dumpfile
);
1206 else if (omp_clauses
->nowait
)
1207 fputs (" NOWAIT", dumpfile
);
1209 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_name
)
1210 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1214 /* Show a single code node and everything underneath it if necessary. */
1217 show_code_node (int level
, gfc_code
*c
)
1219 gfc_forall_iterator
*fa
;
1232 fputc ('\n', dumpfile
);
1233 code_indent (level
, c
->here
);
1240 case EXEC_END_PROCEDURE
:
1244 fputs ("NOP", dumpfile
);
1248 fputs ("CONTINUE", dumpfile
);
1252 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
1255 case EXEC_INIT_ASSIGN
:
1257 fputs ("ASSIGN ", dumpfile
);
1258 show_expr (c
->expr1
);
1259 fputc (' ', dumpfile
);
1260 show_expr (c
->expr2
);
1263 case EXEC_LABEL_ASSIGN
:
1264 fputs ("LABEL ASSIGN ", dumpfile
);
1265 show_expr (c
->expr1
);
1266 fprintf (dumpfile
, " %d", c
->label1
->value
);
1269 case EXEC_POINTER_ASSIGN
:
1270 fputs ("POINTER ASSIGN ", dumpfile
);
1271 show_expr (c
->expr1
);
1272 fputc (' ', dumpfile
);
1273 show_expr (c
->expr2
);
1277 fputs ("GOTO ", dumpfile
);
1279 fprintf (dumpfile
, "%d", c
->label1
->value
);
1282 show_expr (c
->expr1
);
1286 fputs (", (", dumpfile
);
1287 for (; d
; d
= d
->block
)
1289 code_indent (level
, d
->label1
);
1290 if (d
->block
!= NULL
)
1291 fputc (',', dumpfile
);
1293 fputc (')', dumpfile
);
1300 case EXEC_ASSIGN_CALL
:
1301 if (c
->resolved_sym
)
1302 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
1303 else if (c
->symtree
)
1304 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
1306 fputs ("CALL ?? ", dumpfile
);
1308 show_actual_arglist (c
->ext
.actual
);
1312 fputs ("CALL ", dumpfile
);
1313 show_compcall (c
->expr1
);
1317 fputs ("CALL ", dumpfile
);
1318 show_expr (c
->expr1
);
1319 show_actual_arglist (c
->ext
.actual
);
1323 fputs ("RETURN ", dumpfile
);
1325 show_expr (c
->expr1
);
1329 fputs ("PAUSE ", dumpfile
);
1331 if (c
->expr1
!= NULL
)
1332 show_expr (c
->expr1
);
1334 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1338 case EXEC_ERROR_STOP
:
1339 fputs ("ERROR ", dumpfile
);
1343 fputs ("STOP ", dumpfile
);
1345 if (c
->expr1
!= NULL
)
1346 show_expr (c
->expr1
);
1348 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1353 fputs ("SYNC ALL ", dumpfile
);
1354 if (c
->expr2
!= NULL
)
1356 fputs (" stat=", dumpfile
);
1357 show_expr (c
->expr2
);
1359 if (c
->expr3
!= NULL
)
1361 fputs (" errmsg=", dumpfile
);
1362 show_expr (c
->expr3
);
1366 case EXEC_SYNC_MEMORY
:
1367 fputs ("SYNC MEMORY ", dumpfile
);
1368 if (c
->expr2
!= NULL
)
1370 fputs (" stat=", dumpfile
);
1371 show_expr (c
->expr2
);
1373 if (c
->expr3
!= NULL
)
1375 fputs (" errmsg=", dumpfile
);
1376 show_expr (c
->expr3
);
1380 case EXEC_SYNC_IMAGES
:
1381 fputs ("SYNC IMAGES image-set=", dumpfile
);
1382 if (c
->expr1
!= NULL
)
1383 show_expr (c
->expr1
);
1385 fputs ("* ", dumpfile
);
1386 if (c
->expr2
!= NULL
)
1388 fputs (" stat=", dumpfile
);
1389 show_expr (c
->expr2
);
1391 if (c
->expr3
!= NULL
)
1393 fputs (" errmsg=", dumpfile
);
1394 show_expr (c
->expr3
);
1398 case EXEC_ARITHMETIC_IF
:
1399 fputs ("IF ", dumpfile
);
1400 show_expr (c
->expr1
);
1401 fprintf (dumpfile
, " %d, %d, %d",
1402 c
->label1
->value
, c
->label2
->value
, c
->label3
->value
);
1407 fputs ("IF ", dumpfile
);
1408 show_expr (d
->expr1
);
1411 show_code (level
+ 1, d
->next
);
1415 for (; d
; d
= d
->block
)
1417 code_indent (level
, 0);
1419 if (d
->expr1
== NULL
)
1420 fputs ("ELSE", dumpfile
);
1423 fputs ("ELSE IF ", dumpfile
);
1424 show_expr (d
->expr1
);
1428 show_code (level
+ 1, d
->next
);
1433 code_indent (level
, c
->label1
);
1437 fputs ("ENDIF", dumpfile
);
1442 const char* blocktype
;
1443 if (c
->ext
.block
.assoc
)
1444 blocktype
= "ASSOCIATE";
1446 blocktype
= "BLOCK";
1448 fprintf (dumpfile
, "%s ", blocktype
);
1450 ns
= c
->ext
.block
.ns
;
1451 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
1452 show_code (show_level
, ns
->code
);
1455 fprintf (dumpfile
, "END %s ", blocktype
);
1461 fputs ("SELECT CASE ", dumpfile
);
1462 show_expr (c
->expr1
);
1463 fputc ('\n', dumpfile
);
1465 for (; d
; d
= d
->block
)
1467 code_indent (level
, 0);
1469 fputs ("CASE ", dumpfile
);
1470 for (cp
= d
->ext
.case_list
; cp
; cp
= cp
->next
)
1472 fputc ('(', dumpfile
);
1473 show_expr (cp
->low
);
1474 fputc (' ', dumpfile
);
1475 show_expr (cp
->high
);
1476 fputc (')', dumpfile
);
1477 fputc (' ', dumpfile
);
1479 fputc ('\n', dumpfile
);
1481 show_code (level
+ 1, d
->next
);
1484 code_indent (level
, c
->label1
);
1485 fputs ("END SELECT", dumpfile
);
1489 fputs ("WHERE ", dumpfile
);
1492 show_expr (d
->expr1
);
1493 fputc ('\n', dumpfile
);
1495 show_code (level
+ 1, d
->next
);
1497 for (d
= d
->block
; d
; d
= d
->block
)
1499 code_indent (level
, 0);
1500 fputs ("ELSE WHERE ", dumpfile
);
1501 show_expr (d
->expr1
);
1502 fputc ('\n', dumpfile
);
1503 show_code (level
+ 1, d
->next
);
1506 code_indent (level
, 0);
1507 fputs ("END WHERE", dumpfile
);
1512 fputs ("FORALL ", dumpfile
);
1513 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1515 show_expr (fa
->var
);
1516 fputc (' ', dumpfile
);
1517 show_expr (fa
->start
);
1518 fputc (':', dumpfile
);
1519 show_expr (fa
->end
);
1520 fputc (':', dumpfile
);
1521 show_expr (fa
->stride
);
1523 if (fa
->next
!= NULL
)
1524 fputc (',', dumpfile
);
1527 if (c
->expr1
!= NULL
)
1529 fputc (',', dumpfile
);
1530 show_expr (c
->expr1
);
1532 fputc ('\n', dumpfile
);
1534 show_code (level
+ 1, c
->block
->next
);
1536 code_indent (level
, 0);
1537 fputs ("END FORALL", dumpfile
);
1541 fputs ("CRITICAL\n", dumpfile
);
1542 show_code (level
+ 1, c
->block
->next
);
1543 code_indent (level
, 0);
1544 fputs ("END CRITICAL", dumpfile
);
1548 fputs ("DO ", dumpfile
);
1550 fprintf (dumpfile
, " %-5d ", c
->label1
->value
);
1552 show_expr (c
->ext
.iterator
->var
);
1553 fputc ('=', dumpfile
);
1554 show_expr (c
->ext
.iterator
->start
);
1555 fputc (' ', dumpfile
);
1556 show_expr (c
->ext
.iterator
->end
);
1557 fputc (' ', dumpfile
);
1558 show_expr (c
->ext
.iterator
->step
);
1561 show_code (level
+ 1, c
->block
->next
);
1568 fputs ("END DO", dumpfile
);
1572 fputs ("DO WHILE ", dumpfile
);
1573 show_expr (c
->expr1
);
1574 fputc ('\n', dumpfile
);
1576 show_code (level
+ 1, c
->block
->next
);
1578 code_indent (level
, c
->label1
);
1579 fputs ("END DO", dumpfile
);
1583 fputs ("CYCLE", dumpfile
);
1585 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1589 fputs ("EXIT", dumpfile
);
1591 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1595 fputs ("ALLOCATE ", dumpfile
);
1598 fputs (" STAT=", dumpfile
);
1599 show_expr (c
->expr1
);
1604 fputs (" ERRMSG=", dumpfile
);
1605 show_expr (c
->expr2
);
1608 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
1610 fputc (' ', dumpfile
);
1611 show_expr (a
->expr
);
1616 case EXEC_DEALLOCATE
:
1617 fputs ("DEALLOCATE ", dumpfile
);
1620 fputs (" STAT=", dumpfile
);
1621 show_expr (c
->expr1
);
1626 fputs (" ERRMSG=", dumpfile
);
1627 show_expr (c
->expr2
);
1630 for (a
= c
->ext
.alloc
.list
; a
; a
= a
->next
)
1632 fputc (' ', dumpfile
);
1633 show_expr (a
->expr
);
1639 fputs ("OPEN", dumpfile
);
1644 fputs (" UNIT=", dumpfile
);
1645 show_expr (open
->unit
);
1649 fputs (" IOMSG=", dumpfile
);
1650 show_expr (open
->iomsg
);
1654 fputs (" IOSTAT=", dumpfile
);
1655 show_expr (open
->iostat
);
1659 fputs (" FILE=", dumpfile
);
1660 show_expr (open
->file
);
1664 fputs (" STATUS=", dumpfile
);
1665 show_expr (open
->status
);
1669 fputs (" ACCESS=", dumpfile
);
1670 show_expr (open
->access
);
1674 fputs (" FORM=", dumpfile
);
1675 show_expr (open
->form
);
1679 fputs (" RECL=", dumpfile
);
1680 show_expr (open
->recl
);
1684 fputs (" BLANK=", dumpfile
);
1685 show_expr (open
->blank
);
1689 fputs (" POSITION=", dumpfile
);
1690 show_expr (open
->position
);
1694 fputs (" ACTION=", dumpfile
);
1695 show_expr (open
->action
);
1699 fputs (" DELIM=", dumpfile
);
1700 show_expr (open
->delim
);
1704 fputs (" PAD=", dumpfile
);
1705 show_expr (open
->pad
);
1709 fputs (" DECIMAL=", dumpfile
);
1710 show_expr (open
->decimal
);
1714 fputs (" ENCODING=", dumpfile
);
1715 show_expr (open
->encoding
);
1719 fputs (" ROUND=", dumpfile
);
1720 show_expr (open
->round
);
1724 fputs (" SIGN=", dumpfile
);
1725 show_expr (open
->sign
);
1729 fputs (" CONVERT=", dumpfile
);
1730 show_expr (open
->convert
);
1732 if (open
->asynchronous
)
1734 fputs (" ASYNCHRONOUS=", dumpfile
);
1735 show_expr (open
->asynchronous
);
1737 if (open
->err
!= NULL
)
1738 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
1743 fputs ("CLOSE", dumpfile
);
1744 close
= c
->ext
.close
;
1748 fputs (" UNIT=", dumpfile
);
1749 show_expr (close
->unit
);
1753 fputs (" IOMSG=", dumpfile
);
1754 show_expr (close
->iomsg
);
1758 fputs (" IOSTAT=", dumpfile
);
1759 show_expr (close
->iostat
);
1763 fputs (" STATUS=", dumpfile
);
1764 show_expr (close
->status
);
1766 if (close
->err
!= NULL
)
1767 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
1770 case EXEC_BACKSPACE
:
1771 fputs ("BACKSPACE", dumpfile
);
1775 fputs ("ENDFILE", dumpfile
);
1779 fputs ("REWIND", dumpfile
);
1783 fputs ("FLUSH", dumpfile
);
1786 fp
= c
->ext
.filepos
;
1790 fputs (" UNIT=", dumpfile
);
1791 show_expr (fp
->unit
);
1795 fputs (" IOMSG=", dumpfile
);
1796 show_expr (fp
->iomsg
);
1800 fputs (" IOSTAT=", dumpfile
);
1801 show_expr (fp
->iostat
);
1803 if (fp
->err
!= NULL
)
1804 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
1808 fputs ("INQUIRE", dumpfile
);
1813 fputs (" UNIT=", dumpfile
);
1814 show_expr (i
->unit
);
1818 fputs (" FILE=", dumpfile
);
1819 show_expr (i
->file
);
1824 fputs (" IOMSG=", dumpfile
);
1825 show_expr (i
->iomsg
);
1829 fputs (" IOSTAT=", dumpfile
);
1830 show_expr (i
->iostat
);
1834 fputs (" EXIST=", dumpfile
);
1835 show_expr (i
->exist
);
1839 fputs (" OPENED=", dumpfile
);
1840 show_expr (i
->opened
);
1844 fputs (" NUMBER=", dumpfile
);
1845 show_expr (i
->number
);
1849 fputs (" NAMED=", dumpfile
);
1850 show_expr (i
->named
);
1854 fputs (" NAME=", dumpfile
);
1855 show_expr (i
->name
);
1859 fputs (" ACCESS=", dumpfile
);
1860 show_expr (i
->access
);
1864 fputs (" SEQUENTIAL=", dumpfile
);
1865 show_expr (i
->sequential
);
1870 fputs (" DIRECT=", dumpfile
);
1871 show_expr (i
->direct
);
1875 fputs (" FORM=", dumpfile
);
1876 show_expr (i
->form
);
1880 fputs (" FORMATTED", dumpfile
);
1881 show_expr (i
->formatted
);
1885 fputs (" UNFORMATTED=", dumpfile
);
1886 show_expr (i
->unformatted
);
1890 fputs (" RECL=", dumpfile
);
1891 show_expr (i
->recl
);
1895 fputs (" NEXTREC=", dumpfile
);
1896 show_expr (i
->nextrec
);
1900 fputs (" BLANK=", dumpfile
);
1901 show_expr (i
->blank
);
1905 fputs (" POSITION=", dumpfile
);
1906 show_expr (i
->position
);
1910 fputs (" ACTION=", dumpfile
);
1911 show_expr (i
->action
);
1915 fputs (" READ=", dumpfile
);
1916 show_expr (i
->read
);
1920 fputs (" WRITE=", dumpfile
);
1921 show_expr (i
->write
);
1925 fputs (" READWRITE=", dumpfile
);
1926 show_expr (i
->readwrite
);
1930 fputs (" DELIM=", dumpfile
);
1931 show_expr (i
->delim
);
1935 fputs (" PAD=", dumpfile
);
1940 fputs (" CONVERT=", dumpfile
);
1941 show_expr (i
->convert
);
1943 if (i
->asynchronous
)
1945 fputs (" ASYNCHRONOUS=", dumpfile
);
1946 show_expr (i
->asynchronous
);
1950 fputs (" DECIMAL=", dumpfile
);
1951 show_expr (i
->decimal
);
1955 fputs (" ENCODING=", dumpfile
);
1956 show_expr (i
->encoding
);
1960 fputs (" PENDING=", dumpfile
);
1961 show_expr (i
->pending
);
1965 fputs (" ROUND=", dumpfile
);
1966 show_expr (i
->round
);
1970 fputs (" SIGN=", dumpfile
);
1971 show_expr (i
->sign
);
1975 fputs (" SIZE=", dumpfile
);
1976 show_expr (i
->size
);
1980 fputs (" ID=", dumpfile
);
1985 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
1989 fputs ("IOLENGTH ", dumpfile
);
1990 show_expr (c
->expr1
);
1995 fputs ("READ", dumpfile
);
1999 fputs ("WRITE", dumpfile
);
2005 fputs (" UNIT=", dumpfile
);
2006 show_expr (dt
->io_unit
);
2009 if (dt
->format_expr
)
2011 fputs (" FMT=", dumpfile
);
2012 show_expr (dt
->format_expr
);
2015 if (dt
->format_label
!= NULL
)
2016 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
2018 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
2022 fputs (" IOMSG=", dumpfile
);
2023 show_expr (dt
->iomsg
);
2027 fputs (" IOSTAT=", dumpfile
);
2028 show_expr (dt
->iostat
);
2032 fputs (" SIZE=", dumpfile
);
2033 show_expr (dt
->size
);
2037 fputs (" REC=", dumpfile
);
2038 show_expr (dt
->rec
);
2042 fputs (" ADVANCE=", dumpfile
);
2043 show_expr (dt
->advance
);
2047 fputs (" ID=", dumpfile
);
2052 fputs (" POS=", dumpfile
);
2053 show_expr (dt
->pos
);
2055 if (dt
->asynchronous
)
2057 fputs (" ASYNCHRONOUS=", dumpfile
);
2058 show_expr (dt
->asynchronous
);
2062 fputs (" BLANK=", dumpfile
);
2063 show_expr (dt
->blank
);
2067 fputs (" DECIMAL=", dumpfile
);
2068 show_expr (dt
->decimal
);
2072 fputs (" DELIM=", dumpfile
);
2073 show_expr (dt
->delim
);
2077 fputs (" PAD=", dumpfile
);
2078 show_expr (dt
->pad
);
2082 fputs (" ROUND=", dumpfile
);
2083 show_expr (dt
->round
);
2087 fputs (" SIGN=", dumpfile
);
2088 show_expr (dt
->sign
);
2092 for (c
= c
->block
->next
; c
; c
= c
->next
)
2093 show_code_node (level
+ (c
->next
!= NULL
), c
);
2097 fputs ("TRANSFER ", dumpfile
);
2098 show_expr (c
->expr1
);
2102 fputs ("DT_END", dumpfile
);
2105 if (dt
->err
!= NULL
)
2106 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
2107 if (dt
->end
!= NULL
)
2108 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
2109 if (dt
->eor
!= NULL
)
2110 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
2113 case EXEC_OMP_ATOMIC
:
2114 case EXEC_OMP_BARRIER
:
2115 case EXEC_OMP_CRITICAL
:
2116 case EXEC_OMP_FLUSH
:
2118 case EXEC_OMP_MASTER
:
2119 case EXEC_OMP_ORDERED
:
2120 case EXEC_OMP_PARALLEL
:
2121 case EXEC_OMP_PARALLEL_DO
:
2122 case EXEC_OMP_PARALLEL_SECTIONS
:
2123 case EXEC_OMP_PARALLEL_WORKSHARE
:
2124 case EXEC_OMP_SECTIONS
:
2125 case EXEC_OMP_SINGLE
:
2127 case EXEC_OMP_TASKWAIT
:
2128 case EXEC_OMP_WORKSHARE
:
2129 show_omp_node (level
, c
);
2133 gfc_internal_error ("show_code_node(): Bad statement code");
2138 /* Show an equivalence chain. */
2141 show_equiv (gfc_equiv
*eq
)
2144 fputs ("Equivalence: ", dumpfile
);
2147 show_expr (eq
->expr
);
2150 fputs (", ", dumpfile
);
2155 /* Show a freakin' whole namespace. */
2158 show_namespace (gfc_namespace
*ns
)
2160 gfc_interface
*intr
;
2161 gfc_namespace
*save
;
2166 save
= gfc_current_ns
;
2169 fputs ("Namespace:", dumpfile
);
2177 while (i
< GFC_LETTERS
- 1
2178 && gfc_compare_types(&ns
->default_type
[i
+1],
2179 &ns
->default_type
[l
]))
2183 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
2185 fprintf (dumpfile
, " %c: ", l
+'A');
2187 show_typespec(&ns
->default_type
[l
]);
2189 } while (i
< GFC_LETTERS
);
2191 if (ns
->proc_name
!= NULL
)
2194 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
2198 gfc_current_ns
= ns
;
2199 gfc_traverse_symtree (ns
->common_root
, show_common
);
2201 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
2203 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
2205 /* User operator interfaces */
2211 fprintf (dumpfile
, "Operator interfaces for %s:",
2212 gfc_op2string ((gfc_intrinsic_op
) op
));
2214 for (; intr
; intr
= intr
->next
)
2215 fprintf (dumpfile
, " %s", intr
->sym
->name
);
2218 if (ns
->uop_root
!= NULL
)
2221 fputs ("User operators:\n", dumpfile
);
2222 gfc_traverse_user_op (ns
, show_uop
);
2228 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
2231 fputc ('\n', dumpfile
);
2233 fputs ("code:", dumpfile
);
2234 show_code (show_level
, ns
->code
);
2237 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
2239 fputs ("\nCONTAINS\n", dumpfile
);
2241 show_namespace (ns
);
2245 fputc ('\n', dumpfile
);
2246 gfc_current_ns
= save
;
2250 /* Main function for dumping a parse tree. */
2253 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
2256 show_namespace (ns
);