]> gcc.gnu.org Git - gcc.git/blame - gcc/fortran/dump-parse-tree.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Unrevert previously reversed patch, adding this patch:
[gcc.git] / gcc / fortran / dump-parse-tree.c
CommitLineData
6de9cd9a 1/* Parse tree dumper
9fc4d79b 2 Copyright (C) 2003, 2004 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
TS		 18along with GCC; see the file COPYING. If not, write to the Free
19Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2002111-1307, 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
125/* Show an gfc_array_spec array specification structure. */
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
168/* Show an gfc_array_ref array reference structure. */
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:
412 gfc_status ("%s", p->symtree->n.sym->name);
413 gfc_show_ref (p->ref);
414 break;
415
416 case EXPR_OP:
417 gfc_status ("(");
58b03ab2 418 switch (p->value.op.operator)
6de9cd9a
DN		 419 {
420 case INTRINSIC_UPLUS:
421 gfc_status ("U+ ");
422 break;
423 case INTRINSIC_UMINUS:
424 gfc_status ("U- ");
425 break;
426 case INTRINSIC_PLUS:
427 gfc_status ("+ ");
428 break;
429 case INTRINSIC_MINUS:
430 gfc_status ("- ");
431 break;
432 case INTRINSIC_TIMES:
433 gfc_status ("* ");
434 break;
435 case INTRINSIC_DIVIDE:
436 gfc_status ("/ ");
437 break;
438 case INTRINSIC_POWER:
439 gfc_status ("** ");
440 break;
441 case INTRINSIC_CONCAT:
442 gfc_status ("// ");
443 break;
444 case INTRINSIC_AND:
445 gfc_status ("AND ");
446 break;
447 case INTRINSIC_OR:
448 gfc_status ("OR ");
449 break;
450 case INTRINSIC_EQV:
451 gfc_status ("EQV ");
452 break;
453 case INTRINSIC_NEQV:
454 gfc_status ("NEQV ");
455 break;
456 case INTRINSIC_EQ:
457 gfc_status ("= ");
458 break;
459 case INTRINSIC_NE:
460 gfc_status ("<> ");
461 break;
462 case INTRINSIC_GT:
463 gfc_status ("> ");
464 break;
465 case INTRINSIC_GE:
466 gfc_status (">= ");
467 break;
468 case INTRINSIC_LT:
469 gfc_status ("< ");
470 break;
471 case INTRINSIC_LE:
472 gfc_status ("<= ");
473 break;
474 case INTRINSIC_NOT:
475 gfc_status ("NOT ");
476 break;
477
478 default:
479 gfc_internal_error
480 ("gfc_show_expr(): Bad intrinsic in expression!");
481 }
482
58b03ab2 483 gfc_show_expr (p->value.op.op1);
6de9cd9a 484
58b03ab2 485 if (p->value.op.op2)
6de9cd9a
DN		 486 {
487 gfc_status (" ");
58b03ab2 488 gfc_show_expr (p->value.op.op2);
6de9cd9a
DN		 489 }
490
491 gfc_status (")");
492 break;
493
494 case EXPR_FUNCTION:
495 if (p->value.function.name == NULL)
496 {
497 gfc_status ("%s[", p->symtree->n.sym->name);
498 gfc_show_actual_arglist (p->value.function.actual);
499 gfc_status_char (']');
500 }
501 else
502 {
503 gfc_status ("%s[[", p->value.function.name);
504 gfc_show_actual_arglist (p->value.function.actual);
505 gfc_status_char (']');
506 gfc_status_char (']');
507 }
508
509 break;
510
511 default:
512 gfc_internal_error ("gfc_show_expr(): Don't know how to show expr");
513 }
514}
515
516
517/* Show symbol attributes. The flavor and intent are followed by
518 whatever single bit attributes are present. */
519
520static void
521gfc_show_attr (symbol_attribute * attr)
522{
523
524 gfc_status ("(%s %s %s %s", gfc_code2string (flavors, attr->flavor),
525 gfc_intent_string (attr->intent),
526 gfc_code2string (access_types, attr->access),
527 gfc_code2string (procedures, attr->proc));
528
529 if (attr->allocatable)
530 gfc_status (" ALLOCATABLE");
531 if (attr->dimension)
532 gfc_status (" DIMENSION");
533 if (attr->external)
534 gfc_status (" EXTERNAL");
535 if (attr->intrinsic)
536 gfc_status (" INTRINSIC");
537 if (attr->optional)
538 gfc_status (" OPTIONAL");
539 if (attr->pointer)
540 gfc_status (" POINTER");
541 if (attr->save)
542 gfc_status (" SAVE");
543 if (attr->target)
544 gfc_status (" TARGET");
545 if (attr->dummy)
546 gfc_status (" DUMMY");
6de9cd9a
DN		 547 if (attr->result)
548 gfc_status (" RESULT");
549 if (attr->entry)
550 gfc_status (" ENTRY");
551
552 if (attr->data)
553 gfc_status (" DATA");
554 if (attr->use_assoc)
555 gfc_status (" USE-ASSOC");
556 if (attr->in_namelist)
557 gfc_status (" IN-NAMELIST");
558 if (attr->in_common)
559 gfc_status (" IN-COMMON");
6de9cd9a
DN		 560
561 if (attr->function)
562 gfc_status (" FUNCTION");
563 if (attr->subroutine)
564 gfc_status (" SUBROUTINE");
565 if (attr->implicit_type)
566 gfc_status (" IMPLICIT-TYPE");
567
568 if (attr->sequence)
569 gfc_status (" SEQUENCE");
570 if (attr->elemental)
571 gfc_status (" ELEMENTAL");
572 if (attr->pure)
573 gfc_status (" PURE");
574 if (attr->recursive)
575 gfc_status (" RECURSIVE");
576
577 gfc_status (")");
578}
579
580
581/* Show components of a derived type. */
582
583static void
584gfc_show_components (gfc_symbol * sym)
585{
586 gfc_component *c;
587
588 for (c = sym->components; c; c = c->next)
589 {
590 gfc_status ("(%s ", c->name);
591 gfc_show_typespec (&c->ts);
592 if (c->pointer)
593 gfc_status (" POINTER");
594 if (c->dimension)
595 gfc_status (" DIMENSION");
596 gfc_status_char (' ');
597 gfc_show_array_spec (c->as);
598 gfc_status (")");
599 if (c->next != NULL)
600 gfc_status_char (' ');
601 }
602}
603
604
605/* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
606 show the interface. Information needed to reconstruct the list of
607 specific interfaces associated with a generic symbol is done within
608 that symbol. */
609
610static void
611gfc_show_symbol (gfc_symbol * sym)
612{
613 gfc_formal_arglist *formal;
614 gfc_interface *intr;
6de9cd9a
DN		 615
616 if (sym == NULL)
617 return;
618
619 show_indent ();
620
621 gfc_status ("symbol %s ", sym->name);
622 gfc_show_typespec (&sym->ts);
623 gfc_show_attr (&sym->attr);
624
625 if (sym->value)
626 {
627 show_indent ();
628 gfc_status ("value: ");
629 gfc_show_expr (sym->value);
630 }
631
632 if (sym->as)
633 {
634 show_indent ();
635 gfc_status ("Array spec:");
636 gfc_show_array_spec (sym->as);
637 }
638
639 if (sym->generic)
640 {
641 show_indent ();
642 gfc_status ("Generic interfaces:");
643 for (intr = sym->generic; intr; intr = intr->next)
644 gfc_status (" %s", intr->sym->name);
645 }
646
6de9cd9a
DN		 647 if (sym->result)
648 {
649 show_indent ();
650 gfc_status ("result: %s", sym->result->name);
651 }
652
653 if (sym->components)
654 {
655 show_indent ();
656 gfc_status ("components: ");
657 gfc_show_components (sym);
658 }
659
660 if (sym->formal)
661 {
662 show_indent ();
663 gfc_status ("Formal arglist:");
664
665 for (formal = sym->formal; formal; formal = formal->next)
666 gfc_status (" %s", formal->sym->name);
667 }
668
669 if (sym->formal_ns)
670 {
671 show_indent ();
672 gfc_status ("Formal namespace");
673 gfc_show_namespace (sym->formal_ns);
674 }
675
676 gfc_status_char ('\n');
677}
678
679
680/* Show a user-defined operator. Just prints an operator
681 and the name of the associated subroutine, really. */
682static void
683show_uop (gfc_user_op * uop)
684{
685 gfc_interface *intr;
686
687 show_indent ();
688 gfc_status ("%s:", uop->name);
689
690 for (intr = uop->operator; intr; intr = intr->next)
691 gfc_status (" %s", intr->sym->name);
692}
693
694
695/* Workhorse function for traversing the user operator symtree. */
696
697static void
698traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
699{
700
701 if (st == NULL)
702 return;
703
704 (*func) (st->n.uop);
705
706 traverse_uop (st->left, func);
707 traverse_uop (st->right, func);
708}
709
710
711/* Traverse the tree of user operator nodes. */
712
713void
714gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
715{
716
717 traverse_uop (ns->uop_root, func);
718}
719
720
fbc9b453
TS		 721/* Function to display a common block. */
722
723static void
724show_common (gfc_symtree * st)
725{
726 gfc_symbol *s;
727
728 show_indent ();
729 gfc_status ("common: /%s/ ", st->name);
730
731 s = st->n.common->head;
732 while (s)
733 {
734 gfc_status ("%s", s->name);
735 s = s->common_next;
736 if (s)
737 gfc_status (", ");
738 }
739 gfc_status_char ('\n');
740}
741
6de9cd9a
DN		 742/* Worker function to display the symbol tree. */
743
744static void
745show_symtree (gfc_symtree * st)
746{
747
748 show_indent ();
749 gfc_status ("symtree: %s Ambig %d", st->name, st->ambiguous);
750
751 if (st->n.sym->ns != gfc_current_ns)
752 gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
753 else
754 gfc_show_symbol (st->n.sym);
755}
756
757
758/******************* Show gfc_code structures **************/
759
760
761
762static void gfc_show_code_node (int level, gfc_code * c);
763
764/* Show a list of code structures. Mutually recursive with
765 gfc_show_code_node(). */
766
767static void
768gfc_show_code (int level, gfc_code * c)
769{
770
771 for (; c; c = c->next)
772 gfc_show_code_node (level, c);
773}
774
775
776/* Show a single code node and everything underneath it if necessary. */
777
778static void
779gfc_show_code_node (int level, gfc_code * c)
780{
781 gfc_forall_iterator *fa;
782 gfc_open *open;
783 gfc_case *cp;
784 gfc_alloc *a;
785 gfc_code *d;
786 gfc_close *close;
787 gfc_filepos *fp;
788 gfc_inquire *i;
789 gfc_dt *dt;
790
791 code_indent (level, c->here);
792
793 switch (c->op)
794 {
795 case EXEC_NOP:
796 gfc_status ("NOP");
797 break;
798
799 case EXEC_CONTINUE:
800 gfc_status ("CONTINUE");
801 break;
802
3d79abbd
PB		 803 case EXEC_ENTRY:
804 gfc_status ("ENTRY %s", c->ext.entry->sym->name);
805 break;
806
6de9cd9a
DN		 807 case EXEC_ASSIGN:
808 gfc_status ("ASSIGN ");
809 gfc_show_expr (c->expr);
810 gfc_status_char (' ');
811 gfc_show_expr (c->expr2);
812 break;
3d79abbd 813
6de9cd9a
DN		 814 case EXEC_LABEL_ASSIGN:
815 gfc_status ("LABEL ASSIGN ");
816 gfc_show_expr (c->expr);
817 gfc_status (" %d", c->label->value);
818 break;
819
820 case EXEC_POINTER_ASSIGN:
821 gfc_status ("POINTER ASSIGN ");
822 gfc_show_expr (c->expr);
823 gfc_status_char (' ');
824 gfc_show_expr (c->expr2);
825 break;
826
827 case EXEC_GOTO:
828 gfc_status ("GOTO ");
829 if (c->label)
830 gfc_status ("%d", c->label->value);
831 else
832 {
833 gfc_show_expr (c->expr);
834 d = c->block;
835 if (d != NULL)
836 {
837 gfc_status (", (");
838 for (; d; d = d ->block)
839 {
840 code_indent (level, d->label);
841 if (d->block != NULL)
842 gfc_status_char (',');
843 else
844 gfc_status_char (')');
845 }
846 }
847 }
848 break;
849
850 case EXEC_CALL:
851 gfc_status ("CALL %s ", c->resolved_sym->name);
852 gfc_show_actual_arglist (c->ext.actual);
853 break;
854
855 case EXEC_RETURN:
856 gfc_status ("RETURN ");
857 if (c->expr)
858 gfc_show_expr (c->expr);
859 break;
860
861 case EXEC_PAUSE:
862 gfc_status ("PAUSE ");
863
864 if (c->expr != NULL)
865 gfc_show_expr (c->expr);
866 else
867 gfc_status ("%d", c->ext.stop_code);
868
869 break;
870
871 case EXEC_STOP:
872 gfc_status ("STOP ");
873
874 if (c->expr != NULL)
875 gfc_show_expr (c->expr);
876 else
877 gfc_status ("%d", c->ext.stop_code);
878
879 break;
880
881 case EXEC_ARITHMETIC_IF:
882 gfc_status ("IF ");
883 gfc_show_expr (c->expr);
884 gfc_status (" %d, %d, %d",
885 c->label->value, c->label2->value, c->label3->value);
886 break;
887
888 case EXEC_IF:
889 d = c->block;
890 gfc_status ("IF ");
891 gfc_show_expr (d->expr);
892 gfc_status_char ('\n');
893 gfc_show_code (level + 1, d->next);
894
895 d = d->block;
896 for (; d; d = d->block)
897 {
898 code_indent (level, 0);
899
900 if (d->expr == NULL)
901 gfc_status ("ELSE\n");
902 else
903 {
904 gfc_status ("ELSE IF ");
905 gfc_show_expr (d->expr);
906 gfc_status_char ('\n');
907 }
908
909 gfc_show_code (level + 1, d->next);
910 }
911
912 code_indent (level, c->label);
913
914 gfc_status ("ENDIF");
915 break;
916
917 case EXEC_SELECT:
918 d = c->block;
919 gfc_status ("SELECT CASE ");
920 gfc_show_expr (c->expr);
921 gfc_status_char ('\n');
922
923 for (; d; d = d->block)
924 {
925 code_indent (level, 0);
926
927 gfc_status ("CASE ");
928 for (cp = d->ext.case_list; cp; cp = cp->next)
929 {
930 gfc_status_char ('(');
931 gfc_show_expr (cp->low);
932 gfc_status_char (' ');
933 gfc_show_expr (cp->high);
934 gfc_status_char (')');
935 gfc_status_char (' ');
936 }
937 gfc_status_char ('\n');
938
939 gfc_show_code (level + 1, d->next);
940 }
941
942 code_indent (level, c->label);
943 gfc_status ("END SELECT");
944 break;
945
946 case EXEC_WHERE:
947 gfc_status ("WHERE ");
948
949 d = c->block;
950 gfc_show_expr (d->expr);
951 gfc_status_char ('\n');
952
953 gfc_show_code (level + 1, d->next);
954
955 for (d = d->block; d; d = d->block)
956 {
957 code_indent (level, 0);
958 gfc_status ("ELSE WHERE ");
959 gfc_show_expr (d->expr);
960 gfc_status_char ('\n');
961 gfc_show_code (level + 1, d->next);
962 }
963
964 code_indent (level, 0);
965 gfc_status ("END WHERE");
966 break;
967
968
969 case EXEC_FORALL:
970 gfc_status ("FORALL ");
971 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
972 {
973 gfc_show_expr (fa->var);
974 gfc_status_char (' ');
975 gfc_show_expr (fa->start);
976 gfc_status_char (':');
977 gfc_show_expr (fa->end);
978 gfc_status_char (':');
979 gfc_show_expr (fa->stride);
980
981 if (fa->next != NULL)
982 gfc_status_char (',');
983 }
984
985 if (c->expr != NULL)
986 {
987 gfc_status_char (',');
988 gfc_show_expr (c->expr);
989 }
990 gfc_status_char ('\n');
991
992 gfc_show_code (level + 1, c->block->next);
993
994 code_indent (level, 0);
995 gfc_status ("END FORALL");
996 break;
997
998 case EXEC_DO:
999 gfc_status ("DO ");
1000
1001 gfc_show_expr (c->ext.iterator->var);
1002 gfc_status_char ('=');
1003 gfc_show_expr (c->ext.iterator->start);
1004 gfc_status_char (' ');
1005 gfc_show_expr (c->ext.iterator->end);
1006 gfc_status_char (' ');
1007 gfc_show_expr (c->ext.iterator->step);
1008 gfc_status_char ('\n');
1009
1010 gfc_show_code (level + 1, c->block->next);
1011
1012 code_indent (level, 0);
1013 gfc_status ("END DO");
1014 break;
1015
1016 case EXEC_DO_WHILE:
1017 gfc_status ("DO WHILE ");
1018 gfc_show_expr (c->expr);
1019 gfc_status_char ('\n');
1020
1021 gfc_show_code (level + 1, c->block->next);
1022
1023 code_indent (level, c->label);
1024 gfc_status ("END DO");
1025 break;
1026
1027 case EXEC_CYCLE:
1028 gfc_status ("CYCLE");
1029 if (c->symtree)
1030 gfc_status (" %s", c->symtree->n.sym->name);
1031 break;
1032
1033 case EXEC_EXIT:
1034 gfc_status ("EXIT");
1035 if (c->symtree)
1036 gfc_status (" %s", c->symtree->n.sym->name);
1037 break;
1038
1039 case EXEC_ALLOCATE:
1040 gfc_status ("ALLOCATE ");
1041 if (c->expr)
1042 {
1043 gfc_status (" STAT=");
1044 gfc_show_expr (c->expr);
1045 }
1046
1047 for (a = c->ext.alloc_list; a; a = a->next)
1048 {
1049 gfc_status_char (' ');
1050 gfc_show_expr (a->expr);
1051 }
1052
1053 break;
1054
1055 case EXEC_DEALLOCATE:
1056 gfc_status ("DEALLOCATE ");
1057 if (c->expr)
1058 {
1059 gfc_status (" STAT=");
1060 gfc_show_expr (c->expr);
1061 }
1062
1063 for (a = c->ext.alloc_list; a; a = a->next)
1064 {
1065 gfc_status_char (' ');
1066 gfc_show_expr (a->expr);
1067 }
1068
1069 break;
1070
1071 case EXEC_OPEN:
1072 gfc_status ("OPEN");
1073 open = c->ext.open;
1074
1075 if (open->unit)
1076 {
1077 gfc_status (" UNIT=");
1078 gfc_show_expr (open->unit);
1079 }
1080 if (open->iostat)
1081 {
1082 gfc_status (" IOSTAT=");
1083 gfc_show_expr (open->iostat);
1084 }
1085 if (open->file)
1086 {
1087 gfc_status (" FILE=");
1088 gfc_show_expr (open->file);
1089 }
1090 if (open->status)
1091 {
1092 gfc_status (" STATUS=");
1093 gfc_show_expr (open->status);
1094 }
1095 if (open->access)
1096 {
1097 gfc_status (" ACCESS=");
1098 gfc_show_expr (open->access);
1099 }
1100 if (open->form)
1101 {
1102 gfc_status (" FORM=");
1103 gfc_show_expr (open->form);
1104 }
1105 if (open->recl)
1106 {
1107 gfc_status (" RECL=");
1108 gfc_show_expr (open->recl);
1109 }
1110 if (open->blank)
1111 {
1112 gfc_status (" BLANK=");
1113 gfc_show_expr (open->blank);
1114 }
1115 if (open->position)
1116 {
1117 gfc_status (" POSITION=");
1118 gfc_show_expr (open->position);
1119 }
1120 if (open->action)
1121 {
1122 gfc_status (" ACTION=");
1123 gfc_show_expr (open->action);
1124 }
1125 if (open->delim)
1126 {
1127 gfc_status (" DELIM=");
1128 gfc_show_expr (open->delim);
1129 }
1130 if (open->pad)
1131 {
1132 gfc_status (" PAD=");
1133 gfc_show_expr (open->pad);
1134 }
1135 if (open->err != NULL)
1136 gfc_status (" ERR=%d", open->err->value);
1137
1138 break;
1139
1140 case EXEC_CLOSE:
1141 gfc_status ("CLOSE");
1142 close = c->ext.close;
1143
1144 if (close->unit)
1145 {
1146 gfc_status (" UNIT=");
1147 gfc_show_expr (close->unit);
1148 }
1149 if (close->iostat)
1150 {
1151 gfc_status (" IOSTAT=");
1152 gfc_show_expr (close->iostat);
1153 }
1154 if (close->status)
1155 {
1156 gfc_status (" STATUS=");
1157 gfc_show_expr (close->status);
1158 }
1159 if (close->err != NULL)
1160 gfc_status (" ERR=%d", close->err->value);
1161 break;
1162
1163 case EXEC_BACKSPACE:
1164 gfc_status ("BACKSPACE");
1165 goto show_filepos;
1166
1167 case EXEC_ENDFILE:
1168 gfc_status ("ENDFILE");
1169 goto show_filepos;
1170
1171 case EXEC_REWIND:
1172 gfc_status ("REWIND");
1173
1174 show_filepos:
1175 fp = c->ext.filepos;
1176
1177 if (fp->unit)
1178 {
1179 gfc_status (" UNIT=");
1180 gfc_show_expr (fp->unit);
1181 }
1182 if (fp->iostat)
1183 {
1184 gfc_status (" IOSTAT=");
1185 gfc_show_expr (fp->iostat);
1186 }
1187 if (fp->err != NULL)
1188 gfc_status (" ERR=%d", fp->err->value);
1189 break;
1190
1191 case EXEC_INQUIRE:
1192 gfc_status ("INQUIRE");
1193 i = c->ext.inquire;
1194
1195 if (i->unit)
1196 {
1197 gfc_status (" UNIT=");
1198 gfc_show_expr (i->unit);
1199 }
1200 if (i->file)
1201 {
1202 gfc_status (" FILE=");
1203 gfc_show_expr (i->file);
1204 }
1205
1206 if (i->iostat)
1207 {
1208 gfc_status (" IOSTAT=");
1209 gfc_show_expr (i->iostat);
1210 }
1211 if (i->exist)
1212 {
1213 gfc_status (" EXIST=");
1214 gfc_show_expr (i->exist);
1215 }
1216 if (i->opened)
1217 {
1218 gfc_status (" OPENED=");
1219 gfc_show_expr (i->opened);
1220 }
1221 if (i->number)
1222 {
1223 gfc_status (" NUMBER=");
1224 gfc_show_expr (i->number);
1225 }
1226 if (i->named)
1227 {
1228 gfc_status (" NAMED=");
1229 gfc_show_expr (i->named);
1230 }
1231 if (i->name)
1232 {
1233 gfc_status (" NAME=");
1234 gfc_show_expr (i->name);
1235 }
1236 if (i->access)
1237 {
1238 gfc_status (" ACCESS=");
1239 gfc_show_expr (i->access);
1240 }
1241 if (i->sequential)
1242 {
1243 gfc_status (" SEQUENTIAL=");
1244 gfc_show_expr (i->sequential);
1245 }
1246
1247 if (i->direct)
1248 {
1249 gfc_status (" DIRECT=");
1250 gfc_show_expr (i->direct);
1251 }
1252 if (i->form)
1253 {
1254 gfc_status (" FORM=");
1255 gfc_show_expr (i->form);
1256 }
1257 if (i->formatted)
1258 {
1259 gfc_status (" FORMATTED");
1260 gfc_show_expr (i->formatted);
1261 }
1262 if (i->unformatted)
1263 {
1264 gfc_status (" UNFORMATTED=");
1265 gfc_show_expr (i->unformatted);
1266 }
1267 if (i->recl)
1268 {
1269 gfc_status (" RECL=");
1270 gfc_show_expr (i->recl);
1271 }
1272 if (i->nextrec)
1273 {
1274 gfc_status (" NEXTREC=");
1275 gfc_show_expr (i->nextrec);
1276 }
1277 if (i->blank)
1278 {
1279 gfc_status (" BLANK=");
1280 gfc_show_expr (i->blank);
1281 }
1282 if (i->position)
1283 {
1284 gfc_status (" POSITION=");
1285 gfc_show_expr (i->position);
1286 }
1287 if (i->action)
1288 {
1289 gfc_status (" ACTION=");
1290 gfc_show_expr (i->action);
1291 }
1292 if (i->read)
1293 {
1294 gfc_status (" READ=");
1295 gfc_show_expr (i->read);
1296 }
1297 if (i->write)
1298 {
1299 gfc_status (" WRITE=");
1300 gfc_show_expr (i->write);
1301 }
1302 if (i->readwrite)
1303 {
1304 gfc_status (" READWRITE=");
1305 gfc_show_expr (i->readwrite);
1306 }
1307 if (i->delim)
1308 {
1309 gfc_status (" DELIM=");
1310 gfc_show_expr (i->delim);
1311 }
1312 if (i->pad)
1313 {
1314 gfc_status (" PAD=");
1315 gfc_show_expr (i->pad);
1316 }
1317
1318 if (i->err != NULL)
1319 gfc_status (" ERR=%d", i->err->value);
1320 break;
1321
1322 case EXEC_IOLENGTH:
1323 gfc_status ("IOLENGTH ");
1324 gfc_show_expr (c->expr);
1325 break;
1326
1327 case EXEC_READ:
1328 gfc_status ("READ");
1329 goto show_dt;
1330
1331 case EXEC_WRITE:
1332 gfc_status ("WRITE");
1333
1334 show_dt:
1335 dt = c->ext.dt;
1336 if (dt->io_unit)
1337 {
1338 gfc_status (" UNIT=");
1339 gfc_show_expr (dt->io_unit);
1340 }
1341
1342 if (dt->format_expr)
1343 {
1344 gfc_status (" FMT=");
1345 gfc_show_expr (dt->format_expr);
1346 }
1347
1348 if (dt->format_label != NULL)
1349 gfc_status (" FMT=%d", dt->format_label->value);
1350 if (dt->namelist)
1351 gfc_status (" NML=%s", dt->namelist->name);
1352 if (dt->iostat)
1353 {
1354 gfc_status (" IOSTAT=");
1355 gfc_show_expr (dt->iostat);
1356 }
1357 if (dt->size)
1358 {
1359 gfc_status (" SIZE=");
1360 gfc_show_expr (dt->size);
1361 }
1362 if (dt->rec)
1363 {
1364 gfc_status (" REC=");
1365 gfc_show_expr (dt->rec);
1366 }
1367 if (dt->advance)
1368 {
1369 gfc_status (" ADVANCE=");
1370 gfc_show_expr (dt->advance);
1371 }
1372
1373 break;
1374
1375 case EXEC_TRANSFER:
1376 gfc_status ("TRANSFER ");
1377 gfc_show_expr (c->expr);
1378 break;
1379
1380 case EXEC_DT_END:
1381 gfc_status ("DT_END");
1382 dt = c->ext.dt;
1383
1384 if (dt->err != NULL)
1385 gfc_status (" ERR=%d", dt->err->value);
1386 if (dt->end != NULL)
1387 gfc_status (" END=%d", dt->end->value);
1388 if (dt->eor != NULL)
1389 gfc_status (" EOR=%d", dt->eor->value);
1390 break;
1391
1392 default:
1393 gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1394 }
1395
1396 gfc_status_char ('\n');
1397}
1398
1399
1854117e
PB		 1400/* Show and equivalence chain. */
1401
1402static void
1403gfc_show_equiv (gfc_equiv *eq)
1404{
1405 show_indent ();
1406 gfc_status ("Equivalence: ");
1407 while (eq)
1408 {
1409 gfc_show_expr (eq->expr);
1410 eq = eq->eq;
1411 if (eq)
1412 gfc_status (", ");
1413 }
1414}
1415
1416
6de9cd9a
DN		 1417/* Show a freakin' whole namespace. */
1418
1419void
1420gfc_show_namespace (gfc_namespace * ns)
1421{
1422 gfc_interface *intr;
1423 gfc_namespace *save;
1424 gfc_intrinsic_op op;
1854117e 1425 gfc_equiv *eq;
6de9cd9a
DN		 1426 int i;
1427
1428 save = gfc_current_ns;
1429 show_level++;
1430
1431 show_indent ();
1432 gfc_status ("Namespace:");
1433
1434 if (ns != NULL)
1435 {
1436 i = 0;
1437 do
1438 {
1439 int l = i;
1440 while (i < GFC_LETTERS - 1
1441 && gfc_compare_types(&ns->default_type[i+1],
1442 &ns->default_type[l]))
1443 i++;
1444
1445 if (i > l)
1446 gfc_status(" %c-%c: ", l+'A', i+'A');
1447 else
1448 gfc_status(" %c: ", l+'A');
1449
1450 gfc_show_typespec(&ns->default_type[l]);
1451 i++;
1452 } while (i < GFC_LETTERS);
1453
1454 if (ns->proc_name != NULL)
1455 {
1456 show_indent ();
1457 gfc_status ("procedure name = %s", ns->proc_name->name);
1458 }
1459
1460 gfc_current_ns = ns;
fbc9b453
TS		 1461 gfc_traverse_symtree (ns->common_root, show_common);
1462
9056bd70 1463 gfc_traverse_symtree (ns->sym_root, show_symtree);
6de9cd9a
DN		 1464
1465 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1466 {
1467 /* User operator interfaces */
1468 intr = ns->operator[op];
1469 if (intr == NULL)
1470 continue;
1471
1472 show_indent ();
1473 gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
1474
1475 for (; intr; intr = intr->next)
1476 gfc_status (" %s", intr->sym->name);
1477 }
1478
1479 if (ns->uop_root != NULL)
1480 {
1481 show_indent ();
1482 gfc_status ("User operators:\n");
1483 gfc_traverse_user_op (ns, show_uop);
1484 }
1485 }
1854117e
PB		 1486
1487 for (eq = ns->equiv; eq; eq = eq->next)
1488 gfc_show_equiv (eq);
6de9cd9a
DN		 1489
1490 gfc_status_char ('\n');
1491 gfc_status_char ('\n');
1492
1493 gfc_show_code (0, ns->code);
1494
1495 for (ns = ns->contained; ns; ns = ns->sibling)
1496 {
1497 show_indent ();
1498 gfc_status ("CONTAINS\n");
1499 gfc_show_namespace (ns);
1500 }
1501
1502 show_level--;
1503 gfc_status_char ('\n');
1504 gfc_current_ns = save;
1505}
GNU Compiler Collection
This page took 0.473968 seconds and 5 git commands to generate.