gcc/fortran/dump-parse-tree.c

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