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