gcc/fortran/dump-parse-tree.c

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