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