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