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