gcc/fortran/dump-parse-tree.c

   1 /* Parse tree dumper
   2    Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009
   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->dimension)
 593     fputs (" DIMENSION", dumpfile);
 594   if (attr->external)
 595     fputs (" EXTERNAL", dumpfile);
 596   if (attr->intrinsic)
 597     fputs (" INTRINSIC", dumpfile);
 598   if (attr->optional)
 599     fputs (" OPTIONAL", dumpfile);
 600   if (attr->pointer)
 601     fputs (" POINTER", dumpfile);
 602   if (attr->is_protected)
 603     fputs (" PROTECTED", dumpfile);
 604   if (attr->value)
 605     fputs (" VALUE", dumpfile);
 606   if (attr->volatile_)
 607     fputs (" VOLATILE", dumpfile);
 608   if (attr->threadprivate)
 609     fputs (" THREADPRIVATE", dumpfile);
 610   if (attr->target)
 611     fputs (" TARGET", dumpfile);
 612   if (attr->dummy)
 613     fputs (" DUMMY", dumpfile);
 614   if (attr->result)
 615     fputs (" RESULT", dumpfile);
 616   if (attr->entry)
 617     fputs (" ENTRY", dumpfile);
 618   if (attr->is_bind_c)
 619     fputs (" BIND(C)", dumpfile);
 620
 621   if (attr->data)
 622     fputs (" DATA", dumpfile);
 623   if (attr->use_assoc)
 624     fputs (" USE-ASSOC", dumpfile);
 625   if (attr->in_namelist)
 626     fputs (" IN-NAMELIST", dumpfile);
 627   if (attr->in_common)
 628     fputs (" IN-COMMON", dumpfile);
 629
 630   if (attr->abstract)
 631     fputs (" ABSTRACT", dumpfile);
 632   if (attr->function)
 633     fputs (" FUNCTION", dumpfile);
 634   if (attr->subroutine)
 635     fputs (" SUBROUTINE", dumpfile);
 636   if (attr->implicit_type)
 637     fputs (" IMPLICIT-TYPE", dumpfile);
 638
 639   if (attr->sequence)
 640     fputs (" SEQUENCE", dumpfile);
 641   if (attr->elemental)
 642     fputs (" ELEMENTAL", dumpfile);
 643   if (attr->pure)
 644     fputs (" PURE", dumpfile);
 645   if (attr->recursive)
 646     fputs (" RECURSIVE", dumpfile);
 647
 648   fputc (')', dumpfile);
 649 }
 650
 651
 652 /* Show components of a derived type.  */
 653
 654 static void
 655 show_components (gfc_symbol *sym)
 656 {
 657   gfc_component *c;
 658
 659   for (c = sym->components; c; c = c->next)
 660     {
 661       fprintf (dumpfile, "(%s ", c->name);
 662       show_typespec (&c->ts);
 663       if (c->attr.pointer)
 664         fputs (" POINTER", dumpfile);
 665       if (c->attr.proc_pointer)
 666         fputs (" PPC", dumpfile);
 667       if (c->attr.dimension)
 668         fputs (" DIMENSION", dumpfile);
 669       fputc (' ', dumpfile);
 670       show_array_spec (c->as);
 671       if (c->attr.access)
 672         fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
 673       fputc (')', dumpfile);
 674       if (c->next != NULL)
 675         fputc (' ', dumpfile);
 676     }
 677 }
 678
 679
 680 /* Show the f2k_derived namespace with procedure bindings.  */
 681
 682 static void
 683 show_typebound_proc (gfc_typebound_proc* tb, const char* name)
 684 {
 685   show_indent ();
 686
 687   if (tb->is_generic)
 688     fputs ("GENERIC", dumpfile);
 689   else
 690     {
 691       fputs ("PROCEDURE, ", dumpfile);
 692       if (tb->nopass)
 693         fputs ("NOPASS", dumpfile);
 694       else
 695         {
 696           if (tb->pass_arg)
 697             fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
 698           else
 699             fputs ("PASS", dumpfile);
 700         }
 701       if (tb->non_overridable)
 702         fputs (", NON_OVERRIDABLE", dumpfile);
 703     }
 704
 705   if (tb->access == ACCESS_PUBLIC)
 706     fputs (", PUBLIC", dumpfile);
 707   else
 708     fputs (", PRIVATE", dumpfile);
 709
 710   fprintf (dumpfile, " :: %s => ", name);
 711
 712   if (tb->is_generic)
 713     {
 714       gfc_tbp_generic* g;
 715       for (g = tb->u.generic; g; g = g->next)
 716         {
 717           fputs (g->specific_st->name, dumpfile);
 718           if (g->next)
 719             fputs (", ", dumpfile);
 720         }
 721     }
 722   else
 723     fputs (tb->u.specific->n.sym->name, dumpfile);
 724 }
 725
 726 static void
 727 show_typebound_symtree (gfc_symtree* st)
 728 {
 729   gcc_assert (st->n.tb);
 730   show_typebound_proc (st->n.tb, st->name);
 731 }
 732
 733 static void
 734 show_f2k_derived (gfc_namespace* f2k)
 735 {
 736   gfc_finalizer* f;
 737   int op;
 738
 739   show_indent ();
 740   fputs ("Procedure bindings:", dumpfile);
 741   ++show_level;
 742
 743   /* Finalizer bindings.  */
 744   for (f = f2k->finalizers; f; f = f->next)
 745     {
 746       show_indent ();
 747       fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
 748     }
 749
 750   /* Type-bound procedures.  */
 751   gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
 752
 753   --show_level;
 754
 755   show_indent ();
 756   fputs ("Operator bindings:", dumpfile);
 757   ++show_level;
 758
 759   /* User-defined operators.  */
 760   gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
 761
 762   /* Intrinsic operators.  */
 763   for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
 764     if (f2k->tb_op[op])
 765       show_typebound_proc (f2k->tb_op[op],
 766                            gfc_op2string ((gfc_intrinsic_op) op));
 767
 768   --show_level;
 769 }
 770
 771
 772 /* Show a symbol.  If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
 773    show the interface.  Information needed to reconstruct the list of
 774    specific interfaces associated with a generic symbol is done within
 775    that symbol.  */
 776
 777 static void
 778 show_symbol (gfc_symbol *sym)
 779 {
 780   gfc_formal_arglist *formal;
 781   gfc_interface *intr;
 782
 783   if (sym == NULL)
 784     return;
 785
 786   show_indent ();
 787
 788   fprintf (dumpfile, "symbol %s ", sym->name);
 789   show_typespec (&sym->ts);
 790   show_attr (&sym->attr);
 791
 792   if (sym->value)
 793     {
 794       show_indent ();
 795       fputs ("value: ", dumpfile);
 796       show_expr (sym->value);
 797     }
 798
 799   if (sym->as)
 800     {
 801       show_indent ();
 802       fputs ("Array spec:", dumpfile);
 803       show_array_spec (sym->as);
 804     }
 805
 806   if (sym->generic)
 807     {
 808       show_indent ();
 809       fputs ("Generic interfaces:", dumpfile);
 810       for (intr = sym->generic; intr; intr = intr->next)
 811         fprintf (dumpfile, " %s", intr->sym->name);
 812     }
 813
 814   if (sym->result)
 815     {
 816       show_indent ();
 817       fprintf (dumpfile, "result: %s", sym->result->name);
 818     }
 819
 820   if (sym->components)
 821     {
 822       show_indent ();
 823       fputs ("components: ", dumpfile);
 824       show_components (sym);
 825     }
 826
 827   if (sym->f2k_derived)
 828     {
 829       show_indent ();
 830       if (sym->vindex)
 831         fprintf (dumpfile, "vindex: %d", sym->vindex);
 832       show_f2k_derived (sym->f2k_derived);
 833     }
 834
 835   if (sym->formal)
 836     {
 837       show_indent ();
 838       fputs ("Formal arglist:", dumpfile);
 839
 840       for (formal = sym->formal; formal; formal = formal->next)
 841         {
 842           if (formal->sym != NULL)
 843             fprintf (dumpfile, " %s", formal->sym->name);
 844           else
 845             fputs (" [Alt Return]", dumpfile);
 846         }
 847     }
 848
 849   if (sym->formal_ns)
 850     {
 851       show_indent ();
 852       fputs ("Formal namespace", dumpfile);
 853       show_namespace (sym->formal_ns);
 854     }
 855
 856   fputc ('\n', dumpfile);
 857 }
 858
 859
 860 /* Show a user-defined operator.  Just prints an operator
 861    and the name of the associated subroutine, really.  */
 862
 863 static void
 864 show_uop (gfc_user_op *uop)
 865 {
 866   gfc_interface *intr;
 867
 868   show_indent ();
 869   fprintf (dumpfile, "%s:", uop->name);
 870
 871   for (intr = uop->op; intr; intr = intr->next)
 872     fprintf (dumpfile, " %s", intr->sym->name);
 873 }
 874
 875
 876 /* Workhorse function for traversing the user operator symtree.  */
 877
 878 static void
 879 traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
 880 {
 881   if (st == NULL)
 882     return;
 883
 884   (*func) (st->n.uop);
 885
 886   traverse_uop (st->left, func);
 887   traverse_uop (st->right, func);
 888 }
 889
 890
 891 /* Traverse the tree of user operator nodes.  */
 892
 893 void
 894 gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
 895 {
 896   traverse_uop (ns->uop_root, func);
 897 }
 898
 899
 900 /* Function to display a common block.  */
 901
 902 static void
 903 show_common (gfc_symtree *st)
 904 {
 905   gfc_symbol *s;
 906
 907   show_indent ();
 908   fprintf (dumpfile, "common: /%s/ ", st->name);
 909
 910   s = st->n.common->head;
 911   while (s)
 912     {
 913       fprintf (dumpfile, "%s", s->name);
 914       s = s->common_next;
 915       if (s)
 916         fputs (", ", dumpfile);
 917     }
 918   fputc ('\n', dumpfile);
 919 }
 920
 921
 922 /* Worker function to display the symbol tree.  */
 923
 924 static void
 925 show_symtree (gfc_symtree *st)
 926 {
 927   show_indent ();
 928   fprintf (dumpfile, "symtree: %s  Ambig %d", st->name, st->ambiguous);
 929
 930   if (st->n.sym->ns != gfc_current_ns)
 931     fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
 932   else
 933     show_symbol (st->n.sym);
 934 }
 935
 936
 937 /******************* Show gfc_code structures **************/
 938
 939
 940 /* Show a list of code structures.  Mutually recursive with
 941    show_code_node().  */
 942
 943 static void
 944 show_code (int level, gfc_code *c)
 945 {
 946   for (; c; c = c->next)
 947     show_code_node (level, c);
 948 }
 949
 950 static void
 951 show_namelist (gfc_namelist *n)
 952 {
 953   for (; n->next; n = n->next)
 954     fprintf (dumpfile, "%s,", n->sym->name);
 955   fprintf (dumpfile, "%s", n->sym->name);
 956 }
 957
 958 /* Show a single OpenMP directive node and everything underneath it
 959    if necessary.  */
 960
 961 static void
 962 show_omp_node (int level, gfc_code *c)
 963 {
 964   gfc_omp_clauses *omp_clauses = NULL;
 965   const char *name = NULL;
 966
 967   switch (c->op)
 968     {
 969     case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
 970     case EXEC_OMP_BARRIER: name = "BARRIER"; break;
 971     case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
 972     case EXEC_OMP_FLUSH: name = "FLUSH"; break;
 973     case EXEC_OMP_DO: name = "DO"; break;
 974     case EXEC_OMP_MASTER: name = "MASTER"; break;
 975     case EXEC_OMP_ORDERED: name = "ORDERED"; break;
 976     case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
 977     case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
 978     case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
 979     case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
 980     case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
 981     case EXEC_OMP_SINGLE: name = "SINGLE"; break;
 982     case EXEC_OMP_TASK: name = "TASK"; break;
 983     case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
 984     case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
 985     default:
 986       gcc_unreachable ();
 987     }
 988   fprintf (dumpfile, "!$OMP %s", name);
 989   switch (c->op)
 990     {
 991     case EXEC_OMP_DO:
 992     case EXEC_OMP_PARALLEL:
 993     case EXEC_OMP_PARALLEL_DO:
 994     case EXEC_OMP_PARALLEL_SECTIONS:
 995     case EXEC_OMP_SECTIONS:
 996     case EXEC_OMP_SINGLE:
 997     case EXEC_OMP_WORKSHARE:
 998     case EXEC_OMP_PARALLEL_WORKSHARE:
 999     case EXEC_OMP_TASK:
1000       omp_clauses = c->ext.omp_clauses;
1001       break;
1002     case EXEC_OMP_CRITICAL:
1003       if (c->ext.omp_name)
1004         fprintf (dumpfile, " (%s)", c->ext.omp_name);
1005       break;
1006     case EXEC_OMP_FLUSH:
1007       if (c->ext.omp_namelist)
1008         {
1009           fputs (" (", dumpfile);
1010           show_namelist (c->ext.omp_namelist);
1011           fputc (')', dumpfile);
1012         }
1013       return;
1014     case EXEC_OMP_BARRIER:
1015     case EXEC_OMP_TASKWAIT:
1016       return;
1017     default:
1018       break;
1019     }
1020   if (omp_clauses)
1021     {
1022       int list_type;
1023
1024       if (omp_clauses->if_expr)
1025         {
1026           fputs (" IF(", dumpfile);
1027           show_expr (omp_clauses->if_expr);
1028           fputc (')', dumpfile);
1029         }
1030       if (omp_clauses->num_threads)
1031         {
1032           fputs (" NUM_THREADS(", dumpfile);
1033           show_expr (omp_clauses->num_threads);
1034           fputc (')', dumpfile);
1035         }
1036       if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1037         {
1038           const char *type;
1039           switch (omp_clauses->sched_kind)
1040             {
1041             case OMP_SCHED_STATIC: type = "STATIC"; break;
1042             case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1043             case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1044             case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1045             case OMP_SCHED_AUTO: type = "AUTO"; break;
1046             default:
1047               gcc_unreachable ();
1048             }
1049           fprintf (dumpfile, " SCHEDULE (%s", type);
1050           if (omp_clauses->chunk_size)
1051             {
1052               fputc (',', dumpfile);
1053               show_expr (omp_clauses->chunk_size);
1054             }
1055           fputc (')', dumpfile);
1056         }
1057       if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1058         {
1059           const char *type;
1060           switch (omp_clauses->default_sharing)
1061             {
1062             case OMP_DEFAULT_NONE: type = "NONE"; break;
1063             case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1064             case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1065             case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1066             default:
1067               gcc_unreachable ();
1068             }
1069           fprintf (dumpfile, " DEFAULT(%s)", type);
1070         }
1071       if (omp_clauses->ordered)
1072         fputs (" ORDERED", dumpfile);
1073       if (omp_clauses->untied)
1074         fputs (" UNTIED", dumpfile);
1075       if (omp_clauses->collapse)
1076         fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1077       for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1078         if (omp_clauses->lists[list_type] != NULL
1079             && list_type != OMP_LIST_COPYPRIVATE)
1080           {
1081             const char *type;
1082             if (list_type >= OMP_LIST_REDUCTION_FIRST)
1083               {
1084                 switch (list_type)
1085                   {
1086                   case OMP_LIST_PLUS: type = "+"; break;
1087                   case OMP_LIST_MULT: type = "*"; break;
1088                   case OMP_LIST_SUB: type = "-"; break;
1089                   case OMP_LIST_AND: type = ".AND."; break;
1090                   case OMP_LIST_OR: type = ".OR."; break;
1091                   case OMP_LIST_EQV: type = ".EQV."; break;
1092                   case OMP_LIST_NEQV: type = ".NEQV."; break;
1093                   case OMP_LIST_MAX: type = "MAX"; break;
1094                   case OMP_LIST_MIN: type = "MIN"; break;
1095                   case OMP_LIST_IAND: type = "IAND"; break;
1096                   case OMP_LIST_IOR: type = "IOR"; break;
1097                   case OMP_LIST_IEOR: type = "IEOR"; break;
1098                   default:
1099                     gcc_unreachable ();
1100                   }
1101                 fprintf (dumpfile, " REDUCTION(%s:", type);
1102               }
1103             else
1104               {
1105                 switch (list_type)
1106                   {
1107                   case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1108                   case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1109                   case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1110                   case OMP_LIST_SHARED: type = "SHARED"; break;
1111                   case OMP_LIST_COPYIN: type = "COPYIN"; break;
1112                   default:
1113                     gcc_unreachable ();
1114                   }
1115                 fprintf (dumpfile, " %s(", type);
1116               }
1117             show_namelist (omp_clauses->lists[list_type]);
1118             fputc (')', dumpfile);
1119           }
1120     }
1121   fputc ('\n', dumpfile);
1122   if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1123     {
1124       gfc_code *d = c->block;
1125       while (d != NULL)
1126         {
1127           show_code (level + 1, d->next);
1128           if (d->block == NULL)
1129             break;
1130           code_indent (level, 0);
1131           fputs ("!$OMP SECTION\n", dumpfile);
1132           d = d->block;
1133         }
1134     }
1135   else
1136     show_code (level + 1, c->block->next);
1137   if (c->op == EXEC_OMP_ATOMIC)
1138     return;
1139   code_indent (level, 0);
1140   fprintf (dumpfile, "!$OMP END %s", name);
1141   if (omp_clauses != NULL)
1142     {
1143       if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1144         {
1145           fputs (" COPYPRIVATE(", dumpfile);
1146           show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1147           fputc (')', dumpfile);
1148         }
1149       else if (omp_clauses->nowait)
1150         fputs (" NOWAIT", dumpfile);
1151     }
1152   else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1153     fprintf (dumpfile, " (%s)", c->ext.omp_name);
1154 }
1155
1156
1157 /* Show a single code node and everything underneath it if necessary.  */
1158
1159 static void
1160 show_code_node (int level, gfc_code *c)
1161 {
1162   gfc_forall_iterator *fa;
1163   gfc_open *open;
1164   gfc_case *cp;
1165   gfc_alloc *a;
1166   gfc_code *d;
1167   gfc_close *close;
1168   gfc_filepos *fp;
1169   gfc_inquire *i;
1170   gfc_dt *dt;
1171
1172   code_indent (level, c->here);
1173
1174   switch (c->op)
1175     {
1176     case EXEC_END_PROCEDURE:
1177       break;
1178
1179     case EXEC_NOP:
1180       fputs ("NOP", dumpfile);
1181       break;
1182
1183     case EXEC_CONTINUE:
1184       fputs ("CONTINUE", dumpfile);
1185       break;
1186
1187     case EXEC_ENTRY:
1188       fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1189       break;
1190
1191     case EXEC_INIT_ASSIGN:
1192     case EXEC_ASSIGN:
1193       fputs ("ASSIGN ", dumpfile);
1194       show_expr (c->expr1);
1195       fputc (' ', dumpfile);
1196       show_expr (c->expr2);
1197       break;
1198
1199     case EXEC_LABEL_ASSIGN:
1200       fputs ("LABEL ASSIGN ", dumpfile);
1201       show_expr (c->expr1);
1202       fprintf (dumpfile, " %d", c->label1->value);
1203       break;
1204
1205     case EXEC_POINTER_ASSIGN:
1206       fputs ("POINTER ASSIGN ", dumpfile);
1207       show_expr (c->expr1);
1208       fputc (' ', dumpfile);
1209       show_expr (c->expr2);
1210       break;
1211
1212     case EXEC_GOTO:
1213       fputs ("GOTO ", dumpfile);
1214       if (c->label1)
1215         fprintf (dumpfile, "%d", c->label1->value);
1216       else
1217         {
1218           show_expr (c->expr1);
1219           d = c->block;
1220           if (d != NULL)
1221             {
1222               fputs (", (", dumpfile);
1223               for (; d; d = d ->block)
1224                 {
1225                   code_indent (level, d->label1);
1226                   if (d->block != NULL)
1227                     fputc (',', dumpfile);
1228                   else
1229                     fputc (')', dumpfile);
1230                 }
1231             }
1232         }
1233       break;
1234
1235     case EXEC_CALL:
1236     case EXEC_ASSIGN_CALL:
1237       if (c->resolved_sym)
1238         fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1239       else if (c->symtree)
1240         fprintf (dumpfile, "CALL %s ", c->symtree->name);
1241       else
1242         fputs ("CALL ?? ", dumpfile);
1243
1244       show_actual_arglist (c->ext.actual);
1245       break;
1246
1247     case EXEC_COMPCALL:
1248       fputs ("CALL ", dumpfile);
1249       show_compcall (c->expr1);
1250       break;
1251
1252     case EXEC_CALL_PPC:
1253       fputs ("CALL ", dumpfile);
1254       show_expr (c->expr1);
1255       show_actual_arglist (c->ext.actual);
1256       break;
1257
1258     case EXEC_RETURN:
1259       fputs ("RETURN ", dumpfile);
1260       if (c->expr1)
1261         show_expr (c->expr1);
1262       break;
1263
1264     case EXEC_PAUSE:
1265       fputs ("PAUSE ", dumpfile);
1266
1267       if (c->expr1 != NULL)
1268         show_expr (c->expr1);
1269       else
1270         fprintf (dumpfile, "%d", c->ext.stop_code);
1271
1272       break;
1273
1274     case EXEC_STOP:
1275       fputs ("STOP ", dumpfile);
1276
1277       if (c->expr1 != NULL)
1278         show_expr (c->expr1);
1279       else
1280         fprintf (dumpfile, "%d", c->ext.stop_code);
1281
1282       break;
1283
1284     case EXEC_ARITHMETIC_IF:
1285       fputs ("IF ", dumpfile);
1286       show_expr (c->expr1);
1287       fprintf (dumpfile, " %d, %d, %d",
1288                   c->label1->value, c->label2->value, c->label3->value);
1289       break;
1290
1291     case EXEC_IF:
1292       d = c->block;
1293       fputs ("IF ", dumpfile);
1294       show_expr (d->expr1);
1295       fputc ('\n', dumpfile);
1296       show_code (level + 1, d->next);
1297
1298       d = d->block;
1299       for (; d; d = d->block)
1300         {
1301           code_indent (level, 0);
1302
1303           if (d->expr1 == NULL)
1304             fputs ("ELSE\n", dumpfile);
1305           else
1306             {
1307               fputs ("ELSE IF ", dumpfile);
1308               show_expr (d->expr1);
1309               fputc ('\n', dumpfile);
1310             }
1311
1312           show_code (level + 1, d->next);
1313         }
1314
1315       code_indent (level, c->label1);
1316
1317       fputs ("ENDIF", dumpfile);
1318       break;
1319
1320     case EXEC_SELECT:
1321       d = c->block;
1322       fputs ("SELECT CASE ", dumpfile);
1323       show_expr (c->expr1);
1324       fputc ('\n', dumpfile);
1325
1326       for (; d; d = d->block)
1327         {
1328           code_indent (level, 0);
1329
1330           fputs ("CASE ", dumpfile);
1331           for (cp = d->ext.case_list; cp; cp = cp->next)
1332             {
1333               fputc ('(', dumpfile);
1334               show_expr (cp->low);
1335               fputc (' ', dumpfile);
1336               show_expr (cp->high);
1337               fputc (')', dumpfile);
1338               fputc (' ', dumpfile);
1339             }
1340           fputc ('\n', dumpfile);
1341
1342           show_code (level + 1, d->next);
1343         }
1344
1345       code_indent (level, c->label1);
1346       fputs ("END SELECT", dumpfile);
1347       break;
1348
1349     case EXEC_WHERE:
1350       fputs ("WHERE ", dumpfile);
1351
1352       d = c->block;
1353       show_expr (d->expr1);
1354       fputc ('\n', dumpfile);
1355
1356       show_code (level + 1, d->next);
1357
1358       for (d = d->block; d; d = d->block)
1359         {
1360           code_indent (level, 0);
1361           fputs ("ELSE WHERE ", dumpfile);
1362           show_expr (d->expr1);
1363           fputc ('\n', dumpfile);
1364           show_code (level + 1, d->next);
1365         }
1366
1367       code_indent (level, 0);
1368       fputs ("END WHERE", dumpfile);
1369       break;
1370
1371
1372     case EXEC_FORALL:
1373       fputs ("FORALL ", dumpfile);
1374       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1375         {
1376           show_expr (fa->var);
1377           fputc (' ', dumpfile);
1378           show_expr (fa->start);
1379           fputc (':', dumpfile);
1380           show_expr (fa->end);
1381           fputc (':', dumpfile);
1382           show_expr (fa->stride);
1383
1384           if (fa->next != NULL)
1385             fputc (',', dumpfile);
1386         }
1387
1388       if (c->expr1 != NULL)
1389         {
1390           fputc (',', dumpfile);
1391           show_expr (c->expr1);
1392         }
1393       fputc ('\n', dumpfile);
1394
1395       show_code (level + 1, c->block->next);
1396
1397       code_indent (level, 0);
1398       fputs ("END FORALL", dumpfile);
1399       break;
1400
1401     case EXEC_DO:
1402       fputs ("DO ", dumpfile);
1403
1404       show_expr (c->ext.iterator->var);
1405       fputc ('=', dumpfile);
1406       show_expr (c->ext.iterator->start);
1407       fputc (' ', dumpfile);
1408       show_expr (c->ext.iterator->end);
1409       fputc (' ', dumpfile);
1410       show_expr (c->ext.iterator->step);
1411       fputc ('\n', dumpfile);
1412
1413       show_code (level + 1, c->block->next);
1414
1415       code_indent (level, 0);
1416       fputs ("END DO", dumpfile);
1417       break;
1418
1419     case EXEC_DO_WHILE:
1420       fputs ("DO WHILE ", dumpfile);
1421       show_expr (c->expr1);
1422       fputc ('\n', dumpfile);
1423
1424       show_code (level + 1, c->block->next);
1425
1426       code_indent (level, c->label1);
1427       fputs ("END DO", dumpfile);
1428       break;
1429
1430     case EXEC_CYCLE:
1431       fputs ("CYCLE", dumpfile);
1432       if (c->symtree)
1433         fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1434       break;
1435
1436     case EXEC_EXIT:
1437       fputs ("EXIT", dumpfile);
1438       if (c->symtree)
1439         fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1440       break;
1441
1442     case EXEC_ALLOCATE:
1443       fputs ("ALLOCATE ", dumpfile);
1444       if (c->expr1)
1445         {
1446           fputs (" STAT=", dumpfile);
1447           show_expr (c->expr1);
1448         }
1449
1450       if (c->expr2)
1451         {
1452           fputs (" ERRMSG=", dumpfile);
1453           show_expr (c->expr2);
1454         }
1455
1456       for (a = c->ext.alloc.list; a; a = a->next)
1457         {
1458           fputc (' ', dumpfile);
1459           show_expr (a->expr);
1460         }
1461
1462       break;
1463
1464     case EXEC_DEALLOCATE:
1465       fputs ("DEALLOCATE ", dumpfile);
1466       if (c->expr1)
1467         {
1468           fputs (" STAT=", dumpfile);
1469           show_expr (c->expr1);
1470         }
1471
1472       if (c->expr2)
1473         {
1474           fputs (" ERRMSG=", dumpfile);
1475           show_expr (c->expr2);
1476         }
1477
1478       for (a = c->ext.alloc.list; a; a = a->next)
1479         {
1480           fputc (' ', dumpfile);
1481           show_expr (a->expr);
1482         }
1483
1484       break;
1485
1486     case EXEC_OPEN:
1487       fputs ("OPEN", dumpfile);
1488       open = c->ext.open;
1489
1490       if (open->unit)
1491         {
1492           fputs (" UNIT=", dumpfile);
1493           show_expr (open->unit);
1494         }
1495       if (open->iomsg)
1496         {
1497           fputs (" IOMSG=", dumpfile);
1498           show_expr (open->iomsg);
1499         }
1500       if (open->iostat)
1501         {
1502           fputs (" IOSTAT=", dumpfile);
1503           show_expr (open->iostat);
1504         }
1505       if (open->file)
1506         {
1507           fputs (" FILE=", dumpfile);
1508           show_expr (open->file);
1509         }
1510       if (open->status)
1511         {
1512           fputs (" STATUS=", dumpfile);
1513           show_expr (open->status);
1514         }
1515       if (open->access)
1516         {
1517           fputs (" ACCESS=", dumpfile);
1518           show_expr (open->access);
1519         }
1520       if (open->form)
1521         {
1522           fputs (" FORM=", dumpfile);
1523           show_expr (open->form);
1524         }
1525       if (open->recl)
1526         {
1527           fputs (" RECL=", dumpfile);
1528           show_expr (open->recl);
1529         }
1530       if (open->blank)
1531         {
1532           fputs (" BLANK=", dumpfile);
1533           show_expr (open->blank);
1534         }
1535       if (open->position)
1536         {
1537           fputs (" POSITION=", dumpfile);
1538           show_expr (open->position);
1539         }
1540       if (open->action)
1541         {
1542           fputs (" ACTION=", dumpfile);
1543           show_expr (open->action);
1544         }
1545       if (open->delim)
1546         {
1547           fputs (" DELIM=", dumpfile);
1548           show_expr (open->delim);
1549         }
1550       if (open->pad)
1551         {
1552           fputs (" PAD=", dumpfile);
1553           show_expr (open->pad);
1554         }
1555       if (open->decimal)
1556         {
1557           fputs (" DECIMAL=", dumpfile);
1558           show_expr (open->decimal);
1559         }
1560       if (open->encoding)
1561         {
1562           fputs (" ENCODING=", dumpfile);
1563           show_expr (open->encoding);
1564         }
1565       if (open->round)
1566         {
1567           fputs (" ROUND=", dumpfile);
1568           show_expr (open->round);
1569         }
1570       if (open->sign)
1571         {
1572           fputs (" SIGN=", dumpfile);
1573           show_expr (open->sign);
1574         }
1575       if (open->convert)
1576         {
1577           fputs (" CONVERT=", dumpfile);
1578           show_expr (open->convert);
1579         }
1580       if (open->asynchronous)
1581         {
1582           fputs (" ASYNCHRONOUS=", dumpfile);
1583           show_expr (open->asynchronous);
1584         }
1585       if (open->err != NULL)
1586         fprintf (dumpfile, " ERR=%d", open->err->value);
1587
1588       break;
1589
1590     case EXEC_CLOSE:
1591       fputs ("CLOSE", dumpfile);
1592       close = c->ext.close;
1593
1594       if (close->unit)
1595         {
1596           fputs (" UNIT=", dumpfile);
1597           show_expr (close->unit);
1598         }
1599       if (close->iomsg)
1600         {
1601           fputs (" IOMSG=", dumpfile);
1602           show_expr (close->iomsg);
1603         }
1604       if (close->iostat)
1605         {
1606           fputs (" IOSTAT=", dumpfile);
1607           show_expr (close->iostat);
1608         }
1609       if (close->status)
1610         {
1611           fputs (" STATUS=", dumpfile);
1612           show_expr (close->status);
1613         }
1614       if (close->err != NULL)
1615         fprintf (dumpfile, " ERR=%d", close->err->value);
1616       break;
1617
1618     case EXEC_BACKSPACE:
1619       fputs ("BACKSPACE", dumpfile);
1620       goto show_filepos;
1621
1622     case EXEC_ENDFILE:
1623       fputs ("ENDFILE", dumpfile);
1624       goto show_filepos;
1625
1626     case EXEC_REWIND:
1627       fputs ("REWIND", dumpfile);
1628       goto show_filepos;
1629
1630     case EXEC_FLUSH:
1631       fputs ("FLUSH", dumpfile);
1632
1633     show_filepos:
1634       fp = c->ext.filepos;
1635
1636       if (fp->unit)
1637         {
1638           fputs (" UNIT=", dumpfile);
1639           show_expr (fp->unit);
1640         }
1641       if (fp->iomsg)
1642         {
1643           fputs (" IOMSG=", dumpfile);
1644           show_expr (fp->iomsg);
1645         }
1646       if (fp->iostat)
1647         {
1648           fputs (" IOSTAT=", dumpfile);
1649           show_expr (fp->iostat);
1650         }
1651       if (fp->err != NULL)
1652         fprintf (dumpfile, " ERR=%d", fp->err->value);
1653       break;
1654
1655     case EXEC_INQUIRE:
1656       fputs ("INQUIRE", dumpfile);
1657       i = c->ext.inquire;
1658
1659       if (i->unit)
1660         {
1661           fputs (" UNIT=", dumpfile);
1662           show_expr (i->unit);
1663         }
1664       if (i->file)
1665         {
1666           fputs (" FILE=", dumpfile);
1667           show_expr (i->file);
1668         }
1669
1670       if (i->iomsg)
1671         {
1672           fputs (" IOMSG=", dumpfile);
1673           show_expr (i->iomsg);
1674         }
1675       if (i->iostat)
1676         {
1677           fputs (" IOSTAT=", dumpfile);
1678           show_expr (i->iostat);
1679         }
1680       if (i->exist)
1681         {
1682           fputs (" EXIST=", dumpfile);
1683           show_expr (i->exist);
1684         }
1685       if (i->opened)
1686         {
1687           fputs (" OPENED=", dumpfile);
1688           show_expr (i->opened);
1689         }
1690       if (i->number)
1691         {
1692           fputs (" NUMBER=", dumpfile);
1693           show_expr (i->number);
1694         }
1695       if (i->named)
1696         {
1697           fputs (" NAMED=", dumpfile);
1698           show_expr (i->named);
1699         }
1700       if (i->name)
1701         {
1702           fputs (" NAME=", dumpfile);
1703           show_expr (i->name);
1704         }
1705       if (i->access)
1706         {
1707           fputs (" ACCESS=", dumpfile);
1708           show_expr (i->access);
1709         }
1710       if (i->sequential)
1711         {
1712           fputs (" SEQUENTIAL=", dumpfile);
1713           show_expr (i->sequential);
1714         }
1715
1716       if (i->direct)
1717         {
1718           fputs (" DIRECT=", dumpfile);
1719           show_expr (i->direct);
1720         }
1721       if (i->form)
1722         {
1723           fputs (" FORM=", dumpfile);
1724           show_expr (i->form);
1725         }
1726       if (i->formatted)
1727         {
1728           fputs (" FORMATTED", dumpfile);
1729           show_expr (i->formatted);
1730         }
1731       if (i->unformatted)
1732         {
1733           fputs (" UNFORMATTED=", dumpfile);
1734           show_expr (i->unformatted);
1735         }
1736       if (i->recl)
1737         {
1738           fputs (" RECL=", dumpfile);
1739           show_expr (i->recl);
1740         }
1741       if (i->nextrec)
1742         {
1743           fputs (" NEXTREC=", dumpfile);
1744           show_expr (i->nextrec);
1745         }
1746       if (i->blank)
1747         {
1748           fputs (" BLANK=", dumpfile);
1749           show_expr (i->blank);
1750         }
1751       if (i->position)
1752         {
1753           fputs (" POSITION=", dumpfile);
1754           show_expr (i->position);
1755         }
1756       if (i->action)
1757         {
1758           fputs (" ACTION=", dumpfile);
1759           show_expr (i->action);
1760         }
1761       if (i->read)
1762         {
1763           fputs (" READ=", dumpfile);
1764           show_expr (i->read);
1765         }
1766       if (i->write)
1767         {
1768           fputs (" WRITE=", dumpfile);
1769           show_expr (i->write);
1770         }
1771       if (i->readwrite)
1772         {
1773           fputs (" READWRITE=", dumpfile);
1774           show_expr (i->readwrite);
1775         }
1776       if (i->delim)
1777         {
1778           fputs (" DELIM=", dumpfile);
1779           show_expr (i->delim);
1780         }
1781       if (i->pad)
1782         {
1783           fputs (" PAD=", dumpfile);
1784           show_expr (i->pad);
1785         }
1786       if (i->convert)
1787         {
1788           fputs (" CONVERT=", dumpfile);
1789           show_expr (i->convert);
1790         }
1791       if (i->asynchronous)
1792         {
1793           fputs (" ASYNCHRONOUS=", dumpfile);
1794           show_expr (i->asynchronous);
1795         }
1796       if (i->decimal)
1797         {
1798           fputs (" DECIMAL=", dumpfile);
1799           show_expr (i->decimal);
1800         }
1801       if (i->encoding)
1802         {
1803           fputs (" ENCODING=", dumpfile);
1804           show_expr (i->encoding);
1805         }
1806       if (i->pending)
1807         {
1808           fputs (" PENDING=", dumpfile);
1809           show_expr (i->pending);
1810         }
1811       if (i->round)
1812         {
1813           fputs (" ROUND=", dumpfile);
1814           show_expr (i->round);
1815         }
1816       if (i->sign)
1817         {
1818           fputs (" SIGN=", dumpfile);
1819           show_expr (i->sign);
1820         }
1821       if (i->size)
1822         {
1823           fputs (" SIZE=", dumpfile);
1824           show_expr (i->size);
1825         }
1826       if (i->id)
1827         {
1828           fputs (" ID=", dumpfile);
1829           show_expr (i->id);
1830         }
1831
1832       if (i->err != NULL)
1833         fprintf (dumpfile, " ERR=%d", i->err->value);
1834       break;
1835
1836     case EXEC_IOLENGTH:
1837       fputs ("IOLENGTH ", dumpfile);
1838       show_expr (c->expr1);
1839       goto show_dt_code;
1840       break;
1841
1842     case EXEC_READ:
1843       fputs ("READ", dumpfile);
1844       goto show_dt;
1845
1846     case EXEC_WRITE:
1847       fputs ("WRITE", dumpfile);
1848
1849     show_dt:
1850       dt = c->ext.dt;
1851       if (dt->io_unit)
1852         {
1853           fputs (" UNIT=", dumpfile);
1854           show_expr (dt->io_unit);
1855         }
1856
1857       if (dt->format_expr)
1858         {
1859           fputs (" FMT=", dumpfile);
1860           show_expr (dt->format_expr);
1861         }
1862
1863       if (dt->format_label != NULL)
1864         fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1865       if (dt->namelist)
1866         fprintf (dumpfile, " NML=%s", dt->namelist->name);
1867
1868       if (dt->iomsg)
1869         {
1870           fputs (" IOMSG=", dumpfile);
1871           show_expr (dt->iomsg);
1872         }
1873       if (dt->iostat)
1874         {
1875           fputs (" IOSTAT=", dumpfile);
1876           show_expr (dt->iostat);
1877         }
1878       if (dt->size)
1879         {
1880           fputs (" SIZE=", dumpfile);
1881           show_expr (dt->size);
1882         }
1883       if (dt->rec)
1884         {
1885           fputs (" REC=", dumpfile);
1886           show_expr (dt->rec);
1887         }
1888       if (dt->advance)
1889         {
1890           fputs (" ADVANCE=", dumpfile);
1891           show_expr (dt->advance);
1892         }
1893       if (dt->id)
1894         {
1895           fputs (" ID=", dumpfile);
1896           show_expr (dt->id);
1897         }
1898       if (dt->pos)
1899         {
1900           fputs (" POS=", dumpfile);
1901           show_expr (dt->pos);
1902         }
1903       if (dt->asynchronous)
1904         {
1905           fputs (" ASYNCHRONOUS=", dumpfile);
1906           show_expr (dt->asynchronous);
1907         }
1908       if (dt->blank)
1909         {
1910           fputs (" BLANK=", dumpfile);
1911           show_expr (dt->blank);
1912         }
1913       if (dt->decimal)
1914         {
1915           fputs (" DECIMAL=", dumpfile);
1916           show_expr (dt->decimal);
1917         }
1918       if (dt->delim)
1919         {
1920           fputs (" DELIM=", dumpfile);
1921           show_expr (dt->delim);
1922         }
1923       if (dt->pad)
1924         {
1925           fputs (" PAD=", dumpfile);
1926           show_expr (dt->pad);
1927         }
1928       if (dt->round)
1929         {
1930           fputs (" ROUND=", dumpfile);
1931           show_expr (dt->round);
1932         }
1933       if (dt->sign)
1934         {
1935           fputs (" SIGN=", dumpfile);
1936           show_expr (dt->sign);
1937         }
1938
1939     show_dt_code:
1940       fputc ('\n', dumpfile);
1941       for (c = c->block->next; c; c = c->next)
1942         show_code_node (level + (c->next != NULL), c);
1943       return;
1944
1945     case EXEC_TRANSFER:
1946       fputs ("TRANSFER ", dumpfile);
1947       show_expr (c->expr1);
1948       break;
1949
1950     case EXEC_DT_END:
1951       fputs ("DT_END", dumpfile);
1952       dt = c->ext.dt;
1953
1954       if (dt->err != NULL)
1955         fprintf (dumpfile, " ERR=%d", dt->err->value);
1956       if (dt->end != NULL)
1957         fprintf (dumpfile, " END=%d", dt->end->value);
1958       if (dt->eor != NULL)
1959         fprintf (dumpfile, " EOR=%d", dt->eor->value);
1960       break;
1961
1962     case EXEC_OMP_ATOMIC:
1963     case EXEC_OMP_BARRIER:
1964     case EXEC_OMP_CRITICAL:
1965     case EXEC_OMP_FLUSH:
1966     case EXEC_OMP_DO:
1967     case EXEC_OMP_MASTER:
1968     case EXEC_OMP_ORDERED:
1969     case EXEC_OMP_PARALLEL:
1970     case EXEC_OMP_PARALLEL_DO:
1971     case EXEC_OMP_PARALLEL_SECTIONS:
1972     case EXEC_OMP_PARALLEL_WORKSHARE:
1973     case EXEC_OMP_SECTIONS:
1974     case EXEC_OMP_SINGLE:
1975     case EXEC_OMP_TASK:
1976     case EXEC_OMP_TASKWAIT:
1977     case EXEC_OMP_WORKSHARE:
1978       show_omp_node (level, c);
1979       break;
1980
1981     default:
1982       gfc_internal_error ("show_code_node(): Bad statement code");
1983     }
1984
1985   fputc ('\n', dumpfile);
1986 }
1987
1988
1989 /* Show an equivalence chain.  */
1990
1991 static void
1992 show_equiv (gfc_equiv *eq)
1993 {
1994   show_indent ();
1995   fputs ("Equivalence: ", dumpfile);
1996   while (eq)
1997     {
1998       show_expr (eq->expr);
1999       eq = eq->eq;
2000       if (eq)
2001         fputs (", ", dumpfile);
2002     }
2003 }
2004
2005
2006 /* Show a freakin' whole namespace.  */
2007
2008 static void
2009 show_namespace (gfc_namespace *ns)
2010 {
2011   gfc_interface *intr;
2012   gfc_namespace *save;
2013   int op;
2014   gfc_equiv *eq;
2015   int i;
2016
2017   save = gfc_current_ns;
2018   show_level++;
2019
2020   show_indent ();
2021   fputs ("Namespace:", dumpfile);
2022
2023   if (ns != NULL)
2024     {
2025       i = 0;
2026       do
2027         {
2028           int l = i;
2029           while (i < GFC_LETTERS - 1
2030                  && gfc_compare_types(&ns->default_type[i+1],
2031                                       &ns->default_type[l]))
2032             i++;
2033
2034           if (i > l)
2035             fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2036           else
2037             fprintf (dumpfile, " %c: ", l+'A');
2038
2039           show_typespec(&ns->default_type[l]);
2040           i++;
2041       } while (i < GFC_LETTERS);
2042
2043       if (ns->proc_name != NULL)
2044         {
2045           show_indent ();
2046           fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2047         }
2048
2049       gfc_current_ns = ns;
2050       gfc_traverse_symtree (ns->common_root, show_common);
2051
2052       gfc_traverse_symtree (ns->sym_root, show_symtree);
2053
2054       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2055         {
2056           /* User operator interfaces */
2057           intr = ns->op[op];
2058           if (intr == NULL)
2059             continue;
2060
2061           show_indent ();
2062           fprintf (dumpfile, "Operator interfaces for %s:",
2063                    gfc_op2string ((gfc_intrinsic_op) op));
2064
2065           for (; intr; intr = intr->next)
2066             fprintf (dumpfile, " %s", intr->sym->name);
2067         }
2068
2069       if (ns->uop_root != NULL)
2070         {
2071           show_indent ();
2072           fputs ("User operators:\n", dumpfile);
2073           gfc_traverse_user_op (ns, show_uop);
2074         }
2075     }
2076
2077   for (eq = ns->equiv; eq; eq = eq->next)
2078     show_equiv (eq);
2079
2080   fputc ('\n', dumpfile);
2081   fputc ('\n', dumpfile);
2082
2083   show_code (0, ns->code);
2084
2085   for (ns = ns->contained; ns; ns = ns->sibling)
2086     {
2087       show_indent ();
2088       fputs ("CONTAINS\n", dumpfile);
2089       show_namespace (ns);
2090     }
2091
2092   show_level--;
2093   fputc ('\n', dumpfile);
2094   gfc_current_ns = save;
2095 }
2096
2097
2098 /* Main function for dumping a parse tree.  */
2099
2100 void
2101 gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2102 {
2103   dumpfile = file;
2104   show_namespace (ns);
2105 }