?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2009-05-14 Steven G. Kargl <kargl@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / dump-parse-tree.c
blobf6de8e824bc3897232544b863d6772fceaf6c098
1 /* Parse tree dumper
2 Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Steven Bosscher
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
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 /* The file handle we're dumping to is kept in a static variable. This
41 is not too cool, but it avoids a lot of passing it around. */
42 static FILE *dumpfile;
43
44 /* Forward declaration of some of the functions. */
45 static void show_expr (gfc_expr *p);
46 static void show_code_node (int, gfc_code *);
47 static void show_namespace (gfc_namespace *ns);
48
49
50 /* Do indentation for a specific level. */
51
52 static inline void
53 code_indent (int level, gfc_st_label *label)
54 {
55 int i;
56
57 if (label != NULL)
58 fprintf (dumpfile, "%-5d ", label->value);
59 else
60 fputs (" ", dumpfile);
61
62 for (i = 0; i < 2 * level; i++)
63 fputc (' ', dumpfile);
64 }
65
66
67 /* Simple indentation at the current level. This one
68 is used to show symbols. */
69
70 static inline void
71 show_indent (void)
72 {
73 fputc ('\n', dumpfile);
74 code_indent (show_level, NULL);
75 }
76
77
78 /* Show type-specific information. */
79
80 static void
81 show_typespec (gfc_typespec *ts)
82 {
83 fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
84
85 switch (ts->type)
86 {
87 case BT_DERIVED:
88 fprintf (dumpfile, "%s", ts->derived->name);
89 break;
90
91 case BT_CHARACTER:
92 show_expr (ts->cl->length);
93 break;
94
95 default:
96 fprintf (dumpfile, "%d", ts->kind);
97 break;
98 }
99
100 fputc (')', dumpfile);
101 }
102
103
104 /* Show an actual argument list. */
105
106 static void
107 show_actual_arglist (gfc_actual_arglist *a)
108 {
109 fputc ('(', dumpfile);
110
111 for (; a; a = a->next)
112 {
113 fputc ('(', dumpfile);
114 if (a->name != NULL)
115 fprintf (dumpfile, "%s = ", a->name);
116 if (a->expr != NULL)
117 show_expr (a->expr);
118 else
119 fputs ("(arg not-present)", dumpfile);
120
121 fputc (')', dumpfile);
122 if (a->next != NULL)
123 fputc (' ', dumpfile);
124 }
125
126 fputc (')', dumpfile);
127 }
128
129
130 /* Show a gfc_array_spec array specification structure. */
131
132 static void
133 show_array_spec (gfc_array_spec *as)
134 {
135 const char *c;
136 int i;
137
138 if (as == NULL)
139 {
140 fputs ("()", dumpfile);
141 return;
142 }
143
144 fprintf (dumpfile, "(%d", as->rank);
145
146 if (as->rank != 0)
147 {
148 switch (as->type)
149 {
150 case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
151 case AS_DEFERRED: c = "AS_DEFERRED"; break;
152 case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
153 case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
154 default:
155 gfc_internal_error ("show_array_spec(): Unhandled array shape "
156 "type.");
157 }
158 fprintf (dumpfile, " %s ", c);
159
160 for (i = 0; i < as->rank; i++)
161 {
162 show_expr (as->lower[i]);
163 fputc (' ', dumpfile);
164 show_expr (as->upper[i]);
165 fputc (' ', dumpfile);
166 }
167 }
168
169 fputc (')', dumpfile);
170 }
171
172
173 /* Show a gfc_array_ref array reference structure. */
174
175 static void
176 show_array_ref (gfc_array_ref * ar)
177 {
178 int i;
179
180 fputc ('(', dumpfile);
181
182 switch (ar->type)
183 {
184 case AR_FULL:
185 fputs ("FULL", dumpfile);
186 break;
187
188 case AR_SECTION:
189 for (i = 0; i < ar->dimen; i++)
190 {
191 /* There are two types of array sections: either the
192 elements are identified by an integer array ('vector'),
193 or by an index range. In the former case we only have to
194 print the start expression which contains the vector, in
195 the latter case we have to print any of lower and upper
196 bound and the stride, if they're present. */
197
198 if (ar->start[i] != NULL)
199 show_expr (ar->start[i]);
200
201 if (ar->dimen_type[i] == DIMEN_RANGE)
202 {
203 fputc (':', dumpfile);
204
205 if (ar->end[i] != NULL)
206 show_expr (ar->end[i]);
207
208 if (ar->stride[i] != NULL)
209 {
210 fputc (':', dumpfile);
211 show_expr (ar->stride[i]);
212 }
213 }
214
215 if (i != ar->dimen - 1)
216 fputs (" , ", dumpfile);
217 }
218 break;
219
220 case AR_ELEMENT:
221 for (i = 0; i < ar->dimen; i++)
222 {
223 show_expr (ar->start[i]);
224 if (i != ar->dimen - 1)
225 fputs (" , ", dumpfile);
226 }
227 break;
228
229 case AR_UNKNOWN:
230 fputs ("UNKNOWN", dumpfile);
231 break;
232
233 default:
234 gfc_internal_error ("show_array_ref(): Unknown array reference");
235 }
236
237 fputc (')', dumpfile);
238 }
239
240
241 /* Show a list of gfc_ref structures. */
242
243 static void
244 show_ref (gfc_ref *p)
245 {
246 for (; p; p = p->next)
247 switch (p->type)
248 {
249 case REF_ARRAY:
250 show_array_ref (&p->u.ar);
251 break;
252
253 case REF_COMPONENT:
254 fprintf (dumpfile, " %% %s", p->u.c.component->name);
255 break;
256
257 case REF_SUBSTRING:
258 fputc ('(', dumpfile);
259 show_expr (p->u.ss.start);
260 fputc (':', dumpfile);
261 show_expr (p->u.ss.end);
262 fputc (')', dumpfile);
263 break;
264
265 default:
266 gfc_internal_error ("show_ref(): Bad component code");
267 }
268 }
269
270
271 /* Display a constructor. Works recursively for array constructors. */
272
273 static void
274 show_constructor (gfc_constructor *c)
275 {
276 for (; c; c = c->next)
277 {
278 if (c->iterator == NULL)
279 show_expr (c->expr);
280 else
281 {
282 fputc ('(', dumpfile);
283 show_expr (c->expr);
284
285 fputc (' ', dumpfile);
286 show_expr (c->iterator->var);
287 fputc ('=', dumpfile);
288 show_expr (c->iterator->start);
289 fputc (',', dumpfile);
290 show_expr (c->iterator->end);
291 fputc (',', dumpfile);
292 show_expr (c->iterator->step);
293
294 fputc (')', dumpfile);
295 }
296
297 if (c->next != NULL)
298 fputs (" , ", dumpfile);
299 }
300 }
301
302
303 static void
304 show_char_const (const gfc_char_t *c, int length)
305 {
306 int i;
307
308 fputc ('\'', dumpfile);
309 for (i = 0; i < length; i++)
310 {
311 if (c[i] == '\'')
312 fputs ("''", dumpfile);
313 else
314 fputs (gfc_print_wide_char (c[i]), dumpfile);
315 }
316 fputc ('\'', dumpfile);
317 }
318
319
320 /* Show a component-call expression. */
321
322 static void
323 show_compcall (gfc_expr* p)
324 {
325 gcc_assert (p->expr_type == EXPR_COMPCALL);
326
327 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
328 show_ref (p->ref);
329 fprintf (dumpfile, "%s", p->value.compcall.name);
330
331 show_actual_arglist (p->value.compcall.actual);
332 }
333
334
335 /* Show an expression. */
336
337 static void
338 show_expr (gfc_expr *p)
339 {
340 const char *c;
341 int i;
342
343 if (p == NULL)
344 {
345 fputs ("()", dumpfile);
346 return;
347 }
348
349 switch (p->expr_type)
350 {
351 case EXPR_SUBSTRING:
352 show_char_const (p->value.character.string, p->value.character.length);
353 show_ref (p->ref);
354 break;
355
356 case EXPR_STRUCTURE:
357 fprintf (dumpfile, "%s(", p->ts.derived->name);
358 show_constructor (p->value.constructor);
359 fputc (')', dumpfile);
360 break;
361
362 case EXPR_ARRAY:
363 fputs ("(/ ", dumpfile);
364 show_constructor (p->value.constructor);
365 fputs (" /)", dumpfile);
366
367 show_ref (p->ref);
368 break;
369
370 case EXPR_NULL:
371 fputs ("NULL()", dumpfile);
372 break;
373
374 case EXPR_CONSTANT:
375 switch (p->ts.type)
376 {
377 case BT_INTEGER:
378 mpz_out_str (stdout, 10, p->value.integer);
379
380 if (p->ts.kind != gfc_default_integer_kind)
381 fprintf (dumpfile, "_%d", p->ts.kind);
382 break;
383
384 case BT_LOGICAL:
385 if (p->value.logical)
386 fputs (".true.", dumpfile);
387 else
388 fputs (".false.", dumpfile);
389 break;
390
391 case BT_REAL:
392 mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
393 if (p->ts.kind != gfc_default_real_kind)
394 fprintf (dumpfile, "_%d", p->ts.kind);
395 break;
396
397 case BT_CHARACTER:
398 show_char_const (p->value.character.string,
399 p->value.character.length);
400 break;
401
402 case BT_COMPLEX:
403 fputs ("(complex ", dumpfile);
404
405 mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
406 if (p->ts.kind != gfc_default_complex_kind)
407 fprintf (dumpfile, "_%d", p->ts.kind);
408
409 fputc (' ', dumpfile);
410
411 mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE);
412 if (p->ts.kind != gfc_default_complex_kind)
413 fprintf (dumpfile, "_%d", p->ts.kind);
414
415 fputc (')', dumpfile);
416 break;
417
418 case BT_HOLLERITH:
419 fprintf (dumpfile, "%dH", p->representation.length);
420 c = p->representation.string;
421 for (i = 0; i < p->representation.length; i++, c++)
422 {
423 fputc (*c, dumpfile);
424 }
425 break;
426
427 default:
428 fputs ("???", dumpfile);
429 break;
430 }
431
432 if (p->representation.string)
433 {
434 fputs (" {", dumpfile);
435 c = p->representation.string;
436 for (i = 0; i < p->representation.length; i++, c++)
437 {
438 fprintf (dumpfile, "%.2x", (unsigned int) *c);
439 if (i < p->representation.length - 1)
440 fputc (',', dumpfile);
441 }
442 fputc ('}', dumpfile);
443 }
444
445 break;
446
447 case EXPR_VARIABLE:
448 if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
449 fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
450 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
451 show_ref (p->ref);
452 break;
453
454 case EXPR_OP:
455 fputc ('(', dumpfile);
456 switch (p->value.op.op)
457 {
458 case INTRINSIC_UPLUS:
459 fputs ("U+ ", dumpfile);
460 break;
461 case INTRINSIC_UMINUS:
462 fputs ("U- ", dumpfile);
463 break;
464 case INTRINSIC_PLUS:
465 fputs ("+ ", dumpfile);
466 break;
467 case INTRINSIC_MINUS:
468 fputs ("- ", dumpfile);
469 break;
470 case INTRINSIC_TIMES:
471 fputs ("* ", dumpfile);
472 break;
473 case INTRINSIC_DIVIDE:
474 fputs ("/ ", dumpfile);
475 break;
476 case INTRINSIC_POWER:
477 fputs ("** ", dumpfile);
478 break;
479 case INTRINSIC_CONCAT:
480 fputs ("// ", dumpfile);
481 break;
482 case INTRINSIC_AND:
483 fputs ("AND ", dumpfile);
484 break;
485 case INTRINSIC_OR:
486 fputs ("OR ", dumpfile);
487 break;
488 case INTRINSIC_EQV:
489 fputs ("EQV ", dumpfile);
490 break;
491 case INTRINSIC_NEQV:
492 fputs ("NEQV ", dumpfile);
493 break;
494 case INTRINSIC_EQ:
495 case INTRINSIC_EQ_OS:
496 fputs ("= ", dumpfile);
497 break;
498 case INTRINSIC_NE:
499 case INTRINSIC_NE_OS:
500 fputs ("/= ", dumpfile);
501 break;
502 case INTRINSIC_GT:
503 case INTRINSIC_GT_OS:
504 fputs ("> ", dumpfile);
505 break;
506 case INTRINSIC_GE:
507 case INTRINSIC_GE_OS:
508 fputs (">= ", dumpfile);
509 break;
510 case INTRINSIC_LT:
511 case INTRINSIC_LT_OS:
512 fputs ("< ", dumpfile);
513 break;
514 case INTRINSIC_LE:
515 case INTRINSIC_LE_OS:
516 fputs ("<= ", dumpfile);
517 break;
518 case INTRINSIC_NOT:
519 fputs ("NOT ", dumpfile);
520 break;
521 case INTRINSIC_PARENTHESES:
522 fputs ("parens", dumpfile);
523 break;
524
525 default:
526 gfc_internal_error
527 ("show_expr(): Bad intrinsic in expression!");
528 }
529
530 show_expr (p->value.op.op1);
531
532 if (p->value.op.op2)
533 {
534 fputc (' ', dumpfile);
535 show_expr (p->value.op.op2);
536 }
537
538 fputc (')', dumpfile);
539 break;
540
541 case EXPR_FUNCTION:
542 if (p->value.function.name == NULL)
543 {
544 fprintf (dumpfile, "%s", p->symtree->n.sym->name);
545 if (is_proc_ptr_comp (p, NULL))
546 show_ref (p->ref);
547 fputc ('[', dumpfile);
548 show_actual_arglist (p->value.function.actual);
549 fputc (']', dumpfile);
550 }
551 else
552 {
553 fprintf (dumpfile, "%s", p->value.function.name);
554 if (is_proc_ptr_comp (p, NULL))
555 show_ref (p->ref);
556 fputc ('[', dumpfile);
557 fputc ('[', dumpfile);
558 show_actual_arglist (p->value.function.actual);
559 fputc (']', dumpfile);
560 fputc (']', dumpfile);
561 }
562
563 break;
564
565 case EXPR_COMPCALL:
566 show_compcall (p);
567 break;
568
569 default:
570 gfc_internal_error ("show_expr(): Don't know how to show expr");
571 }
572 }
573
574 /* Show symbol attributes. The flavor and intent are followed by
575 whatever single bit attributes are present. */
576
577 static void
578 show_attr (symbol_attribute *attr)
579 {
580
581 fprintf (dumpfile, "(%s %s %s %s %s",
582 gfc_code2string (flavors, attr->flavor),
583 gfc_intent_string (attr->intent),
584 gfc_code2string (access_types, attr->access),
585 gfc_code2string (procedures, attr->proc),
586 gfc_code2string (save_status, attr->save));
587
588 if (attr->allocatable)
589 fputs (" ALLOCATABLE", dumpfile);
590 if (attr->dimension)
591 fputs (" DIMENSION", dumpfile);
592 if (attr->external)
593 fputs (" EXTERNAL", dumpfile);
594 if (attr->intrinsic)
595 fputs (" INTRINSIC", dumpfile);
596 if (attr->optional)
597 fputs (" OPTIONAL", dumpfile);
598 if (attr->pointer)
599 fputs (" POINTER", dumpfile);
600 if (attr->is_protected)
601 fputs (" PROTECTED", dumpfile);
602 if (attr->value)
603 fputs (" VALUE", dumpfile);
604 if (attr->volatile_)
605 fputs (" VOLATILE", dumpfile);
606 if (attr->threadprivate)
607 fputs (" THREADPRIVATE", dumpfile);
608 if (attr->target)
609 fputs (" TARGET", dumpfile);
610 if (attr->dummy)
611 fputs (" DUMMY", dumpfile);
612 if (attr->result)
613 fputs (" RESULT", dumpfile);
614 if (attr->entry)
615 fputs (" ENTRY", dumpfile);
616 if (attr->is_bind_c)
617 fputs (" BIND(C)", dumpfile);
618
619 if (attr->data)
620 fputs (" DATA", dumpfile);
621 if (attr->use_assoc)
622 fputs (" USE-ASSOC", dumpfile);
623 if (attr->in_namelist)
624 fputs (" IN-NAMELIST", dumpfile);
625 if (attr->in_common)
626 fputs (" IN-COMMON", dumpfile);
627
628 if (attr->abstract)
629 fputs (" ABSTRACT", dumpfile);
630 if (attr->function)
631 fputs (" FUNCTION", dumpfile);
632 if (attr->subroutine)
633 fputs (" SUBROUTINE", dumpfile);
634 if (attr->implicit_type)
635 fputs (" IMPLICIT-TYPE", dumpfile);
636
637 if (attr->sequence)
638 fputs (" SEQUENCE", dumpfile);
639 if (attr->elemental)
640 fputs (" ELEMENTAL", dumpfile);
641 if (attr->pure)
642 fputs (" PURE", dumpfile);
643 if (attr->recursive)
644 fputs (" RECURSIVE", dumpfile);
645
646 fputc (')', dumpfile);
647 }
648
649
650 /* Show components of a derived type. */
651
652 static void
653 show_components (gfc_symbol *sym)
654 {
655 gfc_component *c;
656
657 for (c = sym->components; c; c = c->next)
658 {
659 fprintf (dumpfile, "(%s ", c->name);
660 show_typespec (&c->ts);
661 if (c->attr.pointer)
662 fputs (" POINTER", dumpfile);
663 if (c->attr.proc_pointer)
664 fputs (" PPC", dumpfile);
665 if (c->attr.dimension)
666 fputs (" DIMENSION", dumpfile);
667 fputc (' ', dumpfile);
668 show_array_spec (c->as);
669 if (c->attr.access)
670 fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
671 fputc (')', dumpfile);
672 if (c->next != NULL)
673 fputc (' ', dumpfile);
674 }
675 }
676
677
678 /* Show the f2k_derived namespace with procedure bindings. */
679
680 static void
681 show_typebound (gfc_symtree* st)
682 {
683 gcc_assert (st->n.tb);
684 show_indent ();
685
686 if (st->n.tb->is_generic)
687 fputs ("GENERIC", dumpfile);
688 else
689 {
690 fputs ("PROCEDURE, ", dumpfile);
691 if (st->n.tb->nopass)
692 fputs ("NOPASS", dumpfile);
693 else
694 {
695 if (st->n.tb->pass_arg)
696 fprintf (dumpfile, "PASS(%s)", st->n.tb->pass_arg);
697 else
698 fputs ("PASS", dumpfile);
699 }
700 if (st->n.tb->non_overridable)
701 fputs (", NON_OVERRIDABLE", dumpfile);
702 }
703
704 if (st->n.tb->access == ACCESS_PUBLIC)
705 fputs (", PUBLIC", dumpfile);
706 else
707 fputs (", PRIVATE", dumpfile);
708
709 fprintf (dumpfile, " :: %s => ", st->name);
710
711 if (st->n.tb->is_generic)
712 {
713 gfc_tbp_generic* g;
714 for (g = st->n.tb->u.generic; g; g = g->next)
715 {
716 fputs (g->specific_st->name, dumpfile);
717 if (g->next)
718 fputs (", ", dumpfile);
719 }
720 }
721 else
722 fputs (st->n.tb->u.specific->n.sym->name, dumpfile);
723 }
724
725 static void
726 show_f2k_derived (gfc_namespace* f2k)
727 {
728 gfc_finalizer* f;
729
730 ++show_level;
731
732 /* Finalizer bindings. */
733 for (f = f2k->finalizers; f; f = f->next)
734 {
735 show_indent ();
736 fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
737 }
738
739 /* Type-bound procedures. */
740 gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound);
741
742 --show_level;
743 }
744
745
746 /* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
747 show the interface. Information needed to reconstruct the list of
748 specific interfaces associated with a generic symbol is done within
749 that symbol. */
750
751 static void
752 show_symbol (gfc_symbol *sym)
753 {
754 gfc_formal_arglist *formal;
755 gfc_interface *intr;
756
757 if (sym == NULL)
758 return;
759
760 show_indent ();
761
762 fprintf (dumpfile, "symbol %s ", sym->name);
763 show_typespec (&sym->ts);
764 show_attr (&sym->attr);
765
766 if (sym->value)
767 {
768 show_indent ();
769 fputs ("value: ", dumpfile);
770 show_expr (sym->value);
771 }
772
773 if (sym->as)
774 {
775 show_indent ();
776 fputs ("Array spec:", dumpfile);
777 show_array_spec (sym->as);
778 }
779
780 if (sym->generic)
781 {
782 show_indent ();
783 fputs ("Generic interfaces:", dumpfile);
784 for (intr = sym->generic; intr; intr = intr->next)
785 fprintf (dumpfile, " %s", intr->sym->name);
786 }
787
788 if (sym->result)
789 {
790 show_indent ();
791 fprintf (dumpfile, "result: %s", sym->result->name);
792 }
793
794 if (sym->components)
795 {
796 show_indent ();
797 fputs ("components: ", dumpfile);
798 show_components (sym);
799 }
800
801 if (sym->f2k_derived)
802 {
803 show_indent ();
804 fputs ("Procedure bindings:\n", dumpfile);
805 show_f2k_derived (sym->f2k_derived);
806 }
807
808 if (sym->formal)
809 {
810 show_indent ();
811 fputs ("Formal arglist:", dumpfile);
812
813 for (formal = sym->formal; formal; formal = formal->next)
814 {
815 if (formal->sym != NULL)
816 fprintf (dumpfile, " %s", formal->sym->name);
817 else
818 fputs (" [Alt Return]", dumpfile);
819 }
820 }
821
822 if (sym->formal_ns)
823 {
824 show_indent ();
825 fputs ("Formal namespace", dumpfile);
826 show_namespace (sym->formal_ns);
827 }
828
829 fputc ('\n', dumpfile);
830 }
831
832
833 /* Show a user-defined operator. Just prints an operator
834 and the name of the associated subroutine, really. */
835
836 static void
837 show_uop (gfc_user_op *uop)
838 {
839 gfc_interface *intr;
840
841 show_indent ();
842 fprintf (dumpfile, "%s:", uop->name);
843
844 for (intr = uop->op; intr; intr = intr->next)
845 fprintf (dumpfile, " %s", intr->sym->name);
846 }
847
848
849 /* Workhorse function for traversing the user operator symtree. */
850
851 static void
852 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
853 {
854 if (st == NULL)
855 return;
856
857 (*func) (st->n.uop);
858
859 traverse_uop (st->left, func);
860 traverse_uop (st->right, func);
861 }
862
863
864 /* Traverse the tree of user operator nodes. */
865
866 void
867 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
868 {
869 traverse_uop (ns->uop_root, func);
870 }
871
872
873 /* Function to display a common block. */
874
875 static void
876 show_common (gfc_symtree *st)
877 {
878 gfc_symbol *s;
879
880 show_indent ();
881 fprintf (dumpfile, "common: /%s/ ", st->name);
882
883 s = st->n.common->head;
884 while (s)
885 {
886 fprintf (dumpfile, "%s", s->name);
887 s = s->common_next;
888 if (s)
889 fputs (", ", dumpfile);
890 }
891 fputc ('\n', dumpfile);
892 }
893
894
895 /* Worker function to display the symbol tree. */
896
897 static void
898 show_symtree (gfc_symtree *st)
899 {
900 show_indent ();
901 fprintf (dumpfile, "symtree: %s Ambig %d", st->name, st->ambiguous);
902
903 if (st->n.sym->ns != gfc_current_ns)
904 fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
905 else
906 show_symbol (st->n.sym);
907 }
908
909
910 /******************* Show gfc_code structures **************/
911
912
913 /* Show a list of code structures. Mutually recursive with
914 show_code_node(). */
915
916 static void
917 show_code (int level, gfc_code *c)
918 {
919 for (; c; c = c->next)
920 show_code_node (level, c);
921 }
922
923 static void
924 show_namelist (gfc_namelist *n)
925 {
926 for (; n->next; n = n->next)
927 fprintf (dumpfile, "%s,", n->sym->name);
928 fprintf (dumpfile, "%s", n->sym->name);
929 }
930
931 /* Show a single OpenMP directive node and everything underneath it
932 if necessary. */
933
934 static void
935 show_omp_node (int level, gfc_code *c)
936 {
937 gfc_omp_clauses *omp_clauses = NULL;
938 const char *name = NULL;
939
940 switch (c->op)
941 {
942 case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
943 case EXEC_OMP_BARRIER: name = "BARRIER"; break;
944 case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
945 case EXEC_OMP_FLUSH: name = "FLUSH"; break;
946 case EXEC_OMP_DO: name = "DO"; break;
947 case EXEC_OMP_MASTER: name = "MASTER"; break;
948 case EXEC_OMP_ORDERED: name = "ORDERED"; break;
949 case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
950 case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
951 case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
952 case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
953 case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
954 case EXEC_OMP_SINGLE: name = "SINGLE"; break;
955 case EXEC_OMP_TASK: name = "TASK"; break;
956 case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
957 case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
958 default:
959 gcc_unreachable ();
960 }
961 fprintf (dumpfile, "!$OMP %s", name);
962 switch (c->op)
963 {
964 case EXEC_OMP_DO:
965 case EXEC_OMP_PARALLEL:
966 case EXEC_OMP_PARALLEL_DO:
967 case EXEC_OMP_PARALLEL_SECTIONS:
968 case EXEC_OMP_SECTIONS:
969 case EXEC_OMP_SINGLE:
970 case EXEC_OMP_WORKSHARE:
971 case EXEC_OMP_PARALLEL_WORKSHARE:
972 case EXEC_OMP_TASK:
973 omp_clauses = c->ext.omp_clauses;
974 break;
975 case EXEC_OMP_CRITICAL:
976 if (c->ext.omp_name)
977 fprintf (dumpfile, " (%s)", c->ext.omp_name);
978 break;
979 case EXEC_OMP_FLUSH:
980 if (c->ext.omp_namelist)
981 {
982 fputs (" (", dumpfile);
983 show_namelist (c->ext.omp_namelist);
984 fputc (')', dumpfile);
985 }
986 return;
987 case EXEC_OMP_BARRIER:
988 case EXEC_OMP_TASKWAIT:
989 return;
990 default:
991 break;
992 }
993 if (omp_clauses)
994 {
995 int list_type;
996
997 if (omp_clauses->if_expr)
998 {
999 fputs (" IF(", dumpfile);
1000 show_expr (omp_clauses->if_expr);
1001 fputc (')', dumpfile);
1002 }
1003 if (omp_clauses->num_threads)
1004 {
1005 fputs (" NUM_THREADS(", dumpfile);
1006 show_expr (omp_clauses->num_threads);
1007 fputc (')', dumpfile);
1008 }
1009 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1010 {
1011 const char *type;
1012 switch (omp_clauses->sched_kind)
1013 {
1014 case OMP_SCHED_STATIC: type = "STATIC"; break;
1015 case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1016 case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1017 case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1018 case OMP_SCHED_AUTO: type = "AUTO"; break;
1019 default:
1020 gcc_unreachable ();
1021 }
1022 fprintf (dumpfile, " SCHEDULE (%s", type);
1023 if (omp_clauses->chunk_size)
1024 {
1025 fputc (',', dumpfile);
1026 show_expr (omp_clauses->chunk_size);
1027 }
1028 fputc (')', dumpfile);
1029 }
1030 if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1031 {
1032 const char *type;
1033 switch (omp_clauses->default_sharing)
1034 {
1035 case OMP_DEFAULT_NONE: type = "NONE"; break;
1036 case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1037 case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1038 case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1039 default:
1040 gcc_unreachable ();
1041 }
1042 fprintf (dumpfile, " DEFAULT(%s)", type);
1043 }
1044 if (omp_clauses->ordered)
1045 fputs (" ORDERED", dumpfile);
1046 if (omp_clauses->untied)
1047 fputs (" UNTIED", dumpfile);
1048 if (omp_clauses->collapse)
1049 fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1050 for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1051 if (omp_clauses->lists[list_type] != NULL
1052 && list_type != OMP_LIST_COPYPRIVATE)
1053 {
1054 const char *type;
1055 if (list_type >= OMP_LIST_REDUCTION_FIRST)
1056 {
1057 switch (list_type)
1058 {
1059 case OMP_LIST_PLUS: type = "+"; break;
1060 case OMP_LIST_MULT: type = "*"; break;
1061 case OMP_LIST_SUB: type = "-"; break;
1062 case OMP_LIST_AND: type = ".AND."; break;
1063 case OMP_LIST_OR: type = ".OR."; break;
1064 case OMP_LIST_EQV: type = ".EQV."; break;
1065 case OMP_LIST_NEQV: type = ".NEQV."; break;
1066 case OMP_LIST_MAX: type = "MAX"; break;
1067 case OMP_LIST_MIN: type = "MIN"; break;
1068 case OMP_LIST_IAND: type = "IAND"; break;
1069 case OMP_LIST_IOR: type = "IOR"; break;
1070 case OMP_LIST_IEOR: type = "IEOR"; break;
1071 default:
1072 gcc_unreachable ();
1073 }
1074 fprintf (dumpfile, " REDUCTION(%s:", type);
1075 }
1076 else
1077 {
1078 switch (list_type)
1079 {
1080 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1081 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1082 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1083 case OMP_LIST_SHARED: type = "SHARED"; break;
1084 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1085 default:
1086 gcc_unreachable ();
1087 }
1088 fprintf (dumpfile, " %s(", type);
1089 }
1090 show_namelist (omp_clauses->lists[list_type]);
1091 fputc (')', dumpfile);
1092 }
1093 }
1094 fputc ('\n', dumpfile);
1095 if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1096 {
1097 gfc_code *d = c->block;
1098 while (d != NULL)
1099 {
1100 show_code (level + 1, d->next);
1101 if (d->block == NULL)
1102 break;
1103 code_indent (level, 0);
1104 fputs ("!$OMP SECTION\n", dumpfile);
1105 d = d->block;
1106 }
1107 }
1108 else
1109 show_code (level + 1, c->block->next);
1110 if (c->op == EXEC_OMP_ATOMIC)
1111 return;
1112 code_indent (level, 0);
1113 fprintf (dumpfile, "!$OMP END %s", name);
1114 if (omp_clauses != NULL)
1115 {
1116 if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1117 {
1118 fputs (" COPYPRIVATE(", dumpfile);
1119 show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1120 fputc (')', dumpfile);
1121 }
1122 else if (omp_clauses->nowait)
1123 fputs (" NOWAIT", dumpfile);
1124 }
1125 else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1126 fprintf (dumpfile, " (%s)", c->ext.omp_name);
1127 }
1128
1129
1130 /* Show a single code node and everything underneath it if necessary. */
1131
1132 static void
1133 show_code_node (int level, gfc_code *c)
1134 {
1135 gfc_forall_iterator *fa;
1136 gfc_open *open;
1137 gfc_case *cp;
1138 gfc_alloc *a;
1139 gfc_code *d;
1140 gfc_close *close;
1141 gfc_filepos *fp;
1142 gfc_inquire *i;
1143 gfc_dt *dt;
1144
1145 code_indent (level, c->here);
1146
1147 switch (c->op)
1148 {
1149 case EXEC_END_PROCEDURE:
1150 break;
1151
1152 case EXEC_NOP:
1153 fputs ("NOP", dumpfile);
1154 break;
1155
1156 case EXEC_CONTINUE:
1157 fputs ("CONTINUE", dumpfile);
1158 break;
1159
1160 case EXEC_ENTRY:
1161 fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1162 break;
1163
1164 case EXEC_INIT_ASSIGN:
1165 case EXEC_ASSIGN:
1166 fputs ("ASSIGN ", dumpfile);
1167 show_expr (c->expr1);
1168 fputc (' ', dumpfile);
1169 show_expr (c->expr2);
1170 break;
1171
1172 case EXEC_LABEL_ASSIGN:
1173 fputs ("LABEL ASSIGN ", dumpfile);
1174 show_expr (c->expr1);
1175 fprintf (dumpfile, " %d", c->label1->value);
1176 break;
1177
1178 case EXEC_POINTER_ASSIGN:
1179 fputs ("POINTER ASSIGN ", dumpfile);
1180 show_expr (c->expr1);
1181 fputc (' ', dumpfile);
1182 show_expr (c->expr2);
1183 break;
1184
1185 case EXEC_GOTO:
1186 fputs ("GOTO ", dumpfile);
1187 if (c->label1)
1188 fprintf (dumpfile, "%d", c->label1->value);
1189 else
1190 {
1191 show_expr (c->expr1);
1192 d = c->block;
1193 if (d != NULL)
1194 {
1195 fputs (", (", dumpfile);
1196 for (; d; d = d ->block)
1197 {
1198 code_indent (level, d->label1);
1199 if (d->block != NULL)
1200 fputc (',', dumpfile);
1201 else
1202 fputc (')', dumpfile);
1203 }
1204 }
1205 }
1206 break;
1207
1208 case EXEC_CALL:
1209 case EXEC_ASSIGN_CALL:
1210 if (c->resolved_sym)
1211 fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1212 else if (c->symtree)
1213 fprintf (dumpfile, "CALL %s ", c->symtree->name);
1214 else
1215 fputs ("CALL ?? ", dumpfile);
1216
1217 show_actual_arglist (c->ext.actual);
1218 break;
1219
1220 case EXEC_COMPCALL:
1221 fputs ("CALL ", dumpfile);
1222 show_compcall (c->expr1);
1223 break;
1224
1225 case EXEC_CALL_PPC:
1226 fputs ("CALL ", dumpfile);
1227 show_expr (c->expr1);
1228 show_actual_arglist (c->ext.actual);
1229 break;
1230
1231 case EXEC_RETURN:
1232 fputs ("RETURN ", dumpfile);
1233 if (c->expr1)
1234 show_expr (c->expr1);
1235 break;
1236
1237 case EXEC_PAUSE:
1238 fputs ("PAUSE ", dumpfile);
1239
1240 if (c->expr1 != NULL)
1241 show_expr (c->expr1);
1242 else
1243 fprintf (dumpfile, "%d", c->ext.stop_code);
1244
1245 break;
1246
1247 case EXEC_STOP:
1248 fputs ("STOP ", dumpfile);
1249
1250 if (c->expr1 != NULL)
1251 show_expr (c->expr1);
1252 else
1253 fprintf (dumpfile, "%d", c->ext.stop_code);
1254
1255 break;
1256
1257 case EXEC_ARITHMETIC_IF:
1258 fputs ("IF ", dumpfile);
1259 show_expr (c->expr1);
1260 fprintf (dumpfile, " %d, %d, %d",
1261 c->label1->value, c->label2->value, c->label3->value);
1262 break;
1263
1264 case EXEC_IF:
1265 d = c->block;
1266 fputs ("IF ", dumpfile);
1267 show_expr (d->expr1);
1268 fputc ('\n', dumpfile);
1269 show_code (level + 1, d->next);
1270
1271 d = d->block;
1272 for (; d; d = d->block)
1273 {
1274 code_indent (level, 0);
1275
1276 if (d->expr1 == NULL)
1277 fputs ("ELSE\n", dumpfile);
1278 else
1279 {
1280 fputs ("ELSE IF ", dumpfile);
1281 show_expr (d->expr1);
1282 fputc ('\n', dumpfile);
1283 }
1284
1285 show_code (level + 1, d->next);
1286 }
1287
1288 code_indent (level, c->label1);
1289
1290 fputs ("ENDIF", dumpfile);
1291 break;
1292
1293 case EXEC_SELECT:
1294 d = c->block;
1295 fputs ("SELECT CASE ", dumpfile);
1296 show_expr (c->expr1);
1297 fputc ('\n', dumpfile);
1298
1299 for (; d; d = d->block)
1300 {
1301 code_indent (level, 0);
1302
1303 fputs ("CASE ", dumpfile);
1304 for (cp = d->ext.case_list; cp; cp = cp->next)
1305 {
1306 fputc ('(', dumpfile);
1307 show_expr (cp->low);
1308 fputc (' ', dumpfile);
1309 show_expr (cp->high);
1310 fputc (')', dumpfile);
1311 fputc (' ', dumpfile);
1312 }
1313 fputc ('\n', dumpfile);
1314
1315 show_code (level + 1, d->next);
1316 }
1317
1318 code_indent (level, c->label1);
1319 fputs ("END SELECT", dumpfile);
1320 break;
1321
1322 case EXEC_WHERE:
1323 fputs ("WHERE ", dumpfile);
1324
1325 d = c->block;
1326 show_expr (d->expr1);
1327 fputc ('\n', dumpfile);
1328
1329 show_code (level + 1, d->next);
1330
1331 for (d = d->block; d; d = d->block)
1332 {
1333 code_indent (level, 0);
1334 fputs ("ELSE WHERE ", dumpfile);
1335 show_expr (d->expr1);
1336 fputc ('\n', dumpfile);
1337 show_code (level + 1, d->next);
1338 }
1339
1340 code_indent (level, 0);
1341 fputs ("END WHERE", dumpfile);
1342 break;
1343
1344
1345 case EXEC_FORALL:
1346 fputs ("FORALL ", dumpfile);
1347 for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1348 {
1349 show_expr (fa->var);
1350 fputc (' ', dumpfile);
1351 show_expr (fa->start);
1352 fputc (':', dumpfile);
1353 show_expr (fa->end);
1354 fputc (':', dumpfile);
1355 show_expr (fa->stride);
1356
1357 if (fa->next != NULL)
1358 fputc (',', dumpfile);
1359 }
1360
1361 if (c->expr1 != NULL)
1362 {
1363 fputc (',', dumpfile);
1364 show_expr (c->expr1);
1365 }
1366 fputc ('\n', dumpfile);
1367
1368 show_code (level + 1, c->block->next);
1369
1370 code_indent (level, 0);
1371 fputs ("END FORALL", dumpfile);
1372 break;
1373
1374 case EXEC_DO:
1375 fputs ("DO ", dumpfile);
1376
1377 show_expr (c->ext.iterator->var);
1378 fputc ('=', dumpfile);
1379 show_expr (c->ext.iterator->start);
1380 fputc (' ', dumpfile);
1381 show_expr (c->ext.iterator->end);
1382 fputc (' ', dumpfile);
1383 show_expr (c->ext.iterator->step);
1384 fputc ('\n', dumpfile);
1385
1386 show_code (level + 1, c->block->next);
1387
1388 code_indent (level, 0);
1389 fputs ("END DO", dumpfile);
1390 break;
1391
1392 case EXEC_DO_WHILE:
1393 fputs ("DO WHILE ", dumpfile);
1394 show_expr (c->expr1);
1395 fputc ('\n', dumpfile);
1396
1397 show_code (level + 1, c->block->next);
1398
1399 code_indent (level, c->label1);
1400 fputs ("END DO", dumpfile);
1401 break;
1402
1403 case EXEC_CYCLE:
1404 fputs ("CYCLE", dumpfile);
1405 if (c->symtree)
1406 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1407 break;
1408
1409 case EXEC_EXIT:
1410 fputs ("EXIT", dumpfile);
1411 if (c->symtree)
1412 fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1413 break;
1414
1415 case EXEC_ALLOCATE:
1416 fputs ("ALLOCATE ", dumpfile);
1417 if (c->expr1)
1418 {
1419 fputs (" STAT=", dumpfile);
1420 show_expr (c->expr1);
1421 }
1422
1423 if (c->expr2)
1424 {
1425 fputs (" ERRMSG=", dumpfile);
1426 show_expr (c->expr2);
1427 }
1428
1429 for (a = c->ext.alloc_list; a; a = a->next)
1430 {
1431 fputc (' ', dumpfile);
1432 show_expr (a->expr);
1433 }
1434
1435 break;
1436
1437 case EXEC_DEALLOCATE:
1438 fputs ("DEALLOCATE ", dumpfile);
1439 if (c->expr1)
1440 {
1441 fputs (" STAT=", dumpfile);
1442 show_expr (c->expr1);
1443 }
1444
1445 if (c->expr2)
1446 {
1447 fputs (" ERRMSG=", dumpfile);
1448 show_expr (c->expr2);
1449 }
1450
1451 for (a = c->ext.alloc_list; a; a = a->next)
1452 {
1453 fputc (' ', dumpfile);
1454 show_expr (a->expr);
1455 }
1456
1457 break;
1458
1459 case EXEC_OPEN:
1460 fputs ("OPEN", dumpfile);
1461 open = c->ext.open;
1462
1463 if (open->unit)
1464 {
1465 fputs (" UNIT=", dumpfile);
1466 show_expr (open->unit);
1467 }
1468 if (open->iomsg)
1469 {
1470 fputs (" IOMSG=", dumpfile);
1471 show_expr (open->iomsg);
1472 }
1473 if (open->iostat)
1474 {
1475 fputs (" IOSTAT=", dumpfile);
1476 show_expr (open->iostat);
1477 }
1478 if (open->file)
1479 {
1480 fputs (" FILE=", dumpfile);
1481 show_expr (open->file);
1482 }
1483 if (open->status)
1484 {
1485 fputs (" STATUS=", dumpfile);
1486 show_expr (open->status);
1487 }
1488 if (open->access)
1489 {
1490 fputs (" ACCESS=", dumpfile);
1491 show_expr (open->access);
1492 }
1493 if (open->form)
1494 {
1495 fputs (" FORM=", dumpfile);
1496 show_expr (open->form);
1497 }
1498 if (open->recl)
1499 {
1500 fputs (" RECL=", dumpfile);
1501 show_expr (open->recl);
1502 }
1503 if (open->blank)
1504 {
1505 fputs (" BLANK=", dumpfile);
1506 show_expr (open->blank);
1507 }
1508 if (open->position)
1509 {
1510 fputs (" POSITION=", dumpfile);
1511 show_expr (open->position);
1512 }
1513 if (open->action)
1514 {
1515 fputs (" ACTION=", dumpfile);
1516 show_expr (open->action);
1517 }
1518 if (open->delim)
1519 {
1520 fputs (" DELIM=", dumpfile);
1521 show_expr (open->delim);
1522 }
1523 if (open->pad)
1524 {
1525 fputs (" PAD=", dumpfile);
1526 show_expr (open->pad);
1527 }
1528 if (open->decimal)
1529 {
1530 fputs (" DECIMAL=", dumpfile);
1531 show_expr (open->decimal);
1532 }
1533 if (open->encoding)
1534 {
1535 fputs (" ENCODING=", dumpfile);
1536 show_expr (open->encoding);
1537 }
1538 if (open->round)
1539 {
1540 fputs (" ROUND=", dumpfile);
1541 show_expr (open->round);
1542 }
1543 if (open->sign)
1544 {
1545 fputs (" SIGN=", dumpfile);
1546 show_expr (open->sign);
1547 }
1548 if (open->convert)
1549 {
1550 fputs (" CONVERT=", dumpfile);
1551 show_expr (open->convert);
1552 }
1553 if (open->asynchronous)
1554 {
1555 fputs (" ASYNCHRONOUS=", dumpfile);
1556 show_expr (open->asynchronous);
1557 }
1558 if (open->err != NULL)
1559 fprintf (dumpfile, " ERR=%d", open->err->value);
1560
1561 break;
1562
1563 case EXEC_CLOSE:
1564 fputs ("CLOSE", dumpfile);
1565 close = c->ext.close;
1566
1567 if (close->unit)
1568 {
1569 fputs (" UNIT=", dumpfile);
1570 show_expr (close->unit);
1571 }
1572 if (close->iomsg)
1573 {
1574 fputs (" IOMSG=", dumpfile);
1575 show_expr (close->iomsg);
1576 }
1577 if (close->iostat)
1578 {
1579 fputs (" IOSTAT=", dumpfile);
1580 show_expr (close->iostat);
1581 }
1582 if (close->status)
1583 {
1584 fputs (" STATUS=", dumpfile);
1585 show_expr (close->status);
1586 }
1587 if (close->err != NULL)
1588 fprintf (dumpfile, " ERR=%d", close->err->value);
1589 break;
1590
1591 case EXEC_BACKSPACE:
1592 fputs ("BACKSPACE", dumpfile);
1593 goto show_filepos;
1594
1595 case EXEC_ENDFILE:
1596 fputs ("ENDFILE", dumpfile);
1597 goto show_filepos;
1598
1599 case EXEC_REWIND:
1600 fputs ("REWIND", dumpfile);
1601 goto show_filepos;
1602
1603 case EXEC_FLUSH:
1604 fputs ("FLUSH", dumpfile);
1605
1606 show_filepos:
1607 fp = c->ext.filepos;
1608
1609 if (fp->unit)
1610 {
1611 fputs (" UNIT=", dumpfile);
1612 show_expr (fp->unit);
1613 }
1614 if (fp->iomsg)
1615 {
1616 fputs (" IOMSG=", dumpfile);
1617 show_expr (fp->iomsg);
1618 }
1619 if (fp->iostat)
1620 {
1621 fputs (" IOSTAT=", dumpfile);
1622 show_expr (fp->iostat);
1623 }
1624 if (fp->err != NULL)
1625 fprintf (dumpfile, " ERR=%d", fp->err->value);
1626 break;
1627
1628 case EXEC_INQUIRE:
1629 fputs ("INQUIRE", dumpfile);
1630 i = c->ext.inquire;
1631
1632 if (i->unit)
1633 {
1634 fputs (" UNIT=", dumpfile);
1635 show_expr (i->unit);
1636 }
1637 if (i->file)
1638 {
1639 fputs (" FILE=", dumpfile);
1640 show_expr (i->file);
1641 }
1642
1643 if (i->iomsg)
1644 {
1645 fputs (" IOMSG=", dumpfile);
1646 show_expr (i->iomsg);
1647 }
1648 if (i->iostat)
1649 {
1650 fputs (" IOSTAT=", dumpfile);
1651 show_expr (i->iostat);
1652 }
1653 if (i->exist)
1654 {
1655 fputs (" EXIST=", dumpfile);
1656 show_expr (i->exist);
1657 }
1658 if (i->opened)
1659 {
1660 fputs (" OPENED=", dumpfile);
1661 show_expr (i->opened);
1662 }
1663 if (i->number)
1664 {
1665 fputs (" NUMBER=", dumpfile);
1666 show_expr (i->number);
1667 }
1668 if (i->named)
1669 {
1670 fputs (" NAMED=", dumpfile);
1671 show_expr (i->named);
1672 }
1673 if (i->name)
1674 {
1675 fputs (" NAME=", dumpfile);
1676 show_expr (i->name);
1677 }
1678 if (i->access)
1679 {
1680 fputs (" ACCESS=", dumpfile);
1681 show_expr (i->access);
1682 }
1683 if (i->sequential)
1684 {
1685 fputs (" SEQUENTIAL=", dumpfile);
1686 show_expr (i->sequential);
1687 }
1688
1689 if (i->direct)
1690 {
1691 fputs (" DIRECT=", dumpfile);
1692 show_expr (i->direct);
1693 }
1694 if (i->form)
1695 {
1696 fputs (" FORM=", dumpfile);
1697 show_expr (i->form);
1698 }
1699 if (i->formatted)
1700 {
1701 fputs (" FORMATTED", dumpfile);
1702 show_expr (i->formatted);
1703 }
1704 if (i->unformatted)
1705 {
1706 fputs (" UNFORMATTED=", dumpfile);
1707 show_expr (i->unformatted);
1708 }
1709 if (i->recl)
1710 {
1711 fputs (" RECL=", dumpfile);
1712 show_expr (i->recl);
1713 }
1714 if (i->nextrec)
1715 {
1716 fputs (" NEXTREC=", dumpfile);
1717 show_expr (i->nextrec);
1718 }
1719 if (i->blank)
1720 {
1721 fputs (" BLANK=", dumpfile);
1722 show_expr (i->blank);
1723 }
1724 if (i->position)
1725 {
1726 fputs (" POSITION=", dumpfile);
1727 show_expr (i->position);
1728 }
1729 if (i->action)
1730 {
1731 fputs (" ACTION=", dumpfile);
1732 show_expr (i->action);
1733 }
1734 if (i->read)
1735 {
1736 fputs (" READ=", dumpfile);
1737 show_expr (i->read);
1738 }
1739 if (i->write)
1740 {
1741 fputs (" WRITE=", dumpfile);
1742 show_expr (i->write);
1743 }
1744 if (i->readwrite)
1745 {
1746 fputs (" READWRITE=", dumpfile);
1747 show_expr (i->readwrite);
1748 }
1749 if (i->delim)
1750 {
1751 fputs (" DELIM=", dumpfile);
1752 show_expr (i->delim);
1753 }
1754 if (i->pad)
1755 {
1756 fputs (" PAD=", dumpfile);
1757 show_expr (i->pad);
1758 }
1759 if (i->convert)
1760 {
1761 fputs (" CONVERT=", dumpfile);
1762 show_expr (i->convert);
1763 }
1764 if (i->asynchronous)
1765 {
1766 fputs (" ASYNCHRONOUS=", dumpfile);
1767 show_expr (i->asynchronous);
1768 }
1769 if (i->decimal)
1770 {
1771 fputs (" DECIMAL=", dumpfile);
1772 show_expr (i->decimal);
1773 }
1774 if (i->encoding)
1775 {
1776 fputs (" ENCODING=", dumpfile);
1777 show_expr (i->encoding);
1778 }
1779 if (i->pending)
1780 {
1781 fputs (" PENDING=", dumpfile);
1782 show_expr (i->pending);
1783 }
1784 if (i->round)
1785 {
1786 fputs (" ROUND=", dumpfile);
1787 show_expr (i->round);
1788 }
1789 if (i->sign)
1790 {
1791 fputs (" SIGN=", dumpfile);
1792 show_expr (i->sign);
1793 }
1794 if (i->size)
1795 {
1796 fputs (" SIZE=", dumpfile);
1797 show_expr (i->size);
1798 }
1799 if (i->id)
1800 {
1801 fputs (" ID=", dumpfile);
1802 show_expr (i->id);
1803 }
1804
1805 if (i->err != NULL)
1806 fprintf (dumpfile, " ERR=%d", i->err->value);
1807 break;
1808
1809 case EXEC_IOLENGTH:
1810 fputs ("IOLENGTH ", dumpfile);
1811 show_expr (c->expr1);
1812 goto show_dt_code;
1813 break;
1814
1815 case EXEC_READ:
1816 fputs ("READ", dumpfile);
1817 goto show_dt;
1818
1819 case EXEC_WRITE:
1820 fputs ("WRITE", dumpfile);
1821
1822 show_dt:
1823 dt = c->ext.dt;
1824 if (dt->io_unit)
1825 {
1826 fputs (" UNIT=", dumpfile);
1827 show_expr (dt->io_unit);
1828 }
1829
1830 if (dt->format_expr)
1831 {
1832 fputs (" FMT=", dumpfile);
1833 show_expr (dt->format_expr);
1834 }
1835
1836 if (dt->format_label != NULL)
1837 fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1838 if (dt->namelist)
1839 fprintf (dumpfile, " NML=%s", dt->namelist->name);
1840
1841 if (dt->iomsg)
1842 {
1843 fputs (" IOMSG=", dumpfile);
1844 show_expr (dt->iomsg);
1845 }
1846 if (dt->iostat)
1847 {
1848 fputs (" IOSTAT=", dumpfile);
1849 show_expr (dt->iostat);
1850 }
1851 if (dt->size)
1852 {
1853 fputs (" SIZE=", dumpfile);
1854 show_expr (dt->size);
1855 }
1856 if (dt->rec)
1857 {
1858 fputs (" REC=", dumpfile);
1859 show_expr (dt->rec);
1860 }
1861 if (dt->advance)
1862 {
1863 fputs (" ADVANCE=", dumpfile);
1864 show_expr (dt->advance);
1865 }
1866 if (dt->id)
1867 {
1868 fputs (" ID=", dumpfile);
1869 show_expr (dt->id);
1870 }
1871 if (dt->pos)
1872 {
1873 fputs (" POS=", dumpfile);
1874 show_expr (dt->pos);
1875 }
1876 if (dt->asynchronous)
1877 {
1878 fputs (" ASYNCHRONOUS=", dumpfile);
1879 show_expr (dt->asynchronous);
1880 }
1881 if (dt->blank)
1882 {
1883 fputs (" BLANK=", dumpfile);
1884 show_expr (dt->blank);
1885 }
1886 if (dt->decimal)
1887 {
1888 fputs (" DECIMAL=", dumpfile);
1889 show_expr (dt->decimal);
1890 }
1891 if (dt->delim)
1892 {
1893 fputs (" DELIM=", dumpfile);
1894 show_expr (dt->delim);
1895 }
1896 if (dt->pad)
1897 {
1898 fputs (" PAD=", dumpfile);
1899 show_expr (dt->pad);
1900 }
1901 if (dt->round)
1902 {
1903 fputs (" ROUND=", dumpfile);
1904 show_expr (dt->round);
1905 }
1906 if (dt->sign)
1907 {
1908 fputs (" SIGN=", dumpfile);
1909 show_expr (dt->sign);
1910 }
1911
1912 show_dt_code:
1913 fputc ('\n', dumpfile);
1914 for (c = c->block->next; c; c = c->next)
1915 show_code_node (level + (c->next != NULL), c);
1916 return;
1917
1918 case EXEC_TRANSFER:
1919 fputs ("TRANSFER ", dumpfile);
1920 show_expr (c->expr1);
1921 break;
1922
1923 case EXEC_DT_END:
1924 fputs ("DT_END", dumpfile);
1925 dt = c->ext.dt;
1926
1927 if (dt->err != NULL)
1928 fprintf (dumpfile, " ERR=%d", dt->err->value);
1929 if (dt->end != NULL)
1930 fprintf (dumpfile, " END=%d", dt->end->value);
1931 if (dt->eor != NULL)
1932 fprintf (dumpfile, " EOR=%d", dt->eor->value);
1933 break;
1934
1935 case EXEC_OMP_ATOMIC:
1936 case EXEC_OMP_BARRIER:
1937 case EXEC_OMP_CRITICAL:
1938 case EXEC_OMP_FLUSH:
1939 case EXEC_OMP_DO:
1940 case EXEC_OMP_MASTER:
1941 case EXEC_OMP_ORDERED:
1942 case EXEC_OMP_PARALLEL:
1943 case EXEC_OMP_PARALLEL_DO:
1944 case EXEC_OMP_PARALLEL_SECTIONS:
1945 case EXEC_OMP_PARALLEL_WORKSHARE:
1946 case EXEC_OMP_SECTIONS:
1947 case EXEC_OMP_SINGLE:
1948 case EXEC_OMP_TASK:
1949 case EXEC_OMP_TASKWAIT:
1950 case EXEC_OMP_WORKSHARE:
1951 show_omp_node (level, c);
1952 break;
1953
1954 default:
1955 gfc_internal_error ("show_code_node(): Bad statement code");
1956 }
1957
1958 fputc ('\n', dumpfile);
1959 }
1960
1961
1962 /* Show an equivalence chain. */
1963
1964 static void
1965 show_equiv (gfc_equiv *eq)
1966 {
1967 show_indent ();
1968 fputs ("Equivalence: ", dumpfile);
1969 while (eq)
1970 {
1971 show_expr (eq->expr);
1972 eq = eq->eq;
1973 if (eq)
1974 fputs (", ", dumpfile);
1975 }
1976 }
1977
1978
1979 /* Show a freakin' whole namespace. */
1980
1981 static void
1982 show_namespace (gfc_namespace *ns)
1983 {
1984 gfc_interface *intr;
1985 gfc_namespace *save;
1986 int op;
1987 gfc_equiv *eq;
1988 int i;
1989
1990 save = gfc_current_ns;
1991 show_level++;
1992
1993 show_indent ();
1994 fputs ("Namespace:", dumpfile);
1995
1996 if (ns != NULL)
1997 {
1998 i = 0;
1999 do
2000 {
2001 int l = i;
2002 while (i < GFC_LETTERS - 1
2003 && gfc_compare_types(&ns->default_type[i+1],
2004 &ns->default_type[l]))
2005 i++;
2006
2007 if (i > l)
2008 fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2009 else
2010 fprintf (dumpfile, " %c: ", l+'A');
2011
2012 show_typespec(&ns->default_type[l]);
2013 i++;
2014 } while (i < GFC_LETTERS);
2015
2016 if (ns->proc_name != NULL)
2017 {
2018 show_indent ();
2019 fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2020 }
2021
2022 gfc_current_ns = ns;
2023 gfc_traverse_symtree (ns->common_root, show_common);
2024
2025 gfc_traverse_symtree (ns->sym_root, show_symtree);
2026
2027 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2028 {
2029 /* User operator interfaces */
2030 intr = ns->op[op];
2031 if (intr == NULL)
2032 continue;
2033
2034 show_indent ();
2035 fprintf (dumpfile, "Operator interfaces for %s:",
2036 gfc_op2string ((gfc_intrinsic_op) op));
2037
2038 for (; intr; intr = intr->next)
2039 fprintf (dumpfile, " %s", intr->sym->name);
2040 }
2041
2042 if (ns->uop_root != NULL)
2043 {
2044 show_indent ();
2045 fputs ("User operators:\n", dumpfile);
2046 gfc_traverse_user_op (ns, show_uop);
2047 }
2048 }
2049
2050 for (eq = ns->equiv; eq; eq = eq->next)
2051 show_equiv (eq);
2052
2053 fputc ('\n', dumpfile);
2054 fputc ('\n', dumpfile);
2055
2056 show_code (0, ns->code);
2057
2058 for (ns = ns->contained; ns; ns = ns->sibling)
2059 {
2060 show_indent ();
2061 fputs ("CONTAINS\n", dumpfile);
2062 show_namespace (ns);
2063 }
2064
2065 show_level--;
2066 fputc ('\n', dumpfile);
2067 gfc_current_ns = save;
2068 }
2069
2070
2071 /* Main function for dumping a parse tree. */
2072
2073 void
2074 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2075 {
2076 dumpfile = file;
2077 show_namespace (ns);
2078 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org