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