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_END_PROCEDURE:
1152       break;
1153
1154     case EXEC_NOP:
1155       fputs ("NOP", dumpfile);
1156       break;
1157
1158     case EXEC_CONTINUE:
1159       fputs ("CONTINUE", dumpfile);
1160       break;
1161
1162     case EXEC_ENTRY:
1163       fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1164       break;
1165
1166     case EXEC_INIT_ASSIGN:
1167     case EXEC_ASSIGN:
1168       fputs ("ASSIGN ", dumpfile);
1169       show_expr (c->expr);
1170       fputc (' ', dumpfile);
1171       show_expr (c->expr2);
1172       break;
1173
1174     case EXEC_LABEL_ASSIGN:
1175       fputs ("LABEL ASSIGN ", dumpfile);
1176       show_expr (c->expr);
1177       fprintf (dumpfile, " %d", c->label->value);
1178       break;
1179
1180     case EXEC_POINTER_ASSIGN:
1181       fputs ("POINTER ASSIGN ", dumpfile);
1182       show_expr (c->expr);
1183       fputc (' ', dumpfile);
1184       show_expr (c->expr2);
1185       break;
1186
1187     case EXEC_GOTO:
1188       fputs ("GOTO ", dumpfile);
1189       if (c->label)
1190         fprintf (dumpfile, "%d", c->label->value);
1191       else
1192         {
1193           show_expr (c->expr);
1194           d = c->block;
1195           if (d != NULL)
1196             {
1197               fputs (", (", dumpfile);
1198               for (; d; d = d ->block)
1199                 {
1200                   code_indent (level, d->label);
1201                   if (d->block != NULL)
1202                     fputc (',', dumpfile);
1203                   else
1204                     fputc (')', dumpfile);
1205                 }
1206             }
1207         }
1208       break;
1209
1210     case EXEC_CALL:
1211     case EXEC_ASSIGN_CALL:
1212       if (c->resolved_sym)
1213         fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1214       else if (c->symtree)
1215         fprintf (dumpfile, "CALL %s ", c->symtree->name);
1216       else
1217         fputs ("CALL ?? ", dumpfile);
1218
1219       show_actual_arglist (c->ext.actual);
1220       break;
1221
1222     case EXEC_COMPCALL:
1223       fputs ("CALL ", dumpfile);
1224       show_compcall (c->expr);
1225       break;
1226
1227     case EXEC_CALL_PPC:
1228       fputs ("CALL ", dumpfile);
1229       show_expr (c->expr);
1230       show_actual_arglist (c->ext.actual);
1231       break;
1232
1233     case EXEC_RETURN:
1234       fputs ("RETURN ", dumpfile);
1235       if (c->expr)
1236         show_expr (c->expr);
1237       break;
1238
1239     case EXEC_PAUSE:
1240       fputs ("PAUSE ", dumpfile);
1241
1242       if (c->expr != NULL)
1243         show_expr (c->expr);
1244       else
1245         fprintf (dumpfile, "%d", c->ext.stop_code);
1246
1247       break;
1248
1249     case EXEC_STOP:
1250       fputs ("STOP ", dumpfile);
1251
1252       if (c->expr != NULL)
1253         show_expr (c->expr);
1254       else
1255         fprintf (dumpfile, "%d", c->ext.stop_code);
1256
1257       break;
1258
1259     case EXEC_ARITHMETIC_IF:
1260       fputs ("IF ", dumpfile);
1261       show_expr (c->expr);
1262       fprintf (dumpfile, " %d, %d, %d",
1263                   c->label->value, c->label2->value, c->label3->value);
1264       break;
1265
1266     case EXEC_IF:
1267       d = c->block;
1268       fputs ("IF ", dumpfile);
1269       show_expr (d->expr);
1270       fputc ('\n', dumpfile);
1271       show_code (level + 1, d->next);
1272
1273       d = d->block;
1274       for (; d; d = d->block)
1275         {
1276           code_indent (level, 0);
1277
1278           if (d->expr == NULL)
1279             fputs ("ELSE\n", dumpfile);
1280           else
1281             {
1282               fputs ("ELSE IF ", dumpfile);
1283               show_expr (d->expr);
1284               fputc ('\n', dumpfile);
1285             }
1286
1287           show_code (level + 1, d->next);
1288         }
1289
1290       code_indent (level, c->label);
1291
1292       fputs ("ENDIF", dumpfile);
1293       break;
1294
1295     case EXEC_SELECT:
1296       d = c->block;
1297       fputs ("SELECT CASE ", dumpfile);
1298       show_expr (c->expr);
1299       fputc ('\n', dumpfile);
1300
1301       for (; d; d = d->block)
1302         {
1303           code_indent (level, 0);
1304
1305           fputs ("CASE ", dumpfile);
1306           for (cp = d->ext.case_list; cp; cp = cp->next)
1307             {
1308               fputc ('(', dumpfile);
1309               show_expr (cp->low);
1310               fputc (' ', dumpfile);
1311               show_expr (cp->high);
1312               fputc (')', dumpfile);
1313               fputc (' ', dumpfile);
1314             }
1315           fputc ('\n', dumpfile);
1316
1317           show_code (level + 1, d->next);
1318         }
1319
1320       code_indent (level, c->label);
1321       fputs ("END SELECT", dumpfile);
1322       break;
1323
1324     case EXEC_WHERE:
1325       fputs ("WHERE ", dumpfile);
1326
1327       d = c->block;
1328       show_expr (d->expr);
1329       fputc ('\n', dumpfile);
1330
1331       show_code (level + 1, d->next);
1332
1333       for (d = d->block; d; d = d->block)
1334         {
1335           code_indent (level, 0);
1336           fputs ("ELSE WHERE ", dumpfile);
1337           show_expr (d->expr);
1338           fputc ('\n', dumpfile);
1339           show_code (level + 1, d->next);
1340         }
1341
1342       code_indent (level, 0);
1343       fputs ("END WHERE", dumpfile);
1344       break;
1345
1346
1347     case EXEC_FORALL:
1348       fputs ("FORALL ", dumpfile);
1349       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1350         {
1351           show_expr (fa->var);
1352           fputc (' ', dumpfile);
1353           show_expr (fa->start);
1354           fputc (':', dumpfile);
1355           show_expr (fa->end);
1356           fputc (':', dumpfile);
1357           show_expr (fa->stride);
1358
1359           if (fa->next != NULL)
1360             fputc (',', dumpfile);
1361         }
1362
1363       if (c->expr != NULL)
1364         {
1365           fputc (',', dumpfile);
1366           show_expr (c->expr);
1367         }
1368       fputc ('\n', dumpfile);
1369
1370       show_code (level + 1, c->block->next);
1371
1372       code_indent (level, 0);
1373       fputs ("END FORALL", dumpfile);
1374       break;
1375
1376     case EXEC_DO:
1377       fputs ("DO ", dumpfile);
1378
1379       show_expr (c->ext.iterator->var);
1380       fputc ('=', dumpfile);
1381       show_expr (c->ext.iterator->start);
1382       fputc (' ', dumpfile);
1383       show_expr (c->ext.iterator->end);
1384       fputc (' ', dumpfile);
1385       show_expr (c->ext.iterator->step);
1386       fputc ('\n', dumpfile);
1387
1388       show_code (level + 1, c->block->next);
1389
1390       code_indent (level, 0);
1391       fputs ("END DO", dumpfile);
1392       break;
1393
1394     case EXEC_DO_WHILE:
1395       fputs ("DO WHILE ", dumpfile);
1396       show_expr (c->expr);
1397       fputc ('\n', dumpfile);
1398
1399       show_code (level + 1, c->block->next);
1400
1401       code_indent (level, c->label);
1402       fputs ("END DO", dumpfile);
1403       break;
1404
1405     case EXEC_CYCLE:
1406       fputs ("CYCLE", dumpfile);
1407       if (c->symtree)
1408         fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1409       break;
1410
1411     case EXEC_EXIT:
1412       fputs ("EXIT", dumpfile);
1413       if (c->symtree)
1414         fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1415       break;
1416
1417     case EXEC_ALLOCATE:
1418       fputs ("ALLOCATE ", dumpfile);
1419       if (c->expr)
1420         {
1421           fputs (" STAT=", dumpfile);
1422           show_expr (c->expr);
1423         }
1424
1425       for (a = c->ext.alloc_list; a; a = a->next)
1426         {
1427           fputc (' ', dumpfile);
1428           show_expr (a->expr);
1429         }
1430
1431       break;
1432
1433     case EXEC_DEALLOCATE:
1434       fputs ("DEALLOCATE ", dumpfile);
1435       if (c->expr)
1436         {
1437           fputs (" STAT=", dumpfile);
1438           show_expr (c->expr);
1439         }
1440
1441       for (a = c->ext.alloc_list; a; a = a->next)
1442         {
1443           fputc (' ', dumpfile);
1444           show_expr (a->expr);
1445         }
1446
1447       break;
1448
1449     case EXEC_OPEN:
1450       fputs ("OPEN", dumpfile);
1451       open = c->ext.open;
1452
1453       if (open->unit)
1454         {
1455           fputs (" UNIT=", dumpfile);
1456           show_expr (open->unit);
1457         }
1458       if (open->iomsg)
1459         {
1460           fputs (" IOMSG=", dumpfile);
1461           show_expr (open->iomsg);
1462         }
1463       if (open->iostat)
1464         {
1465           fputs (" IOSTAT=", dumpfile);
1466           show_expr (open->iostat);
1467         }
1468       if (open->file)
1469         {
1470           fputs (" FILE=", dumpfile);
1471           show_expr (open->file);
1472         }
1473       if (open->status)
1474         {
1475           fputs (" STATUS=", dumpfile);
1476           show_expr (open->status);
1477         }
1478       if (open->access)
1479         {
1480           fputs (" ACCESS=", dumpfile);
1481           show_expr (open->access);
1482         }
1483       if (open->form)
1484         {
1485           fputs (" FORM=", dumpfile);
1486           show_expr (open->form);
1487         }
1488       if (open->recl)
1489         {
1490           fputs (" RECL=", dumpfile);
1491           show_expr (open->recl);
1492         }
1493       if (open->blank)
1494         {
1495           fputs (" BLANK=", dumpfile);
1496           show_expr (open->blank);
1497         }
1498       if (open->position)
1499         {
1500           fputs (" POSITION=", dumpfile);
1501           show_expr (open->position);
1502         }
1503       if (open->action)
1504         {
1505           fputs (" ACTION=", dumpfile);
1506           show_expr (open->action);
1507         }
1508       if (open->delim)
1509         {
1510           fputs (" DELIM=", dumpfile);
1511           show_expr (open->delim);
1512         }
1513       if (open->pad)
1514         {
1515           fputs (" PAD=", dumpfile);
1516           show_expr (open->pad);
1517         }
1518       if (open->decimal)
1519         {
1520           fputs (" DECIMAL=", dumpfile);
1521           show_expr (open->decimal);
1522         }
1523       if (open->encoding)
1524         {
1525           fputs (" ENCODING=", dumpfile);
1526           show_expr (open->encoding);
1527         }
1528       if (open->round)
1529         {
1530           fputs (" ROUND=", dumpfile);
1531           show_expr (open->round);
1532         }
1533       if (open->sign)
1534         {
1535           fputs (" SIGN=", dumpfile);
1536           show_expr (open->sign);
1537         }
1538       if (open->convert)
1539         {
1540           fputs (" CONVERT=", dumpfile);
1541           show_expr (open->convert);
1542         }
1543       if (open->asynchronous)
1544         {
1545           fputs (" ASYNCHRONOUS=", dumpfile);
1546           show_expr (open->asynchronous);
1547         }
1548       if (open->err != NULL)
1549         fprintf (dumpfile, " ERR=%d", open->err->value);
1550
1551       break;
1552
1553     case EXEC_CLOSE:
1554       fputs ("CLOSE", dumpfile);
1555       close = c->ext.close;
1556
1557       if (close->unit)
1558         {
1559           fputs (" UNIT=", dumpfile);
1560           show_expr (close->unit);
1561         }
1562       if (close->iomsg)
1563         {
1564           fputs (" IOMSG=", dumpfile);
1565           show_expr (close->iomsg);
1566         }
1567       if (close->iostat)
1568         {
1569           fputs (" IOSTAT=", dumpfile);
1570           show_expr (close->iostat);
1571         }
1572       if (close->status)
1573         {
1574           fputs (" STATUS=", dumpfile);
1575           show_expr (close->status);
1576         }
1577       if (close->err != NULL)
1578         fprintf (dumpfile, " ERR=%d", close->err->value);
1579       break;
1580
1581     case EXEC_BACKSPACE:
1582       fputs ("BACKSPACE", dumpfile);
1583       goto show_filepos;
1584
1585     case EXEC_ENDFILE:
1586       fputs ("ENDFILE", dumpfile);
1587       goto show_filepos;
1588
1589     case EXEC_REWIND:
1590       fputs ("REWIND", dumpfile);
1591       goto show_filepos;
1592
1593     case EXEC_FLUSH:
1594       fputs ("FLUSH", dumpfile);
1595
1596     show_filepos:
1597       fp = c->ext.filepos;
1598
1599       if (fp->unit)
1600         {
1601           fputs (" UNIT=", dumpfile);
1602           show_expr (fp->unit);
1603         }
1604       if (fp->iomsg)
1605         {
1606           fputs (" IOMSG=", dumpfile);
1607           show_expr (fp->iomsg);
1608         }
1609       if (fp->iostat)
1610         {
1611           fputs (" IOSTAT=", dumpfile);
1612           show_expr (fp->iostat);
1613         }
1614       if (fp->err != NULL)
1615         fprintf (dumpfile, " ERR=%d", fp->err->value);
1616       break;
1617
1618     case EXEC_INQUIRE:
1619       fputs ("INQUIRE", dumpfile);
1620       i = c->ext.inquire;
1621
1622       if (i->unit)
1623         {
1624           fputs (" UNIT=", dumpfile);
1625           show_expr (i->unit);
1626         }
1627       if (i->file)
1628         {
1629           fputs (" FILE=", dumpfile);
1630           show_expr (i->file);
1631         }
1632
1633       if (i->iomsg)
1634         {
1635           fputs (" IOMSG=", dumpfile);
1636           show_expr (i->iomsg);
1637         }
1638       if (i->iostat)
1639         {
1640           fputs (" IOSTAT=", dumpfile);
1641           show_expr (i->iostat);
1642         }
1643       if (i->exist)
1644         {
1645           fputs (" EXIST=", dumpfile);
1646           show_expr (i->exist);
1647         }
1648       if (i->opened)
1649         {
1650           fputs (" OPENED=", dumpfile);
1651           show_expr (i->opened);
1652         }
1653       if (i->number)
1654         {
1655           fputs (" NUMBER=", dumpfile);
1656           show_expr (i->number);
1657         }
1658       if (i->named)
1659         {
1660           fputs (" NAMED=", dumpfile);
1661           show_expr (i->named);
1662         }
1663       if (i->name)
1664         {
1665           fputs (" NAME=", dumpfile);
1666           show_expr (i->name);
1667         }
1668       if (i->access)
1669         {
1670           fputs (" ACCESS=", dumpfile);
1671           show_expr (i->access);
1672         }
1673       if (i->sequential)
1674         {
1675           fputs (" SEQUENTIAL=", dumpfile);
1676           show_expr (i->sequential);
1677         }
1678
1679       if (i->direct)
1680         {
1681           fputs (" DIRECT=", dumpfile);
1682           show_expr (i->direct);
1683         }
1684       if (i->form)
1685         {
1686           fputs (" FORM=", dumpfile);
1687           show_expr (i->form);
1688         }
1689       if (i->formatted)
1690         {
1691           fputs (" FORMATTED", dumpfile);
1692           show_expr (i->formatted);
1693         }
1694       if (i->unformatted)
1695         {
1696           fputs (" UNFORMATTED=", dumpfile);
1697           show_expr (i->unformatted);
1698         }
1699       if (i->recl)
1700         {
1701           fputs (" RECL=", dumpfile);
1702           show_expr (i->recl);
1703         }
1704       if (i->nextrec)
1705         {
1706           fputs (" NEXTREC=", dumpfile);
1707           show_expr (i->nextrec);
1708         }
1709       if (i->blank)
1710         {
1711           fputs (" BLANK=", dumpfile);
1712           show_expr (i->blank);
1713         }
1714       if (i->position)
1715         {
1716           fputs (" POSITION=", dumpfile);
1717           show_expr (i->position);
1718         }
1719       if (i->action)
1720         {
1721           fputs (" ACTION=", dumpfile);
1722           show_expr (i->action);
1723         }
1724       if (i->read)
1725         {
1726           fputs (" READ=", dumpfile);
1727           show_expr (i->read);
1728         }
1729       if (i->write)
1730         {
1731           fputs (" WRITE=", dumpfile);
1732           show_expr (i->write);
1733         }
1734       if (i->readwrite)
1735         {
1736           fputs (" READWRITE=", dumpfile);
1737           show_expr (i->readwrite);
1738         }
1739       if (i->delim)
1740         {
1741           fputs (" DELIM=", dumpfile);
1742           show_expr (i->delim);
1743         }
1744       if (i->pad)
1745         {
1746           fputs (" PAD=", dumpfile);
1747           show_expr (i->pad);
1748         }
1749       if (i->convert)
1750         {
1751           fputs (" CONVERT=", dumpfile);
1752           show_expr (i->convert);
1753         }
1754       if (i->asynchronous)
1755         {
1756           fputs (" ASYNCHRONOUS=", dumpfile);
1757           show_expr (i->asynchronous);
1758         }
1759       if (i->decimal)
1760         {
1761           fputs (" DECIMAL=", dumpfile);
1762           show_expr (i->decimal);
1763         }
1764       if (i->encoding)
1765         {
1766           fputs (" ENCODING=", dumpfile);
1767           show_expr (i->encoding);
1768         }
1769       if (i->pending)
1770         {
1771           fputs (" PENDING=", dumpfile);
1772           show_expr (i->pending);
1773         }
1774       if (i->round)
1775         {
1776           fputs (" ROUND=", dumpfile);
1777           show_expr (i->round);
1778         }
1779       if (i->sign)
1780         {
1781           fputs (" SIGN=", dumpfile);
1782           show_expr (i->sign);
1783         }
1784       if (i->size)
1785         {
1786           fputs (" SIZE=", dumpfile);
1787           show_expr (i->size);
1788         }
1789       if (i->id)
1790         {
1791           fputs (" ID=", dumpfile);
1792           show_expr (i->id);
1793         }
1794
1795       if (i->err != NULL)
1796         fprintf (dumpfile, " ERR=%d", i->err->value);
1797       break;
1798
1799     case EXEC_IOLENGTH:
1800       fputs ("IOLENGTH ", dumpfile);
1801       show_expr (c->expr);
1802       goto show_dt_code;
1803       break;
1804
1805     case EXEC_READ:
1806       fputs ("READ", dumpfile);
1807       goto show_dt;
1808
1809     case EXEC_WRITE:
1810       fputs ("WRITE", dumpfile);
1811
1812     show_dt:
1813       dt = c->ext.dt;
1814       if (dt->io_unit)
1815         {
1816           fputs (" UNIT=", dumpfile);
1817           show_expr (dt->io_unit);
1818         }
1819
1820       if (dt->format_expr)
1821         {
1822           fputs (" FMT=", dumpfile);
1823           show_expr (dt->format_expr);
1824         }
1825
1826       if (dt->format_label != NULL)
1827         fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1828       if (dt->namelist)
1829         fprintf (dumpfile, " NML=%s", dt->namelist->name);
1830
1831       if (dt->iomsg)
1832         {
1833           fputs (" IOMSG=", dumpfile);
1834           show_expr (dt->iomsg);
1835         }
1836       if (dt->iostat)
1837         {
1838           fputs (" IOSTAT=", dumpfile);
1839           show_expr (dt->iostat);
1840         }
1841       if (dt->size)
1842         {
1843           fputs (" SIZE=", dumpfile);
1844           show_expr (dt->size);
1845         }
1846       if (dt->rec)
1847         {
1848           fputs (" REC=", dumpfile);
1849           show_expr (dt->rec);
1850         }
1851       if (dt->advance)
1852         {
1853           fputs (" ADVANCE=", dumpfile);
1854           show_expr (dt->advance);
1855         }
1856       if (dt->id)
1857         {
1858           fputs (" ID=", dumpfile);
1859           show_expr (dt->id);
1860         }
1861       if (dt->pos)
1862         {
1863           fputs (" POS=", dumpfile);
1864           show_expr (dt->pos);
1865         }
1866       if (dt->asynchronous)
1867         {
1868           fputs (" ASYNCHRONOUS=", dumpfile);
1869           show_expr (dt->asynchronous);
1870         }
1871       if (dt->blank)
1872         {
1873           fputs (" BLANK=", dumpfile);
1874           show_expr (dt->blank);
1875         }
1876       if (dt->decimal)
1877         {
1878           fputs (" DECIMAL=", dumpfile);
1879           show_expr (dt->decimal);
1880         }
1881       if (dt->delim)
1882         {
1883           fputs (" DELIM=", dumpfile);
1884           show_expr (dt->delim);
1885         }
1886       if (dt->pad)
1887         {
1888           fputs (" PAD=", dumpfile);
1889           show_expr (dt->pad);
1890         }
1891       if (dt->round)
1892         {
1893           fputs (" ROUND=", dumpfile);
1894           show_expr (dt->round);
1895         }
1896       if (dt->sign)
1897         {
1898           fputs (" SIGN=", dumpfile);
1899           show_expr (dt->sign);
1900         }
1901
1902     show_dt_code:
1903       fputc ('\n', dumpfile);
1904       for (c = c->block->next; c; c = c->next)
1905         show_code_node (level + (c->next != NULL), c);
1906       return;
1907
1908     case EXEC_TRANSFER:
1909       fputs ("TRANSFER ", dumpfile);
1910       show_expr (c->expr);
1911       break;
1912
1913     case EXEC_DT_END:
1914       fputs ("DT_END", dumpfile);
1915       dt = c->ext.dt;
1916
1917       if (dt->err != NULL)
1918         fprintf (dumpfile, " ERR=%d", dt->err->value);
1919       if (dt->end != NULL)
1920         fprintf (dumpfile, " END=%d", dt->end->value);
1921       if (dt->eor != NULL)
1922         fprintf (dumpfile, " EOR=%d", dt->eor->value);
1923       break;
1924
1925     case EXEC_OMP_ATOMIC:
1926     case EXEC_OMP_BARRIER:
1927     case EXEC_OMP_CRITICAL:
1928     case EXEC_OMP_FLUSH:
1929     case EXEC_OMP_DO:
1930     case EXEC_OMP_MASTER:
1931     case EXEC_OMP_ORDERED:
1932     case EXEC_OMP_PARALLEL:
1933     case EXEC_OMP_PARALLEL_DO:
1934     case EXEC_OMP_PARALLEL_SECTIONS:
1935     case EXEC_OMP_PARALLEL_WORKSHARE:
1936     case EXEC_OMP_SECTIONS:
1937     case EXEC_OMP_SINGLE:
1938     case EXEC_OMP_TASK:
1939     case EXEC_OMP_TASKWAIT:
1940     case EXEC_OMP_WORKSHARE:
1941       show_omp_node (level, c);
1942       break;
1943
1944     default:
1945       gfc_internal_error ("show_code_node(): Bad statement code");
1946     }
1947
1948   fputc ('\n', dumpfile);
1949 }
1950
1951
1952 /* Show an equivalence chain.  */
1953
1954 static void
1955 show_equiv (gfc_equiv *eq)
1956 {
1957   show_indent ();
1958   fputs ("Equivalence: ", dumpfile);
1959   while (eq)
1960     {
1961       show_expr (eq->expr);
1962       eq = eq->eq;
1963       if (eq)
1964         fputs (", ", dumpfile);
1965     }
1966 }
1967
1968
1969 /* Show a freakin' whole namespace.  */
1970
1971 static void
1972 show_namespace (gfc_namespace *ns)
1973 {
1974   gfc_interface *intr;
1975   gfc_namespace *save;
1976   gfc_intrinsic_op op;
1977   gfc_equiv *eq;
1978   int i;
1979
1980   save = gfc_current_ns;
1981   show_level++;
1982
1983   show_indent ();
1984   fputs ("Namespace:", dumpfile);
1985
1986   if (ns != NULL)
1987     {
1988       i = 0;
1989       do
1990         {
1991           int l = i;
1992           while (i < GFC_LETTERS - 1
1993                  && gfc_compare_types(&ns->default_type[i+1],
1994                                       &ns->default_type[l]))
1995             i++;
1996
1997           if (i > l)
1998             fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
1999           else
2000             fprintf (dumpfile, " %c: ", l+'A');
2001
2002           show_typespec(&ns->default_type[l]);
2003           i++;
2004       } while (i < GFC_LETTERS);
2005
2006       if (ns->proc_name != NULL)
2007         {
2008           show_indent ();
2009           fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2010         }
2011
2012       gfc_current_ns = ns;
2013       gfc_traverse_symtree (ns->common_root, show_common);
2014
2015       gfc_traverse_symtree (ns->sym_root, show_symtree);
2016
2017       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2018         {
2019           /* User operator interfaces */
2020           intr = ns->op[op];
2021           if (intr == NULL)
2022             continue;
2023
2024           show_indent ();
2025           fprintf (dumpfile, "Operator interfaces for %s:",
2026                    gfc_op2string (op));
2027
2028           for (; intr; intr = intr->next)
2029             fprintf (dumpfile, " %s", intr->sym->name);
2030         }
2031
2032       if (ns->uop_root != NULL)
2033         {
2034           show_indent ();
2035           fputs ("User operators:\n", dumpfile);
2036           gfc_traverse_user_op (ns, show_uop);
2037         }
2038     }
2039
2040   for (eq = ns->equiv; eq; eq = eq->next)
2041     show_equiv (eq);
2042
2043   fputc ('\n', dumpfile);
2044   fputc ('\n', dumpfile);
2045
2046   show_code (0, ns->code);
2047
2048   for (ns = ns->contained; ns; ns = ns->sibling)
2049     {
2050       show_indent ();
2051       fputs ("CONTAINS\n", dumpfile);
2052       show_namespace (ns);
2053     }
2054
2055   show_level--;
2056   fputc ('\n', dumpfile);
2057   gfc_current_ns = save;
2058 }
2059
2060
2061 /* Main function for dumping a parse tree.  */
2062
2063 void
2064 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2065 {
2066   dumpfile = file;
2067   show_namespace (ns);
2068 }