gcc/fortran/dump-parse-tree.c

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