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.op)
 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->is_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->op; 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_TASK: name = "TASK"; break;
 852     case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
 853     case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
 854     default:
 855       gcc_unreachable ();
 856     }
 857   fprintf (dumpfile, "!$OMP %s", name);
 858   switch (c->op)
 859     {
 860     case EXEC_OMP_DO:
 861     case EXEC_OMP_PARALLEL:
 862     case EXEC_OMP_PARALLEL_DO:
 863     case EXEC_OMP_PARALLEL_SECTIONS:
 864     case EXEC_OMP_SECTIONS:
 865     case EXEC_OMP_SINGLE:
 866     case EXEC_OMP_WORKSHARE:
 867     case EXEC_OMP_PARALLEL_WORKSHARE:
 868     case EXEC_OMP_TASK:
 869       omp_clauses = c->ext.omp_clauses;
 870       break;
 871     case EXEC_OMP_CRITICAL:
 872       if (c->ext.omp_name)
 873         fprintf (dumpfile, " (%s)", c->ext.omp_name);
 874       break;
 875     case EXEC_OMP_FLUSH:
 876       if (c->ext.omp_namelist)
 877         {
 878           fputs (" (", dumpfile);
 879           show_namelist (c->ext.omp_namelist);
 880           fputc (')', dumpfile);
 881         }
 882       return;
 883     case EXEC_OMP_BARRIER:
 884     case EXEC_OMP_TASKWAIT:
 885       return;
 886     default:
 887       break;
 888     }
 889   if (omp_clauses)
 890     {
 891       int list_type;
 892
 893       if (omp_clauses->if_expr)
 894         {
 895           fputs (" IF(", dumpfile);
 896           show_expr (omp_clauses->if_expr);
 897           fputc (')', dumpfile);
 898         }
 899       if (omp_clauses->num_threads)
 900         {
 901           fputs (" NUM_THREADS(", dumpfile);
 902           show_expr (omp_clauses->num_threads);
 903           fputc (')', dumpfile);
 904         }
 905       if (omp_clauses->sched_kind != OMP_SCHED_NONE)
 906         {
 907           const char *type;
 908           switch (omp_clauses->sched_kind)
 909             {
 910             case OMP_SCHED_STATIC: type = "STATIC"; break;
 911             case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
 912             case OMP_SCHED_GUIDED: type = "GUIDED"; break;
 913             case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
 914             case OMP_SCHED_AUTO: type = "AUTO"; break;
 915             default:
 916               gcc_unreachable ();
 917             }
 918           fprintf (dumpfile, " SCHEDULE (%s", type);
 919           if (omp_clauses->chunk_size)
 920             {
 921               fputc (',', dumpfile);
 922               show_expr (omp_clauses->chunk_size);
 923             }
 924           fputc (')', dumpfile);
 925         }
 926       if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
 927         {
 928           const char *type;
 929           switch (omp_clauses->default_sharing)
 930             {
 931             case OMP_DEFAULT_NONE: type = "NONE"; break;
 932             case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
 933             case OMP_DEFAULT_SHARED: type = "SHARED"; break;
 934             case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
 935             default:
 936               gcc_unreachable ();
 937             }
 938           fprintf (dumpfile, " DEFAULT(%s)", type);
 939         }
 940       if (omp_clauses->ordered)
 941         fputs (" ORDERED", dumpfile);
 942       if (omp_clauses->untied)
 943         fputs (" UNTIED", dumpfile);
 944       if (omp_clauses->collapse)
 945         fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
 946       for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
 947         if (omp_clauses->lists[list_type] != NULL
 948             && list_type != OMP_LIST_COPYPRIVATE)
 949           {
 950             const char *type;
 951             if (list_type >= OMP_LIST_REDUCTION_FIRST)
 952               {
 953                 switch (list_type)
 954                   {
 955                   case OMP_LIST_PLUS: type = "+"; break;
 956                   case OMP_LIST_MULT: type = "*"; break;
 957                   case OMP_LIST_SUB: type = "-"; break;
 958                   case OMP_LIST_AND: type = ".AND."; break;
 959                   case OMP_LIST_OR: type = ".OR."; break;
 960                   case OMP_LIST_EQV: type = ".EQV."; break;
 961                   case OMP_LIST_NEQV: type = ".NEQV."; break;
 962                   case OMP_LIST_MAX: type = "MAX"; break;
 963                   case OMP_LIST_MIN: type = "MIN"; break;
 964                   case OMP_LIST_IAND: type = "IAND"; break;
 965                   case OMP_LIST_IOR: type = "IOR"; break;
 966                   case OMP_LIST_IEOR: type = "IEOR"; break;
 967                   default:
 968                     gcc_unreachable ();
 969                   }
 970                 fprintf (dumpfile, " REDUCTION(%s:", type);
 971               }
 972             else
 973               {
 974                 switch (list_type)
 975                   {
 976                   case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
 977                   case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
 978                   case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
 979                   case OMP_LIST_SHARED: type = "SHARED"; break;
 980                   case OMP_LIST_COPYIN: type = "COPYIN"; break;
 981                   default:
 982                     gcc_unreachable ();
 983                   }
 984                 fprintf (dumpfile, " %s(", type);
 985               }
 986             show_namelist (omp_clauses->lists[list_type]);
 987             fputc (')', dumpfile);
 988           }
 989     }
 990   fputc ('\n', dumpfile);
 991   if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
 992     {
 993       gfc_code *d = c->block;
 994       while (d != NULL)
 995         {
 996           show_code (level + 1, d->next);
 997           if (d->block == NULL)
 998             break;
 999           code_indent (level, 0);
1000           fputs ("!$OMP SECTION\n", dumpfile);
1001           d = d->block;
1002         }
1003     }
1004   else
1005     show_code (level + 1, c->block->next);
1006   if (c->op == EXEC_OMP_ATOMIC)
1007     return;
1008   code_indent (level, 0);
1009   fprintf (dumpfile, "!$OMP END %s", name);
1010   if (omp_clauses != NULL)
1011     {
1012       if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1013         {
1014           fputs (" COPYPRIVATE(", dumpfile);
1015           show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1016           fputc (')', dumpfile);
1017         }
1018       else if (omp_clauses->nowait)
1019         fputs (" NOWAIT", dumpfile);
1020     }
1021   else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1022     fprintf (dumpfile, " (%s)", c->ext.omp_name);
1023 }
1024
1025
1026 /* Show a single code node and everything underneath it if necessary.  */
1027
1028 static void
1029 show_code_node (int level, gfc_code *c)
1030 {
1031   gfc_forall_iterator *fa;
1032   gfc_open *open;
1033   gfc_case *cp;
1034   gfc_alloc *a;
1035   gfc_code *d;
1036   gfc_close *close;
1037   gfc_filepos *fp;
1038   gfc_inquire *i;
1039   gfc_dt *dt;
1040
1041   code_indent (level, c->here);
1042
1043   switch (c->op)
1044     {
1045     case EXEC_NOP:
1046       fputs ("NOP", dumpfile);
1047       break;
1048
1049     case EXEC_CONTINUE:
1050       fputs ("CONTINUE", dumpfile);
1051       break;
1052
1053     case EXEC_ENTRY:
1054       fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1055       break;
1056
1057     case EXEC_INIT_ASSIGN:
1058     case EXEC_ASSIGN:
1059       fputs ("ASSIGN ", dumpfile);
1060       show_expr (c->expr);
1061       fputc (' ', dumpfile);
1062       show_expr (c->expr2);
1063       break;
1064
1065     case EXEC_LABEL_ASSIGN:
1066       fputs ("LABEL ASSIGN ", dumpfile);
1067       show_expr (c->expr);
1068       fprintf (dumpfile, " %d", c->label->value);
1069       break;
1070
1071     case EXEC_POINTER_ASSIGN:
1072       fputs ("POINTER ASSIGN ", dumpfile);
1073       show_expr (c->expr);
1074       fputc (' ', dumpfile);
1075       show_expr (c->expr2);
1076       break;
1077
1078     case EXEC_GOTO:
1079       fputs ("GOTO ", dumpfile);
1080       if (c->label)
1081         fprintf (dumpfile, "%d", c->label->value);
1082       else
1083         {
1084           show_expr (c->expr);
1085           d = c->block;
1086           if (d != NULL)
1087             {
1088               fputs (", (", dumpfile);
1089               for (; d; d = d ->block)
1090                 {
1091                   code_indent (level, d->label);
1092                   if (d->block != NULL)
1093                     fputc (',', dumpfile);
1094                   else
1095                     fputc (')', dumpfile);
1096                 }
1097             }
1098         }
1099       break;
1100
1101     case EXEC_CALL:
1102     case EXEC_ASSIGN_CALL:
1103       if (c->resolved_sym)
1104         fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1105       else if (c->symtree)
1106         fprintf (dumpfile, "CALL %s ", c->symtree->name);
1107       else
1108         fputs ("CALL ?? ", dumpfile);
1109
1110       show_actual_arglist (c->ext.actual);
1111       break;
1112
1113     case EXEC_RETURN:
1114       fputs ("RETURN ", dumpfile);
1115       if (c->expr)
1116         show_expr (c->expr);
1117       break;
1118
1119     case EXEC_PAUSE:
1120       fputs ("PAUSE ", dumpfile);
1121
1122       if (c->expr != NULL)
1123         show_expr (c->expr);
1124       else
1125         fprintf (dumpfile, "%d", c->ext.stop_code);
1126
1127       break;
1128
1129     case EXEC_STOP:
1130       fputs ("STOP ", dumpfile);
1131
1132       if (c->expr != NULL)
1133         show_expr (c->expr);
1134       else
1135         fprintf (dumpfile, "%d", c->ext.stop_code);
1136
1137       break;
1138
1139     case EXEC_ARITHMETIC_IF:
1140       fputs ("IF ", dumpfile);
1141       show_expr (c->expr);
1142       fprintf (dumpfile, " %d, %d, %d",
1143                   c->label->value, c->label2->value, c->label3->value);
1144       break;
1145
1146     case EXEC_IF:
1147       d = c->block;
1148       fputs ("IF ", dumpfile);
1149       show_expr (d->expr);
1150       fputc ('\n', dumpfile);
1151       show_code (level + 1, d->next);
1152
1153       d = d->block;
1154       for (; d; d = d->block)
1155         {
1156           code_indent (level, 0);
1157
1158           if (d->expr == NULL)
1159             fputs ("ELSE\n", dumpfile);
1160           else
1161             {
1162               fputs ("ELSE IF ", dumpfile);
1163               show_expr (d->expr);
1164               fputc ('\n', dumpfile);
1165             }
1166
1167           show_code (level + 1, d->next);
1168         }
1169
1170       code_indent (level, c->label);
1171
1172       fputs ("ENDIF", dumpfile);
1173       break;
1174
1175     case EXEC_SELECT:
1176       d = c->block;
1177       fputs ("SELECT CASE ", dumpfile);
1178       show_expr (c->expr);
1179       fputc ('\n', dumpfile);
1180
1181       for (; d; d = d->block)
1182         {
1183           code_indent (level, 0);
1184
1185           fputs ("CASE ", dumpfile);
1186           for (cp = d->ext.case_list; cp; cp = cp->next)
1187             {
1188               fputc ('(', dumpfile);
1189               show_expr (cp->low);
1190               fputc (' ', dumpfile);
1191               show_expr (cp->high);
1192               fputc (')', dumpfile);
1193               fputc (' ', dumpfile);
1194             }
1195           fputc ('\n', dumpfile);
1196
1197           show_code (level + 1, d->next);
1198         }
1199
1200       code_indent (level, c->label);
1201       fputs ("END SELECT", dumpfile);
1202       break;
1203
1204     case EXEC_WHERE:
1205       fputs ("WHERE ", dumpfile);
1206
1207       d = c->block;
1208       show_expr (d->expr);
1209       fputc ('\n', dumpfile);
1210
1211       show_code (level + 1, d->next);
1212
1213       for (d = d->block; d; d = d->block)
1214         {
1215           code_indent (level, 0);
1216           fputs ("ELSE WHERE ", dumpfile);
1217           show_expr (d->expr);
1218           fputc ('\n', dumpfile);
1219           show_code (level + 1, d->next);
1220         }
1221
1222       code_indent (level, 0);
1223       fputs ("END WHERE", dumpfile);
1224       break;
1225
1226
1227     case EXEC_FORALL:
1228       fputs ("FORALL ", dumpfile);
1229       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1230         {
1231           show_expr (fa->var);
1232           fputc (' ', dumpfile);
1233           show_expr (fa->start);
1234           fputc (':', dumpfile);
1235           show_expr (fa->end);
1236           fputc (':', dumpfile);
1237           show_expr (fa->stride);
1238
1239           if (fa->next != NULL)
1240             fputc (',', dumpfile);
1241         }
1242
1243       if (c->expr != NULL)
1244         {
1245           fputc (',', dumpfile);
1246           show_expr (c->expr);
1247         }
1248       fputc ('\n', dumpfile);
1249
1250       show_code (level + 1, c->block->next);
1251
1252       code_indent (level, 0);
1253       fputs ("END FORALL", dumpfile);
1254       break;
1255
1256     case EXEC_DO:
1257       fputs ("DO ", dumpfile);
1258
1259       show_expr (c->ext.iterator->var);
1260       fputc ('=', dumpfile);
1261       show_expr (c->ext.iterator->start);
1262       fputc (' ', dumpfile);
1263       show_expr (c->ext.iterator->end);
1264       fputc (' ', dumpfile);
1265       show_expr (c->ext.iterator->step);
1266       fputc ('\n', dumpfile);
1267
1268       show_code (level + 1, c->block->next);
1269
1270       code_indent (level, 0);
1271       fputs ("END DO", dumpfile);
1272       break;
1273
1274     case EXEC_DO_WHILE:
1275       fputs ("DO WHILE ", dumpfile);
1276       show_expr (c->expr);
1277       fputc ('\n', dumpfile);
1278
1279       show_code (level + 1, c->block->next);
1280
1281       code_indent (level, c->label);
1282       fputs ("END DO", dumpfile);
1283       break;
1284
1285     case EXEC_CYCLE:
1286       fputs ("CYCLE", dumpfile);
1287       if (c->symtree)
1288         fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1289       break;
1290
1291     case EXEC_EXIT:
1292       fputs ("EXIT", dumpfile);
1293       if (c->symtree)
1294         fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1295       break;
1296
1297     case EXEC_ALLOCATE:
1298       fputs ("ALLOCATE ", dumpfile);
1299       if (c->expr)
1300         {
1301           fputs (" STAT=", dumpfile);
1302           show_expr (c->expr);
1303         }
1304
1305       for (a = c->ext.alloc_list; a; a = a->next)
1306         {
1307           fputc (' ', dumpfile);
1308           show_expr (a->expr);
1309         }
1310
1311       break;
1312
1313     case EXEC_DEALLOCATE:
1314       fputs ("DEALLOCATE ", dumpfile);
1315       if (c->expr)
1316         {
1317           fputs (" STAT=", dumpfile);
1318           show_expr (c->expr);
1319         }
1320
1321       for (a = c->ext.alloc_list; a; a = a->next)
1322         {
1323           fputc (' ', dumpfile);
1324           show_expr (a->expr);
1325         }
1326
1327       break;
1328
1329     case EXEC_OPEN:
1330       fputs ("OPEN", dumpfile);
1331       open = c->ext.open;
1332
1333       if (open->unit)
1334         {
1335           fputs (" UNIT=", dumpfile);
1336           show_expr (open->unit);
1337         }
1338       if (open->iomsg)
1339         {
1340           fputs (" IOMSG=", dumpfile);
1341           show_expr (open->iomsg);
1342         }
1343       if (open->iostat)
1344         {
1345           fputs (" IOSTAT=", dumpfile);
1346           show_expr (open->iostat);
1347         }
1348       if (open->file)
1349         {
1350           fputs (" FILE=", dumpfile);
1351           show_expr (open->file);
1352         }
1353       if (open->status)
1354         {
1355           fputs (" STATUS=", dumpfile);
1356           show_expr (open->status);
1357         }
1358       if (open->access)
1359         {
1360           fputs (" ACCESS=", dumpfile);
1361           show_expr (open->access);
1362         }
1363       if (open->form)
1364         {
1365           fputs (" FORM=", dumpfile);
1366           show_expr (open->form);
1367         }
1368       if (open->recl)
1369         {
1370           fputs (" RECL=", dumpfile);
1371           show_expr (open->recl);
1372         }
1373       if (open->blank)
1374         {
1375           fputs (" BLANK=", dumpfile);
1376           show_expr (open->blank);
1377         }
1378       if (open->position)
1379         {
1380           fputs (" POSITION=", dumpfile);
1381           show_expr (open->position);
1382         }
1383       if (open->action)
1384         {
1385           fputs (" ACTION=", dumpfile);
1386           show_expr (open->action);
1387         }
1388       if (open->delim)
1389         {
1390           fputs (" DELIM=", dumpfile);
1391           show_expr (open->delim);
1392         }
1393       if (open->pad)
1394         {
1395           fputs (" PAD=", dumpfile);
1396           show_expr (open->pad);
1397         }
1398       if (open->decimal)
1399         {
1400           fputs (" DECIMAL=", dumpfile);
1401           show_expr (open->decimal);
1402         }
1403       if (open->encoding)
1404         {
1405           fputs (" ENCODING=", dumpfile);
1406           show_expr (open->encoding);
1407         }
1408       if (open->round)
1409         {
1410           fputs (" ROUND=", dumpfile);
1411           show_expr (open->round);
1412         }
1413       if (open->sign)
1414         {
1415           fputs (" SIGN=", dumpfile);
1416           show_expr (open->sign);
1417         }
1418       if (open->convert)
1419         {
1420           fputs (" CONVERT=", dumpfile);
1421           show_expr (open->convert);
1422         }
1423       if (open->asynchronous)
1424         {
1425           fputs (" ASYNCHRONOUS=", dumpfile);
1426           show_expr (open->asynchronous);
1427         }
1428       if (open->err != NULL)
1429         fprintf (dumpfile, " ERR=%d", open->err->value);
1430
1431       break;
1432
1433     case EXEC_CLOSE:
1434       fputs ("CLOSE", dumpfile);
1435       close = c->ext.close;
1436
1437       if (close->unit)
1438         {
1439           fputs (" UNIT=", dumpfile);
1440           show_expr (close->unit);
1441         }
1442       if (close->iomsg)
1443         {
1444           fputs (" IOMSG=", dumpfile);
1445           show_expr (close->iomsg);
1446         }
1447       if (close->iostat)
1448         {
1449           fputs (" IOSTAT=", dumpfile);
1450           show_expr (close->iostat);
1451         }
1452       if (close->status)
1453         {
1454           fputs (" STATUS=", dumpfile);
1455           show_expr (close->status);
1456         }
1457       if (close->err != NULL)
1458         fprintf (dumpfile, " ERR=%d", close->err->value);
1459       break;
1460
1461     case EXEC_BACKSPACE:
1462       fputs ("BACKSPACE", dumpfile);
1463       goto show_filepos;
1464
1465     case EXEC_ENDFILE:
1466       fputs ("ENDFILE", dumpfile);
1467       goto show_filepos;
1468
1469     case EXEC_REWIND:
1470       fputs ("REWIND", dumpfile);
1471       goto show_filepos;
1472
1473     case EXEC_FLUSH:
1474       fputs ("FLUSH", dumpfile);
1475
1476     show_filepos:
1477       fp = c->ext.filepos;
1478
1479       if (fp->unit)
1480         {
1481           fputs (" UNIT=", dumpfile);
1482           show_expr (fp->unit);
1483         }
1484       if (fp->iomsg)
1485         {
1486           fputs (" IOMSG=", dumpfile);
1487           show_expr (fp->iomsg);
1488         }
1489       if (fp->iostat)
1490         {
1491           fputs (" IOSTAT=", dumpfile);
1492           show_expr (fp->iostat);
1493         }
1494       if (fp->err != NULL)
1495         fprintf (dumpfile, " ERR=%d", fp->err->value);
1496       break;
1497
1498     case EXEC_INQUIRE:
1499       fputs ("INQUIRE", dumpfile);
1500       i = c->ext.inquire;
1501
1502       if (i->unit)
1503         {
1504           fputs (" UNIT=", dumpfile);
1505           show_expr (i->unit);
1506         }
1507       if (i->file)
1508         {
1509           fputs (" FILE=", dumpfile);
1510           show_expr (i->file);
1511         }
1512
1513       if (i->iomsg)
1514         {
1515           fputs (" IOMSG=", dumpfile);
1516           show_expr (i->iomsg);
1517         }
1518       if (i->iostat)
1519         {
1520           fputs (" IOSTAT=", dumpfile);
1521           show_expr (i->iostat);
1522         }
1523       if (i->exist)
1524         {
1525           fputs (" EXIST=", dumpfile);
1526           show_expr (i->exist);
1527         }
1528       if (i->opened)
1529         {
1530           fputs (" OPENED=", dumpfile);
1531           show_expr (i->opened);
1532         }
1533       if (i->number)
1534         {
1535           fputs (" NUMBER=", dumpfile);
1536           show_expr (i->number);
1537         }
1538       if (i->named)
1539         {
1540           fputs (" NAMED=", dumpfile);
1541           show_expr (i->named);
1542         }
1543       if (i->name)
1544         {
1545           fputs (" NAME=", dumpfile);
1546           show_expr (i->name);
1547         }
1548       if (i->access)
1549         {
1550           fputs (" ACCESS=", dumpfile);
1551           show_expr (i->access);
1552         }
1553       if (i->sequential)
1554         {
1555           fputs (" SEQUENTIAL=", dumpfile);
1556           show_expr (i->sequential);
1557         }
1558
1559       if (i->direct)
1560         {
1561           fputs (" DIRECT=", dumpfile);
1562           show_expr (i->direct);
1563         }
1564       if (i->form)
1565         {
1566           fputs (" FORM=", dumpfile);
1567           show_expr (i->form);
1568         }
1569       if (i->formatted)
1570         {
1571           fputs (" FORMATTED", dumpfile);
1572           show_expr (i->formatted);
1573         }
1574       if (i->unformatted)
1575         {
1576           fputs (" UNFORMATTED=", dumpfile);
1577           show_expr (i->unformatted);
1578         }
1579       if (i->recl)
1580         {
1581           fputs (" RECL=", dumpfile);
1582           show_expr (i->recl);
1583         }
1584       if (i->nextrec)
1585         {
1586           fputs (" NEXTREC=", dumpfile);
1587           show_expr (i->nextrec);
1588         }
1589       if (i->blank)
1590         {
1591           fputs (" BLANK=", dumpfile);
1592           show_expr (i->blank);
1593         }
1594       if (i->position)
1595         {
1596           fputs (" POSITION=", dumpfile);
1597           show_expr (i->position);
1598         }
1599       if (i->action)
1600         {
1601           fputs (" ACTION=", dumpfile);
1602           show_expr (i->action);
1603         }
1604       if (i->read)
1605         {
1606           fputs (" READ=", dumpfile);
1607           show_expr (i->read);
1608         }
1609       if (i->write)
1610         {
1611           fputs (" WRITE=", dumpfile);
1612           show_expr (i->write);
1613         }
1614       if (i->readwrite)
1615         {
1616           fputs (" READWRITE=", dumpfile);
1617           show_expr (i->readwrite);
1618         }
1619       if (i->delim)
1620         {
1621           fputs (" DELIM=", dumpfile);
1622           show_expr (i->delim);
1623         }
1624       if (i->pad)
1625         {
1626           fputs (" PAD=", dumpfile);
1627           show_expr (i->pad);
1628         }
1629       if (i->convert)
1630         {
1631           fputs (" CONVERT=", dumpfile);
1632           show_expr (i->convert);
1633         }
1634       if (i->asynchronous)
1635         {
1636           fputs (" ASYNCHRONOUS=", dumpfile);
1637           show_expr (i->asynchronous);
1638         }
1639       if (i->decimal)
1640         {
1641           fputs (" DECIMAL=", dumpfile);
1642           show_expr (i->decimal);
1643         }
1644       if (i->encoding)
1645         {
1646           fputs (" ENCODING=", dumpfile);
1647           show_expr (i->encoding);
1648         }
1649       if (i->pending)
1650         {
1651           fputs (" PENDING=", dumpfile);
1652           show_expr (i->pending);
1653         }
1654       if (i->round)
1655         {
1656           fputs (" ROUND=", dumpfile);
1657           show_expr (i->round);
1658         }
1659       if (i->sign)
1660         {
1661           fputs (" SIGN=", dumpfile);
1662           show_expr (i->sign);
1663         }
1664       if (i->size)
1665         {
1666           fputs (" SIZE=", dumpfile);
1667           show_expr (i->size);
1668         }
1669       if (i->id)
1670         {
1671           fputs (" ID=", dumpfile);
1672           show_expr (i->id);
1673         }
1674
1675       if (i->err != NULL)
1676         fprintf (dumpfile, " ERR=%d", i->err->value);
1677       break;
1678
1679     case EXEC_IOLENGTH:
1680       fputs ("IOLENGTH ", dumpfile);
1681       show_expr (c->expr);
1682       goto show_dt_code;
1683       break;
1684
1685     case EXEC_READ:
1686       fputs ("READ", dumpfile);
1687       goto show_dt;
1688
1689     case EXEC_WRITE:
1690       fputs ("WRITE", dumpfile);
1691
1692     show_dt:
1693       dt = c->ext.dt;
1694       if (dt->io_unit)
1695         {
1696           fputs (" UNIT=", dumpfile);
1697           show_expr (dt->io_unit);
1698         }
1699
1700       if (dt->format_expr)
1701         {
1702           fputs (" FMT=", dumpfile);
1703           show_expr (dt->format_expr);
1704         }
1705
1706       if (dt->format_label != NULL)
1707         fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1708       if (dt->namelist)
1709         fprintf (dumpfile, " NML=%s", dt->namelist->name);
1710
1711       if (dt->iomsg)
1712         {
1713           fputs (" IOMSG=", dumpfile);
1714           show_expr (dt->iomsg);
1715         }
1716       if (dt->iostat)
1717         {
1718           fputs (" IOSTAT=", dumpfile);
1719           show_expr (dt->iostat);
1720         }
1721       if (dt->size)
1722         {
1723           fputs (" SIZE=", dumpfile);
1724           show_expr (dt->size);
1725         }
1726       if (dt->rec)
1727         {
1728           fputs (" REC=", dumpfile);
1729           show_expr (dt->rec);
1730         }
1731       if (dt->advance)
1732         {
1733           fputs (" ADVANCE=", dumpfile);
1734           show_expr (dt->advance);
1735         }
1736       if (dt->id)
1737         {
1738           fputs (" ID=", dumpfile);
1739           show_expr (dt->id);
1740         }
1741       if (dt->pos)
1742         {
1743           fputs (" POS=", dumpfile);
1744           show_expr (dt->pos);
1745         }
1746       if (dt->asynchronous)
1747         {
1748           fputs (" ASYNCHRONOUS=", dumpfile);
1749           show_expr (dt->asynchronous);
1750         }
1751       if (dt->blank)
1752         {
1753           fputs (" BLANK=", dumpfile);
1754           show_expr (dt->blank);
1755         }
1756       if (dt->decimal)
1757         {
1758           fputs (" DECIMAL=", dumpfile);
1759           show_expr (dt->decimal);
1760         }
1761       if (dt->delim)
1762         {
1763           fputs (" DELIM=", dumpfile);
1764           show_expr (dt->delim);
1765         }
1766       if (dt->pad)
1767         {
1768           fputs (" PAD=", dumpfile);
1769           show_expr (dt->pad);
1770         }
1771       if (dt->round)
1772         {
1773           fputs (" ROUND=", dumpfile);
1774           show_expr (dt->round);
1775         }
1776       if (dt->sign)
1777         {
1778           fputs (" SIGN=", dumpfile);
1779           show_expr (dt->sign);
1780         }
1781
1782     show_dt_code:
1783       fputc ('\n', dumpfile);
1784       for (c = c->block->next; c; c = c->next)
1785         show_code_node (level + (c->next != NULL), c);
1786       return;
1787
1788     case EXEC_TRANSFER:
1789       fputs ("TRANSFER ", dumpfile);
1790       show_expr (c->expr);
1791       break;
1792
1793     case EXEC_DT_END:
1794       fputs ("DT_END", dumpfile);
1795       dt = c->ext.dt;
1796
1797       if (dt->err != NULL)
1798         fprintf (dumpfile, " ERR=%d", dt->err->value);
1799       if (dt->end != NULL)
1800         fprintf (dumpfile, " END=%d", dt->end->value);
1801       if (dt->eor != NULL)
1802         fprintf (dumpfile, " EOR=%d", dt->eor->value);
1803       break;
1804
1805     case EXEC_OMP_ATOMIC:
1806     case EXEC_OMP_BARRIER:
1807     case EXEC_OMP_CRITICAL:
1808     case EXEC_OMP_FLUSH:
1809     case EXEC_OMP_DO:
1810     case EXEC_OMP_MASTER:
1811     case EXEC_OMP_ORDERED:
1812     case EXEC_OMP_PARALLEL:
1813     case EXEC_OMP_PARALLEL_DO:
1814     case EXEC_OMP_PARALLEL_SECTIONS:
1815     case EXEC_OMP_PARALLEL_WORKSHARE:
1816     case EXEC_OMP_SECTIONS:
1817     case EXEC_OMP_SINGLE:
1818     case EXEC_OMP_TASK:
1819     case EXEC_OMP_TASKWAIT:
1820     case EXEC_OMP_WORKSHARE:
1821       show_omp_node (level, c);
1822       break;
1823
1824     default:
1825       gfc_internal_error ("show_code_node(): Bad statement code");
1826     }
1827
1828   fputc ('\n', dumpfile);
1829 }
1830
1831
1832 /* Show an equivalence chain.  */
1833
1834 static void
1835 show_equiv (gfc_equiv *eq)
1836 {
1837   show_indent ();
1838   fputs ("Equivalence: ", dumpfile);
1839   while (eq)
1840     {
1841       show_expr (eq->expr);
1842       eq = eq->eq;
1843       if (eq)
1844         fputs (", ", dumpfile);
1845     }
1846 }
1847
1848
1849 /* Show a freakin' whole namespace.  */
1850
1851 static void
1852 show_namespace (gfc_namespace *ns)
1853 {
1854   gfc_interface *intr;
1855   gfc_namespace *save;
1856   gfc_intrinsic_op op;
1857   gfc_equiv *eq;
1858   int i;
1859
1860   save = gfc_current_ns;
1861   show_level++;
1862
1863   show_indent ();
1864   fputs ("Namespace:", dumpfile);
1865
1866   if (ns != NULL)
1867     {
1868       i = 0;
1869       do
1870         {
1871           int l = i;
1872           while (i < GFC_LETTERS - 1
1873                  && gfc_compare_types(&ns->default_type[i+1],
1874                                       &ns->default_type[l]))
1875             i++;
1876
1877           if (i > l)
1878             fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
1879           else
1880             fprintf (dumpfile, " %c: ", l+'A');
1881
1882           show_typespec(&ns->default_type[l]);
1883           i++;
1884       } while (i < GFC_LETTERS);
1885
1886       if (ns->proc_name != NULL)
1887         {
1888           show_indent ();
1889           fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
1890         }
1891
1892       gfc_current_ns = ns;
1893       gfc_traverse_symtree (ns->common_root, show_common);
1894
1895       gfc_traverse_symtree (ns->sym_root, show_symtree);
1896
1897       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1898         {
1899           /* User operator interfaces */
1900           intr = ns->op[op];
1901           if (intr == NULL)
1902             continue;
1903
1904           show_indent ();
1905           fprintf (dumpfile, "Operator interfaces for %s:",
1906                    gfc_op2string (op));
1907
1908           for (; intr; intr = intr->next)
1909             fprintf (dumpfile, " %s", intr->sym->name);
1910         }
1911
1912       if (ns->uop_root != NULL)
1913         {
1914           show_indent ();
1915           fputs ("User operators:\n", dumpfile);
1916           gfc_traverse_user_op (ns, show_uop);
1917         }
1918     }
1919
1920   for (eq = ns->equiv; eq; eq = eq->next)
1921     show_equiv (eq);
1922
1923   fputc ('\n', dumpfile);
1924   fputc ('\n', dumpfile);
1925
1926   show_code (0, ns->code);
1927
1928   for (ns = ns->contained; ns; ns = ns->sibling)
1929     {
1930       show_indent ();
1931       fputs ("CONTAINS\n", dumpfile);
1932       show_namespace (ns);
1933     }
1934
1935   show_level--;
1936   fputc ('\n', dumpfile);
1937   gfc_current_ns = save;
1938 }
1939
1940
1941 /* Main function for dumping a parse tree.  */
1942
1943 void
1944 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
1945 {
1946   dumpfile = file;
1947   show_namespace (ns);
1948 }