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