gcc/fortran/dump-parse-tree.c

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