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