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