gcc/fortran/dump-parse-tree.c

   1 /* Parse tree dumper
   2    Copyright (C) 2003, 2004 Free Software Foundation, Inc.
   3    Contributed by Steven Bosscher
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.  */
  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
  41 /* Forward declaration because this one needs all, and all need
  42    this one.  */
  43 static void gfc_show_expr (gfc_expr *);
  44
  45 /* Do indentation for a specific level.  */
  46
  47 static inline void
  48 code_indent (int level, gfc_st_label * label)
  49 {
  50   int i;
  51
  52   if (label != NULL)
  53     gfc_status ("%-5d ", label->value);
  54   else
  55     gfc_status ("      ");
  56
  57   for (i = 0; i < 2 * level; i++)
  58     gfc_status_char (' ');
  59 }
  60
  61
  62 /* Simple indentation at the current level.  This one
  63    is used to show symbols.  */
  64 static inline void
  65 show_indent (void)
  66 {
  67   gfc_status ("\n");
  68   code_indent (show_level, NULL);
  69 }
  70
  71
  72 /* Show type-specific information.  */
  73 static void
  74 gfc_show_typespec (gfc_typespec * ts)
  75 {
  76
  77   gfc_status ("(%s ", gfc_basic_typename (ts->type));
  78
  79   switch (ts->type)
  80     {
  81     case BT_DERIVED:
  82       gfc_status ("%s", ts->derived->name);
  83       break;
  84
  85     case BT_CHARACTER:
  86       gfc_show_expr (ts->cl->length);
  87       break;
  88
  89     default:
  90       gfc_status ("%d", ts->kind);
  91       break;
  92     }
  93
  94   gfc_status (")");
  95 }
  96
  97
  98 /* Show an actual argument list.  */
  99
 100 static void
 101 gfc_show_actual_arglist (gfc_actual_arglist * a)
 102 {
 103
 104   gfc_status ("(");
 105
 106   for (; a; a = a->next)
 107     {
 108       gfc_status_char ('(');
 109       if (a->name != NULL)
 110         gfc_status ("%s = ", a->name);
 111       if (a->expr != NULL)
 112         gfc_show_expr (a->expr);
 113       else
 114         gfc_status ("(arg not-present)");
 115
 116       gfc_status_char (')');
 117       if (a->next != NULL)
 118         gfc_status (" ");
 119     }
 120
 121   gfc_status (")");
 122 }
 123
 124
 125 /* Show an gfc_array_spec array specification structure.  */
 126
 127 static void
 128 gfc_show_array_spec (gfc_array_spec * as)
 129 {
 130   const char *c;
 131   int i;
 132
 133   if (as == NULL)
 134     {
 135       gfc_status ("()");
 136       return;
 137     }
 138
 139   gfc_status ("(%d", as->rank);
 140
 141   if (as->rank != 0)
 142     {
 143       switch (as->type)
 144       {
 145         case AS_EXPLICIT:      c = "AS_EXPLICIT";      break;
 146         case AS_DEFERRED:      c = "AS_DEFERRED";      break;
 147         case AS_ASSUMED_SIZE:  c = "AS_ASSUMED_SIZE";  break;
 148         case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
 149         default:
 150           gfc_internal_error
 151                 ("gfc_show_array_spec(): Unhandled array shape type.");
 152       }
 153       gfc_status (" %s ", c);
 154
 155       for (i = 0; i < as->rank; i++)
 156         {
 157           gfc_show_expr (as->lower[i]);
 158           gfc_status_char (' ');
 159           gfc_show_expr (as->upper[i]);
 160           gfc_status_char (' ');
 161         }
 162     }
 163
 164   gfc_status (")");
 165 }
 166
 167
 168 /* Show an gfc_array_ref array reference structure.  */
 169
 170 static void
 171 gfc_show_array_ref (gfc_array_ref * ar)
 172 {
 173   int i;
 174
 175   gfc_status_char ('(');
 176
 177   switch (ar->type)
 178     {
 179     case AR_FULL:
 180       gfc_status ("FULL");
 181       break;
 182
 183     case AR_SECTION:
 184       for (i = 0; i < ar->dimen; i++)
 185         {
 186           /* There are two types of array sections: either the
 187              elements are identified by an integer array ('vector'),
 188              or by an index range. In the former case we only have to
 189              print the start expression which contains the vector, in
 190              the latter case we have to print any of lower and upper
 191              bound and the stride, if they're present.  */
 192
 193           if (ar->start[i] != NULL)
 194             gfc_show_expr (ar->start[i]);
 195
 196           if (ar->dimen_type[i] == DIMEN_RANGE)
 197             {
 198               gfc_status_char (':');
 199
 200               if (ar->end[i] != NULL)
 201                 gfc_show_expr (ar->end[i]);
 202
 203               if (ar->stride[i] != NULL)
 204                 {
 205                   gfc_status_char (':');
 206                   gfc_show_expr (ar->stride[i]);
 207                 }
 208             }
 209
 210           if (i != ar->dimen - 1)
 211             gfc_status (" , ");
 212         }
 213       break;
 214
 215     case AR_ELEMENT:
 216       for (i = 0; i < ar->dimen; i++)
 217         {
 218           gfc_show_expr (ar->start[i]);
 219           if (i != ar->dimen - 1)
 220             gfc_status (" , ");
 221         }
 222       break;
 223
 224     case AR_UNKNOWN:
 225       gfc_status ("UNKNOWN");
 226       break;
 227
 228     default:
 229       gfc_internal_error ("gfc_show_array_ref(): Unknown array reference");
 230     }
 231
 232   gfc_status_char (')');
 233 }
 234
 235
 236 /* Show a list of gfc_ref structures.  */
 237
 238 static void
 239 gfc_show_ref (gfc_ref * p)
 240 {
 241
 242   for (; p; p = p->next)
 243     switch (p->type)
 244       {
 245       case REF_ARRAY:
 246         gfc_show_array_ref (&p->u.ar);
 247         break;
 248
 249       case REF_COMPONENT:
 250         gfc_status (" %% %s", p->u.c.component->name);
 251         break;
 252
 253       case REF_SUBSTRING:
 254         gfc_status_char ('(');
 255         gfc_show_expr (p->u.ss.start);
 256         gfc_status_char (':');
 257         gfc_show_expr (p->u.ss.end);
 258         gfc_status_char (')');
 259         break;
 260
 261       default:
 262         gfc_internal_error ("gfc_show_ref(): Bad component code");
 263       }
 264 }
 265
 266
 267 /* Display a constructor.  Works recursively for array constructors.  */
 268
 269 static void
 270 gfc_show_constructor (gfc_constructor * c)
 271 {
 272
 273   for (; c; c = c->next)
 274     {
 275       if (c->iterator == NULL)
 276         gfc_show_expr (c->expr);
 277       else
 278         {
 279           gfc_status_char ('(');
 280           gfc_show_expr (c->expr);
 281
 282           gfc_status_char (' ');
 283           gfc_show_expr (c->iterator->var);
 284           gfc_status_char ('=');
 285           gfc_show_expr (c->iterator->start);
 286           gfc_status_char (',');
 287           gfc_show_expr (c->iterator->end);
 288           gfc_status_char (',');
 289           gfc_show_expr (c->iterator->step);
 290
 291           gfc_status_char (')');
 292         }
 293
 294       if (c->next != NULL)
 295         gfc_status (" , ");
 296     }
 297 }
 298
 299
 300 /* Show an expression.  */
 301
 302 static void
 303 gfc_show_expr (gfc_expr * p)
 304 {
 305   const char *c;
 306   int i;
 307
 308   if (p == NULL)
 309     {
 310       gfc_status ("()");
 311       return;
 312     }
 313
 314   switch (p->expr_type)
 315     {
 316     case EXPR_SUBSTRING:
 317       c = p->value.character.string;
 318
 319       for (i = 0; i < p->value.character.length; i++, c++)
 320         {
 321           if (*c == '\'')
 322             gfc_status ("''");
 323           else
 324             gfc_status ("%c", *c);
 325         }
 326
 327       gfc_show_ref (p->ref);
 328       break;
 329
 330     case EXPR_STRUCTURE:
 331       gfc_status ("%s(", p->ts.derived->name);
 332       gfc_show_constructor (p->value.constructor);
 333       gfc_status_char (')');
 334       break;
 335
 336     case EXPR_ARRAY:
 337       gfc_status ("(/ ");
 338       gfc_show_constructor (p->value.constructor);
 339       gfc_status (" /)");
 340
 341       gfc_show_ref (p->ref);
 342       break;
 343
 344     case EXPR_NULL:
 345       gfc_status ("NULL()");
 346       break;
 347
 348     case EXPR_CONSTANT:
 349       switch (p->ts.type)
 350         {
 351         case BT_INTEGER:
 352           mpz_out_str (stdout, 10, p->value.integer);
 353
 354           if (p->ts.kind != gfc_default_integer_kind)
 355             gfc_status ("_%d", p->ts.kind);
 356           break;
 357
 358         case BT_LOGICAL:
 359           if (p->value.logical)
 360             gfc_status (".true.");
 361           else
 362             gfc_status (".false.");
 363           break;
 364
 365         case BT_REAL:
 366           mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
 367           if (p->ts.kind != gfc_default_real_kind)
 368             gfc_status ("_%d", p->ts.kind);
 369           break;
 370
 371         case BT_CHARACTER:
 372           c = p->value.character.string;
 373
 374           gfc_status_char ('\'');
 375
 376           for (i = 0; i < p->value.character.length; i++, c++)
 377             {
 378               if (*c == '\'')
 379                 gfc_status ("''");
 380               else
 381                 gfc_status_char (*c);
 382             }
 383
 384           gfc_status_char ('\'');
 385
 386           break;
 387
 388         case BT_COMPLEX:
 389           gfc_status ("(complex ");
 390
 391           mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
 392           if (p->ts.kind != gfc_default_complex_kind)
 393             gfc_status ("_%d", p->ts.kind);
 394
 395           gfc_status (" ");
 396
 397           mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE);
 398           if (p->ts.kind != gfc_default_complex_kind)
 399             gfc_status ("_%d", p->ts.kind);
 400
 401           gfc_status (")");
 402           break;
 403
 404         default:
 405           gfc_status ("???");
 406           break;
 407         }
 408
 409       break;
 410
 411     case EXPR_VARIABLE:
 412       gfc_status ("%s", p->symtree->n.sym->name);
 413       gfc_show_ref (p->ref);
 414       break;
 415
 416     case EXPR_OP:
 417       gfc_status ("(");
 418       switch (p->value.op.operator)
 419         {
 420         case INTRINSIC_UPLUS:
 421           gfc_status ("U+ ");
 422           break;
 423         case INTRINSIC_UMINUS:
 424           gfc_status ("U- ");
 425           break;
 426         case INTRINSIC_PLUS:
 427           gfc_status ("+ ");
 428           break;
 429         case INTRINSIC_MINUS:
 430           gfc_status ("- ");
 431           break;
 432         case INTRINSIC_TIMES:
 433           gfc_status ("* ");
 434           break;
 435         case INTRINSIC_DIVIDE:
 436           gfc_status ("/ ");
 437           break;
 438         case INTRINSIC_POWER:
 439           gfc_status ("** ");
 440           break;
 441         case INTRINSIC_CONCAT:
 442           gfc_status ("// ");
 443           break;
 444         case INTRINSIC_AND:
 445           gfc_status ("AND ");
 446           break;
 447         case INTRINSIC_OR:
 448           gfc_status ("OR ");
 449           break;
 450         case INTRINSIC_EQV:
 451           gfc_status ("EQV ");
 452           break;
 453         case INTRINSIC_NEQV:
 454           gfc_status ("NEQV ");
 455           break;
 456         case INTRINSIC_EQ:
 457           gfc_status ("= ");
 458           break;
 459         case INTRINSIC_NE:
 460           gfc_status ("<> ");
 461           break;
 462         case INTRINSIC_GT:
 463           gfc_status ("> ");
 464           break;
 465         case INTRINSIC_GE:
 466           gfc_status (">= ");
 467           break;
 468         case INTRINSIC_LT:
 469           gfc_status ("< ");
 470           break;
 471         case INTRINSIC_LE:
 472           gfc_status ("<= ");
 473           break;
 474         case INTRINSIC_NOT:
 475           gfc_status ("NOT ");
 476           break;
 477
 478         default:
 479           gfc_internal_error
 480             ("gfc_show_expr(): Bad intrinsic in expression!");
 481         }
 482
 483       gfc_show_expr (p->value.op.op1);
 484
 485       if (p->value.op.op2)
 486         {
 487           gfc_status (" ");
 488           gfc_show_expr (p->value.op.op2);
 489         }
 490
 491       gfc_status (")");
 492       break;
 493
 494     case EXPR_FUNCTION:
 495       if (p->value.function.name == NULL)
 496         {
 497           gfc_status ("%s[", p->symtree->n.sym->name);
 498           gfc_show_actual_arglist (p->value.function.actual);
 499           gfc_status_char (']');
 500         }
 501       else
 502         {
 503           gfc_status ("%s[[", p->value.function.name);
 504           gfc_show_actual_arglist (p->value.function.actual);
 505           gfc_status_char (']');
 506           gfc_status_char (']');
 507         }
 508
 509       break;
 510
 511     default:
 512       gfc_internal_error ("gfc_show_expr(): Don't know how to show expr");
 513     }
 514 }
 515
 516
 517 /* Show symbol attributes.  The flavor and intent are followed by
 518    whatever single bit attributes are present.  */
 519
 520 static void
 521 gfc_show_attr (symbol_attribute * attr)
 522 {
 523
 524   gfc_status ("(%s %s %s %s", gfc_code2string (flavors, attr->flavor),
 525               gfc_intent_string (attr->intent),
 526               gfc_code2string (access_types, attr->access),
 527               gfc_code2string (procedures, attr->proc));
 528
 529   if (attr->allocatable)
 530     gfc_status (" ALLOCATABLE");
 531   if (attr->dimension)
 532     gfc_status (" DIMENSION");
 533   if (attr->external)
 534     gfc_status (" EXTERNAL");
 535   if (attr->intrinsic)
 536     gfc_status (" INTRINSIC");
 537   if (attr->optional)
 538     gfc_status (" OPTIONAL");
 539   if (attr->pointer)
 540     gfc_status (" POINTER");
 541   if (attr->save)
 542     gfc_status (" SAVE");
 543   if (attr->target)
 544     gfc_status (" TARGET");
 545   if (attr->dummy)
 546     gfc_status (" DUMMY");
 547   if (attr->result)
 548     gfc_status (" RESULT");
 549   if (attr->entry)
 550     gfc_status (" ENTRY");
 551
 552   if (attr->data)
 553     gfc_status (" DATA");
 554   if (attr->use_assoc)
 555     gfc_status (" USE-ASSOC");
 556   if (attr->in_namelist)
 557     gfc_status (" IN-NAMELIST");
 558   if (attr->in_common)
 559     gfc_status (" IN-COMMON");
 560
 561   if (attr->function)
 562     gfc_status (" FUNCTION");
 563   if (attr->subroutine)
 564     gfc_status (" SUBROUTINE");
 565   if (attr->implicit_type)
 566     gfc_status (" IMPLICIT-TYPE");
 567
 568   if (attr->sequence)
 569     gfc_status (" SEQUENCE");
 570   if (attr->elemental)
 571     gfc_status (" ELEMENTAL");
 572   if (attr->pure)
 573     gfc_status (" PURE");
 574   if (attr->recursive)
 575     gfc_status (" RECURSIVE");
 576
 577   gfc_status (")");
 578 }
 579
 580
 581 /* Show components of a derived type.  */
 582
 583 static void
 584 gfc_show_components (gfc_symbol * sym)
 585 {
 586   gfc_component *c;
 587
 588   for (c = sym->components; c; c = c->next)
 589     {
 590       gfc_status ("(%s ", c->name);
 591       gfc_show_typespec (&c->ts);
 592       if (c->pointer)
 593         gfc_status (" POINTER");
 594       if (c->dimension)
 595         gfc_status (" DIMENSION");
 596       gfc_status_char (' ');
 597       gfc_show_array_spec (c->as);
 598       gfc_status (")");
 599       if (c->next != NULL)
 600         gfc_status_char (' ');
 601     }
 602 }
 603
 604
 605 /* Show a symbol.  If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
 606    show the interface.  Information needed to reconstruct the list of
 607    specific interfaces associated with a generic symbol is done within
 608    that symbol.  */
 609
 610 static void
 611 gfc_show_symbol (gfc_symbol * sym)
 612 {
 613   gfc_formal_arglist *formal;
 614   gfc_interface *intr;
 615
 616   if (sym == NULL)
 617     return;
 618
 619   show_indent ();
 620
 621   gfc_status ("symbol %s ", sym->name);
 622   gfc_show_typespec (&sym->ts);
 623   gfc_show_attr (&sym->attr);
 624
 625   if (sym->value)
 626     {
 627       show_indent ();
 628       gfc_status ("value: ");
 629       gfc_show_expr (sym->value);
 630     }
 631
 632   if (sym->as)
 633     {
 634       show_indent ();
 635       gfc_status ("Array spec:");
 636       gfc_show_array_spec (sym->as);
 637     }
 638
 639   if (sym->generic)
 640     {
 641       show_indent ();
 642       gfc_status ("Generic interfaces:");
 643       for (intr = sym->generic; intr; intr = intr->next)
 644         gfc_status (" %s", intr->sym->name);
 645     }
 646
 647   if (sym->result)
 648     {
 649       show_indent ();
 650       gfc_status ("result: %s", sym->result->name);
 651     }
 652
 653   if (sym->components)
 654     {
 655       show_indent ();
 656       gfc_status ("components: ");
 657       gfc_show_components (sym);
 658     }
 659
 660   if (sym->formal)
 661     {
 662       show_indent ();
 663       gfc_status ("Formal arglist:");
 664
 665       for (formal = sym->formal; formal; formal = formal->next)
 666         gfc_status (" %s", formal->sym->name);
 667     }
 668
 669   if (sym->formal_ns)
 670     {
 671       show_indent ();
 672       gfc_status ("Formal namespace");
 673       gfc_show_namespace (sym->formal_ns);
 674     }
 675
 676   gfc_status_char ('\n');
 677 }
 678
 679
 680 /* Show a user-defined operator.  Just prints an operator
 681    and the name of the associated subroutine, really.  */
 682 static void
 683 show_uop (gfc_user_op * uop)
 684 {
 685   gfc_interface *intr;
 686
 687   show_indent ();
 688   gfc_status ("%s:", uop->name);
 689
 690   for (intr = uop->operator; intr; intr = intr->next)
 691     gfc_status (" %s", intr->sym->name);
 692 }
 693
 694
 695 /* Workhorse function for traversing the user operator symtree.  */
 696
 697 static void
 698 traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
 699 {
 700
 701   if (st == NULL)
 702     return;
 703
 704   (*func) (st->n.uop);
 705
 706   traverse_uop (st->left, func);
 707   traverse_uop (st->right, func);
 708 }
 709
 710
 711 /* Traverse the tree of user operator nodes.  */
 712
 713 void
 714 gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
 715 {
 716
 717   traverse_uop (ns->uop_root, func);
 718 }
 719
 720
 721 /* Function to display a common block.  */
 722
 723 static void
 724 show_common (gfc_symtree * st)
 725 {
 726   gfc_symbol *s;
 727
 728   show_indent ();
 729   gfc_status ("common: /%s/ ", st->name);
 730
 731   s = st->n.common->head;
 732   while (s)
 733     {
 734       gfc_status ("%s", s->name);
 735       s = s->common_next;
 736       if (s)
 737         gfc_status (", ");
 738     }
 739   gfc_status_char ('\n');
 740 }
 741
 742 /* Worker function to display the symbol tree.  */
 743
 744 static void
 745 show_symtree (gfc_symtree * st)
 746 {
 747
 748   show_indent ();
 749   gfc_status ("symtree: %s  Ambig %d", st->name, st->ambiguous);
 750
 751   if (st->n.sym->ns != gfc_current_ns)
 752     gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
 753   else
 754     gfc_show_symbol (st->n.sym);
 755 }
 756
 757
 758 /******************* Show gfc_code structures **************/
 759
 760
 761
 762 static void gfc_show_code_node (int level, gfc_code * c);
 763
 764 /* Show a list of code structures.  Mutually recursive with
 765    gfc_show_code_node().  */
 766
 767 static void
 768 gfc_show_code (int level, gfc_code * c)
 769 {
 770
 771   for (; c; c = c->next)
 772     gfc_show_code_node (level, c);
 773 }
 774
 775
 776 /* Show a single code node and everything underneath it if necessary.  */
 777
 778 static void
 779 gfc_show_code_node (int level, gfc_code * c)
 780 {
 781   gfc_forall_iterator *fa;
 782   gfc_open *open;
 783   gfc_case *cp;
 784   gfc_alloc *a;
 785   gfc_code *d;
 786   gfc_close *close;
 787   gfc_filepos *fp;
 788   gfc_inquire *i;
 789   gfc_dt *dt;
 790
 791   code_indent (level, c->here);
 792
 793   switch (c->op)
 794     {
 795     case EXEC_NOP:
 796       gfc_status ("NOP");
 797       break;
 798
 799     case EXEC_CONTINUE:
 800       gfc_status ("CONTINUE");
 801       break;
 802
 803     case EXEC_ENTRY:
 804       gfc_status ("ENTRY %s", c->ext.entry->sym->name);
 805       break;
 806
 807     case EXEC_ASSIGN:
 808       gfc_status ("ASSIGN ");
 809       gfc_show_expr (c->expr);
 810       gfc_status_char (' ');
 811       gfc_show_expr (c->expr2);
 812       break;
 813
 814     case EXEC_LABEL_ASSIGN:
 815       gfc_status ("LABEL ASSIGN ");
 816       gfc_show_expr (c->expr);
 817       gfc_status (" %d", c->label->value);
 818       break;
 819
 820     case EXEC_POINTER_ASSIGN:
 821       gfc_status ("POINTER ASSIGN ");
 822       gfc_show_expr (c->expr);
 823       gfc_status_char (' ');
 824       gfc_show_expr (c->expr2);
 825       break;
 826
 827     case EXEC_GOTO:
 828       gfc_status ("GOTO ");
 829       if (c->label)
 830         gfc_status ("%d", c->label->value);
 831       else
 832         {
 833           gfc_show_expr (c->expr);
 834           d = c->block;
 835           if (d != NULL)
 836             {
 837               gfc_status (", (");
 838               for (; d; d = d ->block)
 839                 {
 840                   code_indent (level, d->label);
 841                   if (d->block != NULL)
 842                     gfc_status_char (',');
 843                   else
 844                     gfc_status_char (')');
 845                 }
 846             }
 847         }
 848       break;
 849
 850     case EXEC_CALL:
 851       gfc_status ("CALL %s ", c->resolved_sym->name);
 852       gfc_show_actual_arglist (c->ext.actual);
 853       break;
 854
 855     case EXEC_RETURN:
 856       gfc_status ("RETURN ");
 857       if (c->expr)
 858         gfc_show_expr (c->expr);
 859       break;
 860
 861     case EXEC_PAUSE:
 862       gfc_status ("PAUSE ");
 863
 864       if (c->expr != NULL)
 865         gfc_show_expr (c->expr);
 866       else
 867         gfc_status ("%d", c->ext.stop_code);
 868
 869       break;
 870
 871     case EXEC_STOP:
 872       gfc_status ("STOP ");
 873
 874       if (c->expr != NULL)
 875         gfc_show_expr (c->expr);
 876       else
 877         gfc_status ("%d", c->ext.stop_code);
 878
 879       break;
 880
 881     case EXEC_ARITHMETIC_IF:
 882       gfc_status ("IF ");
 883       gfc_show_expr (c->expr);
 884       gfc_status (" %d, %d, %d",
 885                   c->label->value, c->label2->value, c->label3->value);
 886       break;
 887
 888     case EXEC_IF:
 889       d = c->block;
 890       gfc_status ("IF ");
 891       gfc_show_expr (d->expr);
 892       gfc_status_char ('\n');
 893       gfc_show_code (level + 1, d->next);
 894
 895       d = d->block;
 896       for (; d; d = d->block)
 897         {
 898           code_indent (level, 0);
 899
 900           if (d->expr == NULL)
 901             gfc_status ("ELSE\n");
 902           else
 903             {
 904               gfc_status ("ELSE IF ");
 905               gfc_show_expr (d->expr);
 906               gfc_status_char ('\n');
 907             }
 908
 909           gfc_show_code (level + 1, d->next);
 910         }
 911
 912       code_indent (level, c->label);
 913
 914       gfc_status ("ENDIF");
 915       break;
 916
 917     case EXEC_SELECT:
 918       d = c->block;
 919       gfc_status ("SELECT CASE ");
 920       gfc_show_expr (c->expr);
 921       gfc_status_char ('\n');
 922
 923       for (; d; d = d->block)
 924         {
 925           code_indent (level, 0);
 926
 927           gfc_status ("CASE ");
 928           for (cp = d->ext.case_list; cp; cp = cp->next)
 929             {
 930               gfc_status_char ('(');
 931               gfc_show_expr (cp->low);
 932               gfc_status_char (' ');
 933               gfc_show_expr (cp->high);
 934               gfc_status_char (')');
 935               gfc_status_char (' ');
 936             }
 937           gfc_status_char ('\n');
 938
 939           gfc_show_code (level + 1, d->next);
 940         }
 941
 942       code_indent (level, c->label);
 943       gfc_status ("END SELECT");
 944       break;
 945
 946     case EXEC_WHERE:
 947       gfc_status ("WHERE ");
 948
 949       d = c->block;
 950       gfc_show_expr (d->expr);
 951       gfc_status_char ('\n');
 952
 953       gfc_show_code (level + 1, d->next);
 954
 955       for (d = d->block; d; d = d->block)
 956         {
 957           code_indent (level, 0);
 958           gfc_status ("ELSE WHERE ");
 959           gfc_show_expr (d->expr);
 960           gfc_status_char ('\n');
 961           gfc_show_code (level + 1, d->next);
 962         }
 963
 964       code_indent (level, 0);
 965       gfc_status ("END WHERE");
 966       break;
 967
 968
 969     case EXEC_FORALL:
 970       gfc_status ("FORALL ");
 971       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
 972         {
 973           gfc_show_expr (fa->var);
 974           gfc_status_char (' ');
 975           gfc_show_expr (fa->start);
 976           gfc_status_char (':');
 977           gfc_show_expr (fa->end);
 978           gfc_status_char (':');
 979           gfc_show_expr (fa->stride);
 980
 981           if (fa->next != NULL)
 982             gfc_status_char (',');
 983         }
 984
 985       if (c->expr != NULL)
 986         {
 987           gfc_status_char (',');
 988           gfc_show_expr (c->expr);
 989         }
 990       gfc_status_char ('\n');
 991
 992       gfc_show_code (level + 1, c->block->next);
 993
 994       code_indent (level, 0);
 995       gfc_status ("END FORALL");
 996       break;
 997
 998     case EXEC_DO:
 999       gfc_status ("DO ");
1000
1001       gfc_show_expr (c->ext.iterator->var);
1002       gfc_status_char ('=');
1003       gfc_show_expr (c->ext.iterator->start);
1004       gfc_status_char (' ');
1005       gfc_show_expr (c->ext.iterator->end);
1006       gfc_status_char (' ');
1007       gfc_show_expr (c->ext.iterator->step);
1008       gfc_status_char ('\n');
1009
1010       gfc_show_code (level + 1, c->block->next);
1011
1012       code_indent (level, 0);
1013       gfc_status ("END DO");
1014       break;
1015
1016     case EXEC_DO_WHILE:
1017       gfc_status ("DO WHILE ");
1018       gfc_show_expr (c->expr);
1019       gfc_status_char ('\n');
1020
1021       gfc_show_code (level + 1, c->block->next);
1022
1023       code_indent (level, c->label);
1024       gfc_status ("END DO");
1025       break;
1026
1027     case EXEC_CYCLE:
1028       gfc_status ("CYCLE");
1029       if (c->symtree)
1030         gfc_status (" %s", c->symtree->n.sym->name);
1031       break;
1032
1033     case EXEC_EXIT:
1034       gfc_status ("EXIT");
1035       if (c->symtree)
1036         gfc_status (" %s", c->symtree->n.sym->name);
1037       break;
1038
1039     case EXEC_ALLOCATE:
1040       gfc_status ("ALLOCATE ");
1041       if (c->expr)
1042         {
1043           gfc_status (" STAT=");
1044           gfc_show_expr (c->expr);
1045         }
1046
1047       for (a = c->ext.alloc_list; a; a = a->next)
1048         {
1049           gfc_status_char (' ');
1050           gfc_show_expr (a->expr);
1051         }
1052
1053       break;
1054
1055     case EXEC_DEALLOCATE:
1056       gfc_status ("DEALLOCATE ");
1057       if (c->expr)
1058         {
1059           gfc_status (" STAT=");
1060           gfc_show_expr (c->expr);
1061         }
1062
1063       for (a = c->ext.alloc_list; a; a = a->next)
1064         {
1065           gfc_status_char (' ');
1066           gfc_show_expr (a->expr);
1067         }
1068
1069       break;
1070
1071     case EXEC_OPEN:
1072       gfc_status ("OPEN");
1073       open = c->ext.open;
1074
1075       if (open->unit)
1076         {
1077           gfc_status (" UNIT=");
1078           gfc_show_expr (open->unit);
1079         }
1080       if (open->iostat)
1081         {
1082           gfc_status (" IOSTAT=");
1083           gfc_show_expr (open->iostat);
1084         }
1085       if (open->file)
1086         {
1087           gfc_status (" FILE=");
1088           gfc_show_expr (open->file);
1089         }
1090       if (open->status)
1091         {
1092           gfc_status (" STATUS=");
1093           gfc_show_expr (open->status);
1094         }
1095       if (open->access)
1096         {
1097           gfc_status (" ACCESS=");
1098           gfc_show_expr (open->access);
1099         }
1100       if (open->form)
1101         {
1102           gfc_status (" FORM=");
1103           gfc_show_expr (open->form);
1104         }
1105       if (open->recl)
1106         {
1107           gfc_status (" RECL=");
1108           gfc_show_expr (open->recl);
1109         }
1110       if (open->blank)
1111         {
1112           gfc_status (" BLANK=");
1113           gfc_show_expr (open->blank);
1114         }
1115       if (open->position)
1116         {
1117           gfc_status (" POSITION=");
1118           gfc_show_expr (open->position);
1119         }
1120       if (open->action)
1121         {
1122           gfc_status (" ACTION=");
1123           gfc_show_expr (open->action);
1124         }
1125       if (open->delim)
1126         {
1127           gfc_status (" DELIM=");
1128           gfc_show_expr (open->delim);
1129         }
1130       if (open->pad)
1131         {
1132           gfc_status (" PAD=");
1133           gfc_show_expr (open->pad);
1134         }
1135       if (open->err != NULL)
1136         gfc_status (" ERR=%d", open->err->value);
1137
1138       break;
1139
1140     case EXEC_CLOSE:
1141       gfc_status ("CLOSE");
1142       close = c->ext.close;
1143
1144       if (close->unit)
1145         {
1146           gfc_status (" UNIT=");
1147           gfc_show_expr (close->unit);
1148         }
1149       if (close->iostat)
1150         {
1151           gfc_status (" IOSTAT=");
1152           gfc_show_expr (close->iostat);
1153         }
1154       if (close->status)
1155         {
1156           gfc_status (" STATUS=");
1157           gfc_show_expr (close->status);
1158         }
1159       if (close->err != NULL)
1160         gfc_status (" ERR=%d", close->err->value);
1161       break;
1162
1163     case EXEC_BACKSPACE:
1164       gfc_status ("BACKSPACE");
1165       goto show_filepos;
1166
1167     case EXEC_ENDFILE:
1168       gfc_status ("ENDFILE");
1169       goto show_filepos;
1170
1171     case EXEC_REWIND:
1172       gfc_status ("REWIND");
1173
1174     show_filepos:
1175       fp = c->ext.filepos;
1176
1177       if (fp->unit)
1178         {
1179           gfc_status (" UNIT=");
1180           gfc_show_expr (fp->unit);
1181         }
1182       if (fp->iostat)
1183         {
1184           gfc_status (" IOSTAT=");
1185           gfc_show_expr (fp->iostat);
1186         }
1187       if (fp->err != NULL)
1188         gfc_status (" ERR=%d", fp->err->value);
1189       break;
1190
1191     case EXEC_INQUIRE:
1192       gfc_status ("INQUIRE");
1193       i = c->ext.inquire;
1194
1195       if (i->unit)
1196         {
1197           gfc_status (" UNIT=");
1198           gfc_show_expr (i->unit);
1199         }
1200       if (i->file)
1201         {
1202           gfc_status (" FILE=");
1203           gfc_show_expr (i->file);
1204         }
1205
1206       if (i->iostat)
1207         {
1208           gfc_status (" IOSTAT=");
1209           gfc_show_expr (i->iostat);
1210         }
1211       if (i->exist)
1212         {
1213           gfc_status (" EXIST=");
1214           gfc_show_expr (i->exist);
1215         }
1216       if (i->opened)
1217         {
1218           gfc_status (" OPENED=");
1219           gfc_show_expr (i->opened);
1220         }
1221       if (i->number)
1222         {
1223           gfc_status (" NUMBER=");
1224           gfc_show_expr (i->number);
1225         }
1226       if (i->named)
1227         {
1228           gfc_status (" NAMED=");
1229           gfc_show_expr (i->named);
1230         }
1231       if (i->name)
1232         {
1233           gfc_status (" NAME=");
1234           gfc_show_expr (i->name);
1235         }
1236       if (i->access)
1237         {
1238           gfc_status (" ACCESS=");
1239           gfc_show_expr (i->access);
1240         }
1241       if (i->sequential)
1242         {
1243           gfc_status (" SEQUENTIAL=");
1244           gfc_show_expr (i->sequential);
1245         }
1246
1247       if (i->direct)
1248         {
1249           gfc_status (" DIRECT=");
1250           gfc_show_expr (i->direct);
1251         }
1252       if (i->form)
1253         {
1254           gfc_status (" FORM=");
1255           gfc_show_expr (i->form);
1256         }
1257       if (i->formatted)
1258         {
1259           gfc_status (" FORMATTED");
1260           gfc_show_expr (i->formatted);
1261         }
1262       if (i->unformatted)
1263         {
1264           gfc_status (" UNFORMATTED=");
1265           gfc_show_expr (i->unformatted);
1266         }
1267       if (i->recl)
1268         {
1269           gfc_status (" RECL=");
1270           gfc_show_expr (i->recl);
1271         }
1272       if (i->nextrec)
1273         {
1274           gfc_status (" NEXTREC=");
1275           gfc_show_expr (i->nextrec);
1276         }
1277       if (i->blank)
1278         {
1279           gfc_status (" BLANK=");
1280           gfc_show_expr (i->blank);
1281         }
1282       if (i->position)
1283         {
1284           gfc_status (" POSITION=");
1285           gfc_show_expr (i->position);
1286         }
1287       if (i->action)
1288         {
1289           gfc_status (" ACTION=");
1290           gfc_show_expr (i->action);
1291         }
1292       if (i->read)
1293         {
1294           gfc_status (" READ=");
1295           gfc_show_expr (i->read);
1296         }
1297       if (i->write)
1298         {
1299           gfc_status (" WRITE=");
1300           gfc_show_expr (i->write);
1301         }
1302       if (i->readwrite)
1303         {
1304           gfc_status (" READWRITE=");
1305           gfc_show_expr (i->readwrite);
1306         }
1307       if (i->delim)
1308         {
1309           gfc_status (" DELIM=");
1310           gfc_show_expr (i->delim);
1311         }
1312       if (i->pad)
1313         {
1314           gfc_status (" PAD=");
1315           gfc_show_expr (i->pad);
1316         }
1317
1318       if (i->err != NULL)
1319         gfc_status (" ERR=%d", i->err->value);
1320       break;
1321
1322     case EXEC_IOLENGTH:
1323       gfc_status ("IOLENGTH ");
1324       gfc_show_expr (c->expr);
1325       break;
1326
1327     case EXEC_READ:
1328       gfc_status ("READ");
1329       goto show_dt;
1330
1331     case EXEC_WRITE:
1332       gfc_status ("WRITE");
1333
1334     show_dt:
1335       dt = c->ext.dt;
1336       if (dt->io_unit)
1337         {
1338           gfc_status (" UNIT=");
1339           gfc_show_expr (dt->io_unit);
1340         }
1341
1342       if (dt->format_expr)
1343         {
1344           gfc_status (" FMT=");
1345           gfc_show_expr (dt->format_expr);
1346         }
1347
1348       if (dt->format_label != NULL)
1349         gfc_status (" FMT=%d", dt->format_label->value);
1350       if (dt->namelist)
1351         gfc_status (" NML=%s", dt->namelist->name);
1352       if (dt->iostat)
1353         {
1354           gfc_status (" IOSTAT=");
1355           gfc_show_expr (dt->iostat);
1356         }
1357       if (dt->size)
1358         {
1359           gfc_status (" SIZE=");
1360           gfc_show_expr (dt->size);
1361         }
1362       if (dt->rec)
1363         {
1364           gfc_status (" REC=");
1365           gfc_show_expr (dt->rec);
1366         }
1367       if (dt->advance)
1368         {
1369           gfc_status (" ADVANCE=");
1370           gfc_show_expr (dt->advance);
1371         }
1372
1373       break;
1374
1375     case EXEC_TRANSFER:
1376       gfc_status ("TRANSFER ");
1377       gfc_show_expr (c->expr);
1378       break;
1379
1380     case EXEC_DT_END:
1381       gfc_status ("DT_END");
1382       dt = c->ext.dt;
1383
1384       if (dt->err != NULL)
1385         gfc_status (" ERR=%d", dt->err->value);
1386       if (dt->end != NULL)
1387         gfc_status (" END=%d", dt->end->value);
1388       if (dt->eor != NULL)
1389         gfc_status (" EOR=%d", dt->eor->value);
1390       break;
1391
1392     default:
1393       gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1394     }
1395
1396   gfc_status_char ('\n');
1397 }
1398
1399
1400 /* Show and equivalence chain.  */
1401
1402 static void
1403 gfc_show_equiv (gfc_equiv *eq)
1404 {
1405   show_indent ();
1406   gfc_status ("Equivalence: ");
1407   while (eq)
1408     {
1409       gfc_show_expr (eq->expr);
1410       eq = eq->eq;
1411       if (eq)
1412         gfc_status (", ");
1413     }
1414 }
1415
1416
1417 /* Show a freakin' whole namespace.  */
1418
1419 void
1420 gfc_show_namespace (gfc_namespace * ns)
1421 {
1422   gfc_interface *intr;
1423   gfc_namespace *save;
1424   gfc_intrinsic_op op;
1425   gfc_equiv *eq;
1426   int i;
1427
1428   save = gfc_current_ns;
1429   show_level++;
1430
1431   show_indent ();
1432   gfc_status ("Namespace:");
1433
1434   if (ns != NULL)
1435     {
1436       i = 0;
1437       do
1438         {
1439           int l = i;
1440           while (i < GFC_LETTERS - 1
1441                  && gfc_compare_types(&ns->default_type[i+1],
1442                                       &ns->default_type[l]))
1443             i++;
1444
1445           if (i > l)
1446             gfc_status(" %c-%c: ", l+'A', i+'A');
1447           else
1448             gfc_status(" %c: ", l+'A');
1449
1450           gfc_show_typespec(&ns->default_type[l]);
1451           i++;
1452       } while (i < GFC_LETTERS);
1453
1454       if (ns->proc_name != NULL)
1455         {
1456           show_indent ();
1457           gfc_status ("procedure name = %s", ns->proc_name->name);
1458         }
1459
1460       gfc_current_ns = ns;
1461       gfc_traverse_symtree (ns->common_root, show_common);
1462
1463       gfc_traverse_symtree (ns->sym_root, show_symtree);
1464
1465       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1466         {
1467           /* User operator interfaces */
1468           intr = ns->operator[op];
1469           if (intr == NULL)
1470             continue;
1471
1472           show_indent ();
1473           gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
1474
1475           for (; intr; intr = intr->next)
1476             gfc_status (" %s", intr->sym->name);
1477         }
1478
1479       if (ns->uop_root != NULL)
1480         {
1481           show_indent ();
1482           gfc_status ("User operators:\n");
1483           gfc_traverse_user_op (ns, show_uop);
1484         }
1485     }
1486
1487   for (eq = ns->equiv; eq; eq = eq->next)
1488     gfc_show_equiv (eq);
1489
1490   gfc_status_char ('\n');
1491   gfc_status_char ('\n');
1492
1493   gfc_show_code (0, ns->code);
1494
1495   for (ns = ns->contained; ns; ns = ns->sibling)
1496     {
1497       show_indent ();
1498       gfc_status ("CONTAINS\n");
1499       gfc_show_namespace (ns);
1500     }
1501
1502   show_level--;
1503   gfc_status_char ('\n');
1504   gfc_current_ns = save;
1505 }