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