gcc/fortran/dump-parse-tree.c

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