gcc/fortran/dump-parse-tree.c

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