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