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