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[0] != '\0')
 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           mpf_out_str (stdout, 10, 0, p->value.real);
 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           mpf_out_str (stdout, 10, 0, p->value.complex.r);
 392           if (p->ts.kind != gfc_default_complex_kind ())
 393             gfc_status ("_%d", p->ts.kind);
 394
 395           gfc_status (" ");
 396
 397           mpf_out_str (stdout, 10, 0, p->value.complex.i);
 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->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->op1);
 484
 485       if (p->op2)
 486         {
 487           gfc_status (" ");
 488           gfc_show_expr (p->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_ASSIGN:
 804       gfc_status ("ASSIGN ");
 805       gfc_show_expr (c->expr);
 806       gfc_status_char (' ');
 807       gfc_show_expr (c->expr2);
 808       break;
 809     case EXEC_LABEL_ASSIGN:
 810       gfc_status ("LABEL ASSIGN ");
 811       gfc_show_expr (c->expr);
 812       gfc_status (" %d", c->label->value);
 813       break;
 814
 815     case EXEC_POINTER_ASSIGN:
 816       gfc_status ("POINTER ASSIGN ");
 817       gfc_show_expr (c->expr);
 818       gfc_status_char (' ');
 819       gfc_show_expr (c->expr2);
 820       break;
 821
 822     case EXEC_GOTO:
 823       gfc_status ("GOTO ");
 824       if (c->label)
 825         gfc_status ("%d", c->label->value);
 826       else
 827         {
 828           gfc_show_expr (c->expr);
 829           d = c->block;
 830           if (d != NULL)
 831             {
 832               gfc_status (", (");
 833               for (; d; d = d ->block)
 834                 {
 835                   code_indent (level, d->label);
 836                   if (d->block != NULL)
 837                     gfc_status_char (',');
 838                   else
 839                     gfc_status_char (')');
 840                 }
 841             }
 842         }
 843       break;
 844
 845     case EXEC_CALL:
 846       gfc_status ("CALL %s ", c->resolved_sym->name);
 847       gfc_show_actual_arglist (c->ext.actual);
 848       break;
 849
 850     case EXEC_RETURN:
 851       gfc_status ("RETURN ");
 852       if (c->expr)
 853         gfc_show_expr (c->expr);
 854       break;
 855
 856     case EXEC_PAUSE:
 857       gfc_status ("PAUSE ");
 858
 859       if (c->expr != NULL)
 860         gfc_show_expr (c->expr);
 861       else
 862         gfc_status ("%d", c->ext.stop_code);
 863
 864       break;
 865
 866     case EXEC_STOP:
 867       gfc_status ("STOP ");
 868
 869       if (c->expr != NULL)
 870         gfc_show_expr (c->expr);
 871       else
 872         gfc_status ("%d", c->ext.stop_code);
 873
 874       break;
 875
 876     case EXEC_ARITHMETIC_IF:
 877       gfc_status ("IF ");
 878       gfc_show_expr (c->expr);
 879       gfc_status (" %d, %d, %d",
 880                   c->label->value, c->label2->value, c->label3->value);
 881       break;
 882
 883     case EXEC_IF:
 884       d = c->block;
 885       gfc_status ("IF ");
 886       gfc_show_expr (d->expr);
 887       gfc_status_char ('\n');
 888       gfc_show_code (level + 1, d->next);
 889
 890       d = d->block;
 891       for (; d; d = d->block)
 892         {
 893           code_indent (level, 0);
 894
 895           if (d->expr == NULL)
 896             gfc_status ("ELSE\n");
 897           else
 898             {
 899               gfc_status ("ELSE IF ");
 900               gfc_show_expr (d->expr);
 901               gfc_status_char ('\n');
 902             }
 903
 904           gfc_show_code (level + 1, d->next);
 905         }
 906
 907       code_indent (level, c->label);
 908
 909       gfc_status ("ENDIF");
 910       break;
 911
 912     case EXEC_SELECT:
 913       d = c->block;
 914       gfc_status ("SELECT CASE ");
 915       gfc_show_expr (c->expr);
 916       gfc_status_char ('\n');
 917
 918       for (; d; d = d->block)
 919         {
 920           code_indent (level, 0);
 921
 922           gfc_status ("CASE ");
 923           for (cp = d->ext.case_list; cp; cp = cp->next)
 924             {
 925               gfc_status_char ('(');
 926               gfc_show_expr (cp->low);
 927               gfc_status_char (' ');
 928               gfc_show_expr (cp->high);
 929               gfc_status_char (')');
 930               gfc_status_char (' ');
 931             }
 932           gfc_status_char ('\n');
 933
 934           gfc_show_code (level + 1, d->next);
 935         }
 936
 937       code_indent (level, c->label);
 938       gfc_status ("END SELECT");
 939       break;
 940
 941     case EXEC_WHERE:
 942       gfc_status ("WHERE ");
 943
 944       d = c->block;
 945       gfc_show_expr (d->expr);
 946       gfc_status_char ('\n');
 947
 948       gfc_show_code (level + 1, d->next);
 949
 950       for (d = d->block; d; d = d->block)
 951         {
 952           code_indent (level, 0);
 953           gfc_status ("ELSE WHERE ");
 954           gfc_show_expr (d->expr);
 955           gfc_status_char ('\n');
 956           gfc_show_code (level + 1, d->next);
 957         }
 958
 959       code_indent (level, 0);
 960       gfc_status ("END WHERE");
 961       break;
 962
 963
 964     case EXEC_FORALL:
 965       gfc_status ("FORALL ");
 966       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
 967         {
 968           gfc_show_expr (fa->var);
 969           gfc_status_char (' ');
 970           gfc_show_expr (fa->start);
 971           gfc_status_char (':');
 972           gfc_show_expr (fa->end);
 973           gfc_status_char (':');
 974           gfc_show_expr (fa->stride);
 975
 976           if (fa->next != NULL)
 977             gfc_status_char (',');
 978         }
 979
 980       if (c->expr != NULL)
 981         {
 982           gfc_status_char (',');
 983           gfc_show_expr (c->expr);
 984         }
 985       gfc_status_char ('\n');
 986
 987       gfc_show_code (level + 1, c->block->next);
 988
 989       code_indent (level, 0);
 990       gfc_status ("END FORALL");
 991       break;
 992
 993     case EXEC_DO:
 994       gfc_status ("DO ");
 995
 996       gfc_show_expr (c->ext.iterator->var);
 997       gfc_status_char ('=');
 998       gfc_show_expr (c->ext.iterator->start);
 999       gfc_status_char (' ');
1000       gfc_show_expr (c->ext.iterator->end);
1001       gfc_status_char (' ');
1002       gfc_show_expr (c->ext.iterator->step);
1003       gfc_status_char ('\n');
1004
1005       gfc_show_code (level + 1, c->block->next);
1006
1007       code_indent (level, 0);
1008       gfc_status ("END DO");
1009       break;
1010
1011     case EXEC_DO_WHILE:
1012       gfc_status ("DO WHILE ");
1013       gfc_show_expr (c->expr);
1014       gfc_status_char ('\n');
1015
1016       gfc_show_code (level + 1, c->block->next);
1017
1018       code_indent (level, c->label);
1019       gfc_status ("END DO");
1020       break;
1021
1022     case EXEC_CYCLE:
1023       gfc_status ("CYCLE");
1024       if (c->symtree)
1025         gfc_status (" %s", c->symtree->n.sym->name);
1026       break;
1027
1028     case EXEC_EXIT:
1029       gfc_status ("EXIT");
1030       if (c->symtree)
1031         gfc_status (" %s", c->symtree->n.sym->name);
1032       break;
1033
1034     case EXEC_ALLOCATE:
1035       gfc_status ("ALLOCATE ");
1036       if (c->expr)
1037         {
1038           gfc_status (" STAT=");
1039           gfc_show_expr (c->expr);
1040         }
1041
1042       for (a = c->ext.alloc_list; a; a = a->next)
1043         {
1044           gfc_status_char (' ');
1045           gfc_show_expr (a->expr);
1046         }
1047
1048       break;
1049
1050     case EXEC_DEALLOCATE:
1051       gfc_status ("DEALLOCATE ");
1052       if (c->expr)
1053         {
1054           gfc_status (" STAT=");
1055           gfc_show_expr (c->expr);
1056         }
1057
1058       for (a = c->ext.alloc_list; a; a = a->next)
1059         {
1060           gfc_status_char (' ');
1061           gfc_show_expr (a->expr);
1062         }
1063
1064       break;
1065
1066     case EXEC_OPEN:
1067       gfc_status ("OPEN");
1068       open = c->ext.open;
1069
1070       if (open->unit)
1071         {
1072           gfc_status (" UNIT=");
1073           gfc_show_expr (open->unit);
1074         }
1075       if (open->iostat)
1076         {
1077           gfc_status (" IOSTAT=");
1078           gfc_show_expr (open->iostat);
1079         }
1080       if (open->file)
1081         {
1082           gfc_status (" FILE=");
1083           gfc_show_expr (open->file);
1084         }
1085       if (open->status)
1086         {
1087           gfc_status (" STATUS=");
1088           gfc_show_expr (open->status);
1089         }
1090       if (open->access)
1091         {
1092           gfc_status (" ACCESS=");
1093           gfc_show_expr (open->access);
1094         }
1095       if (open->form)
1096         {
1097           gfc_status (" FORM=");
1098           gfc_show_expr (open->form);
1099         }
1100       if (open->recl)
1101         {
1102           gfc_status (" RECL=");
1103           gfc_show_expr (open->recl);
1104         }
1105       if (open->blank)
1106         {
1107           gfc_status (" BLANK=");
1108           gfc_show_expr (open->blank);
1109         }
1110       if (open->position)
1111         {
1112           gfc_status (" POSITION=");
1113           gfc_show_expr (open->position);
1114         }
1115       if (open->action)
1116         {
1117           gfc_status (" ACTION=");
1118           gfc_show_expr (open->action);
1119         }
1120       if (open->delim)
1121         {
1122           gfc_status (" DELIM=");
1123           gfc_show_expr (open->delim);
1124         }
1125       if (open->pad)
1126         {
1127           gfc_status (" PAD=");
1128           gfc_show_expr (open->pad);
1129         }
1130       if (open->err != NULL)
1131         gfc_status (" ERR=%d", open->err->value);
1132
1133       break;
1134
1135     case EXEC_CLOSE:
1136       gfc_status ("CLOSE");
1137       close = c->ext.close;
1138
1139       if (close->unit)
1140         {
1141           gfc_status (" UNIT=");
1142           gfc_show_expr (close->unit);
1143         }
1144       if (close->iostat)
1145         {
1146           gfc_status (" IOSTAT=");
1147           gfc_show_expr (close->iostat);
1148         }
1149       if (close->status)
1150         {
1151           gfc_status (" STATUS=");
1152           gfc_show_expr (close->status);
1153         }
1154       if (close->err != NULL)
1155         gfc_status (" ERR=%d", close->err->value);
1156       break;
1157
1158     case EXEC_BACKSPACE:
1159       gfc_status ("BACKSPACE");
1160       goto show_filepos;
1161
1162     case EXEC_ENDFILE:
1163       gfc_status ("ENDFILE");
1164       goto show_filepos;
1165
1166     case EXEC_REWIND:
1167       gfc_status ("REWIND");
1168
1169     show_filepos:
1170       fp = c->ext.filepos;
1171
1172       if (fp->unit)
1173         {
1174           gfc_status (" UNIT=");
1175           gfc_show_expr (fp->unit);
1176         }
1177       if (fp->iostat)
1178         {
1179           gfc_status (" IOSTAT=");
1180           gfc_show_expr (fp->iostat);
1181         }
1182       if (fp->err != NULL)
1183         gfc_status (" ERR=%d", fp->err->value);
1184       break;
1185
1186     case EXEC_INQUIRE:
1187       gfc_status ("INQUIRE");
1188       i = c->ext.inquire;
1189
1190       if (i->unit)
1191         {
1192           gfc_status (" UNIT=");
1193           gfc_show_expr (i->unit);
1194         }
1195       if (i->file)
1196         {
1197           gfc_status (" FILE=");
1198           gfc_show_expr (i->file);
1199         }
1200
1201       if (i->iostat)
1202         {
1203           gfc_status (" IOSTAT=");
1204           gfc_show_expr (i->iostat);
1205         }
1206       if (i->exist)
1207         {
1208           gfc_status (" EXIST=");
1209           gfc_show_expr (i->exist);
1210         }
1211       if (i->opened)
1212         {
1213           gfc_status (" OPENED=");
1214           gfc_show_expr (i->opened);
1215         }
1216       if (i->number)
1217         {
1218           gfc_status (" NUMBER=");
1219           gfc_show_expr (i->number);
1220         }
1221       if (i->named)
1222         {
1223           gfc_status (" NAMED=");
1224           gfc_show_expr (i->named);
1225         }
1226       if (i->name)
1227         {
1228           gfc_status (" NAME=");
1229           gfc_show_expr (i->name);
1230         }
1231       if (i->access)
1232         {
1233           gfc_status (" ACCESS=");
1234           gfc_show_expr (i->access);
1235         }
1236       if (i->sequential)
1237         {
1238           gfc_status (" SEQUENTIAL=");
1239           gfc_show_expr (i->sequential);
1240         }
1241
1242       if (i->direct)
1243         {
1244           gfc_status (" DIRECT=");
1245           gfc_show_expr (i->direct);
1246         }
1247       if (i->form)
1248         {
1249           gfc_status (" FORM=");
1250           gfc_show_expr (i->form);
1251         }
1252       if (i->formatted)
1253         {
1254           gfc_status (" FORMATTED");
1255           gfc_show_expr (i->formatted);
1256         }
1257       if (i->unformatted)
1258         {
1259           gfc_status (" UNFORMATTED=");
1260           gfc_show_expr (i->unformatted);
1261         }
1262       if (i->recl)
1263         {
1264           gfc_status (" RECL=");
1265           gfc_show_expr (i->recl);
1266         }
1267       if (i->nextrec)
1268         {
1269           gfc_status (" NEXTREC=");
1270           gfc_show_expr (i->nextrec);
1271         }
1272       if (i->blank)
1273         {
1274           gfc_status (" BLANK=");
1275           gfc_show_expr (i->blank);
1276         }
1277       if (i->position)
1278         {
1279           gfc_status (" POSITION=");
1280           gfc_show_expr (i->position);
1281         }
1282       if (i->action)
1283         {
1284           gfc_status (" ACTION=");
1285           gfc_show_expr (i->action);
1286         }
1287       if (i->read)
1288         {
1289           gfc_status (" READ=");
1290           gfc_show_expr (i->read);
1291         }
1292       if (i->write)
1293         {
1294           gfc_status (" WRITE=");
1295           gfc_show_expr (i->write);
1296         }
1297       if (i->readwrite)
1298         {
1299           gfc_status (" READWRITE=");
1300           gfc_show_expr (i->readwrite);
1301         }
1302       if (i->delim)
1303         {
1304           gfc_status (" DELIM=");
1305           gfc_show_expr (i->delim);
1306         }
1307       if (i->pad)
1308         {
1309           gfc_status (" PAD=");
1310           gfc_show_expr (i->pad);
1311         }
1312
1313       if (i->err != NULL)
1314         gfc_status (" ERR=%d", i->err->value);
1315       break;
1316
1317     case EXEC_IOLENGTH:
1318       gfc_status ("IOLENGTH ");
1319       gfc_show_expr (c->expr);
1320       break;
1321
1322     case EXEC_READ:
1323       gfc_status ("READ");
1324       goto show_dt;
1325
1326     case EXEC_WRITE:
1327       gfc_status ("WRITE");
1328
1329     show_dt:
1330       dt = c->ext.dt;
1331       if (dt->io_unit)
1332         {
1333           gfc_status (" UNIT=");
1334           gfc_show_expr (dt->io_unit);
1335         }
1336
1337       if (dt->format_expr)
1338         {
1339           gfc_status (" FMT=");
1340           gfc_show_expr (dt->format_expr);
1341         }
1342
1343       if (dt->format_label != NULL)
1344         gfc_status (" FMT=%d", dt->format_label->value);
1345       if (dt->namelist)
1346         gfc_status (" NML=%s", dt->namelist->name);
1347       if (dt->iostat)
1348         {
1349           gfc_status (" IOSTAT=");
1350           gfc_show_expr (dt->iostat);
1351         }
1352       if (dt->size)
1353         {
1354           gfc_status (" SIZE=");
1355           gfc_show_expr (dt->size);
1356         }
1357       if (dt->rec)
1358         {
1359           gfc_status (" REC=");
1360           gfc_show_expr (dt->rec);
1361         }
1362       if (dt->advance)
1363         {
1364           gfc_status (" ADVANCE=");
1365           gfc_show_expr (dt->advance);
1366         }
1367
1368       break;
1369
1370     case EXEC_TRANSFER:
1371       gfc_status ("TRANSFER ");
1372       gfc_show_expr (c->expr);
1373       break;
1374
1375     case EXEC_DT_END:
1376       gfc_status ("DT_END");
1377       dt = c->ext.dt;
1378
1379       if (dt->err != NULL)
1380         gfc_status (" ERR=%d", dt->err->value);
1381       if (dt->end != NULL)
1382         gfc_status (" END=%d", dt->end->value);
1383       if (dt->eor != NULL)
1384         gfc_status (" EOR=%d", dt->eor->value);
1385       break;
1386
1387     default:
1388       gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1389     }
1390
1391   gfc_status_char ('\n');
1392 }
1393
1394
1395 /* Show and equivalence chain.  */
1396
1397 static void
1398 gfc_show_equiv (gfc_equiv *eq)
1399 {
1400   show_indent ();
1401   gfc_status ("Equivalence: ");
1402   while (eq)
1403     {
1404       gfc_show_expr (eq->expr);
1405       eq = eq->eq;
1406       if (eq)
1407         gfc_status (", ");
1408     }
1409 }
1410
1411
1412 /* Show a freakin' whole namespace.  */
1413
1414 void
1415 gfc_show_namespace (gfc_namespace * ns)
1416 {
1417   gfc_interface *intr;
1418   gfc_namespace *save;
1419   gfc_intrinsic_op op;
1420   gfc_equiv *eq;
1421   int i;
1422
1423   save = gfc_current_ns;
1424   show_level++;
1425
1426   show_indent ();
1427   gfc_status ("Namespace:");
1428
1429   if (ns != NULL)
1430     {
1431       i = 0;
1432       do
1433         {
1434           int l = i;
1435           while (i < GFC_LETTERS - 1
1436                  && gfc_compare_types(&ns->default_type[i+1],
1437                                       &ns->default_type[l]))
1438             i++;
1439
1440           if (i > l)
1441             gfc_status(" %c-%c: ", l+'A', i+'A');
1442           else
1443             gfc_status(" %c: ", l+'A');
1444
1445           gfc_show_typespec(&ns->default_type[l]);
1446           i++;
1447       } while (i < GFC_LETTERS);
1448
1449       if (ns->proc_name != NULL)
1450         {
1451           show_indent ();
1452           gfc_status ("procedure name = %s", ns->proc_name->name);
1453         }
1454
1455       gfc_current_ns = ns;
1456       gfc_traverse_symtree (ns->common_root, show_common);
1457
1458       gfc_traverse_symtree (ns->sym_root, show_symtree);
1459
1460       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1461         {
1462           /* User operator interfaces */
1463           intr = ns->operator[op];
1464           if (intr == NULL)
1465             continue;
1466
1467           show_indent ();
1468           gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
1469
1470           for (; intr; intr = intr->next)
1471             gfc_status (" %s", intr->sym->name);
1472         }
1473
1474       if (ns->uop_root != NULL)
1475         {
1476           show_indent ();
1477           gfc_status ("User operators:\n");
1478           gfc_traverse_user_op (ns, show_uop);
1479         }
1480     }
1481
1482   for (eq = ns->equiv; eq; eq = eq->next)
1483     gfc_show_equiv (eq);
1484
1485   gfc_status_char ('\n');
1486   gfc_status_char ('\n');
1487
1488   gfc_show_code (0, ns->code);
1489
1490   for (ns = ns->contained; ns; ns = ns->sibling)
1491     {
1492       show_indent ();
1493       gfc_status ("CONTAINS\n");
1494       gfc_show_namespace (ns);
1495     }
1496
1497   show_level--;
1498   gfc_status_char ('\n');
1499   gfc_current_ns = save;
1500 }