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