gcc/fortran/dump-parse-tree.c

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