2 Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008
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 /* Keep track of indentation for symbol tree dumps. */
38 static int show_level
= 0;
40 /* The file handle we're dumping to is kept in a static variable. This
41 is not too cool, but it avoids a lot of passing it around. */
42 static FILE *dumpfile
;
44 /* Forward declaration of some of the functions. */
45 static void show_expr (gfc_expr
*p
);
46 static void show_code_node (int, gfc_code
*);
47 static void show_namespace (gfc_namespace
*ns
);
50 /* Do indentation for a specific level. */
53 code_indent (int level
, gfc_st_label
*label
)
58 fprintf (dumpfile
, "%-5d ", label
->value
);
60 fputs (" ", dumpfile
);
62 for (i
= 0; i
< 2 * level
; i
++)
63 fputc (' ', dumpfile
);
67 /* Simple indentation at the current level. This one
68 is used to show symbols. */
73 fputc ('\n', dumpfile
);
74 code_indent (show_level
, NULL
);
78 /* Show type-specific information. */
81 show_typespec (gfc_typespec
*ts
)
83 fprintf (dumpfile
, "(%s ", gfc_basic_typename (ts
->type
));
88 fprintf (dumpfile
, "%s", ts
->derived
->name
);
92 show_expr (ts
->cl
->length
);
96 fprintf (dumpfile
, "%d", ts
->kind
);
100 fputc (')', dumpfile
);
104 /* Show an actual argument list. */
107 show_actual_arglist (gfc_actual_arglist
*a
)
109 fputc ('(', dumpfile
);
111 for (; a
; a
= a
->next
)
113 fputc ('(', dumpfile
);
115 fprintf (dumpfile
, "%s = ", a
->name
);
119 fputs ("(arg not-present)", dumpfile
);
121 fputc (')', dumpfile
);
123 fputc (' ', dumpfile
);
126 fputc (')', dumpfile
);
130 /* Show a gfc_array_spec array specification structure. */
133 show_array_spec (gfc_array_spec
*as
)
140 fputs ("()", dumpfile
);
144 fprintf (dumpfile
, "(%d", as
->rank
);
150 case AS_EXPLICIT
: c
= "AS_EXPLICIT"; break;
151 case AS_DEFERRED
: c
= "AS_DEFERRED"; break;
152 case AS_ASSUMED_SIZE
: c
= "AS_ASSUMED_SIZE"; break;
153 case AS_ASSUMED_SHAPE
: c
= "AS_ASSUMED_SHAPE"; break;
155 gfc_internal_error ("show_array_spec(): Unhandled array shape "
158 fprintf (dumpfile
, " %s ", c
);
160 for (i
= 0; i
< as
->rank
; i
++)
162 show_expr (as
->lower
[i
]);
163 fputc (' ', dumpfile
);
164 show_expr (as
->upper
[i
]);
165 fputc (' ', dumpfile
);
169 fputc (')', dumpfile
);
173 /* Show a gfc_array_ref array reference structure. */
176 show_array_ref (gfc_array_ref
* ar
)
180 fputc ('(', dumpfile
);
185 fputs ("FULL", dumpfile
);
189 for (i
= 0; i
< ar
->dimen
; i
++)
191 /* There are two types of array sections: either the
192 elements are identified by an integer array ('vector'),
193 or by an index range. In the former case we only have to
194 print the start expression which contains the vector, in
195 the latter case we have to print any of lower and upper
196 bound and the stride, if they're present. */
198 if (ar
->start
[i
] != NULL
)
199 show_expr (ar
->start
[i
]);
201 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
203 fputc (':', dumpfile
);
205 if (ar
->end
[i
] != NULL
)
206 show_expr (ar
->end
[i
]);
208 if (ar
->stride
[i
] != NULL
)
210 fputc (':', dumpfile
);
211 show_expr (ar
->stride
[i
]);
215 if (i
!= ar
->dimen
- 1)
216 fputs (" , ", dumpfile
);
221 for (i
= 0; i
< ar
->dimen
; i
++)
223 show_expr (ar
->start
[i
]);
224 if (i
!= ar
->dimen
- 1)
225 fputs (" , ", dumpfile
);
230 fputs ("UNKNOWN", dumpfile
);
234 gfc_internal_error ("show_array_ref(): Unknown array reference");
237 fputc (')', dumpfile
);
241 /* Show a list of gfc_ref structures. */
244 show_ref (gfc_ref
*p
)
246 for (; p
; p
= p
->next
)
250 show_array_ref (&p
->u
.ar
);
254 fprintf (dumpfile
, " %% %s", p
->u
.c
.component
->name
);
258 fputc ('(', dumpfile
);
259 show_expr (p
->u
.ss
.start
);
260 fputc (':', dumpfile
);
261 show_expr (p
->u
.ss
.end
);
262 fputc (')', dumpfile
);
266 gfc_internal_error ("show_ref(): Bad component code");
271 /* Display a constructor. Works recursively for array constructors. */
274 show_constructor (gfc_constructor
*c
)
276 for (; c
; c
= c
->next
)
278 if (c
->iterator
== NULL
)
282 fputc ('(', dumpfile
);
285 fputc (' ', dumpfile
);
286 show_expr (c
->iterator
->var
);
287 fputc ('=', dumpfile
);
288 show_expr (c
->iterator
->start
);
289 fputc (',', dumpfile
);
290 show_expr (c
->iterator
->end
);
291 fputc (',', dumpfile
);
292 show_expr (c
->iterator
->step
);
294 fputc (')', dumpfile
);
298 fputs (" , ", dumpfile
);
304 show_char_const (const gfc_char_t
*c
, int length
)
308 fputc ('\'', dumpfile
);
309 for (i
= 0; i
< length
; i
++)
312 fputs ("''", dumpfile
);
314 fputs (gfc_print_wide_char (c
[i
]), dumpfile
);
316 fputc ('\'', dumpfile
);
319 /* Show an expression. */
322 show_expr (gfc_expr
*p
)
329 fputs ("()", dumpfile
);
333 switch (p
->expr_type
)
336 show_char_const (p
->value
.character
.string
, p
->value
.character
.length
);
341 fprintf (dumpfile
, "%s(", p
->ts
.derived
->name
);
342 show_constructor (p
->value
.constructor
);
343 fputc (')', dumpfile
);
347 fputs ("(/ ", dumpfile
);
348 show_constructor (p
->value
.constructor
);
349 fputs (" /)", dumpfile
);
355 fputs ("NULL()", dumpfile
);
362 mpz_out_str (stdout
, 10, p
->value
.integer
);
364 if (p
->ts
.kind
!= gfc_default_integer_kind
)
365 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
369 if (p
->value
.logical
)
370 fputs (".true.", dumpfile
);
372 fputs (".false.", dumpfile
);
376 mpfr_out_str (stdout
, 10, 0, p
->value
.real
, GFC_RND_MODE
);
377 if (p
->ts
.kind
!= gfc_default_real_kind
)
378 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
382 show_char_const (p
->value
.character
.string
,
383 p
->value
.character
.length
);
387 fputs ("(complex ", dumpfile
);
389 mpfr_out_str (stdout
, 10, 0, p
->value
.complex.r
, GFC_RND_MODE
);
390 if (p
->ts
.kind
!= gfc_default_complex_kind
)
391 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
393 fputc (' ', dumpfile
);
395 mpfr_out_str (stdout
, 10, 0, p
->value
.complex.i
, GFC_RND_MODE
);
396 if (p
->ts
.kind
!= gfc_default_complex_kind
)
397 fprintf (dumpfile
, "_%d", p
->ts
.kind
);
399 fputc (')', dumpfile
);
403 fprintf (dumpfile
, "%dH", p
->representation
.length
);
404 c
= p
->representation
.string
;
405 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
407 fputc (*c
, dumpfile
);
412 fputs ("???", dumpfile
);
416 if (p
->representation
.string
)
418 fputs (" {", dumpfile
);
419 c
= p
->representation
.string
;
420 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
422 fprintf (dumpfile
, "%.2x", (unsigned int) *c
);
423 if (i
< p
->representation
.length
- 1)
424 fputc (',', dumpfile
);
426 fputc ('}', dumpfile
);
432 if (p
->symtree
->n
.sym
->ns
&& p
->symtree
->n
.sym
->ns
->proc_name
)
433 fprintf (dumpfile
, "%s:", p
->symtree
->n
.sym
->ns
->proc_name
->name
);
434 fprintf (dumpfile
, "%s", p
->symtree
->n
.sym
->name
);
439 fputc ('(', dumpfile
);
440 switch (p
->value
.op
.operator)
442 case INTRINSIC_UPLUS
:
443 fputs ("U+ ", dumpfile
);
445 case INTRINSIC_UMINUS
:
446 fputs ("U- ", dumpfile
);
449 fputs ("+ ", dumpfile
);
451 case INTRINSIC_MINUS
:
452 fputs ("- ", dumpfile
);
454 case INTRINSIC_TIMES
:
455 fputs ("* ", dumpfile
);
457 case INTRINSIC_DIVIDE
:
458 fputs ("/ ", dumpfile
);
460 case INTRINSIC_POWER
:
461 fputs ("** ", dumpfile
);
463 case INTRINSIC_CONCAT
:
464 fputs ("// ", dumpfile
);
467 fputs ("AND ", dumpfile
);
470 fputs ("OR ", dumpfile
);
473 fputs ("EQV ", dumpfile
);
476 fputs ("NEQV ", dumpfile
);
479 case INTRINSIC_EQ_OS
:
480 fputs ("= ", dumpfile
);
483 case INTRINSIC_NE_OS
:
484 fputs ("/= ", dumpfile
);
487 case INTRINSIC_GT_OS
:
488 fputs ("> ", dumpfile
);
491 case INTRINSIC_GE_OS
:
492 fputs (">= ", dumpfile
);
495 case INTRINSIC_LT_OS
:
496 fputs ("< ", dumpfile
);
499 case INTRINSIC_LE_OS
:
500 fputs ("<= ", dumpfile
);
503 fputs ("NOT ", dumpfile
);
505 case INTRINSIC_PARENTHESES
:
506 fputs ("parens", dumpfile
);
511 ("show_expr(): Bad intrinsic in expression!");
514 show_expr (p
->value
.op
.op1
);
518 fputc (' ', dumpfile
);
519 show_expr (p
->value
.op
.op2
);
522 fputc (')', dumpfile
);
526 if (p
->value
.function
.name
== NULL
)
528 fprintf (dumpfile
, "%s[", p
->symtree
->n
.sym
->name
);
529 show_actual_arglist (p
->value
.function
.actual
);
530 fputc (']', dumpfile
);
534 fprintf (dumpfile
, "%s[[", p
->value
.function
.name
);
535 show_actual_arglist (p
->value
.function
.actual
);
536 fputc (']', dumpfile
);
537 fputc (']', dumpfile
);
543 gfc_internal_error ("show_expr(): Don't know how to show expr");
547 /* Show symbol attributes. The flavor and intent are followed by
548 whatever single bit attributes are present. */
551 show_attr (symbol_attribute
*attr
)
554 fprintf (dumpfile
, "(%s %s %s %s %s",
555 gfc_code2string (flavors
, attr
->flavor
),
556 gfc_intent_string (attr
->intent
),
557 gfc_code2string (access_types
, attr
->access
),
558 gfc_code2string (procedures
, attr
->proc
),
559 gfc_code2string (save_status
, attr
->save
));
561 if (attr
->allocatable
)
562 fputs (" ALLOCATABLE", dumpfile
);
564 fputs (" DIMENSION", dumpfile
);
566 fputs (" EXTERNAL", dumpfile
);
568 fputs (" INTRINSIC", dumpfile
);
570 fputs (" OPTIONAL", dumpfile
);
572 fputs (" POINTER", dumpfile
);
574 fputs (" PROTECTED", dumpfile
);
576 fputs (" VALUE", dumpfile
);
578 fputs (" VOLATILE", dumpfile
);
579 if (attr
->threadprivate
)
580 fputs (" THREADPRIVATE", dumpfile
);
582 fputs (" TARGET", dumpfile
);
584 fputs (" DUMMY", dumpfile
);
586 fputs (" RESULT", dumpfile
);
588 fputs (" ENTRY", dumpfile
);
590 fputs (" BIND(C)", dumpfile
);
593 fputs (" DATA", dumpfile
);
595 fputs (" USE-ASSOC", dumpfile
);
596 if (attr
->in_namelist
)
597 fputs (" IN-NAMELIST", dumpfile
);
599 fputs (" IN-COMMON", dumpfile
);
602 fputs (" ABSTRACT INTERFACE", dumpfile
);
604 fputs (" FUNCTION", dumpfile
);
605 if (attr
->subroutine
)
606 fputs (" SUBROUTINE", dumpfile
);
607 if (attr
->implicit_type
)
608 fputs (" IMPLICIT-TYPE", dumpfile
);
611 fputs (" SEQUENCE", dumpfile
);
613 fputs (" ELEMENTAL", dumpfile
);
615 fputs (" PURE", dumpfile
);
617 fputs (" RECURSIVE", dumpfile
);
619 fputc (')', dumpfile
);
623 /* Show components of a derived type. */
626 show_components (gfc_symbol
*sym
)
630 for (c
= sym
->components
; c
; c
= c
->next
)
632 fprintf (dumpfile
, "(%s ", c
->name
);
633 show_typespec (&c
->ts
);
635 fputs (" POINTER", dumpfile
);
637 fputs (" DIMENSION", dumpfile
);
638 fputc (' ', dumpfile
);
639 show_array_spec (c
->as
);
641 fprintf (dumpfile
, " %s", gfc_code2string (access_types
, c
->access
));
642 fputc (')', dumpfile
);
644 fputc (' ', dumpfile
);
649 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
650 show the interface. Information needed to reconstruct the list of
651 specific interfaces associated with a generic symbol is done within
655 show_symbol (gfc_symbol
*sym
)
657 gfc_formal_arglist
*formal
;
665 fprintf (dumpfile
, "symbol %s ", sym
->name
);
666 show_typespec (&sym
->ts
);
667 show_attr (&sym
->attr
);
672 fputs ("value: ", dumpfile
);
673 show_expr (sym
->value
);
679 fputs ("Array spec:", dumpfile
);
680 show_array_spec (sym
->as
);
686 fputs ("Generic interfaces:", dumpfile
);
687 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
688 fprintf (dumpfile
, " %s", intr
->sym
->name
);
694 fprintf (dumpfile
, "result: %s", sym
->result
->name
);
700 fputs ("components: ", dumpfile
);
701 show_components (sym
);
707 fputs ("Formal arglist:", dumpfile
);
709 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
711 if (formal
->sym
!= NULL
)
712 fprintf (dumpfile
, " %s", formal
->sym
->name
);
714 fputs (" [Alt Return]", dumpfile
);
721 fputs ("Formal namespace", dumpfile
);
722 show_namespace (sym
->formal_ns
);
725 fputc ('\n', dumpfile
);
729 /* Show a user-defined operator. Just prints an operator
730 and the name of the associated subroutine, really. */
733 show_uop (gfc_user_op
*uop
)
738 fprintf (dumpfile
, "%s:", uop
->name
);
740 for (intr
= uop
->operator; intr
; intr
= intr
->next
)
741 fprintf (dumpfile
, " %s", intr
->sym
->name
);
745 /* Workhorse function for traversing the user operator symtree. */
748 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
755 traverse_uop (st
->left
, func
);
756 traverse_uop (st
->right
, func
);
760 /* Traverse the tree of user operator nodes. */
763 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
765 traverse_uop (ns
->uop_root
, func
);
769 /* Function to display a common block. */
772 show_common (gfc_symtree
*st
)
777 fprintf (dumpfile
, "common: /%s/ ", st
->name
);
779 s
= st
->n
.common
->head
;
782 fprintf (dumpfile
, "%s", s
->name
);
785 fputs (", ", dumpfile
);
787 fputc ('\n', dumpfile
);
791 /* Worker function to display the symbol tree. */
794 show_symtree (gfc_symtree
*st
)
797 fprintf (dumpfile
, "symtree: %s Ambig %d", st
->name
, st
->ambiguous
);
799 if (st
->n
.sym
->ns
!= gfc_current_ns
)
800 fprintf (dumpfile
, " from namespace %s", st
->n
.sym
->ns
->proc_name
->name
);
802 show_symbol (st
->n
.sym
);
806 /******************* Show gfc_code structures **************/
809 /* Show a list of code structures. Mutually recursive with
813 show_code (int level
, gfc_code
*c
)
815 for (; c
; c
= c
->next
)
816 show_code_node (level
, c
);
820 show_namelist (gfc_namelist
*n
)
822 for (; n
->next
; n
= n
->next
)
823 fprintf (dumpfile
, "%s,", n
->sym
->name
);
824 fprintf (dumpfile
, "%s", n
->sym
->name
);
827 /* Show a single OpenMP directive node and everything underneath it
831 show_omp_node (int level
, gfc_code
*c
)
833 gfc_omp_clauses
*omp_clauses
= NULL
;
834 const char *name
= NULL
;
838 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
839 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
840 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
841 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
842 case EXEC_OMP_DO
: name
= "DO"; break;
843 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
844 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
845 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
846 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
847 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
848 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
849 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
850 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
851 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
855 fprintf (dumpfile
, "!$OMP %s", name
);
859 case EXEC_OMP_PARALLEL
:
860 case EXEC_OMP_PARALLEL_DO
:
861 case EXEC_OMP_PARALLEL_SECTIONS
:
862 case EXEC_OMP_SECTIONS
:
863 case EXEC_OMP_SINGLE
:
864 case EXEC_OMP_WORKSHARE
:
865 case EXEC_OMP_PARALLEL_WORKSHARE
:
866 omp_clauses
= c
->ext
.omp_clauses
;
868 case EXEC_OMP_CRITICAL
:
870 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
873 if (c
->ext
.omp_namelist
)
875 fputs (" (", dumpfile
);
876 show_namelist (c
->ext
.omp_namelist
);
877 fputc (')', dumpfile
);
880 case EXEC_OMP_BARRIER
:
889 if (omp_clauses
->if_expr
)
891 fputs (" IF(", dumpfile
);
892 show_expr (omp_clauses
->if_expr
);
893 fputc (')', dumpfile
);
895 if (omp_clauses
->num_threads
)
897 fputs (" NUM_THREADS(", dumpfile
);
898 show_expr (omp_clauses
->num_threads
);
899 fputc (')', dumpfile
);
901 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
904 switch (omp_clauses
->sched_kind
)
906 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
907 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
908 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
909 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
913 fprintf (dumpfile
, " SCHEDULE (%s", type
);
914 if (omp_clauses
->chunk_size
)
916 fputc (',', dumpfile
);
917 show_expr (omp_clauses
->chunk_size
);
919 fputc (')', dumpfile
);
921 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
924 switch (omp_clauses
->default_sharing
)
926 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
927 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
928 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
929 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
933 fprintf (dumpfile
, " DEFAULT(%s)", type
);
935 if (omp_clauses
->ordered
)
936 fputs (" ORDERED", dumpfile
);
937 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
938 if (omp_clauses
->lists
[list_type
] != NULL
939 && list_type
!= OMP_LIST_COPYPRIVATE
)
942 if (list_type
>= OMP_LIST_REDUCTION_FIRST
)
946 case OMP_LIST_PLUS
: type
= "+"; break;
947 case OMP_LIST_MULT
: type
= "*"; break;
948 case OMP_LIST_SUB
: type
= "-"; break;
949 case OMP_LIST_AND
: type
= ".AND."; break;
950 case OMP_LIST_OR
: type
= ".OR."; break;
951 case OMP_LIST_EQV
: type
= ".EQV."; break;
952 case OMP_LIST_NEQV
: type
= ".NEQV."; break;
953 case OMP_LIST_MAX
: type
= "MAX"; break;
954 case OMP_LIST_MIN
: type
= "MIN"; break;
955 case OMP_LIST_IAND
: type
= "IAND"; break;
956 case OMP_LIST_IOR
: type
= "IOR"; break;
957 case OMP_LIST_IEOR
: type
= "IEOR"; break;
961 fprintf (dumpfile
, " REDUCTION(%s:", type
);
967 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
968 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
969 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
970 case OMP_LIST_SHARED
: type
= "SHARED"; break;
971 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
975 fprintf (dumpfile
, " %s(", type
);
977 show_namelist (omp_clauses
->lists
[list_type
]);
978 fputc (')', dumpfile
);
981 fputc ('\n', dumpfile
);
982 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
984 gfc_code
*d
= c
->block
;
987 show_code (level
+ 1, d
->next
);
988 if (d
->block
== NULL
)
990 code_indent (level
, 0);
991 fputs ("!$OMP SECTION\n", dumpfile
);
996 show_code (level
+ 1, c
->block
->next
);
997 if (c
->op
== EXEC_OMP_ATOMIC
)
999 code_indent (level
, 0);
1000 fprintf (dumpfile
, "!$OMP END %s", name
);
1001 if (omp_clauses
!= NULL
)
1003 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
1005 fputs (" COPYPRIVATE(", dumpfile
);
1006 show_namelist (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1007 fputc (')', dumpfile
);
1009 else if (omp_clauses
->nowait
)
1010 fputs (" NOWAIT", dumpfile
);
1012 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_name
)
1013 fprintf (dumpfile
, " (%s)", c
->ext
.omp_name
);
1017 /* Show a single code node and everything underneath it if necessary. */
1020 show_code_node (int level
, gfc_code
*c
)
1022 gfc_forall_iterator
*fa
;
1032 code_indent (level
, c
->here
);
1037 fputs ("NOP", dumpfile
);
1041 fputs ("CONTINUE", dumpfile
);
1045 fprintf (dumpfile
, "ENTRY %s", c
->ext
.entry
->sym
->name
);
1048 case EXEC_INIT_ASSIGN
:
1050 fputs ("ASSIGN ", dumpfile
);
1051 show_expr (c
->expr
);
1052 fputc (' ', dumpfile
);
1053 show_expr (c
->expr2
);
1056 case EXEC_LABEL_ASSIGN
:
1057 fputs ("LABEL ASSIGN ", dumpfile
);
1058 show_expr (c
->expr
);
1059 fprintf (dumpfile
, " %d", c
->label
->value
);
1062 case EXEC_POINTER_ASSIGN
:
1063 fputs ("POINTER ASSIGN ", dumpfile
);
1064 show_expr (c
->expr
);
1065 fputc (' ', dumpfile
);
1066 show_expr (c
->expr2
);
1070 fputs ("GOTO ", dumpfile
);
1072 fprintf (dumpfile
, "%d", c
->label
->value
);
1075 show_expr (c
->expr
);
1079 fputs (", (", dumpfile
);
1080 for (; d
; d
= d
->block
)
1082 code_indent (level
, d
->label
);
1083 if (d
->block
!= NULL
)
1084 fputc (',', dumpfile
);
1086 fputc (')', dumpfile
);
1093 case EXEC_ASSIGN_CALL
:
1094 if (c
->resolved_sym
)
1095 fprintf (dumpfile
, "CALL %s ", c
->resolved_sym
->name
);
1096 else if (c
->symtree
)
1097 fprintf (dumpfile
, "CALL %s ", c
->symtree
->name
);
1099 fputs ("CALL ?? ", dumpfile
);
1101 show_actual_arglist (c
->ext
.actual
);
1105 fputs ("RETURN ", dumpfile
);
1107 show_expr (c
->expr
);
1111 fputs ("PAUSE ", dumpfile
);
1113 if (c
->expr
!= NULL
)
1114 show_expr (c
->expr
);
1116 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1121 fputs ("STOP ", dumpfile
);
1123 if (c
->expr
!= NULL
)
1124 show_expr (c
->expr
);
1126 fprintf (dumpfile
, "%d", c
->ext
.stop_code
);
1130 case EXEC_ARITHMETIC_IF
:
1131 fputs ("IF ", dumpfile
);
1132 show_expr (c
->expr
);
1133 fprintf (dumpfile
, " %d, %d, %d",
1134 c
->label
->value
, c
->label2
->value
, c
->label3
->value
);
1139 fputs ("IF ", dumpfile
);
1140 show_expr (d
->expr
);
1141 fputc ('\n', dumpfile
);
1142 show_code (level
+ 1, d
->next
);
1145 for (; d
; d
= d
->block
)
1147 code_indent (level
, 0);
1149 if (d
->expr
== NULL
)
1150 fputs ("ELSE\n", dumpfile
);
1153 fputs ("ELSE IF ", dumpfile
);
1154 show_expr (d
->expr
);
1155 fputc ('\n', dumpfile
);
1158 show_code (level
+ 1, d
->next
);
1161 code_indent (level
, c
->label
);
1163 fputs ("ENDIF", dumpfile
);
1168 fputs ("SELECT CASE ", dumpfile
);
1169 show_expr (c
->expr
);
1170 fputc ('\n', dumpfile
);
1172 for (; d
; d
= d
->block
)
1174 code_indent (level
, 0);
1176 fputs ("CASE ", dumpfile
);
1177 for (cp
= d
->ext
.case_list
; cp
; cp
= cp
->next
)
1179 fputc ('(', dumpfile
);
1180 show_expr (cp
->low
);
1181 fputc (' ', dumpfile
);
1182 show_expr (cp
->high
);
1183 fputc (')', dumpfile
);
1184 fputc (' ', dumpfile
);
1186 fputc ('\n', dumpfile
);
1188 show_code (level
+ 1, d
->next
);
1191 code_indent (level
, c
->label
);
1192 fputs ("END SELECT", dumpfile
);
1196 fputs ("WHERE ", dumpfile
);
1199 show_expr (d
->expr
);
1200 fputc ('\n', dumpfile
);
1202 show_code (level
+ 1, d
->next
);
1204 for (d
= d
->block
; d
; d
= d
->block
)
1206 code_indent (level
, 0);
1207 fputs ("ELSE WHERE ", dumpfile
);
1208 show_expr (d
->expr
);
1209 fputc ('\n', dumpfile
);
1210 show_code (level
+ 1, d
->next
);
1213 code_indent (level
, 0);
1214 fputs ("END WHERE", dumpfile
);
1219 fputs ("FORALL ", dumpfile
);
1220 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1222 show_expr (fa
->var
);
1223 fputc (' ', dumpfile
);
1224 show_expr (fa
->start
);
1225 fputc (':', dumpfile
);
1226 show_expr (fa
->end
);
1227 fputc (':', dumpfile
);
1228 show_expr (fa
->stride
);
1230 if (fa
->next
!= NULL
)
1231 fputc (',', dumpfile
);
1234 if (c
->expr
!= NULL
)
1236 fputc (',', dumpfile
);
1237 show_expr (c
->expr
);
1239 fputc ('\n', dumpfile
);
1241 show_code (level
+ 1, c
->block
->next
);
1243 code_indent (level
, 0);
1244 fputs ("END FORALL", dumpfile
);
1248 fputs ("DO ", dumpfile
);
1250 show_expr (c
->ext
.iterator
->var
);
1251 fputc ('=', dumpfile
);
1252 show_expr (c
->ext
.iterator
->start
);
1253 fputc (' ', dumpfile
);
1254 show_expr (c
->ext
.iterator
->end
);
1255 fputc (' ', dumpfile
);
1256 show_expr (c
->ext
.iterator
->step
);
1257 fputc ('\n', dumpfile
);
1259 show_code (level
+ 1, c
->block
->next
);
1261 code_indent (level
, 0);
1262 fputs ("END DO", dumpfile
);
1266 fputs ("DO WHILE ", dumpfile
);
1267 show_expr (c
->expr
);
1268 fputc ('\n', dumpfile
);
1270 show_code (level
+ 1, c
->block
->next
);
1272 code_indent (level
, c
->label
);
1273 fputs ("END DO", dumpfile
);
1277 fputs ("CYCLE", dumpfile
);
1279 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1283 fputs ("EXIT", dumpfile
);
1285 fprintf (dumpfile
, " %s", c
->symtree
->n
.sym
->name
);
1289 fputs ("ALLOCATE ", dumpfile
);
1292 fputs (" STAT=", dumpfile
);
1293 show_expr (c
->expr
);
1296 for (a
= c
->ext
.alloc_list
; a
; a
= a
->next
)
1298 fputc (' ', dumpfile
);
1299 show_expr (a
->expr
);
1304 case EXEC_DEALLOCATE
:
1305 fputs ("DEALLOCATE ", dumpfile
);
1308 fputs (" STAT=", dumpfile
);
1309 show_expr (c
->expr
);
1312 for (a
= c
->ext
.alloc_list
; a
; a
= a
->next
)
1314 fputc (' ', dumpfile
);
1315 show_expr (a
->expr
);
1321 fputs ("OPEN", dumpfile
);
1326 fputs (" UNIT=", dumpfile
);
1327 show_expr (open
->unit
);
1331 fputs (" IOMSG=", dumpfile
);
1332 show_expr (open
->iomsg
);
1336 fputs (" IOSTAT=", dumpfile
);
1337 show_expr (open
->iostat
);
1341 fputs (" FILE=", dumpfile
);
1342 show_expr (open
->file
);
1346 fputs (" STATUS=", dumpfile
);
1347 show_expr (open
->status
);
1351 fputs (" ACCESS=", dumpfile
);
1352 show_expr (open
->access
);
1356 fputs (" FORM=", dumpfile
);
1357 show_expr (open
->form
);
1361 fputs (" RECL=", dumpfile
);
1362 show_expr (open
->recl
);
1366 fputs (" BLANK=", dumpfile
);
1367 show_expr (open
->blank
);
1371 fputs (" POSITION=", dumpfile
);
1372 show_expr (open
->position
);
1376 fputs (" ACTION=", dumpfile
);
1377 show_expr (open
->action
);
1381 fputs (" DELIM=", dumpfile
);
1382 show_expr (open
->delim
);
1386 fputs (" PAD=", dumpfile
);
1387 show_expr (open
->pad
);
1391 fputs (" DECIMAL=", dumpfile
);
1392 show_expr (open
->decimal
);
1396 fputs (" ENCODING=", dumpfile
);
1397 show_expr (open
->encoding
);
1401 fputs (" ROUND=", dumpfile
);
1402 show_expr (open
->round
);
1406 fputs (" SIGN=", dumpfile
);
1407 show_expr (open
->sign
);
1411 fputs (" CONVERT=", dumpfile
);
1412 show_expr (open
->convert
);
1414 if (open
->asynchronous
)
1416 fputs (" ASYNCHRONOUS=", dumpfile
);
1417 show_expr (open
->asynchronous
);
1419 if (open
->err
!= NULL
)
1420 fprintf (dumpfile
, " ERR=%d", open
->err
->value
);
1425 fputs ("CLOSE", dumpfile
);
1426 close
= c
->ext
.close
;
1430 fputs (" UNIT=", dumpfile
);
1431 show_expr (close
->unit
);
1435 fputs (" IOMSG=", dumpfile
);
1436 show_expr (close
->iomsg
);
1440 fputs (" IOSTAT=", dumpfile
);
1441 show_expr (close
->iostat
);
1445 fputs (" STATUS=", dumpfile
);
1446 show_expr (close
->status
);
1448 if (close
->err
!= NULL
)
1449 fprintf (dumpfile
, " ERR=%d", close
->err
->value
);
1452 case EXEC_BACKSPACE
:
1453 fputs ("BACKSPACE", dumpfile
);
1457 fputs ("ENDFILE", dumpfile
);
1461 fputs ("REWIND", dumpfile
);
1465 fputs ("FLUSH", dumpfile
);
1468 fp
= c
->ext
.filepos
;
1472 fputs (" UNIT=", dumpfile
);
1473 show_expr (fp
->unit
);
1477 fputs (" IOMSG=", dumpfile
);
1478 show_expr (fp
->iomsg
);
1482 fputs (" IOSTAT=", dumpfile
);
1483 show_expr (fp
->iostat
);
1485 if (fp
->err
!= NULL
)
1486 fprintf (dumpfile
, " ERR=%d", fp
->err
->value
);
1490 fputs ("INQUIRE", dumpfile
);
1495 fputs (" UNIT=", dumpfile
);
1496 show_expr (i
->unit
);
1500 fputs (" FILE=", dumpfile
);
1501 show_expr (i
->file
);
1506 fputs (" IOMSG=", dumpfile
);
1507 show_expr (i
->iomsg
);
1511 fputs (" IOSTAT=", dumpfile
);
1512 show_expr (i
->iostat
);
1516 fputs (" EXIST=", dumpfile
);
1517 show_expr (i
->exist
);
1521 fputs (" OPENED=", dumpfile
);
1522 show_expr (i
->opened
);
1526 fputs (" NUMBER=", dumpfile
);
1527 show_expr (i
->number
);
1531 fputs (" NAMED=", dumpfile
);
1532 show_expr (i
->named
);
1536 fputs (" NAME=", dumpfile
);
1537 show_expr (i
->name
);
1541 fputs (" ACCESS=", dumpfile
);
1542 show_expr (i
->access
);
1546 fputs (" SEQUENTIAL=", dumpfile
);
1547 show_expr (i
->sequential
);
1552 fputs (" DIRECT=", dumpfile
);
1553 show_expr (i
->direct
);
1557 fputs (" FORM=", dumpfile
);
1558 show_expr (i
->form
);
1562 fputs (" FORMATTED", dumpfile
);
1563 show_expr (i
->formatted
);
1567 fputs (" UNFORMATTED=", dumpfile
);
1568 show_expr (i
->unformatted
);
1572 fputs (" RECL=", dumpfile
);
1573 show_expr (i
->recl
);
1577 fputs (" NEXTREC=", dumpfile
);
1578 show_expr (i
->nextrec
);
1582 fputs (" BLANK=", dumpfile
);
1583 show_expr (i
->blank
);
1587 fputs (" POSITION=", dumpfile
);
1588 show_expr (i
->position
);
1592 fputs (" ACTION=", dumpfile
);
1593 show_expr (i
->action
);
1597 fputs (" READ=", dumpfile
);
1598 show_expr (i
->read
);
1602 fputs (" WRITE=", dumpfile
);
1603 show_expr (i
->write
);
1607 fputs (" READWRITE=", dumpfile
);
1608 show_expr (i
->readwrite
);
1612 fputs (" DELIM=", dumpfile
);
1613 show_expr (i
->delim
);
1617 fputs (" PAD=", dumpfile
);
1622 fputs (" CONVERT=", dumpfile
);
1623 show_expr (i
->convert
);
1625 if (i
->asynchronous
)
1627 fputs (" ASYNCHRONOUS=", dumpfile
);
1628 show_expr (i
->asynchronous
);
1632 fputs (" DECIMAL=", dumpfile
);
1633 show_expr (i
->decimal
);
1637 fputs (" ENCODING=", dumpfile
);
1638 show_expr (i
->encoding
);
1642 fputs (" PENDING=", dumpfile
);
1643 show_expr (i
->pending
);
1647 fputs (" ROUND=", dumpfile
);
1648 show_expr (i
->round
);
1652 fputs (" SIGN=", dumpfile
);
1653 show_expr (i
->sign
);
1657 fputs (" SIZE=", dumpfile
);
1658 show_expr (i
->size
);
1662 fputs (" ID=", dumpfile
);
1667 fprintf (dumpfile
, " ERR=%d", i
->err
->value
);
1671 fputs ("IOLENGTH ", dumpfile
);
1672 show_expr (c
->expr
);
1677 fputs ("READ", dumpfile
);
1681 fputs ("WRITE", dumpfile
);
1687 fputs (" UNIT=", dumpfile
);
1688 show_expr (dt
->io_unit
);
1691 if (dt
->format_expr
)
1693 fputs (" FMT=", dumpfile
);
1694 show_expr (dt
->format_expr
);
1697 if (dt
->format_label
!= NULL
)
1698 fprintf (dumpfile
, " FMT=%d", dt
->format_label
->value
);
1700 fprintf (dumpfile
, " NML=%s", dt
->namelist
->name
);
1704 fputs (" IOMSG=", dumpfile
);
1705 show_expr (dt
->iomsg
);
1709 fputs (" IOSTAT=", dumpfile
);
1710 show_expr (dt
->iostat
);
1714 fputs (" SIZE=", dumpfile
);
1715 show_expr (dt
->size
);
1719 fputs (" REC=", dumpfile
);
1720 show_expr (dt
->rec
);
1724 fputs (" ADVANCE=", dumpfile
);
1725 show_expr (dt
->advance
);
1729 fputs (" ID=", dumpfile
);
1734 fputs (" POS=", dumpfile
);
1735 show_expr (dt
->pos
);
1737 if (dt
->asynchronous
)
1739 fputs (" ASYNCHRONOUS=", dumpfile
);
1740 show_expr (dt
->asynchronous
);
1744 fputs (" BLANK=", dumpfile
);
1745 show_expr (dt
->blank
);
1749 fputs (" DECIMAL=", dumpfile
);
1750 show_expr (dt
->decimal
);
1754 fputs (" DELIM=", dumpfile
);
1755 show_expr (dt
->delim
);
1759 fputs (" PAD=", dumpfile
);
1760 show_expr (dt
->pad
);
1764 fputs (" ROUND=", dumpfile
);
1765 show_expr (dt
->round
);
1769 fputs (" SIGN=", dumpfile
);
1770 show_expr (dt
->sign
);
1774 fputc ('\n', dumpfile
);
1775 for (c
= c
->block
->next
; c
; c
= c
->next
)
1776 show_code_node (level
+ (c
->next
!= NULL
), c
);
1780 fputs ("TRANSFER ", dumpfile
);
1781 show_expr (c
->expr
);
1785 fputs ("DT_END", dumpfile
);
1788 if (dt
->err
!= NULL
)
1789 fprintf (dumpfile
, " ERR=%d", dt
->err
->value
);
1790 if (dt
->end
!= NULL
)
1791 fprintf (dumpfile
, " END=%d", dt
->end
->value
);
1792 if (dt
->eor
!= NULL
)
1793 fprintf (dumpfile
, " EOR=%d", dt
->eor
->value
);
1796 case EXEC_OMP_ATOMIC
:
1797 case EXEC_OMP_BARRIER
:
1798 case EXEC_OMP_CRITICAL
:
1799 case EXEC_OMP_FLUSH
:
1801 case EXEC_OMP_MASTER
:
1802 case EXEC_OMP_ORDERED
:
1803 case EXEC_OMP_PARALLEL
:
1804 case EXEC_OMP_PARALLEL_DO
:
1805 case EXEC_OMP_PARALLEL_SECTIONS
:
1806 case EXEC_OMP_PARALLEL_WORKSHARE
:
1807 case EXEC_OMP_SECTIONS
:
1808 case EXEC_OMP_SINGLE
:
1809 case EXEC_OMP_WORKSHARE
:
1810 show_omp_node (level
, c
);
1814 gfc_internal_error ("show_code_node(): Bad statement code");
1817 fputc ('\n', dumpfile
);
1821 /* Show an equivalence chain. */
1824 show_equiv (gfc_equiv
*eq
)
1827 fputs ("Equivalence: ", dumpfile
);
1830 show_expr (eq
->expr
);
1833 fputs (", ", dumpfile
);
1838 /* Show a freakin' whole namespace. */
1841 show_namespace (gfc_namespace
*ns
)
1843 gfc_interface
*intr
;
1844 gfc_namespace
*save
;
1845 gfc_intrinsic_op op
;
1849 save
= gfc_current_ns
;
1853 fputs ("Namespace:", dumpfile
);
1861 while (i
< GFC_LETTERS
- 1
1862 && gfc_compare_types(&ns
->default_type
[i
+1],
1863 &ns
->default_type
[l
]))
1867 fprintf (dumpfile
, " %c-%c: ", l
+'A', i
+'A');
1869 fprintf (dumpfile
, " %c: ", l
+'A');
1871 show_typespec(&ns
->default_type
[l
]);
1873 } while (i
< GFC_LETTERS
);
1875 if (ns
->proc_name
!= NULL
)
1878 fprintf (dumpfile
, "procedure name = %s", ns
->proc_name
->name
);
1881 gfc_current_ns
= ns
;
1882 gfc_traverse_symtree (ns
->common_root
, show_common
);
1884 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
1886 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
1888 /* User operator interfaces */
1889 intr
= ns
->operator[op
];
1894 fprintf (dumpfile
, "Operator interfaces for %s:",
1895 gfc_op2string (op
));
1897 for (; intr
; intr
= intr
->next
)
1898 fprintf (dumpfile
, " %s", intr
->sym
->name
);
1901 if (ns
->uop_root
!= NULL
)
1904 fputs ("User operators:\n", dumpfile
);
1905 gfc_traverse_user_op (ns
, show_uop
);
1909 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
1912 fputc ('\n', dumpfile
);
1913 fputc ('\n', dumpfile
);
1915 show_code (0, ns
->code
);
1917 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1920 fputs ("CONTAINS\n", dumpfile
);
1921 show_namespace (ns
);
1925 fputc ('\n', dumpfile
);
1926 gfc_current_ns
= save
;
1930 /* Main function for dumping a parse tree. */
1933 gfc_dump_parse_tree (gfc_namespace
*ns
, FILE *file
)
1936 show_namespace (ns
);