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