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