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