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