gcc/fortran/dump-parse-tree.c

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