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       && !sym->attr.entry)
 898     {
 899       show_indent ();
 900       fputs ("Formal namespace", dumpfile);
 901       show_namespace (sym->formal_ns);
 902     }
 903   --show_level;
 904 }
 905
 906
 907 /* Show a user-defined operator.  Just prints an operator
 908    and the name of the associated subroutine, really.  */
 909
 910 static void
 911 show_uop (gfc_user_op *uop)
 912 {
 913   gfc_interface *intr;
 914
 915   show_indent ();
 916   fprintf (dumpfile, "%s:", uop->name);
 917
 918   for (intr = uop->op; intr; intr = intr->next)
 919     fprintf (dumpfile, " %s", intr->sym->name);
 920 }
 921
 922
 923 /* Workhorse function for traversing the user operator symtree.  */
 924
 925 static void
 926 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
 927 {
 928   if (st == NULL)
 929     return;
 930
 931   (*func) (st->n.uop);
 932
 933   traverse_uop (st->left, func);
 934   traverse_uop (st->right, func);
 935 }
 936
 937
 938 /* Traverse the tree of user operator nodes.  */
 939
 940 void
 941 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
 942 {
 943   traverse_uop (ns->uop_root, func);
 944 }
 945
 946
 947 /* Function to display a common block.  */
 948
 949 static void
 950 show_common (gfc_symtree *st)
 951 {
 952   gfc_symbol *s;
 953
 954   show_indent ();
 955   fprintf (dumpfile, "common: /%s/ ", st->name);
 956
 957   s = st->n.common->head;
 958   while (s)
 959     {
 960       fprintf (dumpfile, "%s", s->name);
 961       s = s->common_next;
 962       if (s)
 963         fputs (", ", dumpfile);
 964     }
 965   fputc ('\n', dumpfile);
 966 }
 967
 968
 969 /* Worker function to display the symbol tree.  */
 970
 971 static void
 972 show_symtree (gfc_symtree *st)
 973 {
 974   int len, i;
 975
 976   show_indent ();
 977
 978   len = strlen(st->name);
 979   fprintf (dumpfile, "symtree: '%s'", st->name);
 980
 981   for (i=len; i<12; i++)
 982     fputc(' ', dumpfile);
 983
 984   if (st->ambiguous)
 985     fputs( " Ambiguous", dumpfile);
 986
 987   if (st->n.sym->ns != gfc_current_ns)
 988     fprintf (dumpfile, "|| symbol: '%s' from namespace '%s'", st->n.sym->name,
 989              st->n.sym->ns->proc_name->name);
 990   else
 991     show_symbol (st->n.sym);
 992 }
 993
 994
 995 /******************* Show gfc_code structures **************/
 996
 997
 998 /* Show a list of code structures.  Mutually recursive with
 999    show_code_node().  */
1000
1001 static void
1002 show_code (int level, gfc_code *c)
1003 {
1004   for (; c; c = c->next)
1005     show_code_node (level, c);
1006 }
1007
1008 static void
1009 show_namelist (gfc_namelist *n)
1010 {
1011   for (; n->next; n = n->next)
1012     fprintf (dumpfile, "%s,", n->sym->name);
1013   fprintf (dumpfile, "%s", n->sym->name);
1014 }
1015
1016 /* Show a single OpenMP directive node and everything underneath it
1017    if necessary.  */
1018
1019 static void
1020 show_omp_node (int level, gfc_code *c)
1021 {
1022   gfc_omp_clauses *omp_clauses = NULL;
1023   const char *name = NULL;
1024
1025   switch (c->op)
1026     {
1027     case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
1028     case EXEC_OMP_BARRIER: name = "BARRIER"; break;
1029     case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
1030     case EXEC_OMP_FLUSH: name = "FLUSH"; break;
1031     case EXEC_OMP_DO: name = "DO"; break;
1032     case EXEC_OMP_MASTER: name = "MASTER"; break;
1033     case EXEC_OMP_ORDERED: name = "ORDERED"; break;
1034     case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
1035     case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
1036     case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
1037     case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
1038     case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
1039     case EXEC_OMP_SINGLE: name = "SINGLE"; break;
1040     case EXEC_OMP_TASK: name = "TASK"; break;
1041     case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
1042     case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
1043     default:
1044       gcc_unreachable ();
1045     }
1046   fprintf (dumpfile, "!$OMP %s", name);
1047   switch (c->op)
1048     {
1049     case EXEC_OMP_DO:
1050     case EXEC_OMP_PARALLEL:
1051     case EXEC_OMP_PARALLEL_DO:
1052     case EXEC_OMP_PARALLEL_SECTIONS:
1053     case EXEC_OMP_SECTIONS:
1054     case EXEC_OMP_SINGLE:
1055     case EXEC_OMP_WORKSHARE:
1056     case EXEC_OMP_PARALLEL_WORKSHARE:
1057     case EXEC_OMP_TASK:
1058       omp_clauses = c->ext.omp_clauses;
1059       break;
1060     case EXEC_OMP_CRITICAL:
1061       if (c->ext.omp_name)
1062         fprintf (dumpfile, " (%s)", c->ext.omp_name);
1063       break;
1064     case EXEC_OMP_FLUSH:
1065       if (c->ext.omp_namelist)
1066         {
1067           fputs (" (", dumpfile);
1068           show_namelist (c->ext.omp_namelist);
1069           fputc (')', dumpfile);
1070         }
1071       return;
1072     case EXEC_OMP_BARRIER:
1073     case EXEC_OMP_TASKWAIT:
1074       return;
1075     default:
1076       break;
1077     }
1078   if (omp_clauses)
1079     {
1080       int list_type;
1081
1082       if (omp_clauses->if_expr)
1083         {
1084           fputs (" IF(", dumpfile);
1085           show_expr (omp_clauses->if_expr);
1086           fputc (')', dumpfile);
1087         }
1088       if (omp_clauses->num_threads)
1089         {
1090           fputs (" NUM_THREADS(", dumpfile);
1091           show_expr (omp_clauses->num_threads);
1092           fputc (')', dumpfile);
1093         }
1094       if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1095         {
1096           const char *type;
1097           switch (omp_clauses->sched_kind)
1098             {
1099             case OMP_SCHED_STATIC: type = "STATIC"; break;
1100             case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1101             case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1102             case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1103             case OMP_SCHED_AUTO: type = "AUTO"; break;
1104             default:
1105               gcc_unreachable ();
1106             }
1107           fprintf (dumpfile, " SCHEDULE (%s", type);
1108           if (omp_clauses->chunk_size)
1109             {
1110               fputc (',', dumpfile);
1111               show_expr (omp_clauses->chunk_size);
1112             }
1113           fputc (')', dumpfile);
1114         }
1115       if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1116         {
1117           const char *type;
1118           switch (omp_clauses->default_sharing)
1119             {
1120             case OMP_DEFAULT_NONE: type = "NONE"; break;
1121             case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1122             case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1123             case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1124             default:
1125               gcc_unreachable ();
1126             }
1127           fprintf (dumpfile, " DEFAULT(%s)", type);
1128         }
1129       if (omp_clauses->ordered)
1130         fputs (" ORDERED", dumpfile);
1131       if (omp_clauses->untied)
1132         fputs (" UNTIED", dumpfile);
1133       if (omp_clauses->collapse)
1134         fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1135       for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1136         if (omp_clauses->lists[list_type] != NULL
1137             && list_type != OMP_LIST_COPYPRIVATE)
1138           {
1139             const char *type;
1140             if (list_type >= OMP_LIST_REDUCTION_FIRST)
1141               {
1142                 switch (list_type)
1143                   {
1144                   case OMP_LIST_PLUS: type = "+"; break;
1145                   case OMP_LIST_MULT: type = "*"; break;
1146                   case OMP_LIST_SUB: type = "-"; break;
1147                   case OMP_LIST_AND: type = ".AND."; break;
1148                   case OMP_LIST_OR: type = ".OR."; break;
1149                   case OMP_LIST_EQV: type = ".EQV."; break;
1150                   case OMP_LIST_NEQV: type = ".NEQV."; break;
1151                   case OMP_LIST_MAX: type = "MAX"; break;
1152                   case OMP_LIST_MIN: type = "MIN"; break;
1153                   case OMP_LIST_IAND: type = "IAND"; break;
1154                   case OMP_LIST_IOR: type = "IOR"; break;
1155                   case OMP_LIST_IEOR: type = "IEOR"; break;
1156                   default:
1157                     gcc_unreachable ();
1158                   }
1159                 fprintf (dumpfile, " REDUCTION(%s:", type);
1160               }
1161             else
1162               {
1163                 switch (list_type)
1164                   {
1165                   case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1166                   case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1167                   case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1168                   case OMP_LIST_SHARED: type = "SHARED"; break;
1169                   case OMP_LIST_COPYIN: type = "COPYIN"; break;
1170                   default:
1171                     gcc_unreachable ();
1172                   }
1173                 fprintf (dumpfile, " %s(", type);
1174               }
1175             show_namelist (omp_clauses->lists[list_type]);
1176             fputc (')', dumpfile);
1177           }
1178     }
1179   fputc ('\n', dumpfile);
1180   if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1181     {
1182       gfc_code *d = c->block;
1183       while (d != NULL)
1184         {
1185           show_code (level + 1, d->next);
1186           if (d->block == NULL)
1187             break;
1188           code_indent (level, 0);
1189           fputs ("!$OMP SECTION\n", dumpfile);
1190           d = d->block;
1191         }
1192     }
1193   else
1194     show_code (level + 1, c->block->next);
1195   if (c->op == EXEC_OMP_ATOMIC)
1196     return;
1197   code_indent (level, 0);
1198   fprintf (dumpfile, "!$OMP END %s", name);
1199   if (omp_clauses != NULL)
1200     {
1201       if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1202         {
1203           fputs (" COPYPRIVATE(", dumpfile);
1204           show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1205           fputc (')', dumpfile);
1206         }
1207       else if (omp_clauses->nowait)
1208         fputs (" NOWAIT", dumpfile);
1209     }
1210   else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1211     fprintf (dumpfile, " (%s)", c->ext.omp_name);
1212 }
1213
1214
1215 /* Show a single code node and everything underneath it if necessary.  */
1216
1217 static void
1218 show_code_node (int level, gfc_code *c)
1219 {
1220   gfc_forall_iterator *fa;
1221   gfc_open *open;
1222   gfc_case *cp;
1223   gfc_alloc *a;
1224   gfc_code *d;
1225   gfc_close *close;
1226   gfc_filepos *fp;
1227   gfc_inquire *i;
1228   gfc_dt *dt;
1229   gfc_namespace *ns;
1230
1231   if (c->here)
1232     {
1233       fputc ('\n', dumpfile);
1234       code_indent (level, c->here);
1235     }
1236   else
1237     show_indent ();
1238
1239   switch (c->op)
1240     {
1241     case EXEC_END_PROCEDURE:
1242       break;
1243
1244     case EXEC_NOP:
1245       fputs ("NOP", dumpfile);
1246       break;
1247
1248     case EXEC_CONTINUE:
1249       fputs ("CONTINUE", dumpfile);
1250       break;
1251
1252     case EXEC_ENTRY:
1253       fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1254       break;
1255
1256     case EXEC_INIT_ASSIGN:
1257     case EXEC_ASSIGN:
1258       fputs ("ASSIGN ", dumpfile);
1259       show_expr (c->expr1);
1260       fputc (' ', dumpfile);
1261       show_expr (c->expr2);
1262       break;
1263
1264     case EXEC_LABEL_ASSIGN:
1265       fputs ("LABEL ASSIGN ", dumpfile);
1266       show_expr (c->expr1);
1267       fprintf (dumpfile, " %d", c->label1->value);
1268       break;
1269
1270     case EXEC_POINTER_ASSIGN:
1271       fputs ("POINTER ASSIGN ", dumpfile);
1272       show_expr (c->expr1);
1273       fputc (' ', dumpfile);
1274       show_expr (c->expr2);
1275       break;
1276
1277     case EXEC_GOTO:
1278       fputs ("GOTO ", dumpfile);
1279       if (c->label1)
1280         fprintf (dumpfile, "%d", c->label1->value);
1281       else
1282         {
1283           show_expr (c->expr1);
1284           d = c->block;
1285           if (d != NULL)
1286             {
1287               fputs (", (", dumpfile);
1288               for (; d; d = d ->block)
1289                 {
1290                   code_indent (level, d->label1);
1291                   if (d->block != NULL)
1292                     fputc (',', dumpfile);
1293                   else
1294                     fputc (')', dumpfile);
1295                 }
1296             }
1297         }
1298       break;
1299
1300     case EXEC_CALL:
1301     case EXEC_ASSIGN_CALL:
1302       if (c->resolved_sym)
1303         fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1304       else if (c->symtree)
1305         fprintf (dumpfile, "CALL %s ", c->symtree->name);
1306       else
1307         fputs ("CALL ?? ", dumpfile);
1308
1309       show_actual_arglist (c->ext.actual);
1310       break;
1311
1312     case EXEC_COMPCALL:
1313       fputs ("CALL ", dumpfile);
1314       show_compcall (c->expr1);
1315       break;
1316
1317     case EXEC_CALL_PPC:
1318       fputs ("CALL ", dumpfile);
1319       show_expr (c->expr1);
1320       show_actual_arglist (c->ext.actual);
1321       break;
1322
1323     case EXEC_RETURN:
1324       fputs ("RETURN ", dumpfile);
1325       if (c->expr1)
1326         show_expr (c->expr1);
1327       break;
1328
1329     case EXEC_PAUSE:
1330       fputs ("PAUSE ", dumpfile);
1331
1332       if (c->expr1 != NULL)
1333         show_expr (c->expr1);
1334       else
1335         fprintf (dumpfile, "%d", c->ext.stop_code);
1336
1337       break;
1338
1339     case EXEC_ERROR_STOP:
1340       fputs ("ERROR ", dumpfile);
1341       /* Fall through.  */
1342
1343     case EXEC_STOP:
1344       fputs ("STOP ", dumpfile);
1345
1346       if (c->expr1 != NULL)
1347         show_expr (c->expr1);
1348       else
1349         fprintf (dumpfile, "%d", c->ext.stop_code);
1350
1351       break;
1352
1353     case EXEC_SYNC_ALL:
1354       fputs ("SYNC ALL ", dumpfile);
1355       if (c->expr2 != NULL)
1356         {
1357           fputs (" stat=", dumpfile);
1358           show_expr (c->expr2);
1359         }
1360       if (c->expr3 != NULL)
1361         {
1362           fputs (" errmsg=", dumpfile);
1363           show_expr (c->expr3);
1364         }
1365       break;
1366
1367     case EXEC_SYNC_MEMORY:
1368       fputs ("SYNC MEMORY ", dumpfile);
1369       if (c->expr2 != NULL)
1370         {
1371           fputs (" stat=", dumpfile);
1372           show_expr (c->expr2);
1373         }
1374       if (c->expr3 != NULL)
1375         {
1376           fputs (" errmsg=", dumpfile);
1377           show_expr (c->expr3);
1378         }
1379       break;
1380
1381     case EXEC_SYNC_IMAGES:
1382       fputs ("SYNC IMAGES  image-set=", dumpfile);
1383       if (c->expr1 != NULL)
1384         show_expr (c->expr1);
1385       else
1386         fputs ("* ", dumpfile);
1387       if (c->expr2 != NULL)
1388         {
1389           fputs (" stat=", dumpfile);
1390           show_expr (c->expr2);
1391         }
1392       if (c->expr3 != NULL)
1393         {
1394           fputs (" errmsg=", dumpfile);
1395           show_expr (c->expr3);
1396         }
1397       break;
1398
1399     case EXEC_LOCK:
1400     case EXEC_UNLOCK:
1401       if (c->op == EXEC_LOCK)
1402         fputs ("LOCK ", dumpfile);
1403       else
1404         fputs ("UNLOCK ", dumpfile);
1405
1406       fputs ("lock-variable=", dumpfile);
1407       if (c->expr1 != NULL)
1408         show_expr (c->expr1);
1409       if (c->expr4 != NULL)
1410         {
1411           fputs (" acquired_lock=", dumpfile);
1412           show_expr (c->expr4);
1413         }
1414       if (c->expr2 != NULL)
1415         {
1416           fputs (" stat=", dumpfile);
1417           show_expr (c->expr2);
1418         }
1419       if (c->expr3 != NULL)
1420         {
1421           fputs (" errmsg=", dumpfile);
1422           show_expr (c->expr3);
1423         }
1424       break;
1425
1426     case EXEC_ARITHMETIC_IF:
1427       fputs ("IF ", dumpfile);
1428       show_expr (c->expr1);
1429       fprintf (dumpfile, " %d, %d, %d",
1430                   c->label1->value, c->label2->value, c->label3->value);
1431       break;
1432
1433     case EXEC_IF:
1434       d = c->block;
1435       fputs ("IF ", dumpfile);
1436       show_expr (d->expr1);
1437
1438       ++show_level;
1439       show_code (level + 1, d->next);
1440       --show_level;
1441
1442       d = d->block;
1443       for (; d; d = d->block)
1444         {
1445           code_indent (level, 0);
1446
1447           if (d->expr1 == NULL)
1448             fputs ("ELSE", dumpfile);
1449           else
1450             {
1451               fputs ("ELSE IF ", dumpfile);
1452               show_expr (d->expr1);
1453             }
1454
1455           ++show_level;
1456           show_code (level + 1, d->next);
1457           --show_level;
1458         }
1459
1460       if (c->label1)
1461         code_indent (level, c->label1);
1462       else
1463         show_indent ();
1464
1465       fputs ("ENDIF", dumpfile);
1466       break;
1467
1468     case EXEC_BLOCK:
1469       {
1470         const char* blocktype;
1471         gfc_namespace *saved_ns;
1472
1473         if (c->ext.block.assoc)
1474           blocktype = "ASSOCIATE";
1475         else
1476           blocktype = "BLOCK";
1477         show_indent ();
1478         fprintf (dumpfile, "%s ", blocktype);
1479         ++show_level;
1480         ns = c->ext.block.ns;
1481         saved_ns = gfc_current_ns;
1482         gfc_current_ns = ns;
1483         gfc_traverse_symtree (ns->sym_root, show_symtree);
1484         gfc_current_ns = saved_ns;
1485         show_code (show_level, ns->code);
1486         --show_level;
1487         show_indent ();
1488         fprintf (dumpfile, "END %s ", blocktype);
1489         break;
1490       }
1491
1492     case EXEC_SELECT:
1493       d = c->block;
1494       fputs ("SELECT CASE ", dumpfile);
1495       show_expr (c->expr1);
1496       fputc ('\n', dumpfile);
1497
1498       for (; d; d = d->block)
1499         {
1500           code_indent (level, 0);
1501
1502           fputs ("CASE ", dumpfile);
1503           for (cp = d->ext.block.case_list; cp; cp = cp->next)
1504             {
1505               fputc ('(', dumpfile);
1506               show_expr (cp->low);
1507               fputc (' ', dumpfile);
1508               show_expr (cp->high);
1509               fputc (')', dumpfile);
1510               fputc (' ', dumpfile);
1511             }
1512           fputc ('\n', dumpfile);
1513
1514           show_code (level + 1, d->next);
1515         }
1516
1517       code_indent (level, c->label1);
1518       fputs ("END SELECT", dumpfile);
1519       break;
1520
1521     case EXEC_WHERE:
1522       fputs ("WHERE ", dumpfile);
1523
1524       d = c->block;
1525       show_expr (d->expr1);
1526       fputc ('\n', dumpfile);
1527
1528       show_code (level + 1, d->next);
1529
1530       for (d = d->block; d; d = d->block)
1531         {
1532           code_indent (level, 0);
1533           fputs ("ELSE WHERE ", dumpfile);
1534           show_expr (d->expr1);
1535           fputc ('\n', dumpfile);
1536           show_code (level + 1, d->next);
1537         }
1538
1539       code_indent (level, 0);
1540       fputs ("END WHERE", dumpfile);
1541       break;
1542
1543
1544     case EXEC_FORALL:
1545       fputs ("FORALL ", dumpfile);
1546       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1547         {
1548           show_expr (fa->var);
1549           fputc (' ', dumpfile);
1550           show_expr (fa->start);
1551           fputc (':', dumpfile);
1552           show_expr (fa->end);
1553           fputc (':', dumpfile);
1554           show_expr (fa->stride);
1555
1556           if (fa->next != NULL)
1557             fputc (',', dumpfile);
1558         }
1559
1560       if (c->expr1 != NULL)
1561         {
1562           fputc (',', dumpfile);
1563           show_expr (c->expr1);
1564         }
1565       fputc ('\n', dumpfile);
1566
1567       show_code (level + 1, c->block->next);
1568
1569       code_indent (level, 0);
1570       fputs ("END FORALL", dumpfile);
1571       break;
1572
1573     case EXEC_CRITICAL:
1574       fputs ("CRITICAL\n", dumpfile);
1575       show_code (level + 1, c->block->next);
1576       code_indent (level, 0);
1577       fputs ("END CRITICAL", dumpfile);
1578       break;
1579
1580     case EXEC_DO:
1581       fputs ("DO ", dumpfile);
1582       if (c->label1)
1583         fprintf (dumpfile, " %-5d ", c->label1->value);
1584
1585       show_expr (c->ext.iterator->var);
1586       fputc ('=', dumpfile);
1587       show_expr (c->ext.iterator->start);
1588       fputc (' ', dumpfile);
1589       show_expr (c->ext.iterator->end);
1590       fputc (' ', dumpfile);
1591       show_expr (c->ext.iterator->step);
1592
1593       ++show_level;
1594       show_code (level + 1, c->block->next);
1595       --show_level;
1596
1597       if (c->label1)
1598         break;
1599
1600       show_indent ();
1601       fputs ("END DO", dumpfile);
1602       break;
1603
1604     case EXEC_DO_WHILE:
1605       fputs ("DO WHILE ", dumpfile);
1606       show_expr (c->expr1);
1607       fputc ('\n', dumpfile);
1608
1609       show_code (level + 1, c->block->next);
1610
1611       code_indent (level, c->label1);
1612       fputs ("END DO", dumpfile);
1613       break;
1614
1615     case EXEC_CYCLE:
1616       fputs ("CYCLE", dumpfile);
1617       if (c->symtree)
1618         fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1619       break;
1620
1621     case EXEC_EXIT:
1622       fputs ("EXIT", dumpfile);
1623       if (c->symtree)
1624         fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1625       break;
1626
1627     case EXEC_ALLOCATE:
1628       fputs ("ALLOCATE ", dumpfile);
1629       if (c->expr1)
1630         {
1631           fputs (" STAT=", dumpfile);
1632           show_expr (c->expr1);
1633         }
1634
1635       if (c->expr2)
1636         {
1637           fputs (" ERRMSG=", dumpfile);
1638           show_expr (c->expr2);
1639         }
1640
1641       if (c->expr3)
1642         {
1643           if (c->expr3->mold)
1644             fputs (" MOLD=", dumpfile);
1645           else
1646             fputs (" SOURCE=", dumpfile);
1647           show_expr (c->expr3);
1648         }
1649
1650       for (a = c->ext.alloc.list; a; a = a->next)
1651         {
1652           fputc (' ', dumpfile);
1653           show_expr (a->expr);
1654         }
1655
1656       break;
1657
1658     case EXEC_DEALLOCATE:
1659       fputs ("DEALLOCATE ", dumpfile);
1660       if (c->expr1)
1661         {
1662           fputs (" STAT=", dumpfile);
1663           show_expr (c->expr1);
1664         }
1665
1666       if (c->expr2)
1667         {
1668           fputs (" ERRMSG=", dumpfile);
1669           show_expr (c->expr2);
1670         }
1671
1672       for (a = c->ext.alloc.list; a; a = a->next)
1673         {
1674           fputc (' ', dumpfile);
1675           show_expr (a->expr);
1676         }
1677
1678       break;
1679
1680     case EXEC_OPEN:
1681       fputs ("OPEN", dumpfile);
1682       open = c->ext.open;
1683
1684       if (open->unit)
1685         {
1686           fputs (" UNIT=", dumpfile);
1687           show_expr (open->unit);
1688         }
1689       if (open->iomsg)
1690         {
1691           fputs (" IOMSG=", dumpfile);
1692           show_expr (open->iomsg);
1693         }
1694       if (open->iostat)
1695         {
1696           fputs (" IOSTAT=", dumpfile);
1697           show_expr (open->iostat);
1698         }
1699       if (open->file)
1700         {
1701           fputs (" FILE=", dumpfile);
1702           show_expr (open->file);
1703         }
1704       if (open->status)
1705         {
1706           fputs (" STATUS=", dumpfile);
1707           show_expr (open->status);
1708         }
1709       if (open->access)
1710         {
1711           fputs (" ACCESS=", dumpfile);
1712           show_expr (open->access);
1713         }
1714       if (open->form)
1715         {
1716           fputs (" FORM=", dumpfile);
1717           show_expr (open->form);
1718         }
1719       if (open->recl)
1720         {
1721           fputs (" RECL=", dumpfile);
1722           show_expr (open->recl);
1723         }
1724       if (open->blank)
1725         {
1726           fputs (" BLANK=", dumpfile);
1727           show_expr (open->blank);
1728         }
1729       if (open->position)
1730         {
1731           fputs (" POSITION=", dumpfile);
1732           show_expr (open->position);
1733         }
1734       if (open->action)
1735         {
1736           fputs (" ACTION=", dumpfile);
1737           show_expr (open->action);
1738         }
1739       if (open->delim)
1740         {
1741           fputs (" DELIM=", dumpfile);
1742           show_expr (open->delim);
1743         }
1744       if (open->pad)
1745         {
1746           fputs (" PAD=", dumpfile);
1747           show_expr (open->pad);
1748         }
1749       if (open->decimal)
1750         {
1751           fputs (" DECIMAL=", dumpfile);
1752           show_expr (open->decimal);
1753         }
1754       if (open->encoding)
1755         {
1756           fputs (" ENCODING=", dumpfile);
1757           show_expr (open->encoding);
1758         }
1759       if (open->round)
1760         {
1761           fputs (" ROUND=", dumpfile);
1762           show_expr (open->round);
1763         }
1764       if (open->sign)
1765         {
1766           fputs (" SIGN=", dumpfile);
1767           show_expr (open->sign);
1768         }
1769       if (open->convert)
1770         {
1771           fputs (" CONVERT=", dumpfile);
1772           show_expr (open->convert);
1773         }
1774       if (open->asynchronous)
1775         {
1776           fputs (" ASYNCHRONOUS=", dumpfile);
1777           show_expr (open->asynchronous);
1778         }
1779       if (open->err != NULL)
1780         fprintf (dumpfile, " ERR=%d", open->err->value);
1781
1782       break;
1783
1784     case EXEC_CLOSE:
1785       fputs ("CLOSE", dumpfile);
1786       close = c->ext.close;
1787
1788       if (close->unit)
1789         {
1790           fputs (" UNIT=", dumpfile);
1791           show_expr (close->unit);
1792         }
1793       if (close->iomsg)
1794         {
1795           fputs (" IOMSG=", dumpfile);
1796           show_expr (close->iomsg);
1797         }
1798       if (close->iostat)
1799         {
1800           fputs (" IOSTAT=", dumpfile);
1801           show_expr (close->iostat);
1802         }
1803       if (close->status)
1804         {
1805           fputs (" STATUS=", dumpfile);
1806           show_expr (close->status);
1807         }
1808       if (close->err != NULL)
1809         fprintf (dumpfile, " ERR=%d", close->err->value);
1810       break;
1811
1812     case EXEC_BACKSPACE:
1813       fputs ("BACKSPACE", dumpfile);
1814       goto show_filepos;
1815
1816     case EXEC_ENDFILE:
1817       fputs ("ENDFILE", dumpfile);
1818       goto show_filepos;
1819
1820     case EXEC_REWIND:
1821       fputs ("REWIND", dumpfile);
1822       goto show_filepos;
1823
1824     case EXEC_FLUSH:
1825       fputs ("FLUSH", dumpfile);
1826
1827     show_filepos:
1828       fp = c->ext.filepos;
1829
1830       if (fp->unit)
1831         {
1832           fputs (" UNIT=", dumpfile);
1833           show_expr (fp->unit);
1834         }
1835       if (fp->iomsg)
1836         {
1837           fputs (" IOMSG=", dumpfile);
1838           show_expr (fp->iomsg);
1839         }
1840       if (fp->iostat)
1841         {
1842           fputs (" IOSTAT=", dumpfile);
1843           show_expr (fp->iostat);
1844         }
1845       if (fp->err != NULL)
1846         fprintf (dumpfile, " ERR=%d", fp->err->value);
1847       break;
1848
1849     case EXEC_INQUIRE:
1850       fputs ("INQUIRE", dumpfile);
1851       i = c->ext.inquire;
1852
1853       if (i->unit)
1854         {
1855           fputs (" UNIT=", dumpfile);
1856           show_expr (i->unit);
1857         }
1858       if (i->file)
1859         {
1860           fputs (" FILE=", dumpfile);
1861           show_expr (i->file);
1862         }
1863
1864       if (i->iomsg)
1865         {
1866           fputs (" IOMSG=", dumpfile);
1867           show_expr (i->iomsg);
1868         }
1869       if (i->iostat)
1870         {
1871           fputs (" IOSTAT=", dumpfile);
1872           show_expr (i->iostat);
1873         }
1874       if (i->exist)
1875         {
1876           fputs (" EXIST=", dumpfile);
1877           show_expr (i->exist);
1878         }
1879       if (i->opened)
1880         {
1881           fputs (" OPENED=", dumpfile);
1882           show_expr (i->opened);
1883         }
1884       if (i->number)
1885         {
1886           fputs (" NUMBER=", dumpfile);
1887           show_expr (i->number);
1888         }
1889       if (i->named)
1890         {
1891           fputs (" NAMED=", dumpfile);
1892           show_expr (i->named);
1893         }
1894       if (i->name)
1895         {
1896           fputs (" NAME=", dumpfile);
1897           show_expr (i->name);
1898         }
1899       if (i->access)
1900         {
1901           fputs (" ACCESS=", dumpfile);
1902           show_expr (i->access);
1903         }
1904       if (i->sequential)
1905         {
1906           fputs (" SEQUENTIAL=", dumpfile);
1907           show_expr (i->sequential);
1908         }
1909
1910       if (i->direct)
1911         {
1912           fputs (" DIRECT=", dumpfile);
1913           show_expr (i->direct);
1914         }
1915       if (i->form)
1916         {
1917           fputs (" FORM=", dumpfile);
1918           show_expr (i->form);
1919         }
1920       if (i->formatted)
1921         {
1922           fputs (" FORMATTED", dumpfile);
1923           show_expr (i->formatted);
1924         }
1925       if (i->unformatted)
1926         {
1927           fputs (" UNFORMATTED=", dumpfile);
1928           show_expr (i->unformatted);
1929         }
1930       if (i->recl)
1931         {
1932           fputs (" RECL=", dumpfile);
1933           show_expr (i->recl);
1934         }
1935       if (i->nextrec)
1936         {
1937           fputs (" NEXTREC=", dumpfile);
1938           show_expr (i->nextrec);
1939         }
1940       if (i->blank)
1941         {
1942           fputs (" BLANK=", dumpfile);
1943           show_expr (i->blank);
1944         }
1945       if (i->position)
1946         {
1947           fputs (" POSITION=", dumpfile);
1948           show_expr (i->position);
1949         }
1950       if (i->action)
1951         {
1952           fputs (" ACTION=", dumpfile);
1953           show_expr (i->action);
1954         }
1955       if (i->read)
1956         {
1957           fputs (" READ=", dumpfile);
1958           show_expr (i->read);
1959         }
1960       if (i->write)
1961         {
1962           fputs (" WRITE=", dumpfile);
1963           show_expr (i->write);
1964         }
1965       if (i->readwrite)
1966         {
1967           fputs (" READWRITE=", dumpfile);
1968           show_expr (i->readwrite);
1969         }
1970       if (i->delim)
1971         {
1972           fputs (" DELIM=", dumpfile);
1973           show_expr (i->delim);
1974         }
1975       if (i->pad)
1976         {
1977           fputs (" PAD=", dumpfile);
1978           show_expr (i->pad);
1979         }
1980       if (i->convert)
1981         {
1982           fputs (" CONVERT=", dumpfile);
1983           show_expr (i->convert);
1984         }
1985       if (i->asynchronous)
1986         {
1987           fputs (" ASYNCHRONOUS=", dumpfile);
1988           show_expr (i->asynchronous);
1989         }
1990       if (i->decimal)
1991         {
1992           fputs (" DECIMAL=", dumpfile);
1993           show_expr (i->decimal);
1994         }
1995       if (i->encoding)
1996         {
1997           fputs (" ENCODING=", dumpfile);
1998           show_expr (i->encoding);
1999         }
2000       if (i->pending)
2001         {
2002           fputs (" PENDING=", dumpfile);
2003           show_expr (i->pending);
2004         }
2005       if (i->round)
2006         {
2007           fputs (" ROUND=", dumpfile);
2008           show_expr (i->round);
2009         }
2010       if (i->sign)
2011         {
2012           fputs (" SIGN=", dumpfile);
2013           show_expr (i->sign);
2014         }
2015       if (i->size)
2016         {
2017           fputs (" SIZE=", dumpfile);
2018           show_expr (i->size);
2019         }
2020       if (i->id)
2021         {
2022           fputs (" ID=", dumpfile);
2023           show_expr (i->id);
2024         }
2025
2026       if (i->err != NULL)
2027         fprintf (dumpfile, " ERR=%d", i->err->value);
2028       break;
2029
2030     case EXEC_IOLENGTH:
2031       fputs ("IOLENGTH ", dumpfile);
2032       show_expr (c->expr1);
2033       goto show_dt_code;
2034       break;
2035
2036     case EXEC_READ:
2037       fputs ("READ", dumpfile);
2038       goto show_dt;
2039
2040     case EXEC_WRITE:
2041       fputs ("WRITE", dumpfile);
2042
2043     show_dt:
2044       dt = c->ext.dt;
2045       if (dt->io_unit)
2046         {
2047           fputs (" UNIT=", dumpfile);
2048           show_expr (dt->io_unit);
2049         }
2050
2051       if (dt->format_expr)
2052         {
2053           fputs (" FMT=", dumpfile);
2054           show_expr (dt->format_expr);
2055         }
2056
2057       if (dt->format_label != NULL)
2058         fprintf (dumpfile, " FMT=%d", dt->format_label->value);
2059       if (dt->namelist)
2060         fprintf (dumpfile, " NML=%s", dt->namelist->name);
2061
2062       if (dt->iomsg)
2063         {
2064           fputs (" IOMSG=", dumpfile);
2065           show_expr (dt->iomsg);
2066         }
2067       if (dt->iostat)
2068         {
2069           fputs (" IOSTAT=", dumpfile);
2070           show_expr (dt->iostat);
2071         }
2072       if (dt->size)
2073         {
2074           fputs (" SIZE=", dumpfile);
2075           show_expr (dt->size);
2076         }
2077       if (dt->rec)
2078         {
2079           fputs (" REC=", dumpfile);
2080           show_expr (dt->rec);
2081         }
2082       if (dt->advance)
2083         {
2084           fputs (" ADVANCE=", dumpfile);
2085           show_expr (dt->advance);
2086         }
2087       if (dt->id)
2088         {
2089           fputs (" ID=", dumpfile);
2090           show_expr (dt->id);
2091         }
2092       if (dt->pos)
2093         {
2094           fputs (" POS=", dumpfile);
2095           show_expr (dt->pos);
2096         }
2097       if (dt->asynchronous)
2098         {
2099           fputs (" ASYNCHRONOUS=", dumpfile);
2100           show_expr (dt->asynchronous);
2101         }
2102       if (dt->blank)
2103         {
2104           fputs (" BLANK=", dumpfile);
2105           show_expr (dt->blank);
2106         }
2107       if (dt->decimal)
2108         {
2109           fputs (" DECIMAL=", dumpfile);
2110           show_expr (dt->decimal);
2111         }
2112       if (dt->delim)
2113         {
2114           fputs (" DELIM=", dumpfile);
2115           show_expr (dt->delim);
2116         }
2117       if (dt->pad)
2118         {
2119           fputs (" PAD=", dumpfile);
2120           show_expr (dt->pad);
2121         }
2122       if (dt->round)
2123         {
2124           fputs (" ROUND=", dumpfile);
2125           show_expr (dt->round);
2126         }
2127       if (dt->sign)
2128         {
2129           fputs (" SIGN=", dumpfile);
2130           show_expr (dt->sign);
2131         }
2132
2133     show_dt_code:
2134       for (c = c->block->next; c; c = c->next)
2135         show_code_node (level + (c->next != NULL), c);
2136       return;
2137
2138     case EXEC_TRANSFER:
2139       fputs ("TRANSFER ", dumpfile);
2140       show_expr (c->expr1);
2141       break;
2142
2143     case EXEC_DT_END:
2144       fputs ("DT_END", dumpfile);
2145       dt = c->ext.dt;
2146
2147       if (dt->err != NULL)
2148         fprintf (dumpfile, " ERR=%d", dt->err->value);
2149       if (dt->end != NULL)
2150         fprintf (dumpfile, " END=%d", dt->end->value);
2151       if (dt->eor != NULL)
2152         fprintf (dumpfile, " EOR=%d", dt->eor->value);
2153       break;
2154
2155     case EXEC_OMP_ATOMIC:
2156     case EXEC_OMP_BARRIER:
2157     case EXEC_OMP_CRITICAL:
2158     case EXEC_OMP_FLUSH:
2159     case EXEC_OMP_DO:
2160     case EXEC_OMP_MASTER:
2161     case EXEC_OMP_ORDERED:
2162     case EXEC_OMP_PARALLEL:
2163     case EXEC_OMP_PARALLEL_DO:
2164     case EXEC_OMP_PARALLEL_SECTIONS:
2165     case EXEC_OMP_PARALLEL_WORKSHARE:
2166     case EXEC_OMP_SECTIONS:
2167     case EXEC_OMP_SINGLE:
2168     case EXEC_OMP_TASK:
2169     case EXEC_OMP_TASKWAIT:
2170     case EXEC_OMP_WORKSHARE:
2171       show_omp_node (level, c);
2172       break;
2173
2174     default:
2175       gfc_internal_error ("show_code_node(): Bad statement code");
2176     }
2177 }
2178
2179
2180 /* Show an equivalence chain.  */
2181
2182 static void
2183 show_equiv (gfc_equiv *eq)
2184 {
2185   show_indent ();
2186   fputs ("Equivalence: ", dumpfile);
2187   while (eq)
2188     {
2189       show_expr (eq->expr);
2190       eq = eq->eq;
2191       if (eq)
2192         fputs (", ", dumpfile);
2193     }
2194 }
2195
2196
2197 /* Show a freakin' whole namespace.  */
2198
2199 static void
2200 show_namespace (gfc_namespace *ns)
2201 {
2202   gfc_interface *intr;
2203   gfc_namespace *save;
2204   int op;
2205   gfc_equiv *eq;
2206   int i;
2207
2208   save = gfc_current_ns;
2209
2210   show_indent ();
2211   fputs ("Namespace:", dumpfile);
2212
2213   if (ns != NULL)
2214     {
2215       i = 0;
2216       do
2217         {
2218           int l = i;
2219           while (i < GFC_LETTERS - 1
2220                  && gfc_compare_types(&ns->default_type[i+1],
2221                                       &ns->default_type[l]))
2222             i++;
2223
2224           if (i > l)
2225             fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2226           else
2227             fprintf (dumpfile, " %c: ", l+'A');
2228
2229           show_typespec(&ns->default_type[l]);
2230           i++;
2231       } while (i < GFC_LETTERS);
2232
2233       if (ns->proc_name != NULL)
2234         {
2235           show_indent ();
2236           fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2237         }
2238
2239       ++show_level;
2240       gfc_current_ns = ns;
2241       gfc_traverse_symtree (ns->common_root, show_common);
2242
2243       gfc_traverse_symtree (ns->sym_root, show_symtree);
2244
2245       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2246         {
2247           /* User operator interfaces */
2248           intr = ns->op[op];
2249           if (intr == NULL)
2250             continue;
2251
2252           show_indent ();
2253           fprintf (dumpfile, "Operator interfaces for %s:",
2254                    gfc_op2string ((gfc_intrinsic_op) op));
2255
2256           for (; intr; intr = intr->next)
2257             fprintf (dumpfile, " %s", intr->sym->name);
2258         }
2259
2260       if (ns->uop_root != NULL)
2261         {
2262           show_indent ();
2263           fputs ("User operators:\n", dumpfile);
2264           gfc_traverse_user_op (ns, show_uop);
2265         }
2266     }
2267   else
2268     ++show_level;
2269
2270   for (eq = ns->equiv; eq; eq = eq->next)
2271     show_equiv (eq);
2272
2273   fputc ('\n', dumpfile);
2274   show_indent ();
2275   fputs ("code:", dumpfile);
2276   show_code (show_level, ns->code);
2277   --show_level;
2278
2279   for (ns = ns->contained; ns; ns = ns->sibling)
2280     {
2281       fputs ("\nCONTAINS\n", dumpfile);
2282       ++show_level;
2283       show_namespace (ns);
2284       --show_level;
2285     }
2286
2287   fputc ('\n', dumpfile);
2288   gfc_current_ns = save;
2289 }
2290
2291
2292 /* Main function for dumping a parse tree.  */
2293
2294 void
2295 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2296 {
2297   dumpfile = file;
2298   show_namespace (ns);
2299 }