gcc/fortran/dump-parse-tree.c

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