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