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