?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* Make-lang.in (GFORTRAN_TARGET_INSTALL_NAME): Define.
[official-gcc.git] / gcc / fortran / dump-parse-tree.c
blob8068b10d35fb3f80787c55be24175b5da0434b7b
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 /* Do nothing
760 gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name); */
761 ;
762 else
763 gfc_show_symbol (st->n.sym);
764 }
765
766
767 /******************* Show gfc_code structures **************/
768
769
770
771 static void gfc_show_code_node (int level, gfc_code * c);
772
773 /* Show a list of code structures. Mutually recursive with
774 gfc_show_code_node(). */
775
776 static void
777 gfc_show_code (int level, gfc_code * c)
778 {
779
780 for (; c; c = c->next)
781 gfc_show_code_node (level, c);
782 }
783
784
785 /* Show a single code node and everything underneath it if necessary. */
786
787 static void
788 gfc_show_code_node (int level, gfc_code * c)
789 {
790 gfc_forall_iterator *fa;
791 gfc_open *open;
792 gfc_case *cp;
793 gfc_alloc *a;
794 gfc_code *d;
795 gfc_close *close;
796 gfc_filepos *fp;
797 gfc_inquire *i;
798 gfc_dt *dt;
799
800 code_indent (level, c->here);
801
802 switch (c->op)
803 {
804 case EXEC_NOP:
805 gfc_status ("NOP");
806 break;
807
808 case EXEC_CONTINUE:
809 gfc_status ("CONTINUE");
810 break;
811
812 case EXEC_ENTRY:
813 gfc_status ("ENTRY %s", c->ext.entry->sym->name);
814 break;
815
816 case EXEC_ASSIGN:
817 gfc_status ("ASSIGN ");
818 gfc_show_expr (c->expr);
819 gfc_status_char (' ');
820 gfc_show_expr (c->expr2);
821 break;
822
823 case EXEC_LABEL_ASSIGN:
824 gfc_status ("LABEL ASSIGN ");
825 gfc_show_expr (c->expr);
826 gfc_status (" %d", c->label->value);
827 break;
828
829 case EXEC_POINTER_ASSIGN:
830 gfc_status ("POINTER ASSIGN ");
831 gfc_show_expr (c->expr);
832 gfc_status_char (' ');
833 gfc_show_expr (c->expr2);
834 break;
835
836 case EXEC_GOTO:
837 gfc_status ("GOTO ");
838 if (c->label)
839 gfc_status ("%d", c->label->value);
840 else
841 {
842 gfc_show_expr (c->expr);
843 d = c->block;
844 if (d != NULL)
845 {
846 gfc_status (", (");
847 for (; d; d = d ->block)
848 {
849 code_indent (level, d->label);
850 if (d->block != NULL)
851 gfc_status_char (',');
852 else
853 gfc_status_char (')');
854 }
855 }
856 }
857 break;
858
859 case EXEC_CALL:
860 gfc_status ("CALL %s ", c->resolved_sym->name);
861 gfc_show_actual_arglist (c->ext.actual);
862 break;
863
864 case EXEC_RETURN:
865 gfc_status ("RETURN ");
866 if (c->expr)
867 gfc_show_expr (c->expr);
868 break;
869
870 case EXEC_PAUSE:
871 gfc_status ("PAUSE ");
872
873 if (c->expr != NULL)
874 gfc_show_expr (c->expr);
875 else
876 gfc_status ("%d", c->ext.stop_code);
877
878 break;
879
880 case EXEC_STOP:
881 gfc_status ("STOP ");
882
883 if (c->expr != NULL)
884 gfc_show_expr (c->expr);
885 else
886 gfc_status ("%d", c->ext.stop_code);
887
888 break;
889
890 case EXEC_ARITHMETIC_IF:
891 gfc_status ("IF ");
892 gfc_show_expr (c->expr);
893 gfc_status (" %d, %d, %d",
894 c->label->value, c->label2->value, c->label3->value);
895 break;
896
897 case EXEC_IF:
898 d = c->block;
899 gfc_status ("IF ");
900 gfc_show_expr (d->expr);
901 gfc_status_char ('\n');
902 gfc_show_code (level + 1, d->next);
903
904 d = d->block;
905 for (; d; d = d->block)
906 {
907 code_indent (level, 0);
908
909 if (d->expr == NULL)
910 gfc_status ("ELSE\n");
911 else
912 {
913 gfc_status ("ELSE IF ");
914 gfc_show_expr (d->expr);
915 gfc_status_char ('\n');
916 }
917
918 gfc_show_code (level + 1, d->next);
919 }
920
921 code_indent (level, c->label);
922
923 gfc_status ("ENDIF");
924 break;
925
926 case EXEC_SELECT:
927 d = c->block;
928 gfc_status ("SELECT CASE ");
929 gfc_show_expr (c->expr);
930 gfc_status_char ('\n');
931
932 for (; d; d = d->block)
933 {
934 code_indent (level, 0);
935
936 gfc_status ("CASE ");
937 for (cp = d->ext.case_list; cp; cp = cp->next)
938 {
939 gfc_status_char ('(');
940 gfc_show_expr (cp->low);
941 gfc_status_char (' ');
942 gfc_show_expr (cp->high);
943 gfc_status_char (')');
944 gfc_status_char (' ');
945 }
946 gfc_status_char ('\n');
947
948 gfc_show_code (level + 1, d->next);
949 }
950
951 code_indent (level, c->label);
952 gfc_status ("END SELECT");
953 break;
954
955 case EXEC_WHERE:
956 gfc_status ("WHERE ");
957
958 d = c->block;
959 gfc_show_expr (d->expr);
960 gfc_status_char ('\n');
961
962 gfc_show_code (level + 1, d->next);
963
964 for (d = d->block; d; d = d->block)
965 {
966 code_indent (level, 0);
967 gfc_status ("ELSE WHERE ");
968 gfc_show_expr (d->expr);
969 gfc_status_char ('\n');
970 gfc_show_code (level + 1, d->next);
971 }
972
973 code_indent (level, 0);
974 gfc_status ("END WHERE");
975 break;
976
977
978 case EXEC_FORALL:
979 gfc_status ("FORALL ");
980 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
981 {
982 gfc_show_expr (fa->var);
983 gfc_status_char (' ');
984 gfc_show_expr (fa->start);
985 gfc_status_char (':');
986 gfc_show_expr (fa->end);
987 gfc_status_char (':');
988 gfc_show_expr (fa->stride);
989
990 if (fa->next != NULL)
991 gfc_status_char (',');
992 }
993
994 if (c->expr != NULL)
995 {
996 gfc_status_char (',');
997 gfc_show_expr (c->expr);
998 }
999 gfc_status_char ('\n');
1000
1001 gfc_show_code (level + 1, c->block->next);
1002
1003 code_indent (level, 0);
1004 gfc_status ("END FORALL");
1005 break;
1006
1007 case EXEC_DO:
1008 gfc_status ("DO ");
1009
1010 gfc_show_expr (c->ext.iterator->var);
1011 gfc_status_char ('=');
1012 gfc_show_expr (c->ext.iterator->start);
1013 gfc_status_char (' ');
1014 gfc_show_expr (c->ext.iterator->end);
1015 gfc_status_char (' ');
1016 gfc_show_expr (c->ext.iterator->step);
1017 gfc_status_char ('\n');
1018
1019 gfc_show_code (level + 1, c->block->next);
1020
1021 code_indent (level, 0);
1022 gfc_status ("END DO");
1023 break;
1024
1025 case EXEC_DO_WHILE:
1026 gfc_status ("DO WHILE ");
1027 gfc_show_expr (c->expr);
1028 gfc_status_char ('\n');
1029
1030 gfc_show_code (level + 1, c->block->next);
1031
1032 code_indent (level, c->label);
1033 gfc_status ("END DO");
1034 break;
1035
1036 case EXEC_CYCLE:
1037 gfc_status ("CYCLE");
1038 if (c->symtree)
1039 gfc_status (" %s", c->symtree->n.sym->name);
1040 break;
1041
1042 case EXEC_EXIT:
1043 gfc_status ("EXIT");
1044 if (c->symtree)
1045 gfc_status (" %s", c->symtree->n.sym->name);
1046 break;
1047
1048 case EXEC_ALLOCATE:
1049 gfc_status ("ALLOCATE ");
1050 if (c->expr)
1051 {
1052 gfc_status (" STAT=");
1053 gfc_show_expr (c->expr);
1054 }
1055
1056 for (a = c->ext.alloc_list; a; a = a->next)
1057 {
1058 gfc_status_char (' ');
1059 gfc_show_expr (a->expr);
1060 }
1061
1062 break;
1063
1064 case EXEC_DEALLOCATE:
1065 gfc_status ("DEALLOCATE ");
1066 if (c->expr)
1067 {
1068 gfc_status (" STAT=");
1069 gfc_show_expr (c->expr);
1070 }
1071
1072 for (a = c->ext.alloc_list; a; a = a->next)
1073 {
1074 gfc_status_char (' ');
1075 gfc_show_expr (a->expr);
1076 }
1077
1078 break;
1079
1080 case EXEC_OPEN:
1081 gfc_status ("OPEN");
1082 open = c->ext.open;
1083
1084 if (open->unit)
1085 {
1086 gfc_status (" UNIT=");
1087 gfc_show_expr (open->unit);
1088 }
1089 if (open->iomsg)
1090 {
1091 gfc_status (" IOMSG=");
1092 gfc_show_expr (open->iomsg);
1093 }
1094 if (open->iostat)
1095 {
1096 gfc_status (" IOSTAT=");
1097 gfc_show_expr (open->iostat);
1098 }
1099 if (open->file)
1100 {
1101 gfc_status (" FILE=");
1102 gfc_show_expr (open->file);
1103 }
1104 if (open->status)
1105 {
1106 gfc_status (" STATUS=");
1107 gfc_show_expr (open->status);
1108 }
1109 if (open->access)
1110 {
1111 gfc_status (" ACCESS=");
1112 gfc_show_expr (open->access);
1113 }
1114 if (open->form)
1115 {
1116 gfc_status (" FORM=");
1117 gfc_show_expr (open->form);
1118 }
1119 if (open->recl)
1120 {
1121 gfc_status (" RECL=");
1122 gfc_show_expr (open->recl);
1123 }
1124 if (open->blank)
1125 {
1126 gfc_status (" BLANK=");
1127 gfc_show_expr (open->blank);
1128 }
1129 if (open->position)
1130 {
1131 gfc_status (" POSITION=");
1132 gfc_show_expr (open->position);
1133 }
1134 if (open->action)
1135 {
1136 gfc_status (" ACTION=");
1137 gfc_show_expr (open->action);
1138 }
1139 if (open->delim)
1140 {
1141 gfc_status (" DELIM=");
1142 gfc_show_expr (open->delim);
1143 }
1144 if (open->pad)
1145 {
1146 gfc_status (" PAD=");
1147 gfc_show_expr (open->pad);
1148 }
1149 if (open->err != NULL)
1150 gfc_status (" ERR=%d", open->err->value);
1151
1152 break;
1153
1154 case EXEC_CLOSE:
1155 gfc_status ("CLOSE");
1156 close = c->ext.close;
1157
1158 if (close->unit)
1159 {
1160 gfc_status (" UNIT=");
1161 gfc_show_expr (close->unit);
1162 }
1163 if (close->iomsg)
1164 {
1165 gfc_status (" IOMSG=");
1166 gfc_show_expr (close->iomsg);
1167 }
1168 if (close->iostat)
1169 {
1170 gfc_status (" IOSTAT=");
1171 gfc_show_expr (close->iostat);
1172 }
1173 if (close->status)
1174 {
1175 gfc_status (" STATUS=");
1176 gfc_show_expr (close->status);
1177 }
1178 if (close->err != NULL)
1179 gfc_status (" ERR=%d", close->err->value);
1180 break;
1181
1182 case EXEC_BACKSPACE:
1183 gfc_status ("BACKSPACE");
1184 goto show_filepos;
1185
1186 case EXEC_ENDFILE:
1187 gfc_status ("ENDFILE");
1188 goto show_filepos;
1189
1190 case EXEC_REWIND:
1191 gfc_status ("REWIND");
1192 goto show_filepos;
1193
1194 case EXEC_FLUSH:
1195 gfc_status ("FLUSH");
1196
1197 show_filepos:
1198 fp = c->ext.filepos;
1199
1200 if (fp->unit)
1201 {
1202 gfc_status (" UNIT=");
1203 gfc_show_expr (fp->unit);
1204 }
1205 if (fp->iomsg)
1206 {
1207 gfc_status (" IOMSG=");
1208 gfc_show_expr (fp->iomsg);
1209 }
1210 if (fp->iostat)
1211 {
1212 gfc_status (" IOSTAT=");
1213 gfc_show_expr (fp->iostat);
1214 }
1215 if (fp->err != NULL)
1216 gfc_status (" ERR=%d", fp->err->value);
1217 break;
1218
1219 case EXEC_INQUIRE:
1220 gfc_status ("INQUIRE");
1221 i = c->ext.inquire;
1222
1223 if (i->unit)
1224 {
1225 gfc_status (" UNIT=");
1226 gfc_show_expr (i->unit);
1227 }
1228 if (i->file)
1229 {
1230 gfc_status (" FILE=");
1231 gfc_show_expr (i->file);
1232 }
1233
1234 if (i->iomsg)
1235 {
1236 gfc_status (" IOMSG=");
1237 gfc_show_expr (i->iomsg);
1238 }
1239 if (i->iostat)
1240 {
1241 gfc_status (" IOSTAT=");
1242 gfc_show_expr (i->iostat);
1243 }
1244 if (i->exist)
1245 {
1246 gfc_status (" EXIST=");
1247 gfc_show_expr (i->exist);
1248 }
1249 if (i->opened)
1250 {
1251 gfc_status (" OPENED=");
1252 gfc_show_expr (i->opened);
1253 }
1254 if (i->number)
1255 {
1256 gfc_status (" NUMBER=");
1257 gfc_show_expr (i->number);
1258 }
1259 if (i->named)
1260 {
1261 gfc_status (" NAMED=");
1262 gfc_show_expr (i->named);
1263 }
1264 if (i->name)
1265 {
1266 gfc_status (" NAME=");
1267 gfc_show_expr (i->name);
1268 }
1269 if (i->access)
1270 {
1271 gfc_status (" ACCESS=");
1272 gfc_show_expr (i->access);
1273 }
1274 if (i->sequential)
1275 {
1276 gfc_status (" SEQUENTIAL=");
1277 gfc_show_expr (i->sequential);
1278 }
1279
1280 if (i->direct)
1281 {
1282 gfc_status (" DIRECT=");
1283 gfc_show_expr (i->direct);
1284 }
1285 if (i->form)
1286 {
1287 gfc_status (" FORM=");
1288 gfc_show_expr (i->form);
1289 }
1290 if (i->formatted)
1291 {
1292 gfc_status (" FORMATTED");
1293 gfc_show_expr (i->formatted);
1294 }
1295 if (i->unformatted)
1296 {
1297 gfc_status (" UNFORMATTED=");
1298 gfc_show_expr (i->unformatted);
1299 }
1300 if (i->recl)
1301 {
1302 gfc_status (" RECL=");
1303 gfc_show_expr (i->recl);
1304 }
1305 if (i->nextrec)
1306 {
1307 gfc_status (" NEXTREC=");
1308 gfc_show_expr (i->nextrec);
1309 }
1310 if (i->blank)
1311 {
1312 gfc_status (" BLANK=");
1313 gfc_show_expr (i->blank);
1314 }
1315 if (i->position)
1316 {
1317 gfc_status (" POSITION=");
1318 gfc_show_expr (i->position);
1319 }
1320 if (i->action)
1321 {
1322 gfc_status (" ACTION=");
1323 gfc_show_expr (i->action);
1324 }
1325 if (i->read)
1326 {
1327 gfc_status (" READ=");
1328 gfc_show_expr (i->read);
1329 }
1330 if (i->write)
1331 {
1332 gfc_status (" WRITE=");
1333 gfc_show_expr (i->write);
1334 }
1335 if (i->readwrite)
1336 {
1337 gfc_status (" READWRITE=");
1338 gfc_show_expr (i->readwrite);
1339 }
1340 if (i->delim)
1341 {
1342 gfc_status (" DELIM=");
1343 gfc_show_expr (i->delim);
1344 }
1345 if (i->pad)
1346 {
1347 gfc_status (" PAD=");
1348 gfc_show_expr (i->pad);
1349 }
1350
1351 if (i->err != NULL)
1352 gfc_status (" ERR=%d", i->err->value);
1353 break;
1354
1355 case EXEC_IOLENGTH:
1356 gfc_status ("IOLENGTH ");
1357 gfc_show_expr (c->expr);
1358 break;
1359
1360 case EXEC_READ:
1361 gfc_status ("READ");
1362 goto show_dt;
1363
1364 case EXEC_WRITE:
1365 gfc_status ("WRITE");
1366
1367 show_dt:
1368 dt = c->ext.dt;
1369 if (dt->io_unit)
1370 {
1371 gfc_status (" UNIT=");
1372 gfc_show_expr (dt->io_unit);
1373 }
1374
1375 if (dt->format_expr)
1376 {
1377 gfc_status (" FMT=");
1378 gfc_show_expr (dt->format_expr);
1379 }
1380
1381 if (dt->format_label != NULL)
1382 gfc_status (" FMT=%d", dt->format_label->value);
1383 if (dt->namelist)
1384 gfc_status (" NML=%s", dt->namelist->name);
1385
1386 if (dt->iomsg)
1387 {
1388 gfc_status (" IOMSG=");
1389 gfc_show_expr (dt->iomsg);
1390 }
1391 if (dt->iostat)
1392 {
1393 gfc_status (" IOSTAT=");
1394 gfc_show_expr (dt->iostat);
1395 }
1396 if (dt->size)
1397 {
1398 gfc_status (" SIZE=");
1399 gfc_show_expr (dt->size);
1400 }
1401 if (dt->rec)
1402 {
1403 gfc_status (" REC=");
1404 gfc_show_expr (dt->rec);
1405 }
1406 if (dt->advance)
1407 {
1408 gfc_status (" ADVANCE=");
1409 gfc_show_expr (dt->advance);
1410 }
1411
1412 break;
1413
1414 case EXEC_TRANSFER:
1415 gfc_status ("TRANSFER ");
1416 gfc_show_expr (c->expr);
1417 break;
1418
1419 case EXEC_DT_END:
1420 gfc_status ("DT_END");
1421 dt = c->ext.dt;
1422
1423 if (dt->err != NULL)
1424 gfc_status (" ERR=%d", dt->err->value);
1425 if (dt->end != NULL)
1426 gfc_status (" END=%d", dt->end->value);
1427 if (dt->eor != NULL)
1428 gfc_status (" EOR=%d", dt->eor->value);
1429 break;
1430
1431 default:
1432 gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1433 }
1434
1435 gfc_status_char ('\n');
1436 }
1437
1438
1439 /* Show and equivalence chain. */
1440
1441 static void
1442 gfc_show_equiv (gfc_equiv *eq)
1443 {
1444 show_indent ();
1445 gfc_status ("Equivalence: ");
1446 while (eq)
1447 {
1448 gfc_show_expr (eq->expr);
1449 eq = eq->eq;
1450 if (eq)
1451 gfc_status (", ");
1452 }
1453 }
1454
1455
1456 /* Show a freakin' whole namespace. */
1457
1458 void
1459 gfc_show_namespace (gfc_namespace * ns)
1460 {
1461 gfc_interface *intr;
1462 gfc_namespace *save;
1463 gfc_intrinsic_op op;
1464 gfc_equiv *eq;
1465 int i;
1466
1467 save = gfc_current_ns;
1468 show_level++;
1469
1470 show_indent ();
1471 gfc_status ("Namespace:");
1472
1473 if (ns != NULL)
1474 {
1475 i = 0;
1476 do
1477 {
1478 int l = i;
1479 while (i < GFC_LETTERS - 1
1480 && gfc_compare_types(&ns->default_type[i+1],
1481 &ns->default_type[l]))
1482 i++;
1483
1484 if (i > l)
1485 gfc_status(" %c-%c: ", l+'A', i+'A');
1486 else
1487 gfc_status(" %c: ", l+'A');
1488
1489 gfc_show_typespec(&ns->default_type[l]);
1490 i++;
1491 } while (i < GFC_LETTERS);
1492
1493 if (ns->proc_name != NULL)
1494 {
1495 show_indent ();
1496 gfc_status ("procedure name = %s", ns->proc_name->name);
1497 }
1498
1499 gfc_current_ns = ns;
1500 gfc_traverse_symtree (ns->common_root, show_common);
1501
1502 gfc_traverse_symtree (ns->sym_root, show_symtree);
1503
1504 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1505 {
1506 /* User operator interfaces */
1507 intr = ns->operator[op];
1508 if (intr == NULL)
1509 continue;
1510
1511 show_indent ();
1512 gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
1513
1514 for (; intr; intr = intr->next)
1515 gfc_status (" %s", intr->sym->name);
1516 }
1517
1518 if (ns->uop_root != NULL)
1519 {
1520 show_indent ();
1521 gfc_status ("User operators:\n");
1522 gfc_traverse_user_op (ns, show_uop);
1523 }
1524 }
1525
1526 for (eq = ns->equiv; eq; eq = eq->next)
1527 gfc_show_equiv (eq);
1528
1529 gfc_status_char ('\n');
1530 gfc_status_char ('\n');
1531
1532 gfc_show_code (0, ns->code);
1533
1534 for (ns = ns->contained; ns; ns = ns->sibling)
1535 {
1536 show_indent ();
1537 gfc_status ("CONTAINS\n");
1538 gfc_show_namespace (ns);
1539 }
1540
1541 show_level--;
1542 gfc_status_char ('\n');
1543 gfc_current_ns = save;
1544 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org