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