]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/dump-parse-tree.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
re PR tree-optimization/23509 (ICE with ivopts)
[thirdparty/gcc.git] / gcc / fortran / dump-parse-tree.c
CommitLineData
6de9cd9a 1/* Parse tree dumper
aa990c83 2 Copyright (C) 2003, 2004, 2005 Free Software Foundation, Inc.
6de9cd9a
DN		 3 Contributed by Steven Bosscher
4
9fc4d79b 5This file is part of GCC.
6de9cd9a 6
9fc4d79b
TS		 7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 2, or (at your option) any later
10version.
6de9cd9a 11
9fc4d79b
TS		 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
6de9cd9a
DN		 16
17You should have received a copy of the GNU General Public License
9fc4d79b 18along with GCC; see the file COPYING. If not, write to the Free
ab57747b
KC		 19Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
2002110-1301, USA. */
6de9cd9a
DN		 21
22
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.
27
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
30 relatives.
31
32 TODO: Dump DATA. */
33
34#include "config.h"
35#include "gfortran.h"
36
37/* Keep track of indentation for symbol tree dumps. */
38static int show_level = 0;
39
40
41/* Forward declaration because this one needs all, and all need
42 this one. */
43static void gfc_show_expr (gfc_expr *);
44
45/* Do indentation for a specific level. */
46
47static inline void
48code_indent (int level, gfc_st_label * label)
49{
50 int i;
51
52 if (label != NULL)
53 gfc_status ("%-5d ", label->value);
54 else
55 gfc_status (" ");
56
57 for (i = 0; i < 2 * level; i++)
58 gfc_status_char (' ');
59}
60
61
62/* Simple indentation at the current level. This one
63 is used to show symbols. */
64static inline void
65show_indent (void)
66{
67 gfc_status ("\n");
68 code_indent (show_level, NULL);
69}
70
71
72/* Show type-specific information. */
73static void
74gfc_show_typespec (gfc_typespec * ts)
75{
76
77 gfc_status ("(%s ", gfc_basic_typename (ts->type));
78
79 switch (ts->type)
80 {
81 case BT_DERIVED:
82 gfc_status ("%s", ts->derived->name);
83 break;
84
85 case BT_CHARACTER:
86 gfc_show_expr (ts->cl->length);
87 break;
88
89 default:
90 gfc_status ("%d", ts->kind);
91 break;
92 }
93
94 gfc_status (")");
95}
96
97
98/* Show an actual argument list. */
99
100static void
101gfc_show_actual_arglist (gfc_actual_arglist * a)
102{
103
104 gfc_status ("(");
105
106 for (; a; a = a->next)
107 {
108 gfc_status_char ('(');
cb9e4f55 109 if (a->name != NULL)
6de9cd9a
DN		 110 gfc_status ("%s = ", a->name);
111 if (a->expr != NULL)
112 gfc_show_expr (a->expr);
113 else
114 gfc_status ("(arg not-present)");
115
116 gfc_status_char (')');
117 if (a->next != NULL)
118 gfc_status (" ");
119 }
120
121 gfc_status (")");
122}
123
124
49de9e73 125/* Show a gfc_array_spec array specification structure. */
6de9cd9a
DN		 126
127static void
128gfc_show_array_spec (gfc_array_spec * as)
129{
130 const char *c;
131 int i;
132
133 if (as == NULL)
134 {
135 gfc_status ("()");
136 return;
137 }
138
139 gfc_status ("(%d", as->rank);
140
141 if (as->rank != 0)
142 {
143 switch (as->type)
144 {
145 case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
146 case AS_DEFERRED: c = "AS_DEFERRED"; break;
147 case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
148 case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
149 default:
150 gfc_internal_error
151 ("gfc_show_array_spec(): Unhandled array shape type.");
152 }
153 gfc_status (" %s ", c);
154
155 for (i = 0; i < as->rank; i++)
156 {
157 gfc_show_expr (as->lower[i]);
158 gfc_status_char (' ');
159 gfc_show_expr (as->upper[i]);
160 gfc_status_char (' ');
161 }
162 }
163
164 gfc_status (")");
165}
166
167
49de9e73 168/* Show a gfc_array_ref array reference structure. */
6de9cd9a
DN		 169
170static void
171gfc_show_array_ref (gfc_array_ref * ar)
172{
173 int i;
174
175 gfc_status_char ('(');
176
177 switch (ar->type)
178 {
179 case AR_FULL:
180 gfc_status ("FULL");
181 break;
182
183 case AR_SECTION:
184 for (i = 0; i < ar->dimen; i++)
185 {
fb89e8bd
TS		 186 /* There are two types of array sections: either the
187 elements are identified by an integer array ('vector'),
188 or by an index range. In the former case we only have to
189 print the start expression which contains the vector, in
190 the latter case we have to print any of lower and upper
191 bound and the stride, if they're present. */
192
6de9cd9a
DN		 193 if (ar->start[i] != NULL)
194 gfc_show_expr (ar->start[i]);
195
fb89e8bd 196 if (ar->dimen_type[i] == DIMEN_RANGE)
6de9cd9a
DN		 197 {
198 gfc_status_char (':');
fb89e8bd
TS		 199
200 if (ar->end[i] != NULL)
201 gfc_show_expr (ar->end[i]);
202
203 if (ar->stride[i] != NULL)
204 {
205 gfc_status_char (':');
206 gfc_show_expr (ar->stride[i]);
207 }
6de9cd9a
DN		 208 }
209
210 if (i != ar->dimen - 1)
211 gfc_status (" , ");
212 }
213 break;
214
215 case AR_ELEMENT:
216 for (i = 0; i < ar->dimen; i++)
217 {
218 gfc_show_expr (ar->start[i]);
219 if (i != ar->dimen - 1)
220 gfc_status (" , ");
221 }
222 break;
223
224 case AR_UNKNOWN:
225 gfc_status ("UNKNOWN");
226 break;
227
228 default:
229 gfc_internal_error ("gfc_show_array_ref(): Unknown array reference");
230 }
231
232 gfc_status_char (')');
233}
234
235
236/* Show a list of gfc_ref structures. */
237
238static void
239gfc_show_ref (gfc_ref * p)
240{
241
242 for (; p; p = p->next)
243 switch (p->type)
244 {
245 case REF_ARRAY:
246 gfc_show_array_ref (&p->u.ar);
247 break;
248
249 case REF_COMPONENT:
250 gfc_status (" %% %s", p->u.c.component->name);
251 break;
252
253 case REF_SUBSTRING:
254 gfc_status_char ('(');
255 gfc_show_expr (p->u.ss.start);
256 gfc_status_char (':');
257 gfc_show_expr (p->u.ss.end);
258 gfc_status_char (')');
259 break;
260
261 default:
262 gfc_internal_error ("gfc_show_ref(): Bad component code");
263 }
264}
265
266
267/* Display a constructor. Works recursively for array constructors. */
268
269static void
270gfc_show_constructor (gfc_constructor * c)
271{
272
273 for (; c; c = c->next)
274 {
275 if (c->iterator == NULL)
276 gfc_show_expr (c->expr);
277 else
278 {
279 gfc_status_char ('(');
280 gfc_show_expr (c->expr);
281
282 gfc_status_char (' ');
283 gfc_show_expr (c->iterator->var);
284 gfc_status_char ('=');
285 gfc_show_expr (c->iterator->start);
286 gfc_status_char (',');
287 gfc_show_expr (c->iterator->end);
288 gfc_status_char (',');
289 gfc_show_expr (c->iterator->step);
290
291 gfc_status_char (')');
292 }
293
294 if (c->next != NULL)
295 gfc_status (" , ");
296 }
297}
298
299
300/* Show an expression. */
301
302static void
303gfc_show_expr (gfc_expr * p)
304{
305 const char *c;
306 int i;
307
308 if (p == NULL)
309 {
310 gfc_status ("()");
311 return;
312 }
313
314 switch (p->expr_type)
315 {
316 case EXPR_SUBSTRING:
317 c = p->value.character.string;
318
319 for (i = 0; i < p->value.character.length; i++, c++)
320 {
321 if (*c == '\'')
322 gfc_status ("''");
323 else
324 gfc_status ("%c", *c);
325 }
326
327 gfc_show_ref (p->ref);
328 break;
329
330 case EXPR_STRUCTURE:
331 gfc_status ("%s(", p->ts.derived->name);
332 gfc_show_constructor (p->value.constructor);
333 gfc_status_char (')');
334 break;
335
336 case EXPR_ARRAY:
337 gfc_status ("(/ ");
338 gfc_show_constructor (p->value.constructor);
339 gfc_status (" /)");
340
341 gfc_show_ref (p->ref);
342 break;
343
344 case EXPR_NULL:
345 gfc_status ("NULL()");
346 break;
347
348 case EXPR_CONSTANT:
349 switch (p->ts.type)
350 {
351 case BT_INTEGER:
352 mpz_out_str (stdout, 10, p->value.integer);
353
9d64df18 354 if (p->ts.kind != gfc_default_integer_kind)
6de9cd9a
DN		 355 gfc_status ("_%d", p->ts.kind);
356 break;
357
358 case BT_LOGICAL:
359 if (p->value.logical)
360 gfc_status (".true.");
361 else
362 gfc_status (".false.");
363 break;
364
365 case BT_REAL:
f8e566e5 366 mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
9d64df18 367 if (p->ts.kind != gfc_default_real_kind)
6de9cd9a
DN		 368 gfc_status ("_%d", p->ts.kind);
369 break;
370
371 case BT_CHARACTER:
372 c = p->value.character.string;
373
374 gfc_status_char ('\'');
375
376 for (i = 0; i < p->value.character.length; i++, c++)
377 {
378 if (*c == '\'')
379 gfc_status ("''");
380 else
381 gfc_status_char (*c);
382 }
383
384 gfc_status_char ('\'');
385
386 break;
387
388 case BT_COMPLEX:
389 gfc_status ("(complex ");
390
f8e566e5 391 mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
9d64df18 392 if (p->ts.kind != gfc_default_complex_kind)
6de9cd9a
DN		 393 gfc_status ("_%d", p->ts.kind);
394
395 gfc_status (" ");
396
f8e566e5 397 mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE);
9d64df18 398 if (p->ts.kind != gfc_default_complex_kind)
6de9cd9a
DN		 399 gfc_status ("_%d", p->ts.kind);
400
401 gfc_status (")");
402 break;
403
404 default:
405 gfc_status ("???");
406 break;
407 }
408
409 break;
410
411 case EXPR_VARIABLE:
9439ae41
TS		 412 if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
413 gfc_status ("%s:", p->symtree->n.sym->ns->proc_name->name);
6de9cd9a
DN		 414 gfc_status ("%s", p->symtree->n.sym->name);
415 gfc_show_ref (p->ref);
416 break;
417
418 case EXPR_OP:
419 gfc_status ("(");
58b03ab2 420 switch (p->value.op.operator)
6de9cd9a
DN		 421 {
422 case INTRINSIC_UPLUS:
423 gfc_status ("U+ ");
424 break;
425 case INTRINSIC_UMINUS:
426 gfc_status ("U- ");
427 break;
428 case INTRINSIC_PLUS:
429 gfc_status ("+ ");
430 break;
431 case INTRINSIC_MINUS:
432 gfc_status ("- ");
433 break;
434 case INTRINSIC_TIMES:
435 gfc_status ("* ");
436 break;
437 case INTRINSIC_DIVIDE:
438 gfc_status ("/ ");
439 break;
440 case INTRINSIC_POWER:
441 gfc_status ("** ");
442 break;
443 case INTRINSIC_CONCAT:
444 gfc_status ("// ");
445 break;
446 case INTRINSIC_AND:
447 gfc_status ("AND ");
448 break;
449 case INTRINSIC_OR:
450 gfc_status ("OR ");
451 break;
452 case INTRINSIC_EQV:
453 gfc_status ("EQV ");
454 break;
455 case INTRINSIC_NEQV:
456 gfc_status ("NEQV ");
457 break;
458 case INTRINSIC_EQ:
459 gfc_status ("= ");
460 break;
461 case INTRINSIC_NE:
462 gfc_status ("<> ");
463 break;
464 case INTRINSIC_GT:
465 gfc_status ("> ");
466 break;
467 case INTRINSIC_GE:
468 gfc_status (">= ");
469 break;
470 case INTRINSIC_LT:
471 gfc_status ("< ");
472 break;
473 case INTRINSIC_LE:
474 gfc_status ("<= ");
475 break;
476 case INTRINSIC_NOT:
477 gfc_status ("NOT ");
478 break;
479
480 default:
481 gfc_internal_error
482 ("gfc_show_expr(): Bad intrinsic in expression!");
483 }
484
58b03ab2 485 gfc_show_expr (p->value.op.op1);
6de9cd9a 486
58b03ab2 487 if (p->value.op.op2)
6de9cd9a
DN		 488 {
489 gfc_status (" ");
58b03ab2 490 gfc_show_expr (p->value.op.op2);
6de9cd9a
DN		 491 }
492
493 gfc_status (")");
494 break;
495
496 case EXPR_FUNCTION:
497 if (p->value.function.name == NULL)
498 {
499 gfc_status ("%s[", p->symtree->n.sym->name);
500 gfc_show_actual_arglist (p->value.function.actual);
501 gfc_status_char (']');
502 }
503 else
504 {
505 gfc_status ("%s[[", p->value.function.name);
506 gfc_show_actual_arglist (p->value.function.actual);
507 gfc_status_char (']');
508 gfc_status_char (']');
509 }
510
511 break;
512
513 default:
514 gfc_internal_error ("gfc_show_expr(): Don't know how to show expr");
515 }
516}
517
518
519/* Show symbol attributes. The flavor and intent are followed by
520 whatever single bit attributes are present. */
521
522static void
523gfc_show_attr (symbol_attribute * attr)
524{
525
526 gfc_status ("(%s %s %s %s", gfc_code2string (flavors, attr->flavor),
527 gfc_intent_string (attr->intent),
528 gfc_code2string (access_types, attr->access),
529 gfc_code2string (procedures, attr->proc));
530
531 if (attr->allocatable)
532 gfc_status (" ALLOCATABLE");
533 if (attr->dimension)
534 gfc_status (" DIMENSION");
535 if (attr->external)
536 gfc_status (" EXTERNAL");
537 if (attr->intrinsic)
538 gfc_status (" INTRINSIC");
539 if (attr->optional)
540 gfc_status (" OPTIONAL");
541 if (attr->pointer)
542 gfc_status (" POINTER");
543 if (attr->save)
544 gfc_status (" SAVE");
545 if (attr->target)
546 gfc_status (" TARGET");
547 if (attr->dummy)
548 gfc_status (" DUMMY");
6de9cd9a
DN		 549 if (attr->result)
550 gfc_status (" RESULT");
551 if (attr->entry)
552 gfc_status (" ENTRY");
553
554 if (attr->data)
555 gfc_status (" DATA");
556 if (attr->use_assoc)
557 gfc_status (" USE-ASSOC");
558 if (attr->in_namelist)
559 gfc_status (" IN-NAMELIST");
560 if (attr->in_common)
561 gfc_status (" IN-COMMON");
6de9cd9a
DN		 562
563 if (attr->function)
564 gfc_status (" FUNCTION");
565 if (attr->subroutine)
566 gfc_status (" SUBROUTINE");
567 if (attr->implicit_type)
568 gfc_status (" IMPLICIT-TYPE");
569
570 if (attr->sequence)
571 gfc_status (" SEQUENCE");
572 if (attr->elemental)
573 gfc_status (" ELEMENTAL");
574 if (attr->pure)
575 gfc_status (" PURE");
576 if (attr->recursive)
577 gfc_status (" RECURSIVE");
578
579 gfc_status (")");
580}
581
582
583/* Show components of a derived type. */
584
585static void
586gfc_show_components (gfc_symbol * sym)
587{
588 gfc_component *c;
589
590 for (c = sym->components; c; c = c->next)
591 {
592 gfc_status ("(%s ", c->name);
593 gfc_show_typespec (&c->ts);
594 if (c->pointer)
595 gfc_status (" POINTER");
596 if (c->dimension)
597 gfc_status (" DIMENSION");
598 gfc_status_char (' ');
599 gfc_show_array_spec (c->as);
600 gfc_status (")");
601 if (c->next != NULL)
602 gfc_status_char (' ');
603 }
604}
605
606
607/* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
608 show the interface. Information needed to reconstruct the list of
609 specific interfaces associated with a generic symbol is done within
610 that symbol. */
611
612static void
613gfc_show_symbol (gfc_symbol * sym)
614{
615 gfc_formal_arglist *formal;
616 gfc_interface *intr;
6de9cd9a
DN		 617
618 if (sym == NULL)
619 return;
620
621 show_indent ();
622
623 gfc_status ("symbol %s ", sym->name);
624 gfc_show_typespec (&sym->ts);
625 gfc_show_attr (&sym->attr);
626
627 if (sym->value)
628 {
629 show_indent ();
630 gfc_status ("value: ");
631 gfc_show_expr (sym->value);
632 }
633
634 if (sym->as)
635 {
636 show_indent ();
637 gfc_status ("Array spec:");
638 gfc_show_array_spec (sym->as);
639 }
640
641 if (sym->generic)
642 {
643 show_indent ();
644 gfc_status ("Generic interfaces:");
645 for (intr = sym->generic; intr; intr = intr->next)
646 gfc_status (" %s", intr->sym->name);
647 }
648
6de9cd9a
DN		 649 if (sym->result)
650 {
651 show_indent ();
652 gfc_status ("result: %s", sym->result->name);
653 }
654
655 if (sym->components)
656 {
657 show_indent ();
658 gfc_status ("components: ");
659 gfc_show_components (sym);
660 }
661
662 if (sym->formal)
663 {
664 show_indent ();
665 gfc_status ("Formal arglist:");
666
667 for (formal = sym->formal; formal; formal = formal->next)
7f42f27f
TS		 668 {
669 if (formal->sym != NULL)
670 gfc_status (" %s", formal->sym->name);
671 else
672 gfc_status (" [Alt Return]");
673 }
6de9cd9a
DN		 674 }
675
676 if (sym->formal_ns)
677 {
678 show_indent ();
679 gfc_status ("Formal namespace");
680 gfc_show_namespace (sym->formal_ns);
681 }
682
683 gfc_status_char ('\n');
684}
685
686
687/* Show a user-defined operator. Just prints an operator
688 and the name of the associated subroutine, really. */
689static void
690show_uop (gfc_user_op * uop)
691{
692 gfc_interface *intr;
693
694 show_indent ();
695 gfc_status ("%s:", uop->name);
696
697 for (intr = uop->operator; intr; intr = intr->next)
698 gfc_status (" %s", intr->sym->name);
699}
700
701
702/* Workhorse function for traversing the user operator symtree. */
703
704static void
705traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
706{
707
708 if (st == NULL)
709 return;
710
711 (*func) (st->n.uop);
712
713 traverse_uop (st->left, func);
714 traverse_uop (st->right, func);
715}
716
717
718/* Traverse the tree of user operator nodes. */
719
720void
721gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
722{
723
724 traverse_uop (ns->uop_root, func);
725}
726
727
fbc9b453
TS		 728/* Function to display a common block. */
729
730static void
731show_common (gfc_symtree * st)
732{
733 gfc_symbol *s;
734
735 show_indent ();
736 gfc_status ("common: /%s/ ", st->name);
737
738 s = st->n.common->head;
739 while (s)
740 {
741 gfc_status ("%s", s->name);
742 s = s->common_next;
743 if (s)
744 gfc_status (", ");
745 }
746 gfc_status_char ('\n');
747}
748
6de9cd9a
DN		 749/* Worker function to display the symbol tree. */
750
751static void
752show_symtree (gfc_symtree * st)
753{
754
755 show_indent ();
756 gfc_status ("symtree: %s Ambig %d", st->name, st->ambiguous);
757
758 if (st->n.sym->ns != gfc_current_ns)
759 gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
760 else
761 gfc_show_symbol (st->n.sym);
762}
763
764
765/******************* Show gfc_code structures **************/
766
767
768
769static void gfc_show_code_node (int level, gfc_code * c);
770
771/* Show a list of code structures. Mutually recursive with
772 gfc_show_code_node(). */
773
774static void
775gfc_show_code (int level, gfc_code * c)
776{
777
778 for (; c; c = c->next)
779 gfc_show_code_node (level, c);
780}
781
782
783/* Show a single code node and everything underneath it if necessary. */
784
785static void
786gfc_show_code_node (int level, gfc_code * c)
787{
788 gfc_forall_iterator *fa;
789 gfc_open *open;
790 gfc_case *cp;
791 gfc_alloc *a;
792 gfc_code *d;
793 gfc_close *close;
794 gfc_filepos *fp;
795 gfc_inquire *i;
796 gfc_dt *dt;
797
798 code_indent (level, c->here);
799
800 switch (c->op)
801 {
802 case EXEC_NOP:
803 gfc_status ("NOP");
804 break;
805
806 case EXEC_CONTINUE:
807 gfc_status ("CONTINUE");
808 break;
809
3d79abbd
PB		 810 case EXEC_ENTRY:
811 gfc_status ("ENTRY %s", c->ext.entry->sym->name);
812 break;
813
6de9cd9a
DN		 814 case EXEC_ASSIGN:
815 gfc_status ("ASSIGN ");
816 gfc_show_expr (c->expr);
817 gfc_status_char (' ');
818 gfc_show_expr (c->expr2);
819 break;
3d79abbd 820
6de9cd9a
DN		 821 case EXEC_LABEL_ASSIGN:
822 gfc_status ("LABEL ASSIGN ");
823 gfc_show_expr (c->expr);
824 gfc_status (" %d", c->label->value);
825 break;
826
827 case EXEC_POINTER_ASSIGN:
828 gfc_status ("POINTER ASSIGN ");
829 gfc_show_expr (c->expr);
830 gfc_status_char (' ');
831 gfc_show_expr (c->expr2);
832 break;
833
834 case EXEC_GOTO:
835 gfc_status ("GOTO ");
836 if (c->label)
837 gfc_status ("%d", c->label->value);
838 else
839 {
840 gfc_show_expr (c->expr);
841 d = c->block;
842 if (d != NULL)
843 {
844 gfc_status (", (");
845 for (; d; d = d ->block)
846 {
847 code_indent (level, d->label);
848 if (d->block != NULL)
849 gfc_status_char (',');
850 else
851 gfc_status_char (')');
852 }
853 }
854 }
855 break;
856
857 case EXEC_CALL:
858 gfc_status ("CALL %s ", c->resolved_sym->name);
859 gfc_show_actual_arglist (c->ext.actual);
860 break;
861
862 case EXEC_RETURN:
863 gfc_status ("RETURN ");
864 if (c->expr)
865 gfc_show_expr (c->expr);
866 break;
867
868 case EXEC_PAUSE:
869 gfc_status ("PAUSE ");
870
871 if (c->expr != NULL)
872 gfc_show_expr (c->expr);
873 else
874 gfc_status ("%d", c->ext.stop_code);
875
876 break;
877
878 case EXEC_STOP:
879 gfc_status ("STOP ");
880
881 if (c->expr != NULL)
882 gfc_show_expr (c->expr);
883 else
884 gfc_status ("%d", c->ext.stop_code);
885
886 break;
887
888 case EXEC_ARITHMETIC_IF:
889 gfc_status ("IF ");
890 gfc_show_expr (c->expr);
891 gfc_status (" %d, %d, %d",
892 c->label->value, c->label2->value, c->label3->value);
893 break;
894
895 case EXEC_IF:
896 d = c->block;
897 gfc_status ("IF ");
898 gfc_show_expr (d->expr);
899 gfc_status_char ('\n');
900 gfc_show_code (level + 1, d->next);
901
902 d = d->block;
903 for (; d; d = d->block)
904 {
905 code_indent (level, 0);
906
907 if (d->expr == NULL)
908 gfc_status ("ELSE\n");
909 else
910 {
911 gfc_status ("ELSE IF ");
912 gfc_show_expr (d->expr);
913 gfc_status_char ('\n');
914 }
915
916 gfc_show_code (level + 1, d->next);
917 }
918
919 code_indent (level, c->label);
920
921 gfc_status ("ENDIF");
922 break;
923
924 case EXEC_SELECT:
925 d = c->block;
926 gfc_status ("SELECT CASE ");
927 gfc_show_expr (c->expr);
928 gfc_status_char ('\n');
929
930 for (; d; d = d->block)
931 {
932 code_indent (level, 0);
933
934 gfc_status ("CASE ");
935 for (cp = d->ext.case_list; cp; cp = cp->next)
936 {
937 gfc_status_char ('(');
938 gfc_show_expr (cp->low);
939 gfc_status_char (' ');
940 gfc_show_expr (cp->high);
941 gfc_status_char (')');
942 gfc_status_char (' ');
943 }
944 gfc_status_char ('\n');
945
946 gfc_show_code (level + 1, d->next);
947 }
948
949 code_indent (level, c->label);
950 gfc_status ("END SELECT");
951 break;
952
953 case EXEC_WHERE:
954 gfc_status ("WHERE ");
955
956 d = c->block;
957 gfc_show_expr (d->expr);
958 gfc_status_char ('\n');
959
960 gfc_show_code (level + 1, d->next);
961
962 for (d = d->block; d; d = d->block)
963 {
964 code_indent (level, 0);
965 gfc_status ("ELSE WHERE ");
966 gfc_show_expr (d->expr);
967 gfc_status_char ('\n');
968 gfc_show_code (level + 1, d->next);
969 }
970
971 code_indent (level, 0);
972 gfc_status ("END WHERE");
973 break;
974
975
976 case EXEC_FORALL:
977 gfc_status ("FORALL ");
978 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
979 {
980 gfc_show_expr (fa->var);
981 gfc_status_char (' ');
982 gfc_show_expr (fa->start);
983 gfc_status_char (':');
984 gfc_show_expr (fa->end);
985 gfc_status_char (':');
986 gfc_show_expr (fa->stride);
987
988 if (fa->next != NULL)
989 gfc_status_char (',');
990 }
991
992 if (c->expr != NULL)
993 {
994 gfc_status_char (',');
995 gfc_show_expr (c->expr);
996 }
997 gfc_status_char ('\n');
998
999 gfc_show_code (level + 1, c->block->next);
1000
1001 code_indent (level, 0);
1002 gfc_status ("END FORALL");
1003 break;
1004
1005 case EXEC_DO:
1006 gfc_status ("DO ");
1007
1008 gfc_show_expr (c->ext.iterator->var);
1009 gfc_status_char ('=');
1010 gfc_show_expr (c->ext.iterator->start);
1011 gfc_status_char (' ');
1012 gfc_show_expr (c->ext.iterator->end);
1013 gfc_status_char (' ');
1014 gfc_show_expr (c->ext.iterator->step);
1015 gfc_status_char ('\n');
1016
1017 gfc_show_code (level + 1, c->block->next);
1018
1019 code_indent (level, 0);
1020 gfc_status ("END DO");
1021 break;
1022
1023 case EXEC_DO_WHILE:
1024 gfc_status ("DO WHILE ");
1025 gfc_show_expr (c->expr);
1026 gfc_status_char ('\n');
1027
1028 gfc_show_code (level + 1, c->block->next);
1029
1030 code_indent (level, c->label);
1031 gfc_status ("END DO");
1032 break;
1033
1034 case EXEC_CYCLE:
1035 gfc_status ("CYCLE");
1036 if (c->symtree)
1037 gfc_status (" %s", c->symtree->n.sym->name);
1038 break;
1039
1040 case EXEC_EXIT:
1041 gfc_status ("EXIT");
1042 if (c->symtree)
1043 gfc_status (" %s", c->symtree->n.sym->name);
1044 break;
1045
1046 case EXEC_ALLOCATE:
1047 gfc_status ("ALLOCATE ");
1048 if (c->expr)
1049 {
1050 gfc_status (" STAT=");
1051 gfc_show_expr (c->expr);
1052 }
1053
1054 for (a = c->ext.alloc_list; a; a = a->next)
1055 {
1056 gfc_status_char (' ');
1057 gfc_show_expr (a->expr);
1058 }
1059
1060 break;
1061
1062 case EXEC_DEALLOCATE:
1063 gfc_status ("DEALLOCATE ");
1064 if (c->expr)
1065 {
1066 gfc_status (" STAT=");
1067 gfc_show_expr (c->expr);
1068 }
1069
1070 for (a = c->ext.alloc_list; a; a = a->next)
1071 {
1072 gfc_status_char (' ');
1073 gfc_show_expr (a->expr);
1074 }
1075
1076 break;
1077
1078 case EXEC_OPEN:
1079 gfc_status ("OPEN");
1080 open = c->ext.open;
1081
1082 if (open->unit)
1083 {
1084 gfc_status (" UNIT=");
1085 gfc_show_expr (open->unit);
1086 }
1087 if (open->iostat)
1088 {
1089 gfc_status (" IOSTAT=");
1090 gfc_show_expr (open->iostat);
1091 }
1092 if (open->file)
1093 {
1094 gfc_status (" FILE=");
1095 gfc_show_expr (open->file);
1096 }
1097 if (open->status)
1098 {
1099 gfc_status (" STATUS=");
1100 gfc_show_expr (open->status);
1101 }
1102 if (open->access)
1103 {
1104 gfc_status (" ACCESS=");
1105 gfc_show_expr (open->access);
1106 }
1107 if (open->form)
1108 {
1109 gfc_status (" FORM=");
1110 gfc_show_expr (open->form);
1111 }
1112 if (open->recl)
1113 {
1114 gfc_status (" RECL=");
1115 gfc_show_expr (open->recl);
1116 }
1117 if (open->blank)
1118 {
1119 gfc_status (" BLANK=");
1120 gfc_show_expr (open->blank);
1121 }
1122 if (open->position)
1123 {
1124 gfc_status (" POSITION=");
1125 gfc_show_expr (open->position);
1126 }
1127 if (open->action)
1128 {
1129 gfc_status (" ACTION=");
1130 gfc_show_expr (open->action);
1131 }
1132 if (open->delim)
1133 {
1134 gfc_status (" DELIM=");
1135 gfc_show_expr (open->delim);
1136 }
1137 if (open->pad)
1138 {
1139 gfc_status (" PAD=");
1140 gfc_show_expr (open->pad);
1141 }
1142 if (open->err != NULL)
1143 gfc_status (" ERR=%d", open->err->value);
1144
1145 break;
1146
1147 case EXEC_CLOSE:
1148 gfc_status ("CLOSE");
1149 close = c->ext.close;
1150
1151 if (close->unit)
1152 {
1153 gfc_status (" UNIT=");
1154 gfc_show_expr (close->unit);
1155 }
1156 if (close->iostat)
1157 {
1158 gfc_status (" IOSTAT=");
1159 gfc_show_expr (close->iostat);
1160 }
1161 if (close->status)
1162 {
1163 gfc_status (" STATUS=");
1164 gfc_show_expr (close->status);
1165 }
1166 if (close->err != NULL)
1167 gfc_status (" ERR=%d", close->err->value);
1168 break;
1169
1170 case EXEC_BACKSPACE:
1171 gfc_status ("BACKSPACE");
1172 goto show_filepos;
1173
1174 case EXEC_ENDFILE:
1175 gfc_status ("ENDFILE");
1176 goto show_filepos;
1177
1178 case EXEC_REWIND:
1179 gfc_status ("REWIND");
6403ec5f
JB		 1180 goto show_filepos;
1181
1182 case EXEC_FLUSH:
1183 gfc_status ("FLUSH");
6de9cd9a
DN		 1184
1185 show_filepos:
1186 fp = c->ext.filepos;
1187
1188 if (fp->unit)
1189 {
1190 gfc_status (" UNIT=");
1191 gfc_show_expr (fp->unit);
1192 }
1193 if (fp->iostat)
1194 {
1195 gfc_status (" IOSTAT=");
1196 gfc_show_expr (fp->iostat);
1197 }
1198 if (fp->err != NULL)
1199 gfc_status (" ERR=%d", fp->err->value);
1200 break;
1201
1202 case EXEC_INQUIRE:
1203 gfc_status ("INQUIRE");
1204 i = c->ext.inquire;
1205
1206 if (i->unit)
1207 {
1208 gfc_status (" UNIT=");
1209 gfc_show_expr (i->unit);
1210 }
1211 if (i->file)
1212 {
1213 gfc_status (" FILE=");
1214 gfc_show_expr (i->file);
1215 }
1216
1217 if (i->iostat)
1218 {
1219 gfc_status (" IOSTAT=");
1220 gfc_show_expr (i->iostat);
1221 }
1222 if (i->exist)
1223 {
1224 gfc_status (" EXIST=");
1225 gfc_show_expr (i->exist);
1226 }
1227 if (i->opened)
1228 {
1229 gfc_status (" OPENED=");
1230 gfc_show_expr (i->opened);
1231 }
1232 if (i->number)
1233 {
1234 gfc_status (" NUMBER=");
1235 gfc_show_expr (i->number);
1236 }
1237 if (i->named)
1238 {
1239 gfc_status (" NAMED=");
1240 gfc_show_expr (i->named);
1241 }
1242 if (i->name)
1243 {
1244 gfc_status (" NAME=");
1245 gfc_show_expr (i->name);
1246 }
1247 if (i->access)
1248 {
1249 gfc_status (" ACCESS=");
1250 gfc_show_expr (i->access);
1251 }
1252 if (i->sequential)
1253 {
1254 gfc_status (" SEQUENTIAL=");
1255 gfc_show_expr (i->sequential);
1256 }
1257
1258 if (i->direct)
1259 {
1260 gfc_status (" DIRECT=");
1261 gfc_show_expr (i->direct);
1262 }
1263 if (i->form)
1264 {
1265 gfc_status (" FORM=");
1266 gfc_show_expr (i->form);
1267 }
1268 if (i->formatted)
1269 {
1270 gfc_status (" FORMATTED");
1271 gfc_show_expr (i->formatted);
1272 }
1273 if (i->unformatted)
1274 {
1275 gfc_status (" UNFORMATTED=");
1276 gfc_show_expr (i->unformatted);
1277 }
1278 if (i->recl)
1279 {
1280 gfc_status (" RECL=");
1281 gfc_show_expr (i->recl);
1282 }
1283 if (i->nextrec)
1284 {
1285 gfc_status (" NEXTREC=");
1286 gfc_show_expr (i->nextrec);
1287 }
1288 if (i->blank)
1289 {
1290 gfc_status (" BLANK=");
1291 gfc_show_expr (i->blank);
1292 }
1293 if (i->position)
1294 {
1295 gfc_status (" POSITION=");
1296 gfc_show_expr (i->position);
1297 }
1298 if (i->action)
1299 {
1300 gfc_status (" ACTION=");
1301 gfc_show_expr (i->action);
1302 }
1303 if (i->read)
1304 {
1305 gfc_status (" READ=");
1306 gfc_show_expr (i->read);
1307 }
1308 if (i->write)
1309 {
1310 gfc_status (" WRITE=");
1311 gfc_show_expr (i->write);
1312 }
1313 if (i->readwrite)
1314 {
1315 gfc_status (" READWRITE=");
1316 gfc_show_expr (i->readwrite);
1317 }
1318 if (i->delim)
1319 {
1320 gfc_status (" DELIM=");
1321 gfc_show_expr (i->delim);
1322 }
1323 if (i->pad)
1324 {
1325 gfc_status (" PAD=");
1326 gfc_show_expr (i->pad);
1327 }
1328
1329 if (i->err != NULL)
1330 gfc_status (" ERR=%d", i->err->value);
1331 break;
1332
1333 case EXEC_IOLENGTH:
1334 gfc_status ("IOLENGTH ");
1335 gfc_show_expr (c->expr);
1336 break;
1337
1338 case EXEC_READ:
1339 gfc_status ("READ");
1340 goto show_dt;
1341
1342 case EXEC_WRITE:
1343 gfc_status ("WRITE");
1344
1345 show_dt:
1346 dt = c->ext.dt;
1347 if (dt->io_unit)
1348 {
1349 gfc_status (" UNIT=");
1350 gfc_show_expr (dt->io_unit);
1351 }
1352
1353 if (dt->format_expr)
1354 {
1355 gfc_status (" FMT=");
1356 gfc_show_expr (dt->format_expr);
1357 }
1358
1359 if (dt->format_label != NULL)
1360 gfc_status (" FMT=%d", dt->format_label->value);
1361 if (dt->namelist)
1362 gfc_status (" NML=%s", dt->namelist->name);
1363 if (dt->iostat)
1364 {
1365 gfc_status (" IOSTAT=");
1366 gfc_show_expr (dt->iostat);
1367 }
1368 if (dt->size)
1369 {
1370 gfc_status (" SIZE=");
1371 gfc_show_expr (dt->size);
1372 }
1373 if (dt->rec)
1374 {
1375 gfc_status (" REC=");
1376 gfc_show_expr (dt->rec);
1377 }
1378 if (dt->advance)
1379 {
1380 gfc_status (" ADVANCE=");
1381 gfc_show_expr (dt->advance);
1382 }
1383
1384 break;
1385
1386 case EXEC_TRANSFER:
1387 gfc_status ("TRANSFER ");
1388 gfc_show_expr (c->expr);
1389 break;
1390
1391 case EXEC_DT_END:
1392 gfc_status ("DT_END");
1393 dt = c->ext.dt;
1394
1395 if (dt->err != NULL)
1396 gfc_status (" ERR=%d", dt->err->value);
1397 if (dt->end != NULL)
1398 gfc_status (" END=%d", dt->end->value);
1399 if (dt->eor != NULL)
1400 gfc_status (" EOR=%d", dt->eor->value);
1401 break;
1402
1403 default:
1404 gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1405 }
1406
1407 gfc_status_char ('\n');
1408}
1409
1410
1854117e
PB		 1411/* Show and equivalence chain. */
1412
1413static void
1414gfc_show_equiv (gfc_equiv *eq)
1415{
1416 show_indent ();
1417 gfc_status ("Equivalence: ");
1418 while (eq)
1419 {
1420 gfc_show_expr (eq->expr);
1421 eq = eq->eq;
1422 if (eq)
1423 gfc_status (", ");
1424 }
1425}
1426
1427
6de9cd9a
DN		 1428/* Show a freakin' whole namespace. */
1429
1430void
1431gfc_show_namespace (gfc_namespace * ns)
1432{
1433 gfc_interface *intr;
1434 gfc_namespace *save;
1435 gfc_intrinsic_op op;
1854117e 1436 gfc_equiv *eq;
6de9cd9a
DN		 1437 int i;
1438
1439 save = gfc_current_ns;
1440 show_level++;
1441
1442 show_indent ();
1443 gfc_status ("Namespace:");
1444
1445 if (ns != NULL)
1446 {
1447 i = 0;
1448 do
1449 {
1450 int l = i;
1451 while (i < GFC_LETTERS - 1
1452 && gfc_compare_types(&ns->default_type[i+1],
1453 &ns->default_type[l]))
1454 i++;
1455
1456 if (i > l)
1457 gfc_status(" %c-%c: ", l+'A', i+'A');
1458 else
1459 gfc_status(" %c: ", l+'A');
1460
1461 gfc_show_typespec(&ns->default_type[l]);
1462 i++;
1463 } while (i < GFC_LETTERS);
1464
1465 if (ns->proc_name != NULL)
1466 {
1467 show_indent ();
1468 gfc_status ("procedure name = %s", ns->proc_name->name);
1469 }
1470
1471 gfc_current_ns = ns;
fbc9b453
TS		 1472 gfc_traverse_symtree (ns->common_root, show_common);
1473
9056bd70 1474 gfc_traverse_symtree (ns->sym_root, show_symtree);
6de9cd9a
DN		 1475
1476 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1477 {
1478 /* User operator interfaces */
1479 intr = ns->operator[op];
1480 if (intr == NULL)
1481 continue;
1482
1483 show_indent ();
1484 gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
1485
1486 for (; intr; intr = intr->next)
1487 gfc_status (" %s", intr->sym->name);
1488 }
1489
1490 if (ns->uop_root != NULL)
1491 {
1492 show_indent ();
1493 gfc_status ("User operators:\n");
1494 gfc_traverse_user_op (ns, show_uop);
1495 }
1496 }
1854117e
PB		 1497
1498 for (eq = ns->equiv; eq; eq = eq->next)
1499 gfc_show_equiv (eq);
6de9cd9a
DN		 1500
1501 gfc_status_char ('\n');
1502 gfc_status_char ('\n');
1503
1504 gfc_show_code (0, ns->code);
1505
1506 for (ns = ns->contained; ns; ns = ns->sibling)
1507 {
1508 show_indent ();
1509 gfc_status ("CONTAINS\n");
1510 gfc_show_namespace (ns);
1511 }
1512
1513 show_level--;
1514 gfc_status_char ('\n');
1515 gfc_current_ns = save;
1516}
Mirror of https://gcc.gnu.org/git/gcc.git