?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
*sigh* checked in the wrong patch
[official-gcc.git] / gcc / fortran / dump-parse-tree.c
blob2d708f7efed41f74c4518c19243a552ad134b741
1 /* Parse tree dumper
2 Copyright (C) 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Steven Bosscher
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
20 02110-1301, USA. */
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. */
38 static int show_level = 0;
39
40
41 /* Forward declaration because this one needs all, and all need
42 this one. */
43 static void gfc_show_expr (gfc_expr *);
44
45 /* Do indentation for a specific level. */
46
47 static inline void
48 code_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. */
64 static inline void
65 show_indent (void)
66 {
67 gfc_status ("\n");
68 code_indent (show_level, NULL);
69 }
70
71
72 /* Show type-specific information. */
73 static void
74 gfc_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
100 static void
101 gfc_show_actual_arglist (gfc_actual_arglist * a)
102 {
103
104 gfc_status ("(");
105
106 for (; a; a = a->next)
107 {
108 gfc_status_char ('(');
109 if (a->name != NULL)
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 a gfc_array_spec array specification structure. */
126
127 static void
128 gfc_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 a gfc_array_ref array reference structure. */
169
170 static void
171 gfc_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 {
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
193 if (ar->start[i] != NULL)
194 gfc_show_expr (ar->start[i]);
195
196 if (ar->dimen_type[i] == DIMEN_RANGE)
197 {
198 gfc_status_char (':');
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 }
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
238 static void
239 gfc_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
269 static void
270 gfc_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
302 static void
303 gfc_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
354 if (p->ts.kind != gfc_default_integer_kind)
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:
366 mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
367 if (p->ts.kind != gfc_default_real_kind)
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
391 mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
392 if (p->ts.kind != gfc_default_complex_kind)
393 gfc_status ("_%d", p->ts.kind);
394
395 gfc_status (" ");
396
397 mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE);
398 if (p->ts.kind != gfc_default_complex_kind)
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 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);
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 ("(");
420 switch (p->value.op.operator)
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
485 gfc_show_expr (p->value.op.op1);
486
487 if (p->value.op.op2)
488 {
489 gfc_status (" ");
490 gfc_show_expr (p->value.op.op2);
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
522 static void
523 gfc_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");
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");
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
585 static void
586 gfc_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
612 static void
613 gfc_show_symbol (gfc_symbol * sym)
614 {
615 gfc_formal_arglist *formal;
616 gfc_interface *intr;
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
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)
668 {
669 if (formal->sym != NULL)
670 gfc_status (" %s", formal->sym->name);
671 else
672 gfc_status (" [Alt Return]");
673 }
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. */
689 static void
690 show_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
704 static void
705 traverse_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
720 void
721 gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
722 {
723
724 traverse_uop (ns->uop_root, func);
725 }
726
727
728 /* Function to display a common block. */
729
730 static void
731 show_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
749 /* Worker function to display the symbol tree. */
750
751 static void
752 show_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
769 static 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
774 static void
775 gfc_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
785 static void
786 gfc_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
810 case EXEC_ENTRY:
811 gfc_status ("ENTRY %s", c->ext.entry->sym->name);
812 break;
813
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;
820
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->iomsg)
1088 {
1089 gfc_status (" IOMSG=");
1090 gfc_show_expr (open->iomsg);
1091 }
1092 if (open->iostat)
1093 {
1094 gfc_status (" IOSTAT=");
1095 gfc_show_expr (open->iostat);
1096 }
1097 if (open->file)
1098 {
1099 gfc_status (" FILE=");
1100 gfc_show_expr (open->file);
1101 }
1102 if (open->status)
1103 {
1104 gfc_status (" STATUS=");
1105 gfc_show_expr (open->status);
1106 }
1107 if (open->access)
1108 {
1109 gfc_status (" ACCESS=");
1110 gfc_show_expr (open->access);
1111 }
1112 if (open->form)
1113 {
1114 gfc_status (" FORM=");
1115 gfc_show_expr (open->form);
1116 }
1117 if (open->recl)
1118 {
1119 gfc_status (" RECL=");
1120 gfc_show_expr (open->recl);
1121 }
1122 if (open->blank)
1123 {
1124 gfc_status (" BLANK=");
1125 gfc_show_expr (open->blank);
1126 }
1127 if (open->position)
1128 {
1129 gfc_status (" POSITION=");
1130 gfc_show_expr (open->position);
1131 }
1132 if (open->action)
1133 {
1134 gfc_status (" ACTION=");
1135 gfc_show_expr (open->action);
1136 }
1137 if (open->delim)
1138 {
1139 gfc_status (" DELIM=");
1140 gfc_show_expr (open->delim);
1141 }
1142 if (open->pad)
1143 {
1144 gfc_status (" PAD=");
1145 gfc_show_expr (open->pad);
1146 }
1147 if (open->err != NULL)
1148 gfc_status (" ERR=%d", open->err->value);
1149
1150 break;
1151
1152 case EXEC_CLOSE:
1153 gfc_status ("CLOSE");
1154 close = c->ext.close;
1155
1156 if (close->unit)
1157 {
1158 gfc_status (" UNIT=");
1159 gfc_show_expr (close->unit);
1160 }
1161 if (close->iomsg)
1162 {
1163 gfc_status (" IOMSG=");
1164 gfc_show_expr (close->iomsg);
1165 }
1166 if (close->iostat)
1167 {
1168 gfc_status (" IOSTAT=");
1169 gfc_show_expr (close->iostat);
1170 }
1171 if (close->status)
1172 {
1173 gfc_status (" STATUS=");
1174 gfc_show_expr (close->status);
1175 }
1176 if (close->err != NULL)
1177 gfc_status (" ERR=%d", close->err->value);
1178 break;
1179
1180 case EXEC_BACKSPACE:
1181 gfc_status ("BACKSPACE");
1182 goto show_filepos;
1183
1184 case EXEC_ENDFILE:
1185 gfc_status ("ENDFILE");
1186 goto show_filepos;
1187
1188 case EXEC_REWIND:
1189 gfc_status ("REWIND");
1190 goto show_filepos;
1191
1192 case EXEC_FLUSH:
1193 gfc_status ("FLUSH");
1194
1195 show_filepos:
1196 fp = c->ext.filepos;
1197
1198 if (fp->unit)
1199 {
1200 gfc_status (" UNIT=");
1201 gfc_show_expr (fp->unit);
1202 }
1203 if (fp->iomsg)
1204 {
1205 gfc_status (" IOMSG=");
1206 gfc_show_expr (fp->iomsg);
1207 }
1208 if (fp->iostat)
1209 {
1210 gfc_status (" IOSTAT=");
1211 gfc_show_expr (fp->iostat);
1212 }
1213 if (fp->err != NULL)
1214 gfc_status (" ERR=%d", fp->err->value);
1215 break;
1216
1217 case EXEC_INQUIRE:
1218 gfc_status ("INQUIRE");
1219 i = c->ext.inquire;
1220
1221 if (i->unit)
1222 {
1223 gfc_status (" UNIT=");
1224 gfc_show_expr (i->unit);
1225 }
1226 if (i->file)
1227 {
1228 gfc_status (" FILE=");
1229 gfc_show_expr (i->file);
1230 }
1231
1232 if (i->iomsg)
1233 {
1234 gfc_status (" IOMSG=");
1235 gfc_show_expr (i->iomsg);
1236 }
1237 if (i->iostat)
1238 {
1239 gfc_status (" IOSTAT=");
1240 gfc_show_expr (i->iostat);
1241 }
1242 if (i->exist)
1243 {
1244 gfc_status (" EXIST=");
1245 gfc_show_expr (i->exist);
1246 }
1247 if (i->opened)
1248 {
1249 gfc_status (" OPENED=");
1250 gfc_show_expr (i->opened);
1251 }
1252 if (i->number)
1253 {
1254 gfc_status (" NUMBER=");
1255 gfc_show_expr (i->number);
1256 }
1257 if (i->named)
1258 {
1259 gfc_status (" NAMED=");
1260 gfc_show_expr (i->named);
1261 }
1262 if (i->name)
1263 {
1264 gfc_status (" NAME=");
1265 gfc_show_expr (i->name);
1266 }
1267 if (i->access)
1268 {
1269 gfc_status (" ACCESS=");
1270 gfc_show_expr (i->access);
1271 }
1272 if (i->sequential)
1273 {
1274 gfc_status (" SEQUENTIAL=");
1275 gfc_show_expr (i->sequential);
1276 }
1277
1278 if (i->direct)
1279 {
1280 gfc_status (" DIRECT=");
1281 gfc_show_expr (i->direct);
1282 }
1283 if (i->form)
1284 {
1285 gfc_status (" FORM=");
1286 gfc_show_expr (i->form);
1287 }
1288 if (i->formatted)
1289 {
1290 gfc_status (" FORMATTED");
1291 gfc_show_expr (i->formatted);
1292 }
1293 if (i->unformatted)
1294 {
1295 gfc_status (" UNFORMATTED=");
1296 gfc_show_expr (i->unformatted);
1297 }
1298 if (i->recl)
1299 {
1300 gfc_status (" RECL=");
1301 gfc_show_expr (i->recl);
1302 }
1303 if (i->nextrec)
1304 {
1305 gfc_status (" NEXTREC=");
1306 gfc_show_expr (i->nextrec);
1307 }
1308 if (i->blank)
1309 {
1310 gfc_status (" BLANK=");
1311 gfc_show_expr (i->blank);
1312 }
1313 if (i->position)
1314 {
1315 gfc_status (" POSITION=");
1316 gfc_show_expr (i->position);
1317 }
1318 if (i->action)
1319 {
1320 gfc_status (" ACTION=");
1321 gfc_show_expr (i->action);
1322 }
1323 if (i->read)
1324 {
1325 gfc_status (" READ=");
1326 gfc_show_expr (i->read);
1327 }
1328 if (i->write)
1329 {
1330 gfc_status (" WRITE=");
1331 gfc_show_expr (i->write);
1332 }
1333 if (i->readwrite)
1334 {
1335 gfc_status (" READWRITE=");
1336 gfc_show_expr (i->readwrite);
1337 }
1338 if (i->delim)
1339 {
1340 gfc_status (" DELIM=");
1341 gfc_show_expr (i->delim);
1342 }
1343 if (i->pad)
1344 {
1345 gfc_status (" PAD=");
1346 gfc_show_expr (i->pad);
1347 }
1348
1349 if (i->err != NULL)
1350 gfc_status (" ERR=%d", i->err->value);
1351 break;
1352
1353 case EXEC_IOLENGTH:
1354 gfc_status ("IOLENGTH ");
1355 gfc_show_expr (c->expr);
1356 break;
1357
1358 case EXEC_READ:
1359 gfc_status ("READ");
1360 goto show_dt;
1361
1362 case EXEC_WRITE:
1363 gfc_status ("WRITE");
1364
1365 show_dt:
1366 dt = c->ext.dt;
1367 if (dt->io_unit)
1368 {
1369 gfc_status (" UNIT=");
1370 gfc_show_expr (dt->io_unit);
1371 }
1372
1373 if (dt->format_expr)
1374 {
1375 gfc_status (" FMT=");
1376 gfc_show_expr (dt->format_expr);
1377 }
1378
1379 if (dt->format_label != NULL)
1380 gfc_status (" FMT=%d", dt->format_label->value);
1381 if (dt->namelist)
1382 gfc_status (" NML=%s", dt->namelist->name);
1383
1384 if (dt->iomsg)
1385 {
1386 gfc_status (" IOMSG=");
1387 gfc_show_expr (dt->iomsg);
1388 }
1389 if (dt->iostat)
1390 {
1391 gfc_status (" IOSTAT=");
1392 gfc_show_expr (dt->iostat);
1393 }
1394 if (dt->size)
1395 {
1396 gfc_status (" SIZE=");
1397 gfc_show_expr (dt->size);
1398 }
1399 if (dt->rec)
1400 {
1401 gfc_status (" REC=");
1402 gfc_show_expr (dt->rec);
1403 }
1404 if (dt->advance)
1405 {
1406 gfc_status (" ADVANCE=");
1407 gfc_show_expr (dt->advance);
1408 }
1409
1410 break;
1411
1412 case EXEC_TRANSFER:
1413 gfc_status ("TRANSFER ");
1414 gfc_show_expr (c->expr);
1415 break;
1416
1417 case EXEC_DT_END:
1418 gfc_status ("DT_END");
1419 dt = c->ext.dt;
1420
1421 if (dt->err != NULL)
1422 gfc_status (" ERR=%d", dt->err->value);
1423 if (dt->end != NULL)
1424 gfc_status (" END=%d", dt->end->value);
1425 if (dt->eor != NULL)
1426 gfc_status (" EOR=%d", dt->eor->value);
1427 break;
1428
1429 default:
1430 gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1431 }
1432
1433 gfc_status_char ('\n');
1434 }
1435
1436
1437 /* Show and equivalence chain. */
1438
1439 static void
1440 gfc_show_equiv (gfc_equiv *eq)
1441 {
1442 show_indent ();
1443 gfc_status ("Equivalence: ");
1444 while (eq)
1445 {
1446 gfc_show_expr (eq->expr);
1447 eq = eq->eq;
1448 if (eq)
1449 gfc_status (", ");
1450 }
1451 }
1452
1453
1454 /* Show a freakin' whole namespace. */
1455
1456 void
1457 gfc_show_namespace (gfc_namespace * ns)
1458 {
1459 gfc_interface *intr;
1460 gfc_namespace *save;
1461 gfc_intrinsic_op op;
1462 gfc_equiv *eq;
1463 int i;
1464
1465 save = gfc_current_ns;
1466 show_level++;
1467
1468 show_indent ();
1469 gfc_status ("Namespace:");
1470
1471 if (ns != NULL)
1472 {
1473 i = 0;
1474 do
1475 {
1476 int l = i;
1477 while (i < GFC_LETTERS - 1
1478 && gfc_compare_types(&ns->default_type[i+1],
1479 &ns->default_type[l]))
1480 i++;
1481
1482 if (i > l)
1483 gfc_status(" %c-%c: ", l+'A', i+'A');
1484 else
1485 gfc_status(" %c: ", l+'A');
1486
1487 gfc_show_typespec(&ns->default_type[l]);
1488 i++;
1489 } while (i < GFC_LETTERS);
1490
1491 if (ns->proc_name != NULL)
1492 {
1493 show_indent ();
1494 gfc_status ("procedure name = %s", ns->proc_name->name);
1495 }
1496
1497 gfc_current_ns = ns;
1498 gfc_traverse_symtree (ns->common_root, show_common);
1499
1500 gfc_traverse_symtree (ns->sym_root, show_symtree);
1501
1502 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1503 {
1504 /* User operator interfaces */
1505 intr = ns->operator[op];
1506 if (intr == NULL)
1507 continue;
1508
1509 show_indent ();
1510 gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
1511
1512 for (; intr; intr = intr->next)
1513 gfc_status (" %s", intr->sym->name);
1514 }
1515
1516 if (ns->uop_root != NULL)
1517 {
1518 show_indent ();
1519 gfc_status ("User operators:\n");
1520 gfc_traverse_user_op (ns, show_uop);
1521 }
1522 }
1523
1524 for (eq = ns->equiv; eq; eq = eq->next)
1525 gfc_show_equiv (eq);
1526
1527 gfc_status_char ('\n');
1528 gfc_status_char ('\n');
1529
1530 gfc_show_code (0, ns->code);
1531
1532 for (ns = ns->contained; ns; ns = ns->sibling)
1533 {
1534 show_indent ();
1535 gfc_status ("CONTAINS\n");
1536 gfc_show_namespace (ns);
1537 }
1538
1539 show_level--;
1540 gfc_status_char ('\n');
1541 gfc_current_ns = save;
1542 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org