2 Copyright (C) 2003, 2004, 2005, 2006, 2007
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 /* Do indentation for a specific level. */
43 code_indent (int level
, gfc_st_label
*label
)
48 gfc_status ("%-5d ", label
->value
);
52 for (i
= 0; i
< 2 * level
; i
++)
53 gfc_status_char (' ');
57 /* Simple indentation at the current level. This one
58 is used to show symbols. */
64 code_indent (show_level
, NULL
);
68 /* Show type-specific information. */
71 gfc_show_typespec (gfc_typespec
*ts
)
73 gfc_status ("(%s ", gfc_basic_typename (ts
->type
));
78 gfc_status ("%s", ts
->derived
->name
);
82 gfc_show_expr (ts
->cl
->length
);
86 gfc_status ("%d", ts
->kind
);
94 /* Show an actual argument list. */
97 gfc_show_actual_arglist (gfc_actual_arglist
*a
)
101 for (; a
; a
= a
->next
)
103 gfc_status_char ('(');
105 gfc_status ("%s = ", a
->name
);
107 gfc_show_expr (a
->expr
);
109 gfc_status ("(arg not-present)");
111 gfc_status_char (')');
120 /* Show a gfc_array_spec array specification structure. */
123 gfc_show_array_spec (gfc_array_spec
*as
)
134 gfc_status ("(%d", as
->rank
);
140 case AS_EXPLICIT
: c
= "AS_EXPLICIT"; break;
141 case AS_DEFERRED
: c
= "AS_DEFERRED"; break;
142 case AS_ASSUMED_SIZE
: c
= "AS_ASSUMED_SIZE"; break;
143 case AS_ASSUMED_SHAPE
: c
= "AS_ASSUMED_SHAPE"; break;
145 gfc_internal_error ("gfc_show_array_spec(): Unhandled array shape "
148 gfc_status (" %s ", c
);
150 for (i
= 0; i
< as
->rank
; i
++)
152 gfc_show_expr (as
->lower
[i
]);
153 gfc_status_char (' ');
154 gfc_show_expr (as
->upper
[i
]);
155 gfc_status_char (' ');
163 /* Show a gfc_array_ref array reference structure. */
166 gfc_show_array_ref (gfc_array_ref
* ar
)
170 gfc_status_char ('(');
179 for (i
= 0; i
< ar
->dimen
; i
++)
181 /* There are two types of array sections: either the
182 elements are identified by an integer array ('vector'),
183 or by an index range. In the former case we only have to
184 print the start expression which contains the vector, in
185 the latter case we have to print any of lower and upper
186 bound and the stride, if they're present. */
188 if (ar
->start
[i
] != NULL
)
189 gfc_show_expr (ar
->start
[i
]);
191 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
193 gfc_status_char (':');
195 if (ar
->end
[i
] != NULL
)
196 gfc_show_expr (ar
->end
[i
]);
198 if (ar
->stride
[i
] != NULL
)
200 gfc_status_char (':');
201 gfc_show_expr (ar
->stride
[i
]);
205 if (i
!= ar
->dimen
- 1)
211 for (i
= 0; i
< ar
->dimen
; i
++)
213 gfc_show_expr (ar
->start
[i
]);
214 if (i
!= ar
->dimen
- 1)
220 gfc_status ("UNKNOWN");
224 gfc_internal_error ("gfc_show_array_ref(): Unknown array reference");
227 gfc_status_char (')');
231 /* Show a list of gfc_ref structures. */
234 gfc_show_ref (gfc_ref
*p
)
236 for (; p
; p
= p
->next
)
240 gfc_show_array_ref (&p
->u
.ar
);
244 gfc_status (" %% %s", p
->u
.c
.component
->name
);
248 gfc_status_char ('(');
249 gfc_show_expr (p
->u
.ss
.start
);
250 gfc_status_char (':');
251 gfc_show_expr (p
->u
.ss
.end
);
252 gfc_status_char (')');
256 gfc_internal_error ("gfc_show_ref(): Bad component code");
261 /* Display a constructor. Works recursively for array constructors. */
264 gfc_show_constructor (gfc_constructor
*c
)
266 for (; c
; c
= c
->next
)
268 if (c
->iterator
== NULL
)
269 gfc_show_expr (c
->expr
);
272 gfc_status_char ('(');
273 gfc_show_expr (c
->expr
);
275 gfc_status_char (' ');
276 gfc_show_expr (c
->iterator
->var
);
277 gfc_status_char ('=');
278 gfc_show_expr (c
->iterator
->start
);
279 gfc_status_char (',');
280 gfc_show_expr (c
->iterator
->end
);
281 gfc_status_char (',');
282 gfc_show_expr (c
->iterator
->step
);
284 gfc_status_char (')');
293 /* Show an expression. */
296 gfc_show_expr (gfc_expr
*p
)
307 switch (p
->expr_type
)
310 c
= p
->value
.character
.string
;
312 for (i
= 0; i
< p
->value
.character
.length
; i
++, c
++)
317 gfc_status ("%c", *c
);
320 gfc_show_ref (p
->ref
);
324 gfc_status ("%s(", p
->ts
.derived
->name
);
325 gfc_show_constructor (p
->value
.constructor
);
326 gfc_status_char (')');
331 gfc_show_constructor (p
->value
.constructor
);
334 gfc_show_ref (p
->ref
);
338 gfc_status ("NULL()");
345 mpz_out_str (stdout
, 10, p
->value
.integer
);
347 if (p
->ts
.kind
!= gfc_default_integer_kind
)
348 gfc_status ("_%d", p
->ts
.kind
);
352 if (p
->value
.logical
)
353 gfc_status (".true.");
355 gfc_status (".false.");
359 mpfr_out_str (stdout
, 10, 0, p
->value
.real
, GFC_RND_MODE
);
360 if (p
->ts
.kind
!= gfc_default_real_kind
)
361 gfc_status ("_%d", p
->ts
.kind
);
365 c
= p
->value
.character
.string
;
367 gfc_status_char ('\'');
369 for (i
= 0; i
< p
->value
.character
.length
; i
++, c
++)
374 gfc_status_char (*c
);
377 gfc_status_char ('\'');
382 gfc_status ("(complex ");
384 mpfr_out_str (stdout
, 10, 0, p
->value
.complex.r
, GFC_RND_MODE
);
385 if (p
->ts
.kind
!= gfc_default_complex_kind
)
386 gfc_status ("_%d", p
->ts
.kind
);
390 mpfr_out_str (stdout
, 10, 0, p
->value
.complex.i
, GFC_RND_MODE
);
391 if (p
->ts
.kind
!= gfc_default_complex_kind
)
392 gfc_status ("_%d", p
->ts
.kind
);
398 gfc_status ("%dH", p
->representation
.length
);
399 c
= p
->representation
.string
;
400 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
402 gfc_status_char (*c
);
411 if (p
->representation
.string
)
414 c
= p
->representation
.string
;
415 for (i
= 0; i
< p
->representation
.length
; i
++, c
++)
417 gfc_status ("%.2x", (unsigned int) *c
);
418 if (i
< p
->representation
.length
- 1)
419 gfc_status_char (',');
421 gfc_status_char ('}');
427 if (p
->symtree
->n
.sym
->ns
&& p
->symtree
->n
.sym
->ns
->proc_name
)
428 gfc_status ("%s:", p
->symtree
->n
.sym
->ns
->proc_name
->name
);
429 gfc_status ("%s", p
->symtree
->n
.sym
->name
);
430 gfc_show_ref (p
->ref
);
435 switch (p
->value
.op
.operator)
437 case INTRINSIC_UPLUS
:
440 case INTRINSIC_UMINUS
:
446 case INTRINSIC_MINUS
:
449 case INTRINSIC_TIMES
:
452 case INTRINSIC_DIVIDE
:
455 case INTRINSIC_POWER
:
458 case INTRINSIC_CONCAT
:
471 gfc_status ("NEQV ");
474 case INTRINSIC_EQ_OS
:
478 case INTRINSIC_NE_OS
:
482 case INTRINSIC_GT_OS
:
486 case INTRINSIC_GE_OS
:
490 case INTRINSIC_LT_OS
:
494 case INTRINSIC_LE_OS
:
500 case INTRINSIC_PARENTHESES
:
501 gfc_status ("parens");
506 ("gfc_show_expr(): Bad intrinsic in expression!");
509 gfc_show_expr (p
->value
.op
.op1
);
514 gfc_show_expr (p
->value
.op
.op2
);
521 if (p
->value
.function
.name
== NULL
)
523 gfc_status ("%s[", p
->symtree
->n
.sym
->name
);
524 gfc_show_actual_arglist (p
->value
.function
.actual
);
525 gfc_status_char (']');
529 gfc_status ("%s[[", p
->value
.function
.name
);
530 gfc_show_actual_arglist (p
->value
.function
.actual
);
531 gfc_status_char (']');
532 gfc_status_char (']');
538 gfc_internal_error ("gfc_show_expr(): Don't know how to show expr");
543 /* Show symbol attributes. The flavor and intent are followed by
544 whatever single bit attributes are present. */
547 gfc_show_attr (symbol_attribute
*attr
)
550 gfc_status ("(%s %s %s %s %s", gfc_code2string (flavors
, attr
->flavor
),
551 gfc_intent_string (attr
->intent
),
552 gfc_code2string (access_types
, attr
->access
),
553 gfc_code2string (procedures
, attr
->proc
),
554 gfc_code2string (save_status
, attr
->save
));
556 if (attr
->allocatable
)
557 gfc_status (" ALLOCATABLE");
559 gfc_status (" DIMENSION");
561 gfc_status (" EXTERNAL");
563 gfc_status (" INTRINSIC");
565 gfc_status (" OPTIONAL");
567 gfc_status (" POINTER");
569 gfc_status (" PROTECTED");
571 gfc_status (" VALUE");
573 gfc_status (" VOLATILE");
574 if (attr
->threadprivate
)
575 gfc_status (" THREADPRIVATE");
577 gfc_status (" TARGET");
579 gfc_status (" DUMMY");
581 gfc_status (" RESULT");
583 gfc_status (" ENTRY");
586 gfc_status (" DATA");
588 gfc_status (" USE-ASSOC");
589 if (attr
->in_namelist
)
590 gfc_status (" IN-NAMELIST");
592 gfc_status (" IN-COMMON");
595 gfc_status (" FUNCTION");
596 if (attr
->subroutine
)
597 gfc_status (" SUBROUTINE");
598 if (attr
->implicit_type
)
599 gfc_status (" IMPLICIT-TYPE");
602 gfc_status (" SEQUENCE");
604 gfc_status (" ELEMENTAL");
606 gfc_status (" PURE");
608 gfc_status (" RECURSIVE");
614 /* Show components of a derived type. */
617 gfc_show_components (gfc_symbol
*sym
)
621 for (c
= sym
->components
; c
; c
= c
->next
)
623 gfc_status ("(%s ", c
->name
);
624 gfc_show_typespec (&c
->ts
);
626 gfc_status (" POINTER");
628 gfc_status (" DIMENSION");
629 gfc_status_char (' ');
630 gfc_show_array_spec (c
->as
);
632 gfc_status (" %s", gfc_code2string (access_types
, c
->access
));
635 gfc_status_char (' ');
640 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
641 show the interface. Information needed to reconstruct the list of
642 specific interfaces associated with a generic symbol is done within
646 gfc_show_symbol (gfc_symbol
*sym
)
648 gfc_formal_arglist
*formal
;
656 gfc_status ("symbol %s ", sym
->name
);
657 gfc_show_typespec (&sym
->ts
);
658 gfc_show_attr (&sym
->attr
);
663 gfc_status ("value: ");
664 gfc_show_expr (sym
->value
);
670 gfc_status ("Array spec:");
671 gfc_show_array_spec (sym
->as
);
677 gfc_status ("Generic interfaces:");
678 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
679 gfc_status (" %s", intr
->sym
->name
);
685 gfc_status ("result: %s", sym
->result
->name
);
691 gfc_status ("components: ");
692 gfc_show_components (sym
);
698 gfc_status ("Formal arglist:");
700 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
702 if (formal
->sym
!= NULL
)
703 gfc_status (" %s", formal
->sym
->name
);
705 gfc_status (" [Alt Return]");
712 gfc_status ("Formal namespace");
713 gfc_show_namespace (sym
->formal_ns
);
716 gfc_status_char ('\n');
720 /* Show a user-defined operator. Just prints an operator
721 and the name of the associated subroutine, really. */
724 show_uop (gfc_user_op
*uop
)
729 gfc_status ("%s:", uop
->name
);
731 for (intr
= uop
->operator; intr
; intr
= intr
->next
)
732 gfc_status (" %s", intr
->sym
->name
);
736 /* Workhorse function for traversing the user operator symtree. */
739 traverse_uop (gfc_symtree
*st
, void (*func
) (gfc_user_op
*))
746 traverse_uop (st
->left
, func
);
747 traverse_uop (st
->right
, func
);
751 /* Traverse the tree of user operator nodes. */
754 gfc_traverse_user_op (gfc_namespace
*ns
, void (*func
) (gfc_user_op
*))
756 traverse_uop (ns
->uop_root
, func
);
760 /* Function to display a common block. */
763 show_common (gfc_symtree
*st
)
768 gfc_status ("common: /%s/ ", st
->name
);
770 s
= st
->n
.common
->head
;
773 gfc_status ("%s", s
->name
);
778 gfc_status_char ('\n');
782 /* Worker function to display the symbol tree. */
785 show_symtree (gfc_symtree
*st
)
788 gfc_status ("symtree: %s Ambig %d", st
->name
, st
->ambiguous
);
790 if (st
->n
.sym
->ns
!= gfc_current_ns
)
791 gfc_status (" from namespace %s", st
->n
.sym
->ns
->proc_name
->name
);
793 gfc_show_symbol (st
->n
.sym
);
797 /******************* Show gfc_code structures **************/
801 static void gfc_show_code_node (int, gfc_code
*);
803 /* Show a list of code structures. Mutually recursive with
804 gfc_show_code_node(). */
807 gfc_show_code (int level
, gfc_code
*c
)
809 for (; c
; c
= c
->next
)
810 gfc_show_code_node (level
, c
);
814 gfc_show_namelist (gfc_namelist
*n
)
816 for (; n
->next
; n
= n
->next
)
817 gfc_status ("%s,", n
->sym
->name
);
818 gfc_status ("%s", n
->sym
->name
);
821 /* Show a single OpenMP directive node and everything underneath it
825 gfc_show_omp_node (int level
, gfc_code
*c
)
827 gfc_omp_clauses
*omp_clauses
= NULL
;
828 const char *name
= NULL
;
832 case EXEC_OMP_ATOMIC
: name
= "ATOMIC"; break;
833 case EXEC_OMP_BARRIER
: name
= "BARRIER"; break;
834 case EXEC_OMP_CRITICAL
: name
= "CRITICAL"; break;
835 case EXEC_OMP_FLUSH
: name
= "FLUSH"; break;
836 case EXEC_OMP_DO
: name
= "DO"; break;
837 case EXEC_OMP_MASTER
: name
= "MASTER"; break;
838 case EXEC_OMP_ORDERED
: name
= "ORDERED"; break;
839 case EXEC_OMP_PARALLEL
: name
= "PARALLEL"; break;
840 case EXEC_OMP_PARALLEL_DO
: name
= "PARALLEL DO"; break;
841 case EXEC_OMP_PARALLEL_SECTIONS
: name
= "PARALLEL SECTIONS"; break;
842 case EXEC_OMP_PARALLEL_WORKSHARE
: name
= "PARALLEL WORKSHARE"; break;
843 case EXEC_OMP_SECTIONS
: name
= "SECTIONS"; break;
844 case EXEC_OMP_SINGLE
: name
= "SINGLE"; break;
845 case EXEC_OMP_WORKSHARE
: name
= "WORKSHARE"; break;
849 gfc_status ("!$OMP %s", name
);
853 case EXEC_OMP_PARALLEL
:
854 case EXEC_OMP_PARALLEL_DO
:
855 case EXEC_OMP_PARALLEL_SECTIONS
:
856 case EXEC_OMP_SECTIONS
:
857 case EXEC_OMP_SINGLE
:
858 case EXEC_OMP_WORKSHARE
:
859 case EXEC_OMP_PARALLEL_WORKSHARE
:
860 omp_clauses
= c
->ext
.omp_clauses
;
862 case EXEC_OMP_CRITICAL
:
864 gfc_status (" (%s)", c
->ext
.omp_name
);
867 if (c
->ext
.omp_namelist
)
870 gfc_show_namelist (c
->ext
.omp_namelist
);
871 gfc_status_char (')');
874 case EXEC_OMP_BARRIER
:
883 if (omp_clauses
->if_expr
)
886 gfc_show_expr (omp_clauses
->if_expr
);
887 gfc_status_char (')');
889 if (omp_clauses
->num_threads
)
891 gfc_status (" NUM_THREADS(");
892 gfc_show_expr (omp_clauses
->num_threads
);
893 gfc_status_char (')');
895 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
898 switch (omp_clauses
->sched_kind
)
900 case OMP_SCHED_STATIC
: type
= "STATIC"; break;
901 case OMP_SCHED_DYNAMIC
: type
= "DYNAMIC"; break;
902 case OMP_SCHED_GUIDED
: type
= "GUIDED"; break;
903 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
907 gfc_status (" SCHEDULE (%s", type
);
908 if (omp_clauses
->chunk_size
)
910 gfc_status_char (',');
911 gfc_show_expr (omp_clauses
->chunk_size
);
913 gfc_status_char (')');
915 if (omp_clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
918 switch (omp_clauses
->default_sharing
)
920 case OMP_DEFAULT_NONE
: type
= "NONE"; break;
921 case OMP_DEFAULT_PRIVATE
: type
= "PRIVATE"; break;
922 case OMP_DEFAULT_SHARED
: type
= "SHARED"; break;
923 case OMP_SCHED_RUNTIME
: type
= "RUNTIME"; break;
927 gfc_status (" DEFAULT(%s)", type
);
929 if (omp_clauses
->ordered
)
930 gfc_status (" ORDERED");
931 for (list_type
= 0; list_type
< OMP_LIST_NUM
; list_type
++)
932 if (omp_clauses
->lists
[list_type
] != NULL
933 && list_type
!= OMP_LIST_COPYPRIVATE
)
936 if (list_type
>= OMP_LIST_REDUCTION_FIRST
)
940 case OMP_LIST_PLUS
: type
= "+"; break;
941 case OMP_LIST_MULT
: type
= "*"; break;
942 case OMP_LIST_SUB
: type
= "-"; break;
943 case OMP_LIST_AND
: type
= ".AND."; break;
944 case OMP_LIST_OR
: type
= ".OR."; break;
945 case OMP_LIST_EQV
: type
= ".EQV."; break;
946 case OMP_LIST_NEQV
: type
= ".NEQV."; break;
947 case OMP_LIST_MAX
: type
= "MAX"; break;
948 case OMP_LIST_MIN
: type
= "MIN"; break;
949 case OMP_LIST_IAND
: type
= "IAND"; break;
950 case OMP_LIST_IOR
: type
= "IOR"; break;
951 case OMP_LIST_IEOR
: type
= "IEOR"; break;
955 gfc_status (" REDUCTION(%s:", type
);
961 case OMP_LIST_PRIVATE
: type
= "PRIVATE"; break;
962 case OMP_LIST_FIRSTPRIVATE
: type
= "FIRSTPRIVATE"; break;
963 case OMP_LIST_LASTPRIVATE
: type
= "LASTPRIVATE"; break;
964 case OMP_LIST_SHARED
: type
= "SHARED"; break;
965 case OMP_LIST_COPYIN
: type
= "COPYIN"; break;
969 gfc_status (" %s(", type
);
971 gfc_show_namelist (omp_clauses
->lists
[list_type
]);
972 gfc_status_char (')');
975 gfc_status_char ('\n');
976 if (c
->op
== EXEC_OMP_SECTIONS
|| c
->op
== EXEC_OMP_PARALLEL_SECTIONS
)
978 gfc_code
*d
= c
->block
;
981 gfc_show_code (level
+ 1, d
->next
);
982 if (d
->block
== NULL
)
984 code_indent (level
, 0);
985 gfc_status ("!$OMP SECTION\n");
990 gfc_show_code (level
+ 1, c
->block
->next
);
991 if (c
->op
== EXEC_OMP_ATOMIC
)
993 code_indent (level
, 0);
994 gfc_status ("!$OMP END %s", name
);
995 if (omp_clauses
!= NULL
)
997 if (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
999 gfc_status (" COPYPRIVATE(");
1000 gfc_show_namelist (omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]);
1001 gfc_status_char (')');
1003 else if (omp_clauses
->nowait
)
1004 gfc_status (" NOWAIT");
1006 else if (c
->op
== EXEC_OMP_CRITICAL
&& c
->ext
.omp_name
)
1007 gfc_status (" (%s)", c
->ext
.omp_name
);
1011 /* Show a single code node and everything underneath it if necessary. */
1014 gfc_show_code_node (int level
, gfc_code
*c
)
1016 gfc_forall_iterator
*fa
;
1026 code_indent (level
, c
->here
);
1035 gfc_status ("CONTINUE");
1039 gfc_status ("ENTRY %s", c
->ext
.entry
->sym
->name
);
1042 case EXEC_INIT_ASSIGN
:
1044 gfc_status ("ASSIGN ");
1045 gfc_show_expr (c
->expr
);
1046 gfc_status_char (' ');
1047 gfc_show_expr (c
->expr2
);
1050 case EXEC_LABEL_ASSIGN
:
1051 gfc_status ("LABEL ASSIGN ");
1052 gfc_show_expr (c
->expr
);
1053 gfc_status (" %d", c
->label
->value
);
1056 case EXEC_POINTER_ASSIGN
:
1057 gfc_status ("POINTER ASSIGN ");
1058 gfc_show_expr (c
->expr
);
1059 gfc_status_char (' ');
1060 gfc_show_expr (c
->expr2
);
1064 gfc_status ("GOTO ");
1066 gfc_status ("%d", c
->label
->value
);
1069 gfc_show_expr (c
->expr
);
1074 for (; d
; d
= d
->block
)
1076 code_indent (level
, d
->label
);
1077 if (d
->block
!= NULL
)
1078 gfc_status_char (',');
1080 gfc_status_char (')');
1087 case EXEC_ASSIGN_CALL
:
1088 if (c
->resolved_sym
)
1089 gfc_status ("CALL %s ", c
->resolved_sym
->name
);
1090 else if (c
->symtree
)
1091 gfc_status ("CALL %s ", c
->symtree
->name
);
1093 gfc_status ("CALL ?? ");
1095 gfc_show_actual_arglist (c
->ext
.actual
);
1099 gfc_status ("RETURN ");
1101 gfc_show_expr (c
->expr
);
1105 gfc_status ("PAUSE ");
1107 if (c
->expr
!= NULL
)
1108 gfc_show_expr (c
->expr
);
1110 gfc_status ("%d", c
->ext
.stop_code
);
1115 gfc_status ("STOP ");
1117 if (c
->expr
!= NULL
)
1118 gfc_show_expr (c
->expr
);
1120 gfc_status ("%d", c
->ext
.stop_code
);
1124 case EXEC_ARITHMETIC_IF
:
1126 gfc_show_expr (c
->expr
);
1127 gfc_status (" %d, %d, %d",
1128 c
->label
->value
, c
->label2
->value
, c
->label3
->value
);
1134 gfc_show_expr (d
->expr
);
1135 gfc_status_char ('\n');
1136 gfc_show_code (level
+ 1, d
->next
);
1139 for (; d
; d
= d
->block
)
1141 code_indent (level
, 0);
1143 if (d
->expr
== NULL
)
1144 gfc_status ("ELSE\n");
1147 gfc_status ("ELSE IF ");
1148 gfc_show_expr (d
->expr
);
1149 gfc_status_char ('\n');
1152 gfc_show_code (level
+ 1, d
->next
);
1155 code_indent (level
, c
->label
);
1157 gfc_status ("ENDIF");
1162 gfc_status ("SELECT CASE ");
1163 gfc_show_expr (c
->expr
);
1164 gfc_status_char ('\n');
1166 for (; d
; d
= d
->block
)
1168 code_indent (level
, 0);
1170 gfc_status ("CASE ");
1171 for (cp
= d
->ext
.case_list
; cp
; cp
= cp
->next
)
1173 gfc_status_char ('(');
1174 gfc_show_expr (cp
->low
);
1175 gfc_status_char (' ');
1176 gfc_show_expr (cp
->high
);
1177 gfc_status_char (')');
1178 gfc_status_char (' ');
1180 gfc_status_char ('\n');
1182 gfc_show_code (level
+ 1, d
->next
);
1185 code_indent (level
, c
->label
);
1186 gfc_status ("END SELECT");
1190 gfc_status ("WHERE ");
1193 gfc_show_expr (d
->expr
);
1194 gfc_status_char ('\n');
1196 gfc_show_code (level
+ 1, d
->next
);
1198 for (d
= d
->block
; d
; d
= d
->block
)
1200 code_indent (level
, 0);
1201 gfc_status ("ELSE WHERE ");
1202 gfc_show_expr (d
->expr
);
1203 gfc_status_char ('\n');
1204 gfc_show_code (level
+ 1, d
->next
);
1207 code_indent (level
, 0);
1208 gfc_status ("END WHERE");
1213 gfc_status ("FORALL ");
1214 for (fa
= c
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1216 gfc_show_expr (fa
->var
);
1217 gfc_status_char (' ');
1218 gfc_show_expr (fa
->start
);
1219 gfc_status_char (':');
1220 gfc_show_expr (fa
->end
);
1221 gfc_status_char (':');
1222 gfc_show_expr (fa
->stride
);
1224 if (fa
->next
!= NULL
)
1225 gfc_status_char (',');
1228 if (c
->expr
!= NULL
)
1230 gfc_status_char (',');
1231 gfc_show_expr (c
->expr
);
1233 gfc_status_char ('\n');
1235 gfc_show_code (level
+ 1, c
->block
->next
);
1237 code_indent (level
, 0);
1238 gfc_status ("END FORALL");
1244 gfc_show_expr (c
->ext
.iterator
->var
);
1245 gfc_status_char ('=');
1246 gfc_show_expr (c
->ext
.iterator
->start
);
1247 gfc_status_char (' ');
1248 gfc_show_expr (c
->ext
.iterator
->end
);
1249 gfc_status_char (' ');
1250 gfc_show_expr (c
->ext
.iterator
->step
);
1251 gfc_status_char ('\n');
1253 gfc_show_code (level
+ 1, c
->block
->next
);
1255 code_indent (level
, 0);
1256 gfc_status ("END DO");
1260 gfc_status ("DO WHILE ");
1261 gfc_show_expr (c
->expr
);
1262 gfc_status_char ('\n');
1264 gfc_show_code (level
+ 1, c
->block
->next
);
1266 code_indent (level
, c
->label
);
1267 gfc_status ("END DO");
1271 gfc_status ("CYCLE");
1273 gfc_status (" %s", c
->symtree
->n
.sym
->name
);
1277 gfc_status ("EXIT");
1279 gfc_status (" %s", c
->symtree
->n
.sym
->name
);
1283 gfc_status ("ALLOCATE ");
1286 gfc_status (" STAT=");
1287 gfc_show_expr (c
->expr
);
1290 for (a
= c
->ext
.alloc_list
; a
; a
= a
->next
)
1292 gfc_status_char (' ');
1293 gfc_show_expr (a
->expr
);
1298 case EXEC_DEALLOCATE
:
1299 gfc_status ("DEALLOCATE ");
1302 gfc_status (" STAT=");
1303 gfc_show_expr (c
->expr
);
1306 for (a
= c
->ext
.alloc_list
; a
; a
= a
->next
)
1308 gfc_status_char (' ');
1309 gfc_show_expr (a
->expr
);
1315 gfc_status ("OPEN");
1320 gfc_status (" UNIT=");
1321 gfc_show_expr (open
->unit
);
1325 gfc_status (" IOMSG=");
1326 gfc_show_expr (open
->iomsg
);
1330 gfc_status (" IOSTAT=");
1331 gfc_show_expr (open
->iostat
);
1335 gfc_status (" FILE=");
1336 gfc_show_expr (open
->file
);
1340 gfc_status (" STATUS=");
1341 gfc_show_expr (open
->status
);
1345 gfc_status (" ACCESS=");
1346 gfc_show_expr (open
->access
);
1350 gfc_status (" FORM=");
1351 gfc_show_expr (open
->form
);
1355 gfc_status (" RECL=");
1356 gfc_show_expr (open
->recl
);
1360 gfc_status (" BLANK=");
1361 gfc_show_expr (open
->blank
);
1365 gfc_status (" POSITION=");
1366 gfc_show_expr (open
->position
);
1370 gfc_status (" ACTION=");
1371 gfc_show_expr (open
->action
);
1375 gfc_status (" DELIM=");
1376 gfc_show_expr (open
->delim
);
1380 gfc_status (" PAD=");
1381 gfc_show_expr (open
->pad
);
1385 gfc_status (" CONVERT=");
1386 gfc_show_expr (open
->convert
);
1388 if (open
->err
!= NULL
)
1389 gfc_status (" ERR=%d", open
->err
->value
);
1394 gfc_status ("CLOSE");
1395 close
= c
->ext
.close
;
1399 gfc_status (" UNIT=");
1400 gfc_show_expr (close
->unit
);
1404 gfc_status (" IOMSG=");
1405 gfc_show_expr (close
->iomsg
);
1409 gfc_status (" IOSTAT=");
1410 gfc_show_expr (close
->iostat
);
1414 gfc_status (" STATUS=");
1415 gfc_show_expr (close
->status
);
1417 if (close
->err
!= NULL
)
1418 gfc_status (" ERR=%d", close
->err
->value
);
1421 case EXEC_BACKSPACE
:
1422 gfc_status ("BACKSPACE");
1426 gfc_status ("ENDFILE");
1430 gfc_status ("REWIND");
1434 gfc_status ("FLUSH");
1437 fp
= c
->ext
.filepos
;
1441 gfc_status (" UNIT=");
1442 gfc_show_expr (fp
->unit
);
1446 gfc_status (" IOMSG=");
1447 gfc_show_expr (fp
->iomsg
);
1451 gfc_status (" IOSTAT=");
1452 gfc_show_expr (fp
->iostat
);
1454 if (fp
->err
!= NULL
)
1455 gfc_status (" ERR=%d", fp
->err
->value
);
1459 gfc_status ("INQUIRE");
1464 gfc_status (" UNIT=");
1465 gfc_show_expr (i
->unit
);
1469 gfc_status (" FILE=");
1470 gfc_show_expr (i
->file
);
1475 gfc_status (" IOMSG=");
1476 gfc_show_expr (i
->iomsg
);
1480 gfc_status (" IOSTAT=");
1481 gfc_show_expr (i
->iostat
);
1485 gfc_status (" EXIST=");
1486 gfc_show_expr (i
->exist
);
1490 gfc_status (" OPENED=");
1491 gfc_show_expr (i
->opened
);
1495 gfc_status (" NUMBER=");
1496 gfc_show_expr (i
->number
);
1500 gfc_status (" NAMED=");
1501 gfc_show_expr (i
->named
);
1505 gfc_status (" NAME=");
1506 gfc_show_expr (i
->name
);
1510 gfc_status (" ACCESS=");
1511 gfc_show_expr (i
->access
);
1515 gfc_status (" SEQUENTIAL=");
1516 gfc_show_expr (i
->sequential
);
1521 gfc_status (" DIRECT=");
1522 gfc_show_expr (i
->direct
);
1526 gfc_status (" FORM=");
1527 gfc_show_expr (i
->form
);
1531 gfc_status (" FORMATTED");
1532 gfc_show_expr (i
->formatted
);
1536 gfc_status (" UNFORMATTED=");
1537 gfc_show_expr (i
->unformatted
);
1541 gfc_status (" RECL=");
1542 gfc_show_expr (i
->recl
);
1546 gfc_status (" NEXTREC=");
1547 gfc_show_expr (i
->nextrec
);
1551 gfc_status (" BLANK=");
1552 gfc_show_expr (i
->blank
);
1556 gfc_status (" POSITION=");
1557 gfc_show_expr (i
->position
);
1561 gfc_status (" ACTION=");
1562 gfc_show_expr (i
->action
);
1566 gfc_status (" READ=");
1567 gfc_show_expr (i
->read
);
1571 gfc_status (" WRITE=");
1572 gfc_show_expr (i
->write
);
1576 gfc_status (" READWRITE=");
1577 gfc_show_expr (i
->readwrite
);
1581 gfc_status (" DELIM=");
1582 gfc_show_expr (i
->delim
);
1586 gfc_status (" PAD=");
1587 gfc_show_expr (i
->pad
);
1591 gfc_status (" CONVERT=");
1592 gfc_show_expr (i
->convert
);
1596 gfc_status (" ERR=%d", i
->err
->value
);
1600 gfc_status ("IOLENGTH ");
1601 gfc_show_expr (c
->expr
);
1606 gfc_status ("READ");
1610 gfc_status ("WRITE");
1616 gfc_status (" UNIT=");
1617 gfc_show_expr (dt
->io_unit
);
1620 if (dt
->format_expr
)
1622 gfc_status (" FMT=");
1623 gfc_show_expr (dt
->format_expr
);
1626 if (dt
->format_label
!= NULL
)
1627 gfc_status (" FMT=%d", dt
->format_label
->value
);
1629 gfc_status (" NML=%s", dt
->namelist
->name
);
1633 gfc_status (" IOMSG=");
1634 gfc_show_expr (dt
->iomsg
);
1638 gfc_status (" IOSTAT=");
1639 gfc_show_expr (dt
->iostat
);
1643 gfc_status (" SIZE=");
1644 gfc_show_expr (dt
->size
);
1648 gfc_status (" REC=");
1649 gfc_show_expr (dt
->rec
);
1653 gfc_status (" ADVANCE=");
1654 gfc_show_expr (dt
->advance
);
1658 gfc_status_char ('\n');
1659 for (c
= c
->block
->next
; c
; c
= c
->next
)
1660 gfc_show_code_node (level
+ (c
->next
!= NULL
), c
);
1664 gfc_status ("TRANSFER ");
1665 gfc_show_expr (c
->expr
);
1669 gfc_status ("DT_END");
1672 if (dt
->err
!= NULL
)
1673 gfc_status (" ERR=%d", dt
->err
->value
);
1674 if (dt
->end
!= NULL
)
1675 gfc_status (" END=%d", dt
->end
->value
);
1676 if (dt
->eor
!= NULL
)
1677 gfc_status (" EOR=%d", dt
->eor
->value
);
1680 case EXEC_OMP_ATOMIC
:
1681 case EXEC_OMP_BARRIER
:
1682 case EXEC_OMP_CRITICAL
:
1683 case EXEC_OMP_FLUSH
:
1685 case EXEC_OMP_MASTER
:
1686 case EXEC_OMP_ORDERED
:
1687 case EXEC_OMP_PARALLEL
:
1688 case EXEC_OMP_PARALLEL_DO
:
1689 case EXEC_OMP_PARALLEL_SECTIONS
:
1690 case EXEC_OMP_PARALLEL_WORKSHARE
:
1691 case EXEC_OMP_SECTIONS
:
1692 case EXEC_OMP_SINGLE
:
1693 case EXEC_OMP_WORKSHARE
:
1694 gfc_show_omp_node (level
, c
);
1698 gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1701 gfc_status_char ('\n');
1705 /* Show an equivalence chain. */
1708 gfc_show_equiv (gfc_equiv
*eq
)
1711 gfc_status ("Equivalence: ");
1714 gfc_show_expr (eq
->expr
);
1722 /* Show a freakin' whole namespace. */
1725 gfc_show_namespace (gfc_namespace
*ns
)
1727 gfc_interface
*intr
;
1728 gfc_namespace
*save
;
1729 gfc_intrinsic_op op
;
1733 save
= gfc_current_ns
;
1737 gfc_status ("Namespace:");
1745 while (i
< GFC_LETTERS
- 1
1746 && gfc_compare_types(&ns
->default_type
[i
+1],
1747 &ns
->default_type
[l
]))
1751 gfc_status(" %c-%c: ", l
+'A', i
+'A');
1753 gfc_status(" %c: ", l
+'A');
1755 gfc_show_typespec(&ns
->default_type
[l
]);
1757 } while (i
< GFC_LETTERS
);
1759 if (ns
->proc_name
!= NULL
)
1762 gfc_status ("procedure name = %s", ns
->proc_name
->name
);
1765 gfc_current_ns
= ns
;
1766 gfc_traverse_symtree (ns
->common_root
, show_common
);
1768 gfc_traverse_symtree (ns
->sym_root
, show_symtree
);
1770 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; op
++)
1772 /* User operator interfaces */
1773 intr
= ns
->operator[op
];
1778 gfc_status ("Operator interfaces for %s:", gfc_op2string (op
));
1780 for (; intr
; intr
= intr
->next
)
1781 gfc_status (" %s", intr
->sym
->name
);
1784 if (ns
->uop_root
!= NULL
)
1787 gfc_status ("User operators:\n");
1788 gfc_traverse_user_op (ns
, show_uop
);
1792 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
1793 gfc_show_equiv (eq
);
1795 gfc_status_char ('\n');
1796 gfc_status_char ('\n');
1798 gfc_show_code (0, ns
->code
);
1800 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1803 gfc_status ("CONTAINS\n");
1804 gfc_show_namespace (ns
);
1808 gfc_status_char ('\n');
1809 gfc_current_ns
= save
;