gcc/fortran/dump-parse-tree.c

   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 /* Do indentation for a specific level.  */
  41
  42 static inline void
  43 code_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.  */
  59
  60 static inline void
  61 show_indent (void)
  62 {
  63   gfc_status ("\n");
  64   code_indent (show_level, NULL);
  65 }
  66
  67
  68 /* Show type-specific information.  */
  69
  70 void
  71 gfc_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
  97 void
  98 gfc_show_actual_arglist (gfc_actual_arglist * a)
  99 {
 100
 101   gfc_status ("(");
 102
 103   for (; a; a = a->next)
 104     {
 105       gfc_status_char ('(');
 106       if (a->name != NULL)
 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
 122 /* Show a gfc_array_spec array specification structure.  */
 123
 124 void
 125 gfc_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
 165 /* Show a gfc_array_ref array reference structure.  */
 166
 167 void
 168 gfc_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         {
 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
 190           if (ar->start[i] != NULL)
 191             gfc_show_expr (ar->start[i]);
 192
 193           if (ar->dimen_type[i] == DIMEN_RANGE)
 194             {
 195               gfc_status_char (':');
 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                 }
 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
 235 void
 236 gfc_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
 266 void
 267 gfc_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
 299 void
 300 gfc_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:
 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         }
 356       switch (p->ts.type)
 357         {
 358         case BT_INTEGER:
 359           mpz_out_str (stdout, 10, p->value.integer);
 360
 361           if (p->ts.kind != gfc_default_integer_kind)
 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:
 373           mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
 374           if (p->ts.kind != gfc_default_real_kind)
 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
 398           mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
 399           if (p->ts.kind != gfc_default_complex_kind)
 400             gfc_status ("_%d", p->ts.kind);
 401
 402           gfc_status (" ");
 403
 404           mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE);
 405           if (p->ts.kind != gfc_default_complex_kind)
 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:
 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);
 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 ("(");
 427       switch (p->value.op.operator)
 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;
 486         case INTRINSIC_PARENTHESES:
 487           gfc_status ("parens");
 488           break;
 489
 490         default:
 491           gfc_internal_error
 492             ("gfc_show_expr(): Bad intrinsic in expression!");
 493         }
 494
 495       gfc_show_expr (p->value.op.op1);
 496
 497       if (p->value.op.op2)
 498         {
 499           gfc_status (" ");
 500           gfc_show_expr (p->value.op.op2);
 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
 532 void
 533 gfc_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->protected)
 554     gfc_status (" PROTECTED");
 555   if (attr->save)
 556     gfc_status (" SAVE");
 557   if (attr->value)
 558     gfc_status (" VALUE");
 559   if (attr->volatile_)
 560     gfc_status (" VOLATILE");
 561   if (attr->threadprivate)
 562     gfc_status (" THREADPRIVATE");
 563   if (attr->target)
 564     gfc_status (" TARGET");
 565   if (attr->dummy)
 566     gfc_status (" DUMMY");
 567   if (attr->result)
 568     gfc_status (" RESULT");
 569   if (attr->entry)
 570     gfc_status (" ENTRY");
 571
 572   if (attr->data)
 573     gfc_status (" DATA");
 574   if (attr->use_assoc)
 575     gfc_status (" USE-ASSOC");
 576   if (attr->in_namelist)
 577     gfc_status (" IN-NAMELIST");
 578   if (attr->in_common)
 579     gfc_status (" IN-COMMON");
 580
 581   if (attr->function)
 582     gfc_status (" FUNCTION");
 583   if (attr->subroutine)
 584     gfc_status (" SUBROUTINE");
 585   if (attr->implicit_type)
 586     gfc_status (" IMPLICIT-TYPE");
 587
 588   if (attr->sequence)
 589     gfc_status (" SEQUENCE");
 590   if (attr->elemental)
 591     gfc_status (" ELEMENTAL");
 592   if (attr->pure)
 593     gfc_status (" PURE");
 594   if (attr->recursive)
 595     gfc_status (" RECURSIVE");
 596
 597   gfc_status (")");
 598 }
 599
 600
 601 /* Show components of a derived type.  */
 602
 603 void
 604 gfc_show_components (gfc_symbol * sym)
 605 {
 606   gfc_component *c;
 607
 608   for (c = sym->components; c; c = c->next)
 609     {
 610       gfc_status ("(%s ", c->name);
 611       gfc_show_typespec (&c->ts);
 612       if (c->pointer)
 613         gfc_status (" POINTER");
 614       if (c->dimension)
 615         gfc_status (" DIMENSION");
 616       gfc_status_char (' ');
 617       gfc_show_array_spec (c->as);
 618       gfc_status (")");
 619       if (c->next != NULL)
 620         gfc_status_char (' ');
 621     }
 622 }
 623
 624
 625 /* Show a symbol.  If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
 626    show the interface.  Information needed to reconstruct the list of
 627    specific interfaces associated with a generic symbol is done within
 628    that symbol.  */
 629
 630 void
 631 gfc_show_symbol (gfc_symbol * sym)
 632 {
 633   gfc_formal_arglist *formal;
 634   gfc_interface *intr;
 635
 636   if (sym == NULL)
 637     return;
 638
 639   show_indent ();
 640
 641   gfc_status ("symbol %s ", sym->name);
 642   gfc_show_typespec (&sym->ts);
 643   gfc_show_attr (&sym->attr);
 644
 645   if (sym->value)
 646     {
 647       show_indent ();
 648       gfc_status ("value: ");
 649       gfc_show_expr (sym->value);
 650     }
 651
 652   if (sym->as)
 653     {
 654       show_indent ();
 655       gfc_status ("Array spec:");
 656       gfc_show_array_spec (sym->as);
 657     }
 658
 659   if (sym->generic)
 660     {
 661       show_indent ();
 662       gfc_status ("Generic interfaces:");
 663       for (intr = sym->generic; intr; intr = intr->next)
 664         gfc_status (" %s", intr->sym->name);
 665     }
 666
 667   if (sym->result)
 668     {
 669       show_indent ();
 670       gfc_status ("result: %s", sym->result->name);
 671     }
 672
 673   if (sym->components)
 674     {
 675       show_indent ();
 676       gfc_status ("components: ");
 677       gfc_show_components (sym);
 678     }
 679
 680   if (sym->formal)
 681     {
 682       show_indent ();
 683       gfc_status ("Formal arglist:");
 684
 685       for (formal = sym->formal; formal; formal = formal->next)
 686         {
 687           if (formal->sym != NULL)
 688             gfc_status (" %s", formal->sym->name);
 689           else
 690             gfc_status (" [Alt Return]");
 691         }
 692     }
 693
 694   if (sym->formal_ns)
 695     {
 696       show_indent ();
 697       gfc_status ("Formal namespace");
 698       gfc_show_namespace (sym->formal_ns);
 699     }
 700
 701   gfc_status_char ('\n');
 702 }
 703
 704
 705 /* Show a user-defined operator.  Just prints an operator
 706    and the name of the associated subroutine, really.  */
 707
 708 static void
 709 show_uop (gfc_user_op * uop)
 710 {
 711   gfc_interface *intr;
 712
 713   show_indent ();
 714   gfc_status ("%s:", uop->name);
 715
 716   for (intr = uop->operator; intr; intr = intr->next)
 717     gfc_status (" %s", intr->sym->name);
 718 }
 719
 720
 721 /* Workhorse function for traversing the user operator symtree.  */
 722
 723 static void
 724 traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
 725 {
 726
 727   if (st == NULL)
 728     return;
 729
 730   (*func) (st->n.uop);
 731
 732   traverse_uop (st->left, func);
 733   traverse_uop (st->right, func);
 734 }
 735
 736
 737 /* Traverse the tree of user operator nodes.  */
 738
 739 void
 740 gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
 741 {
 742
 743   traverse_uop (ns->uop_root, func);
 744 }
 745
 746
 747 /* Function to display a common block.  */
 748
 749 static void
 750 show_common (gfc_symtree * st)
 751 {
 752   gfc_symbol *s;
 753
 754   show_indent ();
 755   gfc_status ("common: /%s/ ", st->name);
 756
 757   s = st->n.common->head;
 758   while (s)
 759     {
 760       gfc_status ("%s", s->name);
 761       s = s->common_next;
 762       if (s)
 763         gfc_status (", ");
 764     }
 765   gfc_status_char ('\n');
 766 }
 767
 768
 769 /* Worker function to display the symbol tree.  */
 770
 771 static void
 772 show_symtree (gfc_symtree * st)
 773 {
 774
 775   show_indent ();
 776   gfc_status ("symtree: %s  Ambig %d", st->name, st->ambiguous);
 777
 778   if (st->n.sym->ns != gfc_current_ns)
 779     gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
 780   else
 781     gfc_show_symbol (st->n.sym);
 782 }
 783
 784
 785 /******************* Show gfc_code structures **************/
 786
 787
 788
 789 static void gfc_show_code_node (int level, gfc_code * c);
 790
 791 /* Show a list of code structures.  Mutually recursive with
 792    gfc_show_code_node().  */
 793
 794 void
 795 gfc_show_code (int level, gfc_code * c)
 796 {
 797
 798   for (; c; c = c->next)
 799     gfc_show_code_node (level, c);
 800 }
 801
 802 void
 803 gfc_show_namelist (gfc_namelist *n)
 804 {
 805   for (; n->next; n = n->next)
 806     gfc_status ("%s,", n->sym->name);
 807   gfc_status ("%s", n->sym->name);
 808 }
 809
 810 /* Show a single OpenMP directive node and everything underneath it
 811    if necessary.  */
 812
 813 static void
 814 gfc_show_omp_node (int level, gfc_code * c)
 815 {
 816   gfc_omp_clauses *omp_clauses = NULL;
 817   const char *name = NULL;
 818
 819   switch (c->op)
 820     {
 821     case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
 822     case EXEC_OMP_BARRIER: name = "BARRIER"; break;
 823     case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
 824     case EXEC_OMP_FLUSH: name = "FLUSH"; break;
 825     case EXEC_OMP_DO: name = "DO"; break;
 826     case EXEC_OMP_MASTER: name = "MASTER"; break;
 827     case EXEC_OMP_ORDERED: name = "ORDERED"; break;
 828     case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
 829     case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
 830     case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
 831     case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
 832     case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
 833     case EXEC_OMP_SINGLE: name = "SINGLE"; break;
 834     case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
 835     default:
 836       gcc_unreachable ();
 837     }
 838   gfc_status ("!$OMP %s", name);
 839   switch (c->op)
 840     {
 841     case EXEC_OMP_DO:
 842     case EXEC_OMP_PARALLEL:
 843     case EXEC_OMP_PARALLEL_DO:
 844     case EXEC_OMP_PARALLEL_SECTIONS:
 845     case EXEC_OMP_SECTIONS:
 846     case EXEC_OMP_SINGLE:
 847     case EXEC_OMP_WORKSHARE:
 848     case EXEC_OMP_PARALLEL_WORKSHARE:
 849       omp_clauses = c->ext.omp_clauses;
 850       break;
 851     case EXEC_OMP_CRITICAL:
 852       if (c->ext.omp_name)
 853         gfc_status (" (%s)", c->ext.omp_name);
 854       break;
 855     case EXEC_OMP_FLUSH:
 856       if (c->ext.omp_namelist)
 857         {
 858           gfc_status (" (");
 859           gfc_show_namelist (c->ext.omp_namelist);
 860           gfc_status_char (')');
 861         }
 862       return;
 863     case EXEC_OMP_BARRIER:
 864       return;
 865     default:
 866       break;
 867     }
 868   if (omp_clauses)
 869     {
 870       int list_type;
 871
 872       if (omp_clauses->if_expr)
 873         {
 874           gfc_status (" IF(");
 875           gfc_show_expr (omp_clauses->if_expr);
 876           gfc_status_char (')');
 877         }
 878       if (omp_clauses->num_threads)
 879         {
 880           gfc_status (" NUM_THREADS(");
 881           gfc_show_expr (omp_clauses->num_threads);
 882           gfc_status_char (')');
 883         }
 884       if (omp_clauses->sched_kind != OMP_SCHED_NONE)
 885         {
 886           const char *type;
 887           switch (omp_clauses->sched_kind)
 888             {
 889             case OMP_SCHED_STATIC: type = "STATIC"; break;
 890             case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
 891             case OMP_SCHED_GUIDED: type = "GUIDED"; break;
 892             case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
 893             default:
 894               gcc_unreachable ();
 895             }
 896           gfc_status (" SCHEDULE (%s", type);
 897           if (omp_clauses->chunk_size)
 898             {
 899               gfc_status_char (',');
 900               gfc_show_expr (omp_clauses->chunk_size);
 901             }
 902           gfc_status_char (')');
 903         }
 904       if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
 905         {
 906           const char *type;
 907           switch (omp_clauses->default_sharing)
 908             {
 909             case OMP_DEFAULT_NONE: type = "NONE"; break;
 910             case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
 911             case OMP_DEFAULT_SHARED: type = "SHARED"; break;
 912             case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
 913             default:
 914               gcc_unreachable ();
 915             }
 916           gfc_status (" DEFAULT(%s)", type);
 917         }
 918       if (omp_clauses->ordered)
 919         gfc_status (" ORDERED");
 920       for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
 921         if (omp_clauses->lists[list_type] != NULL
 922             && list_type != OMP_LIST_COPYPRIVATE)
 923           {
 924             const char *type;
 925             if (list_type >= OMP_LIST_REDUCTION_FIRST)
 926               {
 927                 switch (list_type)
 928                   {
 929                   case OMP_LIST_PLUS: type = "+"; break;
 930                   case OMP_LIST_MULT: type = "*"; break;
 931                   case OMP_LIST_SUB: type = "-"; break;
 932                   case OMP_LIST_AND: type = ".AND."; break;
 933                   case OMP_LIST_OR: type = ".OR."; break;
 934                   case OMP_LIST_EQV: type = ".EQV."; break;
 935                   case OMP_LIST_NEQV: type = ".NEQV."; break;
 936                   case OMP_LIST_MAX: type = "MAX"; break;
 937                   case OMP_LIST_MIN: type = "MIN"; break;
 938                   case OMP_LIST_IAND: type = "IAND"; break;
 939                   case OMP_LIST_IOR: type = "IOR"; break;
 940                   case OMP_LIST_IEOR: type = "IEOR"; break;
 941                   default:
 942                     gcc_unreachable ();
 943                   }
 944                 gfc_status (" REDUCTION(%s:", type);
 945               }
 946             else
 947               {
 948                 switch (list_type)
 949                   {
 950                   case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
 951                   case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
 952                   case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
 953                   case OMP_LIST_SHARED: type = "SHARED"; break;
 954                   case OMP_LIST_COPYIN: type = "COPYIN"; break;
 955                   default:
 956                     gcc_unreachable ();
 957                   }
 958                 gfc_status (" %s(", type);
 959               }
 960             gfc_show_namelist (omp_clauses->lists[list_type]);
 961             gfc_status_char (')');
 962           }
 963     }
 964   gfc_status_char ('\n');
 965   if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
 966     {
 967       gfc_code *d = c->block;
 968       while (d != NULL)
 969         {
 970           gfc_show_code (level + 1, d->next);
 971           if (d->block == NULL)
 972             break;
 973           code_indent (level, 0);
 974           gfc_status ("!$OMP SECTION\n");
 975           d = d->block;
 976         }
 977     }
 978   else
 979     gfc_show_code (level + 1, c->block->next);
 980   if (c->op == EXEC_OMP_ATOMIC)
 981     return;
 982   code_indent (level, 0);
 983   gfc_status ("!$OMP END %s", name);
 984   if (omp_clauses != NULL)
 985     {
 986       if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
 987         {
 988           gfc_status (" COPYPRIVATE(");
 989           gfc_show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
 990           gfc_status_char (')');
 991         }
 992       else if (omp_clauses->nowait)
 993         gfc_status (" NOWAIT");
 994     }
 995   else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
 996     gfc_status (" (%s)", c->ext.omp_name);
 997 }
 998
 999 /* Show a single code node and everything underneath it if necessary.  */
1000
1001 static void
1002 gfc_show_code_node (int level, gfc_code * c)
1003 {
1004   gfc_forall_iterator *fa;
1005   gfc_open *open;
1006   gfc_case *cp;
1007   gfc_alloc *a;
1008   gfc_code *d;
1009   gfc_close *close;
1010   gfc_filepos *fp;
1011   gfc_inquire *i;
1012   gfc_dt *dt;
1013
1014   code_indent (level, c->here);
1015
1016   switch (c->op)
1017     {
1018     case EXEC_NOP:
1019       gfc_status ("NOP");
1020       break;
1021
1022     case EXEC_CONTINUE:
1023       gfc_status ("CONTINUE");
1024       break;
1025
1026     case EXEC_ENTRY:
1027       gfc_status ("ENTRY %s", c->ext.entry->sym->name);
1028       break;
1029
1030     case EXEC_INIT_ASSIGN:
1031     case EXEC_ASSIGN:
1032       gfc_status ("ASSIGN ");
1033       gfc_show_expr (c->expr);
1034       gfc_status_char (' ');
1035       gfc_show_expr (c->expr2);
1036       break;
1037
1038     case EXEC_LABEL_ASSIGN:
1039       gfc_status ("LABEL ASSIGN ");
1040       gfc_show_expr (c->expr);
1041       gfc_status (" %d", c->label->value);
1042       break;
1043
1044     case EXEC_POINTER_ASSIGN:
1045       gfc_status ("POINTER ASSIGN ");
1046       gfc_show_expr (c->expr);
1047       gfc_status_char (' ');
1048       gfc_show_expr (c->expr2);
1049       break;
1050
1051     case EXEC_GOTO:
1052       gfc_status ("GOTO ");
1053       if (c->label)
1054         gfc_status ("%d", c->label->value);
1055       else
1056         {
1057           gfc_show_expr (c->expr);
1058           d = c->block;
1059           if (d != NULL)
1060             {
1061               gfc_status (", (");
1062               for (; d; d = d ->block)
1063                 {
1064                   code_indent (level, d->label);
1065                   if (d->block != NULL)
1066                     gfc_status_char (',');
1067                   else
1068                     gfc_status_char (')');
1069                 }
1070             }
1071         }
1072       break;
1073
1074     case EXEC_CALL:
1075       if (c->resolved_sym)
1076         gfc_status ("CALL %s ", c->resolved_sym->name);
1077       else if (c->symtree)
1078         gfc_status ("CALL %s ", c->symtree->name);
1079       else
1080         gfc_status ("CALL ?? ");
1081
1082       gfc_show_actual_arglist (c->ext.actual);
1083       break;
1084
1085     case EXEC_RETURN:
1086       gfc_status ("RETURN ");
1087       if (c->expr)
1088         gfc_show_expr (c->expr);
1089       break;
1090
1091     case EXEC_PAUSE:
1092       gfc_status ("PAUSE ");
1093
1094       if (c->expr != NULL)
1095         gfc_show_expr (c->expr);
1096       else
1097         gfc_status ("%d", c->ext.stop_code);
1098
1099       break;
1100
1101     case EXEC_STOP:
1102       gfc_status ("STOP ");
1103
1104       if (c->expr != NULL)
1105         gfc_show_expr (c->expr);
1106       else
1107         gfc_status ("%d", c->ext.stop_code);
1108
1109       break;
1110
1111     case EXEC_ARITHMETIC_IF:
1112       gfc_status ("IF ");
1113       gfc_show_expr (c->expr);
1114       gfc_status (" %d, %d, %d",
1115                   c->label->value, c->label2->value, c->label3->value);
1116       break;
1117
1118     case EXEC_IF:
1119       d = c->block;
1120       gfc_status ("IF ");
1121       gfc_show_expr (d->expr);
1122       gfc_status_char ('\n');
1123       gfc_show_code (level + 1, d->next);
1124
1125       d = d->block;
1126       for (; d; d = d->block)
1127         {
1128           code_indent (level, 0);
1129
1130           if (d->expr == NULL)
1131             gfc_status ("ELSE\n");
1132           else
1133             {
1134               gfc_status ("ELSE IF ");
1135               gfc_show_expr (d->expr);
1136               gfc_status_char ('\n');
1137             }
1138
1139           gfc_show_code (level + 1, d->next);
1140         }
1141
1142       code_indent (level, c->label);
1143
1144       gfc_status ("ENDIF");
1145       break;
1146
1147     case EXEC_SELECT:
1148       d = c->block;
1149       gfc_status ("SELECT CASE ");
1150       gfc_show_expr (c->expr);
1151       gfc_status_char ('\n');
1152
1153       for (; d; d = d->block)
1154         {
1155           code_indent (level, 0);
1156
1157           gfc_status ("CASE ");
1158           for (cp = d->ext.case_list; cp; cp = cp->next)
1159             {
1160               gfc_status_char ('(');
1161               gfc_show_expr (cp->low);
1162               gfc_status_char (' ');
1163               gfc_show_expr (cp->high);
1164               gfc_status_char (')');
1165               gfc_status_char (' ');
1166             }
1167           gfc_status_char ('\n');
1168
1169           gfc_show_code (level + 1, d->next);
1170         }
1171
1172       code_indent (level, c->label);
1173       gfc_status ("END SELECT");
1174       break;
1175
1176     case EXEC_WHERE:
1177       gfc_status ("WHERE ");
1178
1179       d = c->block;
1180       gfc_show_expr (d->expr);
1181       gfc_status_char ('\n');
1182
1183       gfc_show_code (level + 1, d->next);
1184
1185       for (d = d->block; d; d = d->block)
1186         {
1187           code_indent (level, 0);
1188           gfc_status ("ELSE WHERE ");
1189           gfc_show_expr (d->expr);
1190           gfc_status_char ('\n');
1191           gfc_show_code (level + 1, d->next);
1192         }
1193
1194       code_indent (level, 0);
1195       gfc_status ("END WHERE");
1196       break;
1197
1198
1199     case EXEC_FORALL:
1200       gfc_status ("FORALL ");
1201       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1202         {
1203           gfc_show_expr (fa->var);
1204           gfc_status_char (' ');
1205           gfc_show_expr (fa->start);
1206           gfc_status_char (':');
1207           gfc_show_expr (fa->end);
1208           gfc_status_char (':');
1209           gfc_show_expr (fa->stride);
1210
1211           if (fa->next != NULL)
1212             gfc_status_char (',');
1213         }
1214
1215       if (c->expr != NULL)
1216         {
1217           gfc_status_char (',');
1218           gfc_show_expr (c->expr);
1219         }
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 FORALL");
1226       break;
1227
1228     case EXEC_DO:
1229       gfc_status ("DO ");
1230
1231       gfc_show_expr (c->ext.iterator->var);
1232       gfc_status_char ('=');
1233       gfc_show_expr (c->ext.iterator->start);
1234       gfc_status_char (' ');
1235       gfc_show_expr (c->ext.iterator->end);
1236       gfc_status_char (' ');
1237       gfc_show_expr (c->ext.iterator->step);
1238       gfc_status_char ('\n');
1239
1240       gfc_show_code (level + 1, c->block->next);
1241
1242       code_indent (level, 0);
1243       gfc_status ("END DO");
1244       break;
1245
1246     case EXEC_DO_WHILE:
1247       gfc_status ("DO WHILE ");
1248       gfc_show_expr (c->expr);
1249       gfc_status_char ('\n');
1250
1251       gfc_show_code (level + 1, c->block->next);
1252
1253       code_indent (level, c->label);
1254       gfc_status ("END DO");
1255       break;
1256
1257     case EXEC_CYCLE:
1258       gfc_status ("CYCLE");
1259       if (c->symtree)
1260         gfc_status (" %s", c->symtree->n.sym->name);
1261       break;
1262
1263     case EXEC_EXIT:
1264       gfc_status ("EXIT");
1265       if (c->symtree)
1266         gfc_status (" %s", c->symtree->n.sym->name);
1267       break;
1268
1269     case EXEC_ALLOCATE:
1270       gfc_status ("ALLOCATE ");
1271       if (c->expr)
1272         {
1273           gfc_status (" STAT=");
1274           gfc_show_expr (c->expr);
1275         }
1276
1277       for (a = c->ext.alloc_list; a; a = a->next)
1278         {
1279           gfc_status_char (' ');
1280           gfc_show_expr (a->expr);
1281         }
1282
1283       break;
1284
1285     case EXEC_DEALLOCATE:
1286       gfc_status ("DEALLOCATE ");
1287       if (c->expr)
1288         {
1289           gfc_status (" STAT=");
1290           gfc_show_expr (c->expr);
1291         }
1292
1293       for (a = c->ext.alloc_list; a; a = a->next)
1294         {
1295           gfc_status_char (' ');
1296           gfc_show_expr (a->expr);
1297         }
1298
1299       break;
1300
1301     case EXEC_OPEN:
1302       gfc_status ("OPEN");
1303       open = c->ext.open;
1304
1305       if (open->unit)
1306         {
1307           gfc_status (" UNIT=");
1308           gfc_show_expr (open->unit);
1309         }
1310       if (open->iomsg)
1311         {
1312           gfc_status (" IOMSG=");
1313           gfc_show_expr (open->iomsg);
1314         }
1315       if (open->iostat)
1316         {
1317           gfc_status (" IOSTAT=");
1318           gfc_show_expr (open->iostat);
1319         }
1320       if (open->file)
1321         {
1322           gfc_status (" FILE=");
1323           gfc_show_expr (open->file);
1324         }
1325       if (open->status)
1326         {
1327           gfc_status (" STATUS=");
1328           gfc_show_expr (open->status);
1329         }
1330       if (open->access)
1331         {
1332           gfc_status (" ACCESS=");
1333           gfc_show_expr (open->access);
1334         }
1335       if (open->form)
1336         {
1337           gfc_status (" FORM=");
1338           gfc_show_expr (open->form);
1339         }
1340       if (open->recl)
1341         {
1342           gfc_status (" RECL=");
1343           gfc_show_expr (open->recl);
1344         }
1345       if (open->blank)
1346         {
1347           gfc_status (" BLANK=");
1348           gfc_show_expr (open->blank);
1349         }
1350       if (open->position)
1351         {
1352           gfc_status (" POSITION=");
1353           gfc_show_expr (open->position);
1354         }
1355       if (open->action)
1356         {
1357           gfc_status (" ACTION=");
1358           gfc_show_expr (open->action);
1359         }
1360       if (open->delim)
1361         {
1362           gfc_status (" DELIM=");
1363           gfc_show_expr (open->delim);
1364         }
1365       if (open->pad)
1366         {
1367           gfc_status (" PAD=");
1368           gfc_show_expr (open->pad);
1369         }
1370       if (open->convert)
1371         {
1372           gfc_status (" CONVERT=");
1373           gfc_show_expr (open->convert);
1374         }
1375       if (open->err != NULL)
1376         gfc_status (" ERR=%d", open->err->value);
1377
1378       break;
1379
1380     case EXEC_CLOSE:
1381       gfc_status ("CLOSE");
1382       close = c->ext.close;
1383
1384       if (close->unit)
1385         {
1386           gfc_status (" UNIT=");
1387           gfc_show_expr (close->unit);
1388         }
1389       if (close->iomsg)
1390         {
1391           gfc_status (" IOMSG=");
1392           gfc_show_expr (close->iomsg);
1393         }
1394       if (close->iostat)
1395         {
1396           gfc_status (" IOSTAT=");
1397           gfc_show_expr (close->iostat);
1398         }
1399       if (close->status)
1400         {
1401           gfc_status (" STATUS=");
1402           gfc_show_expr (close->status);
1403         }
1404       if (close->err != NULL)
1405         gfc_status (" ERR=%d", close->err->value);
1406       break;
1407
1408     case EXEC_BACKSPACE:
1409       gfc_status ("BACKSPACE");
1410       goto show_filepos;
1411
1412     case EXEC_ENDFILE:
1413       gfc_status ("ENDFILE");
1414       goto show_filepos;
1415
1416     case EXEC_REWIND:
1417       gfc_status ("REWIND");
1418       goto show_filepos;
1419
1420     case EXEC_FLUSH:
1421       gfc_status ("FLUSH");
1422
1423     show_filepos:
1424       fp = c->ext.filepos;
1425
1426       if (fp->unit)
1427         {
1428           gfc_status (" UNIT=");
1429           gfc_show_expr (fp->unit);
1430         }
1431       if (fp->iomsg)
1432         {
1433           gfc_status (" IOMSG=");
1434           gfc_show_expr (fp->iomsg);
1435         }
1436       if (fp->iostat)
1437         {
1438           gfc_status (" IOSTAT=");
1439           gfc_show_expr (fp->iostat);
1440         }
1441       if (fp->err != NULL)
1442         gfc_status (" ERR=%d", fp->err->value);
1443       break;
1444
1445     case EXEC_INQUIRE:
1446       gfc_status ("INQUIRE");
1447       i = c->ext.inquire;
1448
1449       if (i->unit)
1450         {
1451           gfc_status (" UNIT=");
1452           gfc_show_expr (i->unit);
1453         }
1454       if (i->file)
1455         {
1456           gfc_status (" FILE=");
1457           gfc_show_expr (i->file);
1458         }
1459
1460       if (i->iomsg)
1461         {
1462           gfc_status (" IOMSG=");
1463           gfc_show_expr (i->iomsg);
1464         }
1465       if (i->iostat)
1466         {
1467           gfc_status (" IOSTAT=");
1468           gfc_show_expr (i->iostat);
1469         }
1470       if (i->exist)
1471         {
1472           gfc_status (" EXIST=");
1473           gfc_show_expr (i->exist);
1474         }
1475       if (i->opened)
1476         {
1477           gfc_status (" OPENED=");
1478           gfc_show_expr (i->opened);
1479         }
1480       if (i->number)
1481         {
1482           gfc_status (" NUMBER=");
1483           gfc_show_expr (i->number);
1484         }
1485       if (i->named)
1486         {
1487           gfc_status (" NAMED=");
1488           gfc_show_expr (i->named);
1489         }
1490       if (i->name)
1491         {
1492           gfc_status (" NAME=");
1493           gfc_show_expr (i->name);
1494         }
1495       if (i->access)
1496         {
1497           gfc_status (" ACCESS=");
1498           gfc_show_expr (i->access);
1499         }
1500       if (i->sequential)
1501         {
1502           gfc_status (" SEQUENTIAL=");
1503           gfc_show_expr (i->sequential);
1504         }
1505
1506       if (i->direct)
1507         {
1508           gfc_status (" DIRECT=");
1509           gfc_show_expr (i->direct);
1510         }
1511       if (i->form)
1512         {
1513           gfc_status (" FORM=");
1514           gfc_show_expr (i->form);
1515         }
1516       if (i->formatted)
1517         {
1518           gfc_status (" FORMATTED");
1519           gfc_show_expr (i->formatted);
1520         }
1521       if (i->unformatted)
1522         {
1523           gfc_status (" UNFORMATTED=");
1524           gfc_show_expr (i->unformatted);
1525         }
1526       if (i->recl)
1527         {
1528           gfc_status (" RECL=");
1529           gfc_show_expr (i->recl);
1530         }
1531       if (i->nextrec)
1532         {
1533           gfc_status (" NEXTREC=");
1534           gfc_show_expr (i->nextrec);
1535         }
1536       if (i->blank)
1537         {
1538           gfc_status (" BLANK=");
1539           gfc_show_expr (i->blank);
1540         }
1541       if (i->position)
1542         {
1543           gfc_status (" POSITION=");
1544           gfc_show_expr (i->position);
1545         }
1546       if (i->action)
1547         {
1548           gfc_status (" ACTION=");
1549           gfc_show_expr (i->action);
1550         }
1551       if (i->read)
1552         {
1553           gfc_status (" READ=");
1554           gfc_show_expr (i->read);
1555         }
1556       if (i->write)
1557         {
1558           gfc_status (" WRITE=");
1559           gfc_show_expr (i->write);
1560         }
1561       if (i->readwrite)
1562         {
1563           gfc_status (" READWRITE=");
1564           gfc_show_expr (i->readwrite);
1565         }
1566       if (i->delim)
1567         {
1568           gfc_status (" DELIM=");
1569           gfc_show_expr (i->delim);
1570         }
1571       if (i->pad)
1572         {
1573           gfc_status (" PAD=");
1574           gfc_show_expr (i->pad);
1575         }
1576       if (i->convert)
1577         {
1578           gfc_status (" CONVERT=");
1579           gfc_show_expr (i->convert);
1580         }
1581
1582       if (i->err != NULL)
1583         gfc_status (" ERR=%d", i->err->value);
1584       break;
1585
1586     case EXEC_IOLENGTH:
1587       gfc_status ("IOLENGTH ");
1588       gfc_show_expr (c->expr);
1589       goto show_dt_code;
1590       break;
1591
1592     case EXEC_READ:
1593       gfc_status ("READ");
1594       goto show_dt;
1595
1596     case EXEC_WRITE:
1597       gfc_status ("WRITE");
1598
1599     show_dt:
1600       dt = c->ext.dt;
1601       if (dt->io_unit)
1602         {
1603           gfc_status (" UNIT=");
1604           gfc_show_expr (dt->io_unit);
1605         }
1606
1607       if (dt->format_expr)
1608         {
1609           gfc_status (" FMT=");
1610           gfc_show_expr (dt->format_expr);
1611         }
1612
1613       if (dt->format_label != NULL)
1614         gfc_status (" FMT=%d", dt->format_label->value);
1615       if (dt->namelist)
1616         gfc_status (" NML=%s", dt->namelist->name);
1617
1618       if (dt->iomsg)
1619         {
1620           gfc_status (" IOMSG=");
1621           gfc_show_expr (dt->iomsg);
1622         }
1623       if (dt->iostat)
1624         {
1625           gfc_status (" IOSTAT=");
1626           gfc_show_expr (dt->iostat);
1627         }
1628       if (dt->size)
1629         {
1630           gfc_status (" SIZE=");
1631           gfc_show_expr (dt->size);
1632         }
1633       if (dt->rec)
1634         {
1635           gfc_status (" REC=");
1636           gfc_show_expr (dt->rec);
1637         }
1638       if (dt->advance)
1639         {
1640           gfc_status (" ADVANCE=");
1641           gfc_show_expr (dt->advance);
1642         }
1643
1644     show_dt_code:
1645       gfc_status_char ('\n');
1646       for (c = c->block->next; c; c = c->next)
1647         gfc_show_code_node (level + (c->next != NULL), c);
1648       return;
1649
1650     case EXEC_TRANSFER:
1651       gfc_status ("TRANSFER ");
1652       gfc_show_expr (c->expr);
1653       break;
1654
1655     case EXEC_DT_END:
1656       gfc_status ("DT_END");
1657       dt = c->ext.dt;
1658
1659       if (dt->err != NULL)
1660         gfc_status (" ERR=%d", dt->err->value);
1661       if (dt->end != NULL)
1662         gfc_status (" END=%d", dt->end->value);
1663       if (dt->eor != NULL)
1664         gfc_status (" EOR=%d", dt->eor->value);
1665       break;
1666
1667     case EXEC_OMP_ATOMIC:
1668     case EXEC_OMP_BARRIER:
1669     case EXEC_OMP_CRITICAL:
1670     case EXEC_OMP_FLUSH:
1671     case EXEC_OMP_DO:
1672     case EXEC_OMP_MASTER:
1673     case EXEC_OMP_ORDERED:
1674     case EXEC_OMP_PARALLEL:
1675     case EXEC_OMP_PARALLEL_DO:
1676     case EXEC_OMP_PARALLEL_SECTIONS:
1677     case EXEC_OMP_PARALLEL_WORKSHARE:
1678     case EXEC_OMP_SECTIONS:
1679     case EXEC_OMP_SINGLE:
1680     case EXEC_OMP_WORKSHARE:
1681       gfc_show_omp_node (level, c);
1682       break;
1683
1684     default:
1685       gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1686     }
1687
1688   gfc_status_char ('\n');
1689 }
1690
1691
1692 /* Show an equivalence chain.  */
1693
1694 void
1695 gfc_show_equiv (gfc_equiv *eq)
1696 {
1697   show_indent ();
1698   gfc_status ("Equivalence: ");
1699   while (eq)
1700     {
1701       gfc_show_expr (eq->expr);
1702       eq = eq->eq;
1703       if (eq)
1704         gfc_status (", ");
1705     }
1706 }
1707
1708
1709 /* Show a freakin' whole namespace.  */
1710
1711 void
1712 gfc_show_namespace (gfc_namespace * ns)
1713 {
1714   gfc_interface *intr;
1715   gfc_namespace *save;
1716   gfc_intrinsic_op op;
1717   gfc_equiv *eq;
1718   int i;
1719
1720   save = gfc_current_ns;
1721   show_level++;
1722
1723   show_indent ();
1724   gfc_status ("Namespace:");
1725
1726   if (ns != NULL)
1727     {
1728       i = 0;
1729       do
1730         {
1731           int l = i;
1732           while (i < GFC_LETTERS - 1
1733                  && gfc_compare_types(&ns->default_type[i+1],
1734                                       &ns->default_type[l]))
1735             i++;
1736
1737           if (i > l)
1738             gfc_status(" %c-%c: ", l+'A', i+'A');
1739           else
1740             gfc_status(" %c: ", l+'A');
1741
1742           gfc_show_typespec(&ns->default_type[l]);
1743           i++;
1744       } while (i < GFC_LETTERS);
1745
1746       if (ns->proc_name != NULL)
1747         {
1748           show_indent ();
1749           gfc_status ("procedure name = %s", ns->proc_name->name);
1750         }
1751
1752       gfc_current_ns = ns;
1753       gfc_traverse_symtree (ns->common_root, show_common);
1754
1755       gfc_traverse_symtree (ns->sym_root, show_symtree);
1756
1757       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1758         {
1759           /* User operator interfaces */
1760           intr = ns->operator[op];
1761           if (intr == NULL)
1762             continue;
1763
1764           show_indent ();
1765           gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
1766
1767           for (; intr; intr = intr->next)
1768             gfc_status (" %s", intr->sym->name);
1769         }
1770
1771       if (ns->uop_root != NULL)
1772         {
1773           show_indent ();
1774           gfc_status ("User operators:\n");
1775           gfc_traverse_user_op (ns, show_uop);
1776         }
1777     }
1778
1779   for (eq = ns->equiv; eq; eq = eq->next)
1780     gfc_show_equiv (eq);
1781
1782   gfc_status_char ('\n');
1783   gfc_status_char ('\n');
1784
1785   gfc_show_code (0, ns->code);
1786
1787   for (ns = ns->contained; ns; ns = ns->sibling)
1788     {
1789       show_indent ();
1790       gfc_status ("CONTAINS\n");
1791       gfc_show_namespace (ns);
1792     }
1793
1794   show_level--;
1795   gfc_status_char ('\n');
1796   gfc_current_ns = save;
1797 }