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