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