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       if (c->resolved_sym)
1088         gfc_status ("CALL %s ", c->resolved_sym->name);
1089       else if (c->symtree)
1090         gfc_status ("CALL %s ", c->symtree->name);
1091       else
1092         gfc_status ("CALL ?? ");
1093
1094       gfc_show_actual_arglist (c->ext.actual);
1095       break;
1096
1097     case EXEC_RETURN:
1098       gfc_status ("RETURN ");
1099       if (c->expr)
1100         gfc_show_expr (c->expr);
1101       break;
1102
1103     case EXEC_PAUSE:
1104       gfc_status ("PAUSE ");
1105
1106       if (c->expr != NULL)
1107         gfc_show_expr (c->expr);
1108       else
1109         gfc_status ("%d", c->ext.stop_code);
1110
1111       break;
1112
1113     case EXEC_STOP:
1114       gfc_status ("STOP ");
1115
1116       if (c->expr != NULL)
1117         gfc_show_expr (c->expr);
1118       else
1119         gfc_status ("%d", c->ext.stop_code);
1120
1121       break;
1122
1123     case EXEC_ARITHMETIC_IF:
1124       gfc_status ("IF ");
1125       gfc_show_expr (c->expr);
1126       gfc_status (" %d, %d, %d",
1127                   c->label->value, c->label2->value, c->label3->value);
1128       break;
1129
1130     case EXEC_IF:
1131       d = c->block;
1132       gfc_status ("IF ");
1133       gfc_show_expr (d->expr);
1134       gfc_status_char ('\n');
1135       gfc_show_code (level + 1, d->next);
1136
1137       d = d->block;
1138       for (; d; d = d->block)
1139         {
1140           code_indent (level, 0);
1141
1142           if (d->expr == NULL)
1143             gfc_status ("ELSE\n");
1144           else
1145             {
1146               gfc_status ("ELSE IF ");
1147               gfc_show_expr (d->expr);
1148               gfc_status_char ('\n');
1149             }
1150
1151           gfc_show_code (level + 1, d->next);
1152         }
1153
1154       code_indent (level, c->label);
1155
1156       gfc_status ("ENDIF");
1157       break;
1158
1159     case EXEC_SELECT:
1160       d = c->block;
1161       gfc_status ("SELECT CASE ");
1162       gfc_show_expr (c->expr);
1163       gfc_status_char ('\n');
1164
1165       for (; d; d = d->block)
1166         {
1167           code_indent (level, 0);
1168
1169           gfc_status ("CASE ");
1170           for (cp = d->ext.case_list; cp; cp = cp->next)
1171             {
1172               gfc_status_char ('(');
1173               gfc_show_expr (cp->low);
1174               gfc_status_char (' ');
1175               gfc_show_expr (cp->high);
1176               gfc_status_char (')');
1177               gfc_status_char (' ');
1178             }
1179           gfc_status_char ('\n');
1180
1181           gfc_show_code (level + 1, d->next);
1182         }
1183
1184       code_indent (level, c->label);
1185       gfc_status ("END SELECT");
1186       break;
1187
1188     case EXEC_WHERE:
1189       gfc_status ("WHERE ");
1190
1191       d = c->block;
1192       gfc_show_expr (d->expr);
1193       gfc_status_char ('\n');
1194
1195       gfc_show_code (level + 1, d->next);
1196
1197       for (d = d->block; d; d = d->block)
1198         {
1199           code_indent (level, 0);
1200           gfc_status ("ELSE WHERE ");
1201           gfc_show_expr (d->expr);
1202           gfc_status_char ('\n');
1203           gfc_show_code (level + 1, d->next);
1204         }
1205
1206       code_indent (level, 0);
1207       gfc_status ("END WHERE");
1208       break;
1209
1210
1211     case EXEC_FORALL:
1212       gfc_status ("FORALL ");
1213       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1214         {
1215           gfc_show_expr (fa->var);
1216           gfc_status_char (' ');
1217           gfc_show_expr (fa->start);
1218           gfc_status_char (':');
1219           gfc_show_expr (fa->end);
1220           gfc_status_char (':');
1221           gfc_show_expr (fa->stride);
1222
1223           if (fa->next != NULL)
1224             gfc_status_char (',');
1225         }
1226
1227       if (c->expr != NULL)
1228         {
1229           gfc_status_char (',');
1230           gfc_show_expr (c->expr);
1231         }
1232       gfc_status_char ('\n');
1233
1234       gfc_show_code (level + 1, c->block->next);
1235
1236       code_indent (level, 0);
1237       gfc_status ("END FORALL");
1238       break;
1239
1240     case EXEC_DO:
1241       gfc_status ("DO ");
1242
1243       gfc_show_expr (c->ext.iterator->var);
1244       gfc_status_char ('=');
1245       gfc_show_expr (c->ext.iterator->start);
1246       gfc_status_char (' ');
1247       gfc_show_expr (c->ext.iterator->end);
1248       gfc_status_char (' ');
1249       gfc_show_expr (c->ext.iterator->step);
1250       gfc_status_char ('\n');
1251
1252       gfc_show_code (level + 1, c->block->next);
1253
1254       code_indent (level, 0);
1255       gfc_status ("END DO");
1256       break;
1257
1258     case EXEC_DO_WHILE:
1259       gfc_status ("DO WHILE ");
1260       gfc_show_expr (c->expr);
1261       gfc_status_char ('\n');
1262
1263       gfc_show_code (level + 1, c->block->next);
1264
1265       code_indent (level, c->label);
1266       gfc_status ("END DO");
1267       break;
1268
1269     case EXEC_CYCLE:
1270       gfc_status ("CYCLE");
1271       if (c->symtree)
1272         gfc_status (" %s", c->symtree->n.sym->name);
1273       break;
1274
1275     case EXEC_EXIT:
1276       gfc_status ("EXIT");
1277       if (c->symtree)
1278         gfc_status (" %s", c->symtree->n.sym->name);
1279       break;
1280
1281     case EXEC_ALLOCATE:
1282       gfc_status ("ALLOCATE ");
1283       if (c->expr)
1284         {
1285           gfc_status (" STAT=");
1286           gfc_show_expr (c->expr);
1287         }
1288
1289       for (a = c->ext.alloc_list; a; a = a->next)
1290         {
1291           gfc_status_char (' ');
1292           gfc_show_expr (a->expr);
1293         }
1294
1295       break;
1296
1297     case EXEC_DEALLOCATE:
1298       gfc_status ("DEALLOCATE ");
1299       if (c->expr)
1300         {
1301           gfc_status (" STAT=");
1302           gfc_show_expr (c->expr);
1303         }
1304
1305       for (a = c->ext.alloc_list; a; a = a->next)
1306         {
1307           gfc_status_char (' ');
1308           gfc_show_expr (a->expr);
1309         }
1310
1311       break;
1312
1313     case EXEC_OPEN:
1314       gfc_status ("OPEN");
1315       open = c->ext.open;
1316
1317       if (open->unit)
1318         {
1319           gfc_status (" UNIT=");
1320           gfc_show_expr (open->unit);
1321         }
1322       if (open->iomsg)
1323         {
1324           gfc_status (" IOMSG=");
1325           gfc_show_expr (open->iomsg);
1326         }
1327       if (open->iostat)
1328         {
1329           gfc_status (" IOSTAT=");
1330           gfc_show_expr (open->iostat);
1331         }
1332       if (open->file)
1333         {
1334           gfc_status (" FILE=");
1335           gfc_show_expr (open->file);
1336         }
1337       if (open->status)
1338         {
1339           gfc_status (" STATUS=");
1340           gfc_show_expr (open->status);
1341         }
1342       if (open->access)
1343         {
1344           gfc_status (" ACCESS=");
1345           gfc_show_expr (open->access);
1346         }
1347       if (open->form)
1348         {
1349           gfc_status (" FORM=");
1350           gfc_show_expr (open->form);
1351         }
1352       if (open->recl)
1353         {
1354           gfc_status (" RECL=");
1355           gfc_show_expr (open->recl);
1356         }
1357       if (open->blank)
1358         {
1359           gfc_status (" BLANK=");
1360           gfc_show_expr (open->blank);
1361         }
1362       if (open->position)
1363         {
1364           gfc_status (" POSITION=");
1365           gfc_show_expr (open->position);
1366         }
1367       if (open->action)
1368         {
1369           gfc_status (" ACTION=");
1370           gfc_show_expr (open->action);
1371         }
1372       if (open->delim)
1373         {
1374           gfc_status (" DELIM=");
1375           gfc_show_expr (open->delim);
1376         }
1377       if (open->pad)
1378         {
1379           gfc_status (" PAD=");
1380           gfc_show_expr (open->pad);
1381         }
1382       if (open->convert)
1383         {
1384           gfc_status (" CONVERT=");
1385           gfc_show_expr (open->convert);
1386         }
1387       if (open->err != NULL)
1388         gfc_status (" ERR=%d", open->err->value);
1389
1390       break;
1391
1392     case EXEC_CLOSE:
1393       gfc_status ("CLOSE");
1394       close = c->ext.close;
1395
1396       if (close->unit)
1397         {
1398           gfc_status (" UNIT=");
1399           gfc_show_expr (close->unit);
1400         }
1401       if (close->iomsg)
1402         {
1403           gfc_status (" IOMSG=");
1404           gfc_show_expr (close->iomsg);
1405         }
1406       if (close->iostat)
1407         {
1408           gfc_status (" IOSTAT=");
1409           gfc_show_expr (close->iostat);
1410         }
1411       if (close->status)
1412         {
1413           gfc_status (" STATUS=");
1414           gfc_show_expr (close->status);
1415         }
1416       if (close->err != NULL)
1417         gfc_status (" ERR=%d", close->err->value);
1418       break;
1419
1420     case EXEC_BACKSPACE:
1421       gfc_status ("BACKSPACE");
1422       goto show_filepos;
1423
1424     case EXEC_ENDFILE:
1425       gfc_status ("ENDFILE");
1426       goto show_filepos;
1427
1428     case EXEC_REWIND:
1429       gfc_status ("REWIND");
1430       goto show_filepos;
1431
1432     case EXEC_FLUSH:
1433       gfc_status ("FLUSH");
1434
1435     show_filepos:
1436       fp = c->ext.filepos;
1437
1438       if (fp->unit)
1439         {
1440           gfc_status (" UNIT=");
1441           gfc_show_expr (fp->unit);
1442         }
1443       if (fp->iomsg)
1444         {
1445           gfc_status (" IOMSG=");
1446           gfc_show_expr (fp->iomsg);
1447         }
1448       if (fp->iostat)
1449         {
1450           gfc_status (" IOSTAT=");
1451           gfc_show_expr (fp->iostat);
1452         }
1453       if (fp->err != NULL)
1454         gfc_status (" ERR=%d", fp->err->value);
1455       break;
1456
1457     case EXEC_INQUIRE:
1458       gfc_status ("INQUIRE");
1459       i = c->ext.inquire;
1460
1461       if (i->unit)
1462         {
1463           gfc_status (" UNIT=");
1464           gfc_show_expr (i->unit);
1465         }
1466       if (i->file)
1467         {
1468           gfc_status (" FILE=");
1469           gfc_show_expr (i->file);
1470         }
1471
1472       if (i->iomsg)
1473         {
1474           gfc_status (" IOMSG=");
1475           gfc_show_expr (i->iomsg);
1476         }
1477       if (i->iostat)
1478         {
1479           gfc_status (" IOSTAT=");
1480           gfc_show_expr (i->iostat);
1481         }
1482       if (i->exist)
1483         {
1484           gfc_status (" EXIST=");
1485           gfc_show_expr (i->exist);
1486         }
1487       if (i->opened)
1488         {
1489           gfc_status (" OPENED=");
1490           gfc_show_expr (i->opened);
1491         }
1492       if (i->number)
1493         {
1494           gfc_status (" NUMBER=");
1495           gfc_show_expr (i->number);
1496         }
1497       if (i->named)
1498         {
1499           gfc_status (" NAMED=");
1500           gfc_show_expr (i->named);
1501         }
1502       if (i->name)
1503         {
1504           gfc_status (" NAME=");
1505           gfc_show_expr (i->name);
1506         }
1507       if (i->access)
1508         {
1509           gfc_status (" ACCESS=");
1510           gfc_show_expr (i->access);
1511         }
1512       if (i->sequential)
1513         {
1514           gfc_status (" SEQUENTIAL=");
1515           gfc_show_expr (i->sequential);
1516         }
1517
1518       if (i->direct)
1519         {
1520           gfc_status (" DIRECT=");
1521           gfc_show_expr (i->direct);
1522         }
1523       if (i->form)
1524         {
1525           gfc_status (" FORM=");
1526           gfc_show_expr (i->form);
1527         }
1528       if (i->formatted)
1529         {
1530           gfc_status (" FORMATTED");
1531           gfc_show_expr (i->formatted);
1532         }
1533       if (i->unformatted)
1534         {
1535           gfc_status (" UNFORMATTED=");
1536           gfc_show_expr (i->unformatted);
1537         }
1538       if (i->recl)
1539         {
1540           gfc_status (" RECL=");
1541           gfc_show_expr (i->recl);
1542         }
1543       if (i->nextrec)
1544         {
1545           gfc_status (" NEXTREC=");
1546           gfc_show_expr (i->nextrec);
1547         }
1548       if (i->blank)
1549         {
1550           gfc_status (" BLANK=");
1551           gfc_show_expr (i->blank);
1552         }
1553       if (i->position)
1554         {
1555           gfc_status (" POSITION=");
1556           gfc_show_expr (i->position);
1557         }
1558       if (i->action)
1559         {
1560           gfc_status (" ACTION=");
1561           gfc_show_expr (i->action);
1562         }
1563       if (i->read)
1564         {
1565           gfc_status (" READ=");
1566           gfc_show_expr (i->read);
1567         }
1568       if (i->write)
1569         {
1570           gfc_status (" WRITE=");
1571           gfc_show_expr (i->write);
1572         }
1573       if (i->readwrite)
1574         {
1575           gfc_status (" READWRITE=");
1576           gfc_show_expr (i->readwrite);
1577         }
1578       if (i->delim)
1579         {
1580           gfc_status (" DELIM=");
1581           gfc_show_expr (i->delim);
1582         }
1583       if (i->pad)
1584         {
1585           gfc_status (" PAD=");
1586           gfc_show_expr (i->pad);
1587         }
1588       if (i->convert)
1589         {
1590           gfc_status (" CONVERT=");
1591           gfc_show_expr (i->convert);
1592         }
1593
1594       if (i->err != NULL)
1595         gfc_status (" ERR=%d", i->err->value);
1596       break;
1597
1598     case EXEC_IOLENGTH:
1599       gfc_status ("IOLENGTH ");
1600       gfc_show_expr (c->expr);
1601       goto show_dt_code;
1602       break;
1603
1604     case EXEC_READ:
1605       gfc_status ("READ");
1606       goto show_dt;
1607
1608     case EXEC_WRITE:
1609       gfc_status ("WRITE");
1610
1611     show_dt:
1612       dt = c->ext.dt;
1613       if (dt->io_unit)
1614         {
1615           gfc_status (" UNIT=");
1616           gfc_show_expr (dt->io_unit);
1617         }
1618
1619       if (dt->format_expr)
1620         {
1621           gfc_status (" FMT=");
1622           gfc_show_expr (dt->format_expr);
1623         }
1624
1625       if (dt->format_label != NULL)
1626         gfc_status (" FMT=%d", dt->format_label->value);
1627       if (dt->namelist)
1628         gfc_status (" NML=%s", dt->namelist->name);
1629
1630       if (dt->iomsg)
1631         {
1632           gfc_status (" IOMSG=");
1633           gfc_show_expr (dt->iomsg);
1634         }
1635       if (dt->iostat)
1636         {
1637           gfc_status (" IOSTAT=");
1638           gfc_show_expr (dt->iostat);
1639         }
1640       if (dt->size)
1641         {
1642           gfc_status (" SIZE=");
1643           gfc_show_expr (dt->size);
1644         }
1645       if (dt->rec)
1646         {
1647           gfc_status (" REC=");
1648           gfc_show_expr (dt->rec);
1649         }
1650       if (dt->advance)
1651         {
1652           gfc_status (" ADVANCE=");
1653           gfc_show_expr (dt->advance);
1654         }
1655
1656     show_dt_code:
1657       gfc_status_char ('\n');
1658       for (c = c->block->next; c; c = c->next)
1659         gfc_show_code_node (level + (c->next != NULL), c);
1660       return;
1661
1662     case EXEC_TRANSFER:
1663       gfc_status ("TRANSFER ");
1664       gfc_show_expr (c->expr);
1665       break;
1666
1667     case EXEC_DT_END:
1668       gfc_status ("DT_END");
1669       dt = c->ext.dt;
1670
1671       if (dt->err != NULL)
1672         gfc_status (" ERR=%d", dt->err->value);
1673       if (dt->end != NULL)
1674         gfc_status (" END=%d", dt->end->value);
1675       if (dt->eor != NULL)
1676         gfc_status (" EOR=%d", dt->eor->value);
1677       break;
1678
1679     case EXEC_OMP_ATOMIC:
1680     case EXEC_OMP_BARRIER:
1681     case EXEC_OMP_CRITICAL:
1682     case EXEC_OMP_FLUSH:
1683     case EXEC_OMP_DO:
1684     case EXEC_OMP_MASTER:
1685     case EXEC_OMP_ORDERED:
1686     case EXEC_OMP_PARALLEL:
1687     case EXEC_OMP_PARALLEL_DO:
1688     case EXEC_OMP_PARALLEL_SECTIONS:
1689     case EXEC_OMP_PARALLEL_WORKSHARE:
1690     case EXEC_OMP_SECTIONS:
1691     case EXEC_OMP_SINGLE:
1692     case EXEC_OMP_WORKSHARE:
1693       gfc_show_omp_node (level, c);
1694       break;
1695
1696     default:
1697       gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1698     }
1699
1700   gfc_status_char ('\n');
1701 }
1702
1703
1704 /* Show an equivalence chain.  */
1705
1706 void
1707 gfc_show_equiv (gfc_equiv *eq)
1708 {
1709   show_indent ();
1710   gfc_status ("Equivalence: ");
1711   while (eq)
1712     {
1713       gfc_show_expr (eq->expr);
1714       eq = eq->eq;
1715       if (eq)
1716         gfc_status (", ");
1717     }
1718 }
1719
1720
1721 /* Show a freakin' whole namespace.  */
1722
1723 void
1724 gfc_show_namespace (gfc_namespace *ns)
1725 {
1726   gfc_interface *intr;
1727   gfc_namespace *save;
1728   gfc_intrinsic_op op;
1729   gfc_equiv *eq;
1730   int i;
1731
1732   save = gfc_current_ns;
1733   show_level++;
1734
1735   show_indent ();
1736   gfc_status ("Namespace:");
1737
1738   if (ns != NULL)
1739     {
1740       i = 0;
1741       do
1742         {
1743           int l = i;
1744           while (i < GFC_LETTERS - 1
1745                  && gfc_compare_types(&ns->default_type[i+1],
1746                                       &ns->default_type[l]))
1747             i++;
1748
1749           if (i > l)
1750             gfc_status(" %c-%c: ", l+'A', i+'A');
1751           else
1752             gfc_status(" %c: ", l+'A');
1753
1754           gfc_show_typespec(&ns->default_type[l]);
1755           i++;
1756       } while (i < GFC_LETTERS);
1757
1758       if (ns->proc_name != NULL)
1759         {
1760           show_indent ();
1761           gfc_status ("procedure name = %s", ns->proc_name->name);
1762         }
1763
1764       gfc_current_ns = ns;
1765       gfc_traverse_symtree (ns->common_root, show_common);
1766
1767       gfc_traverse_symtree (ns->sym_root, show_symtree);
1768
1769       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1770         {
1771           /* User operator interfaces */
1772           intr = ns->operator[op];
1773           if (intr == NULL)
1774             continue;
1775
1776           show_indent ();
1777           gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
1778
1779           for (; intr; intr = intr->next)
1780             gfc_status (" %s", intr->sym->name);
1781         }
1782
1783       if (ns->uop_root != NULL)
1784         {
1785           show_indent ();
1786           gfc_status ("User operators:\n");
1787           gfc_traverse_user_op (ns, show_uop);
1788         }
1789     }
1790
1791   for (eq = ns->equiv; eq; eq = eq->next)
1792     gfc_show_equiv (eq);
1793
1794   gfc_status_char ('\n');
1795   gfc_status_char ('\n');
1796
1797   gfc_show_code (0, ns->code);
1798
1799   for (ns = ns->contained; ns; ns = ns->sibling)
1800     {
1801       show_indent ();
1802       gfc_status ("CONTAINS\n");
1803       gfc_show_namespace (ns);
1804     }
1805
1806   show_level--;
1807   gfc_status_char ('\n');
1808   gfc_current_ns = save;
1809 }