gcc/fortran/dump-parse-tree.c

   1 /* Parse tree dumper
   2    Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009
   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, mpc_realref (p->value.complex),
 406                         GFC_RND_MODE);
 407           if (p->ts.kind != gfc_default_complex_kind)
 408             fprintf (dumpfile, "_%d", p->ts.kind);
 409
 410           fputc (' ', dumpfile);
 411
 412           mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
 413                         GFC_RND_MODE);
 414           if (p->ts.kind != gfc_default_complex_kind)
 415             fprintf (dumpfile, "_%d", p->ts.kind);
 416
 417           fputc (')', dumpfile);
 418           break;
 419
 420         case BT_HOLLERITH:
 421           fprintf (dumpfile, "%dH", p->representation.length);
 422           c = p->representation.string;
 423           for (i = 0; i < p->representation.length; i++, c++)
 424             {
 425               fputc (*c, dumpfile);
 426             }
 427           break;
 428
 429         default:
 430           fputs ("???", dumpfile);
 431           break;
 432         }
 433
 434       if (p->representation.string)
 435         {
 436           fputs (" {", dumpfile);
 437           c = p->representation.string;
 438           for (i = 0; i < p->representation.length; i++, c++)
 439             {
 440               fprintf (dumpfile, "%.2x", (unsigned int) *c);
 441               if (i < p->representation.length - 1)
 442                 fputc (',', dumpfile);
 443             }
 444           fputc ('}', dumpfile);
 445         }
 446
 447       break;
 448
 449     case EXPR_VARIABLE:
 450       if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
 451         fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
 452       fprintf (dumpfile, "%s", p->symtree->n.sym->name);
 453       show_ref (p->ref);
 454       break;
 455
 456     case EXPR_OP:
 457       fputc ('(', dumpfile);
 458       switch (p->value.op.op)
 459         {
 460         case INTRINSIC_UPLUS:
 461           fputs ("U+ ", dumpfile);
 462           break;
 463         case INTRINSIC_UMINUS:
 464           fputs ("U- ", dumpfile);
 465           break;
 466         case INTRINSIC_PLUS:
 467           fputs ("+ ", dumpfile);
 468           break;
 469         case INTRINSIC_MINUS:
 470           fputs ("- ", dumpfile);
 471           break;
 472         case INTRINSIC_TIMES:
 473           fputs ("* ", dumpfile);
 474           break;
 475         case INTRINSIC_DIVIDE:
 476           fputs ("/ ", dumpfile);
 477           break;
 478         case INTRINSIC_POWER:
 479           fputs ("** ", dumpfile);
 480           break;
 481         case INTRINSIC_CONCAT:
 482           fputs ("// ", dumpfile);
 483           break;
 484         case INTRINSIC_AND:
 485           fputs ("AND ", dumpfile);
 486           break;
 487         case INTRINSIC_OR:
 488           fputs ("OR ", dumpfile);
 489           break;
 490         case INTRINSIC_EQV:
 491           fputs ("EQV ", dumpfile);
 492           break;
 493         case INTRINSIC_NEQV:
 494           fputs ("NEQV ", dumpfile);
 495           break;
 496         case INTRINSIC_EQ:
 497         case INTRINSIC_EQ_OS:
 498           fputs ("= ", dumpfile);
 499           break;
 500         case INTRINSIC_NE:
 501         case INTRINSIC_NE_OS:
 502           fputs ("/= ", dumpfile);
 503           break;
 504         case INTRINSIC_GT:
 505         case INTRINSIC_GT_OS:
 506           fputs ("> ", dumpfile);
 507           break;
 508         case INTRINSIC_GE:
 509         case INTRINSIC_GE_OS:
 510           fputs (">= ", dumpfile);
 511           break;
 512         case INTRINSIC_LT:
 513         case INTRINSIC_LT_OS:
 514           fputs ("< ", dumpfile);
 515           break;
 516         case INTRINSIC_LE:
 517         case INTRINSIC_LE_OS:
 518           fputs ("<= ", dumpfile);
 519           break;
 520         case INTRINSIC_NOT:
 521           fputs ("NOT ", dumpfile);
 522           break;
 523         case INTRINSIC_PARENTHESES:
 524           fputs ("parens", dumpfile);
 525           break;
 526
 527         default:
 528           gfc_internal_error
 529             ("show_expr(): Bad intrinsic in expression!");
 530         }
 531
 532       show_expr (p->value.op.op1);
 533
 534       if (p->value.op.op2)
 535         {
 536           fputc (' ', dumpfile);
 537           show_expr (p->value.op.op2);
 538         }
 539
 540       fputc (')', dumpfile);
 541       break;
 542
 543     case EXPR_FUNCTION:
 544       if (p->value.function.name == NULL)
 545         {
 546           fprintf (dumpfile, "%s", p->symtree->n.sym->name);
 547           if (is_proc_ptr_comp (p, NULL))
 548             show_ref (p->ref);
 549           fputc ('[', dumpfile);
 550           show_actual_arglist (p->value.function.actual);
 551           fputc (']', dumpfile);
 552         }
 553       else
 554         {
 555           fprintf (dumpfile, "%s", p->value.function.name);
 556           if (is_proc_ptr_comp (p, NULL))
 557             show_ref (p->ref);
 558           fputc ('[', dumpfile);
 559           fputc ('[', dumpfile);
 560           show_actual_arglist (p->value.function.actual);
 561           fputc (']', dumpfile);
 562           fputc (']', dumpfile);
 563         }
 564
 565       break;
 566
 567     case EXPR_COMPCALL:
 568       show_compcall (p);
 569       break;
 570
 571     default:
 572       gfc_internal_error ("show_expr(): Don't know how to show expr");
 573     }
 574 }
 575
 576 /* Show symbol attributes.  The flavor and intent are followed by
 577    whatever single bit attributes are present.  */
 578
 579 static void
 580 show_attr (symbol_attribute *attr)
 581 {
 582
 583   fprintf (dumpfile, "(%s %s %s %s %s",
 584            gfc_code2string (flavors, attr->flavor),
 585            gfc_intent_string (attr->intent),
 586            gfc_code2string (access_types, attr->access),
 587            gfc_code2string (procedures, attr->proc),
 588            gfc_code2string (save_status, attr->save));
 589
 590   if (attr->allocatable)
 591     fputs (" ALLOCATABLE", dumpfile);
 592   if (attr->dimension)
 593     fputs (" DIMENSION", dumpfile);
 594   if (attr->external)
 595     fputs (" EXTERNAL", dumpfile);
 596   if (attr->intrinsic)
 597     fputs (" INTRINSIC", dumpfile);
 598   if (attr->optional)
 599     fputs (" OPTIONAL", dumpfile);
 600   if (attr->pointer)
 601     fputs (" POINTER", dumpfile);
 602   if (attr->is_protected)
 603     fputs (" PROTECTED", dumpfile);
 604   if (attr->value)
 605     fputs (" VALUE", dumpfile);
 606   if (attr->volatile_)
 607     fputs (" VOLATILE", dumpfile);
 608   if (attr->threadprivate)
 609     fputs (" THREADPRIVATE", dumpfile);
 610   if (attr->target)
 611     fputs (" TARGET", dumpfile);
 612   if (attr->dummy)
 613     fputs (" DUMMY", dumpfile);
 614   if (attr->result)
 615     fputs (" RESULT", dumpfile);
 616   if (attr->entry)
 617     fputs (" ENTRY", dumpfile);
 618   if (attr->is_bind_c)
 619     fputs (" BIND(C)", dumpfile);
 620
 621   if (attr->data)
 622     fputs (" DATA", dumpfile);
 623   if (attr->use_assoc)
 624     fputs (" USE-ASSOC", dumpfile);
 625   if (attr->in_namelist)
 626     fputs (" IN-NAMELIST", dumpfile);
 627   if (attr->in_common)
 628     fputs (" IN-COMMON", dumpfile);
 629
 630   if (attr->abstract)
 631     fputs (" ABSTRACT", dumpfile);
 632   if (attr->function)
 633     fputs (" FUNCTION", dumpfile);
 634   if (attr->subroutine)
 635     fputs (" SUBROUTINE", dumpfile);
 636   if (attr->implicit_type)
 637     fputs (" IMPLICIT-TYPE", dumpfile);
 638
 639   if (attr->sequence)
 640     fputs (" SEQUENCE", dumpfile);
 641   if (attr->elemental)
 642     fputs (" ELEMENTAL", dumpfile);
 643   if (attr->pure)
 644     fputs (" PURE", dumpfile);
 645   if (attr->recursive)
 646     fputs (" RECURSIVE", dumpfile);
 647
 648   fputc (')', dumpfile);
 649 }
 650
 651
 652 /* Show components of a derived type.  */
 653
 654 static void
 655 show_components (gfc_symbol *sym)
 656 {
 657   gfc_component *c;
 658
 659   for (c = sym->components; c; c = c->next)
 660     {
 661       fprintf (dumpfile, "(%s ", c->name);
 662       show_typespec (&c->ts);
 663       if (c->attr.pointer)
 664         fputs (" POINTER", dumpfile);
 665       if (c->attr.proc_pointer)
 666         fputs (" PPC", dumpfile);
 667       if (c->attr.dimension)
 668         fputs (" DIMENSION", dumpfile);
 669       fputc (' ', dumpfile);
 670       show_array_spec (c->as);
 671       if (c->attr.access)
 672         fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
 673       fputc (')', dumpfile);
 674       if (c->next != NULL)
 675         fputc (' ', dumpfile);
 676     }
 677 }
 678
 679
 680 /* Show the f2k_derived namespace with procedure bindings.  */
 681
 682 static void
 683 show_typebound (gfc_symtree* st)
 684 {
 685   gcc_assert (st->n.tb);
 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->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->tb_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->expr1);
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->expr1);
1177       fprintf (dumpfile, " %d", c->label1->value);
1178       break;
1179
1180     case EXEC_POINTER_ASSIGN:
1181       fputs ("POINTER ASSIGN ", dumpfile);
1182       show_expr (c->expr1);
1183       fputc (' ', dumpfile);
1184       show_expr (c->expr2);
1185       break;
1186
1187     case EXEC_GOTO:
1188       fputs ("GOTO ", dumpfile);
1189       if (c->label1)
1190         fprintf (dumpfile, "%d", c->label1->value);
1191       else
1192         {
1193           show_expr (c->expr1);
1194           d = c->block;
1195           if (d != NULL)
1196             {
1197               fputs (", (", dumpfile);
1198               for (; d; d = d ->block)
1199                 {
1200                   code_indent (level, d->label1);
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->expr1);
1225       break;
1226
1227     case EXEC_CALL_PPC:
1228       fputs ("CALL ", dumpfile);
1229       show_expr (c->expr1);
1230       show_actual_arglist (c->ext.actual);
1231       break;
1232
1233     case EXEC_RETURN:
1234       fputs ("RETURN ", dumpfile);
1235       if (c->expr1)
1236         show_expr (c->expr1);
1237       break;
1238
1239     case EXEC_PAUSE:
1240       fputs ("PAUSE ", dumpfile);
1241
1242       if (c->expr1 != NULL)
1243         show_expr (c->expr1);
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->expr1 != NULL)
1253         show_expr (c->expr1);
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->expr1);
1262       fprintf (dumpfile, " %d, %d, %d",
1263                   c->label1->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->expr1);
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->expr1 == NULL)
1279             fputs ("ELSE\n", dumpfile);
1280           else
1281             {
1282               fputs ("ELSE IF ", dumpfile);
1283               show_expr (d->expr1);
1284               fputc ('\n', dumpfile);
1285             }
1286
1287           show_code (level + 1, d->next);
1288         }
1289
1290       code_indent (level, c->label1);
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->expr1);
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->label1);
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->expr1);
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->expr1);
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->expr1 != NULL)
1364         {
1365           fputc (',', dumpfile);
1366           show_expr (c->expr1);
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->expr1);
1397       fputc ('\n', dumpfile);
1398
1399       show_code (level + 1, c->block->next);
1400
1401       code_indent (level, c->label1);
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->expr1)
1420         {
1421           fputs (" STAT=", dumpfile);
1422           show_expr (c->expr1);
1423         }
1424
1425       if (c->expr2)
1426         {
1427           fputs (" ERRMSG=", dumpfile);
1428           show_expr (c->expr2);
1429         }
1430
1431       for (a = c->ext.alloc_list; a; a = a->next)
1432         {
1433           fputc (' ', dumpfile);
1434           show_expr (a->expr);
1435         }
1436
1437       break;
1438
1439     case EXEC_DEALLOCATE:
1440       fputs ("DEALLOCATE ", dumpfile);
1441       if (c->expr1)
1442         {
1443           fputs (" STAT=", dumpfile);
1444           show_expr (c->expr1);
1445         }
1446
1447       if (c->expr2)
1448         {
1449           fputs (" ERRMSG=", dumpfile);
1450           show_expr (c->expr2);
1451         }
1452
1453       for (a = c->ext.alloc_list; a; a = a->next)
1454         {
1455           fputc (' ', dumpfile);
1456           show_expr (a->expr);
1457         }
1458
1459       break;
1460
1461     case EXEC_OPEN:
1462       fputs ("OPEN", dumpfile);
1463       open = c->ext.open;
1464
1465       if (open->unit)
1466         {
1467           fputs (" UNIT=", dumpfile);
1468           show_expr (open->unit);
1469         }
1470       if (open->iomsg)
1471         {
1472           fputs (" IOMSG=", dumpfile);
1473           show_expr (open->iomsg);
1474         }
1475       if (open->iostat)
1476         {
1477           fputs (" IOSTAT=", dumpfile);
1478           show_expr (open->iostat);
1479         }
1480       if (open->file)
1481         {
1482           fputs (" FILE=", dumpfile);
1483           show_expr (open->file);
1484         }
1485       if (open->status)
1486         {
1487           fputs (" STATUS=", dumpfile);
1488           show_expr (open->status);
1489         }
1490       if (open->access)
1491         {
1492           fputs (" ACCESS=", dumpfile);
1493           show_expr (open->access);
1494         }
1495       if (open->form)
1496         {
1497           fputs (" FORM=", dumpfile);
1498           show_expr (open->form);
1499         }
1500       if (open->recl)
1501         {
1502           fputs (" RECL=", dumpfile);
1503           show_expr (open->recl);
1504         }
1505       if (open->blank)
1506         {
1507           fputs (" BLANK=", dumpfile);
1508           show_expr (open->blank);
1509         }
1510       if (open->position)
1511         {
1512           fputs (" POSITION=", dumpfile);
1513           show_expr (open->position);
1514         }
1515       if (open->action)
1516         {
1517           fputs (" ACTION=", dumpfile);
1518           show_expr (open->action);
1519         }
1520       if (open->delim)
1521         {
1522           fputs (" DELIM=", dumpfile);
1523           show_expr (open->delim);
1524         }
1525       if (open->pad)
1526         {
1527           fputs (" PAD=", dumpfile);
1528           show_expr (open->pad);
1529         }
1530       if (open->decimal)
1531         {
1532           fputs (" DECIMAL=", dumpfile);
1533           show_expr (open->decimal);
1534         }
1535       if (open->encoding)
1536         {
1537           fputs (" ENCODING=", dumpfile);
1538           show_expr (open->encoding);
1539         }
1540       if (open->round)
1541         {
1542           fputs (" ROUND=", dumpfile);
1543           show_expr (open->round);
1544         }
1545       if (open->sign)
1546         {
1547           fputs (" SIGN=", dumpfile);
1548           show_expr (open->sign);
1549         }
1550       if (open->convert)
1551         {
1552           fputs (" CONVERT=", dumpfile);
1553           show_expr (open->convert);
1554         }
1555       if (open->asynchronous)
1556         {
1557           fputs (" ASYNCHRONOUS=", dumpfile);
1558           show_expr (open->asynchronous);
1559         }
1560       if (open->err != NULL)
1561         fprintf (dumpfile, " ERR=%d", open->err->value);
1562
1563       break;
1564
1565     case EXEC_CLOSE:
1566       fputs ("CLOSE", dumpfile);
1567       close = c->ext.close;
1568
1569       if (close->unit)
1570         {
1571           fputs (" UNIT=", dumpfile);
1572           show_expr (close->unit);
1573         }
1574       if (close->iomsg)
1575         {
1576           fputs (" IOMSG=", dumpfile);
1577           show_expr (close->iomsg);
1578         }
1579       if (close->iostat)
1580         {
1581           fputs (" IOSTAT=", dumpfile);
1582           show_expr (close->iostat);
1583         }
1584       if (close->status)
1585         {
1586           fputs (" STATUS=", dumpfile);
1587           show_expr (close->status);
1588         }
1589       if (close->err != NULL)
1590         fprintf (dumpfile, " ERR=%d", close->err->value);
1591       break;
1592
1593     case EXEC_BACKSPACE:
1594       fputs ("BACKSPACE", dumpfile);
1595       goto show_filepos;
1596
1597     case EXEC_ENDFILE:
1598       fputs ("ENDFILE", dumpfile);
1599       goto show_filepos;
1600
1601     case EXEC_REWIND:
1602       fputs ("REWIND", dumpfile);
1603       goto show_filepos;
1604
1605     case EXEC_FLUSH:
1606       fputs ("FLUSH", dumpfile);
1607
1608     show_filepos:
1609       fp = c->ext.filepos;
1610
1611       if (fp->unit)
1612         {
1613           fputs (" UNIT=", dumpfile);
1614           show_expr (fp->unit);
1615         }
1616       if (fp->iomsg)
1617         {
1618           fputs (" IOMSG=", dumpfile);
1619           show_expr (fp->iomsg);
1620         }
1621       if (fp->iostat)
1622         {
1623           fputs (" IOSTAT=", dumpfile);
1624           show_expr (fp->iostat);
1625         }
1626       if (fp->err != NULL)
1627         fprintf (dumpfile, " ERR=%d", fp->err->value);
1628       break;
1629
1630     case EXEC_INQUIRE:
1631       fputs ("INQUIRE", dumpfile);
1632       i = c->ext.inquire;
1633
1634       if (i->unit)
1635         {
1636           fputs (" UNIT=", dumpfile);
1637           show_expr (i->unit);
1638         }
1639       if (i->file)
1640         {
1641           fputs (" FILE=", dumpfile);
1642           show_expr (i->file);
1643         }
1644
1645       if (i->iomsg)
1646         {
1647           fputs (" IOMSG=", dumpfile);
1648           show_expr (i->iomsg);
1649         }
1650       if (i->iostat)
1651         {
1652           fputs (" IOSTAT=", dumpfile);
1653           show_expr (i->iostat);
1654         }
1655       if (i->exist)
1656         {
1657           fputs (" EXIST=", dumpfile);
1658           show_expr (i->exist);
1659         }
1660       if (i->opened)
1661         {
1662           fputs (" OPENED=", dumpfile);
1663           show_expr (i->opened);
1664         }
1665       if (i->number)
1666         {
1667           fputs (" NUMBER=", dumpfile);
1668           show_expr (i->number);
1669         }
1670       if (i->named)
1671         {
1672           fputs (" NAMED=", dumpfile);
1673           show_expr (i->named);
1674         }
1675       if (i->name)
1676         {
1677           fputs (" NAME=", dumpfile);
1678           show_expr (i->name);
1679         }
1680       if (i->access)
1681         {
1682           fputs (" ACCESS=", dumpfile);
1683           show_expr (i->access);
1684         }
1685       if (i->sequential)
1686         {
1687           fputs (" SEQUENTIAL=", dumpfile);
1688           show_expr (i->sequential);
1689         }
1690
1691       if (i->direct)
1692         {
1693           fputs (" DIRECT=", dumpfile);
1694           show_expr (i->direct);
1695         }
1696       if (i->form)
1697         {
1698           fputs (" FORM=", dumpfile);
1699           show_expr (i->form);
1700         }
1701       if (i->formatted)
1702         {
1703           fputs (" FORMATTED", dumpfile);
1704           show_expr (i->formatted);
1705         }
1706       if (i->unformatted)
1707         {
1708           fputs (" UNFORMATTED=", dumpfile);
1709           show_expr (i->unformatted);
1710         }
1711       if (i->recl)
1712         {
1713           fputs (" RECL=", dumpfile);
1714           show_expr (i->recl);
1715         }
1716       if (i->nextrec)
1717         {
1718           fputs (" NEXTREC=", dumpfile);
1719           show_expr (i->nextrec);
1720         }
1721       if (i->blank)
1722         {
1723           fputs (" BLANK=", dumpfile);
1724           show_expr (i->blank);
1725         }
1726       if (i->position)
1727         {
1728           fputs (" POSITION=", dumpfile);
1729           show_expr (i->position);
1730         }
1731       if (i->action)
1732         {
1733           fputs (" ACTION=", dumpfile);
1734           show_expr (i->action);
1735         }
1736       if (i->read)
1737         {
1738           fputs (" READ=", dumpfile);
1739           show_expr (i->read);
1740         }
1741       if (i->write)
1742         {
1743           fputs (" WRITE=", dumpfile);
1744           show_expr (i->write);
1745         }
1746       if (i->readwrite)
1747         {
1748           fputs (" READWRITE=", dumpfile);
1749           show_expr (i->readwrite);
1750         }
1751       if (i->delim)
1752         {
1753           fputs (" DELIM=", dumpfile);
1754           show_expr (i->delim);
1755         }
1756       if (i->pad)
1757         {
1758           fputs (" PAD=", dumpfile);
1759           show_expr (i->pad);
1760         }
1761       if (i->convert)
1762         {
1763           fputs (" CONVERT=", dumpfile);
1764           show_expr (i->convert);
1765         }
1766       if (i->asynchronous)
1767         {
1768           fputs (" ASYNCHRONOUS=", dumpfile);
1769           show_expr (i->asynchronous);
1770         }
1771       if (i->decimal)
1772         {
1773           fputs (" DECIMAL=", dumpfile);
1774           show_expr (i->decimal);
1775         }
1776       if (i->encoding)
1777         {
1778           fputs (" ENCODING=", dumpfile);
1779           show_expr (i->encoding);
1780         }
1781       if (i->pending)
1782         {
1783           fputs (" PENDING=", dumpfile);
1784           show_expr (i->pending);
1785         }
1786       if (i->round)
1787         {
1788           fputs (" ROUND=", dumpfile);
1789           show_expr (i->round);
1790         }
1791       if (i->sign)
1792         {
1793           fputs (" SIGN=", dumpfile);
1794           show_expr (i->sign);
1795         }
1796       if (i->size)
1797         {
1798           fputs (" SIZE=", dumpfile);
1799           show_expr (i->size);
1800         }
1801       if (i->id)
1802         {
1803           fputs (" ID=", dumpfile);
1804           show_expr (i->id);
1805         }
1806
1807       if (i->err != NULL)
1808         fprintf (dumpfile, " ERR=%d", i->err->value);
1809       break;
1810
1811     case EXEC_IOLENGTH:
1812       fputs ("IOLENGTH ", dumpfile);
1813       show_expr (c->expr1);
1814       goto show_dt_code;
1815       break;
1816
1817     case EXEC_READ:
1818       fputs ("READ", dumpfile);
1819       goto show_dt;
1820
1821     case EXEC_WRITE:
1822       fputs ("WRITE", dumpfile);
1823
1824     show_dt:
1825       dt = c->ext.dt;
1826       if (dt->io_unit)
1827         {
1828           fputs (" UNIT=", dumpfile);
1829           show_expr (dt->io_unit);
1830         }
1831
1832       if (dt->format_expr)
1833         {
1834           fputs (" FMT=", dumpfile);
1835           show_expr (dt->format_expr);
1836         }
1837
1838       if (dt->format_label != NULL)
1839         fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1840       if (dt->namelist)
1841         fprintf (dumpfile, " NML=%s", dt->namelist->name);
1842
1843       if (dt->iomsg)
1844         {
1845           fputs (" IOMSG=", dumpfile);
1846           show_expr (dt->iomsg);
1847         }
1848       if (dt->iostat)
1849         {
1850           fputs (" IOSTAT=", dumpfile);
1851           show_expr (dt->iostat);
1852         }
1853       if (dt->size)
1854         {
1855           fputs (" SIZE=", dumpfile);
1856           show_expr (dt->size);
1857         }
1858       if (dt->rec)
1859         {
1860           fputs (" REC=", dumpfile);
1861           show_expr (dt->rec);
1862         }
1863       if (dt->advance)
1864         {
1865           fputs (" ADVANCE=", dumpfile);
1866           show_expr (dt->advance);
1867         }
1868       if (dt->id)
1869         {
1870           fputs (" ID=", dumpfile);
1871           show_expr (dt->id);
1872         }
1873       if (dt->pos)
1874         {
1875           fputs (" POS=", dumpfile);
1876           show_expr (dt->pos);
1877         }
1878       if (dt->asynchronous)
1879         {
1880           fputs (" ASYNCHRONOUS=", dumpfile);
1881           show_expr (dt->asynchronous);
1882         }
1883       if (dt->blank)
1884         {
1885           fputs (" BLANK=", dumpfile);
1886           show_expr (dt->blank);
1887         }
1888       if (dt->decimal)
1889         {
1890           fputs (" DECIMAL=", dumpfile);
1891           show_expr (dt->decimal);
1892         }
1893       if (dt->delim)
1894         {
1895           fputs (" DELIM=", dumpfile);
1896           show_expr (dt->delim);
1897         }
1898       if (dt->pad)
1899         {
1900           fputs (" PAD=", dumpfile);
1901           show_expr (dt->pad);
1902         }
1903       if (dt->round)
1904         {
1905           fputs (" ROUND=", dumpfile);
1906           show_expr (dt->round);
1907         }
1908       if (dt->sign)
1909         {
1910           fputs (" SIGN=", dumpfile);
1911           show_expr (dt->sign);
1912         }
1913
1914     show_dt_code:
1915       fputc ('\n', dumpfile);
1916       for (c = c->block->next; c; c = c->next)
1917         show_code_node (level + (c->next != NULL), c);
1918       return;
1919
1920     case EXEC_TRANSFER:
1921       fputs ("TRANSFER ", dumpfile);
1922       show_expr (c->expr1);
1923       break;
1924
1925     case EXEC_DT_END:
1926       fputs ("DT_END", dumpfile);
1927       dt = c->ext.dt;
1928
1929       if (dt->err != NULL)
1930         fprintf (dumpfile, " ERR=%d", dt->err->value);
1931       if (dt->end != NULL)
1932         fprintf (dumpfile, " END=%d", dt->end->value);
1933       if (dt->eor != NULL)
1934         fprintf (dumpfile, " EOR=%d", dt->eor->value);
1935       break;
1936
1937     case EXEC_OMP_ATOMIC:
1938     case EXEC_OMP_BARRIER:
1939     case EXEC_OMP_CRITICAL:
1940     case EXEC_OMP_FLUSH:
1941     case EXEC_OMP_DO:
1942     case EXEC_OMP_MASTER:
1943     case EXEC_OMP_ORDERED:
1944     case EXEC_OMP_PARALLEL:
1945     case EXEC_OMP_PARALLEL_DO:
1946     case EXEC_OMP_PARALLEL_SECTIONS:
1947     case EXEC_OMP_PARALLEL_WORKSHARE:
1948     case EXEC_OMP_SECTIONS:
1949     case EXEC_OMP_SINGLE:
1950     case EXEC_OMP_TASK:
1951     case EXEC_OMP_TASKWAIT:
1952     case EXEC_OMP_WORKSHARE:
1953       show_omp_node (level, c);
1954       break;
1955
1956     default:
1957       gfc_internal_error ("show_code_node(): Bad statement code");
1958     }
1959
1960   fputc ('\n', dumpfile);
1961 }
1962
1963
1964 /* Show an equivalence chain.  */
1965
1966 static void
1967 show_equiv (gfc_equiv *eq)
1968 {
1969   show_indent ();
1970   fputs ("Equivalence: ", dumpfile);
1971   while (eq)
1972     {
1973       show_expr (eq->expr);
1974       eq = eq->eq;
1975       if (eq)
1976         fputs (", ", dumpfile);
1977     }
1978 }
1979
1980
1981 /* Show a freakin' whole namespace.  */
1982
1983 static void
1984 show_namespace (gfc_namespace *ns)
1985 {
1986   gfc_interface *intr;
1987   gfc_namespace *save;
1988   int op;
1989   gfc_equiv *eq;
1990   int i;
1991
1992   save = gfc_current_ns;
1993   show_level++;
1994
1995   show_indent ();
1996   fputs ("Namespace:", dumpfile);
1997
1998   if (ns != NULL)
1999     {
2000       i = 0;
2001       do
2002         {
2003           int l = i;
2004           while (i < GFC_LETTERS - 1
2005                  && gfc_compare_types(&ns->default_type[i+1],
2006                                       &ns->default_type[l]))
2007             i++;
2008
2009           if (i > l)
2010             fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2011           else
2012             fprintf (dumpfile, " %c: ", l+'A');
2013
2014           show_typespec(&ns->default_type[l]);
2015           i++;
2016       } while (i < GFC_LETTERS);
2017
2018       if (ns->proc_name != NULL)
2019         {
2020           show_indent ();
2021           fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2022         }
2023
2024       gfc_current_ns = ns;
2025       gfc_traverse_symtree (ns->common_root, show_common);
2026
2027       gfc_traverse_symtree (ns->sym_root, show_symtree);
2028
2029       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2030         {
2031           /* User operator interfaces */
2032           intr = ns->op[op];
2033           if (intr == NULL)
2034             continue;
2035
2036           show_indent ();
2037           fprintf (dumpfile, "Operator interfaces for %s:",
2038                    gfc_op2string ((gfc_intrinsic_op) op));
2039
2040           for (; intr; intr = intr->next)
2041             fprintf (dumpfile, " %s", intr->sym->name);
2042         }
2043
2044       if (ns->uop_root != NULL)
2045         {
2046           show_indent ();
2047           fputs ("User operators:\n", dumpfile);
2048           gfc_traverse_user_op (ns, show_uop);
2049         }
2050     }
2051
2052   for (eq = ns->equiv; eq; eq = eq->next)
2053     show_equiv (eq);
2054
2055   fputc ('\n', dumpfile);
2056   fputc ('\n', dumpfile);
2057
2058   show_code (0, ns->code);
2059
2060   for (ns = ns->contained; ns; ns = ns->sibling)
2061     {
2062       show_indent ();
2063       fputs ("CONTAINS\n", dumpfile);
2064       show_namespace (ns);
2065     }
2066
2067   show_level--;
2068   fputc ('\n', dumpfile);
2069   gfc_current_ns = save;
2070 }
2071
2072
2073 /* Main function for dumping a parse tree.  */
2074
2075 void
2076 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2077 {
2078   dumpfile = file;
2079   show_namespace (ns);
2080 }