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