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