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->common)
 548     gfc_status (" COMMON");
 549   if (attr->result)
 550     gfc_status (" RESULT");
 551   if (attr->entry)
 552     gfc_status (" ENTRY");
 553
 554   if (attr->data)
 555     gfc_status (" DATA");
 556   if (attr->use_assoc)
 557     gfc_status (" USE-ASSOC");
 558   if (attr->in_namelist)
 559     gfc_status (" IN-NAMELIST");
 560   if (attr->in_common)
 561     gfc_status (" IN-COMMON");
 562   if (attr->saved_common)
 563     gfc_status (" SAVED-COMMON");
 564
 565   if (attr->function)
 566     gfc_status (" FUNCTION");
 567   if (attr->subroutine)
 568     gfc_status (" SUBROUTINE");
 569   if (attr->implicit_type)
 570     gfc_status (" IMPLICIT-TYPE");
 571
 572   if (attr->sequence)
 573     gfc_status (" SEQUENCE");
 574   if (attr->elemental)
 575     gfc_status (" ELEMENTAL");
 576   if (attr->pure)
 577     gfc_status (" PURE");
 578   if (attr->recursive)
 579     gfc_status (" RECURSIVE");
 580
 581   gfc_status (")");
 582 }
 583
 584
 585 /* Show components of a derived type.  */
 586
 587 static void
 588 gfc_show_components (gfc_symbol * sym)
 589 {
 590   gfc_component *c;
 591
 592   for (c = sym->components; c; c = c->next)
 593     {
 594       gfc_status ("(%s ", c->name);
 595       gfc_show_typespec (&c->ts);
 596       if (c->pointer)
 597         gfc_status (" POINTER");
 598       if (c->dimension)
 599         gfc_status (" DIMENSION");
 600       gfc_status_char (' ');
 601       gfc_show_array_spec (c->as);
 602       gfc_status (")");
 603       if (c->next != NULL)
 604         gfc_status_char (' ');
 605     }
 606 }
 607
 608
 609 /* Show a symbol.  If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
 610    show the interface.  Information needed to reconstruct the list of
 611    specific interfaces associated with a generic symbol is done within
 612    that symbol.  */
 613
 614 static void
 615 gfc_show_symbol (gfc_symbol * sym)
 616 {
 617   gfc_formal_arglist *formal;
 618   gfc_interface *intr;
 619   gfc_symbol *s;
 620
 621   if (sym == NULL)
 622     return;
 623
 624   show_indent ();
 625
 626   gfc_status ("symbol %s ", sym->name);
 627   gfc_show_typespec (&sym->ts);
 628   gfc_show_attr (&sym->attr);
 629
 630   if (sym->value)
 631     {
 632       show_indent ();
 633       gfc_status ("value: ");
 634       gfc_show_expr (sym->value);
 635     }
 636
 637   if (sym->as)
 638     {
 639       show_indent ();
 640       gfc_status ("Array spec:");
 641       gfc_show_array_spec (sym->as);
 642     }
 643
 644   if (sym->generic)
 645     {
 646       show_indent ();
 647       gfc_status ("Generic interfaces:");
 648       for (intr = sym->generic; intr; intr = intr->next)
 649         gfc_status (" %s", intr->sym->name);
 650     }
 651
 652   if (sym->common_head)
 653     {
 654       show_indent ();
 655       gfc_status ("Common members:");
 656       for (s = sym->common_head; s; s = s->common_next)
 657         gfc_status (" %s", s->name);
 658     }
 659
 660   if (sym->result)
 661     {
 662       show_indent ();
 663       gfc_status ("result: %s", sym->result->name);
 664     }
 665
 666   if (sym->components)
 667     {
 668       show_indent ();
 669       gfc_status ("components: ");
 670       gfc_show_components (sym);
 671     }
 672
 673   if (sym->formal)
 674     {
 675       show_indent ();
 676       gfc_status ("Formal arglist:");
 677
 678       for (formal = sym->formal; formal; formal = formal->next)
 679         gfc_status (" %s", formal->sym->name);
 680     }
 681
 682   if (sym->formal_ns)
 683     {
 684       show_indent ();
 685       gfc_status ("Formal namespace");
 686       gfc_show_namespace (sym->formal_ns);
 687     }
 688
 689   gfc_status_char ('\n');
 690 }
 691
 692
 693 /* Show a user-defined operator.  Just prints an operator
 694    and the name of the associated subroutine, really.  */
 695 static void
 696 show_uop (gfc_user_op * uop)
 697 {
 698   gfc_interface *intr;
 699
 700   show_indent ();
 701   gfc_status ("%s:", uop->name);
 702
 703   for (intr = uop->operator; intr; intr = intr->next)
 704     gfc_status (" %s", intr->sym->name);
 705 }
 706
 707
 708 /* Workhorse function for traversing the user operator symtree.  */
 709
 710 static void
 711 traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
 712 {
 713
 714   if (st == NULL)
 715     return;
 716
 717   (*func) (st->n.uop);
 718
 719   traverse_uop (st->left, func);
 720   traverse_uop (st->right, func);
 721 }
 722
 723
 724 /* Traverse the tree of user operator nodes.  */
 725
 726 void
 727 gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
 728 {
 729
 730   traverse_uop (ns->uop_root, func);
 731 }
 732
 733
 734 /* Worker function to display the symbol tree.  */
 735
 736 static void
 737 show_symtree (gfc_symtree * st)
 738 {
 739
 740   show_indent ();
 741   gfc_status ("symtree: %s  Ambig %d", st->name, st->ambiguous);
 742
 743   if (st->n.sym->ns != gfc_current_ns)
 744     gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
 745   else
 746     gfc_show_symbol (st->n.sym);
 747 }
 748
 749
 750 /******************* Show gfc_code structures **************/
 751
 752
 753
 754 static void gfc_show_code_node (int level, gfc_code * c);
 755
 756 /* Show a list of code structures.  Mutually recursive with
 757    gfc_show_code_node().  */
 758
 759 static void
 760 gfc_show_code (int level, gfc_code * c)
 761 {
 762
 763   for (; c; c = c->next)
 764     gfc_show_code_node (level, c);
 765 }
 766
 767
 768 /* Show a single code node and everything underneath it if necessary.  */
 769
 770 static void
 771 gfc_show_code_node (int level, gfc_code * c)
 772 {
 773   gfc_forall_iterator *fa;
 774   gfc_open *open;
 775   gfc_case *cp;
 776   gfc_alloc *a;
 777   gfc_code *d;
 778   gfc_close *close;
 779   gfc_filepos *fp;
 780   gfc_inquire *i;
 781   gfc_dt *dt;
 782
 783   code_indent (level, c->here);
 784
 785   switch (c->op)
 786     {
 787     case EXEC_NOP:
 788       gfc_status ("NOP");
 789       break;
 790
 791     case EXEC_CONTINUE:
 792       gfc_status ("CONTINUE");
 793       break;
 794
 795     case EXEC_ASSIGN:
 796       gfc_status ("ASSIGN ");
 797       gfc_show_expr (c->expr);
 798       gfc_status_char (' ');
 799       gfc_show_expr (c->expr2);
 800       break;
 801     case EXEC_LABEL_ASSIGN:
 802       gfc_status ("LABEL ASSIGN ");
 803       gfc_show_expr (c->expr);
 804       gfc_status (" %d", c->label->value);
 805       break;
 806
 807     case EXEC_POINTER_ASSIGN:
 808       gfc_status ("POINTER ASSIGN ");
 809       gfc_show_expr (c->expr);
 810       gfc_status_char (' ');
 811       gfc_show_expr (c->expr2);
 812       break;
 813
 814     case EXEC_GOTO:
 815       gfc_status ("GOTO ");
 816       if (c->label)
 817         gfc_status ("%d", c->label->value);
 818       else
 819         {
 820           gfc_show_expr (c->expr);
 821           d = c->block;
 822           if (d != NULL)
 823             {
 824               gfc_status (", (");
 825               for (; d; d = d ->block)
 826                 {
 827                   code_indent (level, d->label);
 828                   if (d->block != NULL)
 829                     gfc_status_char (',');
 830                   else
 831                     gfc_status_char (')');
 832                 }
 833             }
 834         }
 835       break;
 836
 837     case EXEC_CALL:
 838       gfc_status ("CALL %s ", c->resolved_sym->name);
 839       gfc_show_actual_arglist (c->ext.actual);
 840       break;
 841
 842     case EXEC_RETURN:
 843       gfc_status ("RETURN ");
 844       if (c->expr)
 845         gfc_show_expr (c->expr);
 846       break;
 847
 848     case EXEC_PAUSE:
 849       gfc_status ("PAUSE ");
 850
 851       if (c->expr != NULL)
 852         gfc_show_expr (c->expr);
 853       else
 854         gfc_status ("%d", c->ext.stop_code);
 855
 856       break;
 857
 858     case EXEC_STOP:
 859       gfc_status ("STOP ");
 860
 861       if (c->expr != NULL)
 862         gfc_show_expr (c->expr);
 863       else
 864         gfc_status ("%d", c->ext.stop_code);
 865
 866       break;
 867
 868     case EXEC_ARITHMETIC_IF:
 869       gfc_status ("IF ");
 870       gfc_show_expr (c->expr);
 871       gfc_status (" %d, %d, %d",
 872                   c->label->value, c->label2->value, c->label3->value);
 873       break;
 874
 875     case EXEC_IF:
 876       d = c->block;
 877       gfc_status ("IF ");
 878       gfc_show_expr (d->expr);
 879       gfc_status_char ('\n');
 880       gfc_show_code (level + 1, d->next);
 881
 882       d = d->block;
 883       for (; d; d = d->block)
 884         {
 885           code_indent (level, 0);
 886
 887           if (d->expr == NULL)
 888             gfc_status ("ELSE\n");
 889           else
 890             {
 891               gfc_status ("ELSE IF ");
 892               gfc_show_expr (d->expr);
 893               gfc_status_char ('\n');
 894             }
 895
 896           gfc_show_code (level + 1, d->next);
 897         }
 898
 899       code_indent (level, c->label);
 900
 901       gfc_status ("ENDIF");
 902       break;
 903
 904     case EXEC_SELECT:
 905       d = c->block;
 906       gfc_status ("SELECT CASE ");
 907       gfc_show_expr (c->expr);
 908       gfc_status_char ('\n');
 909
 910       for (; d; d = d->block)
 911         {
 912           code_indent (level, 0);
 913
 914           gfc_status ("CASE ");
 915           for (cp = d->ext.case_list; cp; cp = cp->next)
 916             {
 917               gfc_status_char ('(');
 918               gfc_show_expr (cp->low);
 919               gfc_status_char (' ');
 920               gfc_show_expr (cp->high);
 921               gfc_status_char (')');
 922               gfc_status_char (' ');
 923             }
 924           gfc_status_char ('\n');
 925
 926           gfc_show_code (level + 1, d->next);
 927         }
 928
 929       code_indent (level, c->label);
 930       gfc_status ("END SELECT");
 931       break;
 932
 933     case EXEC_WHERE:
 934       gfc_status ("WHERE ");
 935
 936       d = c->block;
 937       gfc_show_expr (d->expr);
 938       gfc_status_char ('\n');
 939
 940       gfc_show_code (level + 1, d->next);
 941
 942       for (d = d->block; d; d = d->block)
 943         {
 944           code_indent (level, 0);
 945           gfc_status ("ELSE WHERE ");
 946           gfc_show_expr (d->expr);
 947           gfc_status_char ('\n');
 948           gfc_show_code (level + 1, d->next);
 949         }
 950
 951       code_indent (level, 0);
 952       gfc_status ("END WHERE");
 953       break;
 954
 955
 956     case EXEC_FORALL:
 957       gfc_status ("FORALL ");
 958       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
 959         {
 960           gfc_show_expr (fa->var);
 961           gfc_status_char (' ');
 962           gfc_show_expr (fa->start);
 963           gfc_status_char (':');
 964           gfc_show_expr (fa->end);
 965           gfc_status_char (':');
 966           gfc_show_expr (fa->stride);
 967
 968           if (fa->next != NULL)
 969             gfc_status_char (',');
 970         }
 971
 972       if (c->expr != NULL)
 973         {
 974           gfc_status_char (',');
 975           gfc_show_expr (c->expr);
 976         }
 977       gfc_status_char ('\n');
 978
 979       gfc_show_code (level + 1, c->block->next);
 980
 981       code_indent (level, 0);
 982       gfc_status ("END FORALL");
 983       break;
 984
 985     case EXEC_DO:
 986       gfc_status ("DO ");
 987
 988       gfc_show_expr (c->ext.iterator->var);
 989       gfc_status_char ('=');
 990       gfc_show_expr (c->ext.iterator->start);
 991       gfc_status_char (' ');
 992       gfc_show_expr (c->ext.iterator->end);
 993       gfc_status_char (' ');
 994       gfc_show_expr (c->ext.iterator->step);
 995       gfc_status_char ('\n');
 996
 997       gfc_show_code (level + 1, c->block->next);
 998
 999       code_indent (level, 0);
1000       gfc_status ("END DO");
1001       break;
1002
1003     case EXEC_DO_WHILE:
1004       gfc_status ("DO WHILE ");
1005       gfc_show_expr (c->expr);
1006       gfc_status_char ('\n');
1007
1008       gfc_show_code (level + 1, c->block->next);
1009
1010       code_indent (level, c->label);
1011       gfc_status ("END DO");
1012       break;
1013
1014     case EXEC_CYCLE:
1015       gfc_status ("CYCLE");
1016       if (c->symtree)
1017         gfc_status (" %s", c->symtree->n.sym->name);
1018       break;
1019
1020     case EXEC_EXIT:
1021       gfc_status ("EXIT");
1022       if (c->symtree)
1023         gfc_status (" %s", c->symtree->n.sym->name);
1024       break;
1025
1026     case EXEC_ALLOCATE:
1027       gfc_status ("ALLOCATE ");
1028       if (c->expr)
1029         {
1030           gfc_status (" STAT=");
1031           gfc_show_expr (c->expr);
1032         }
1033
1034       for (a = c->ext.alloc_list; a; a = a->next)
1035         {
1036           gfc_status_char (' ');
1037           gfc_show_expr (a->expr);
1038         }
1039
1040       break;
1041
1042     case EXEC_DEALLOCATE:
1043       gfc_status ("DEALLOCATE ");
1044       if (c->expr)
1045         {
1046           gfc_status (" STAT=");
1047           gfc_show_expr (c->expr);
1048         }
1049
1050       for (a = c->ext.alloc_list; a; a = a->next)
1051         {
1052           gfc_status_char (' ');
1053           gfc_show_expr (a->expr);
1054         }
1055
1056       break;
1057
1058     case EXEC_OPEN:
1059       gfc_status ("OPEN");
1060       open = c->ext.open;
1061
1062       if (open->unit)
1063         {
1064           gfc_status (" UNIT=");
1065           gfc_show_expr (open->unit);
1066         }
1067       if (open->iostat)
1068         {
1069           gfc_status (" IOSTAT=");
1070           gfc_show_expr (open->iostat);
1071         }
1072       if (open->file)
1073         {
1074           gfc_status (" FILE=");
1075           gfc_show_expr (open->file);
1076         }
1077       if (open->status)
1078         {
1079           gfc_status (" STATUS=");
1080           gfc_show_expr (open->status);
1081         }
1082       if (open->access)
1083         {
1084           gfc_status (" ACCESS=");
1085           gfc_show_expr (open->access);
1086         }
1087       if (open->form)
1088         {
1089           gfc_status (" FORM=");
1090           gfc_show_expr (open->form);
1091         }
1092       if (open->recl)
1093         {
1094           gfc_status (" RECL=");
1095           gfc_show_expr (open->recl);
1096         }
1097       if (open->blank)
1098         {
1099           gfc_status (" BLANK=");
1100           gfc_show_expr (open->blank);
1101         }
1102       if (open->position)
1103         {
1104           gfc_status (" POSITION=");
1105           gfc_show_expr (open->position);
1106         }
1107       if (open->action)
1108         {
1109           gfc_status (" ACTION=");
1110           gfc_show_expr (open->action);
1111         }
1112       if (open->delim)
1113         {
1114           gfc_status (" DELIM=");
1115           gfc_show_expr (open->delim);
1116         }
1117       if (open->pad)
1118         {
1119           gfc_status (" PAD=");
1120           gfc_show_expr (open->pad);
1121         }
1122       if (open->err != NULL)
1123         gfc_status (" ERR=%d", open->err->value);
1124
1125       break;
1126
1127     case EXEC_CLOSE:
1128       gfc_status ("CLOSE");
1129       close = c->ext.close;
1130
1131       if (close->unit)
1132         {
1133           gfc_status (" UNIT=");
1134           gfc_show_expr (close->unit);
1135         }
1136       if (close->iostat)
1137         {
1138           gfc_status (" IOSTAT=");
1139           gfc_show_expr (close->iostat);
1140         }
1141       if (close->status)
1142         {
1143           gfc_status (" STATUS=");
1144           gfc_show_expr (close->status);
1145         }
1146       if (close->err != NULL)
1147         gfc_status (" ERR=%d", close->err->value);
1148       break;
1149
1150     case EXEC_BACKSPACE:
1151       gfc_status ("BACKSPACE");
1152       goto show_filepos;
1153
1154     case EXEC_ENDFILE:
1155       gfc_status ("ENDFILE");
1156       goto show_filepos;
1157
1158     case EXEC_REWIND:
1159       gfc_status ("REWIND");
1160
1161     show_filepos:
1162       fp = c->ext.filepos;
1163
1164       if (fp->unit)
1165         {
1166           gfc_status (" UNIT=");
1167           gfc_show_expr (fp->unit);
1168         }
1169       if (fp->iostat)
1170         {
1171           gfc_status (" IOSTAT=");
1172           gfc_show_expr (fp->iostat);
1173         }
1174       if (fp->err != NULL)
1175         gfc_status (" ERR=%d", fp->err->value);
1176       break;
1177
1178     case EXEC_INQUIRE:
1179       gfc_status ("INQUIRE");
1180       i = c->ext.inquire;
1181
1182       if (i->unit)
1183         {
1184           gfc_status (" UNIT=");
1185           gfc_show_expr (i->unit);
1186         }
1187       if (i->file)
1188         {
1189           gfc_status (" FILE=");
1190           gfc_show_expr (i->file);
1191         }
1192
1193       if (i->iostat)
1194         {
1195           gfc_status (" IOSTAT=");
1196           gfc_show_expr (i->iostat);
1197         }
1198       if (i->exist)
1199         {
1200           gfc_status (" EXIST=");
1201           gfc_show_expr (i->exist);
1202         }
1203       if (i->opened)
1204         {
1205           gfc_status (" OPENED=");
1206           gfc_show_expr (i->opened);
1207         }
1208       if (i->number)
1209         {
1210           gfc_status (" NUMBER=");
1211           gfc_show_expr (i->number);
1212         }
1213       if (i->named)
1214         {
1215           gfc_status (" NAMED=");
1216           gfc_show_expr (i->named);
1217         }
1218       if (i->name)
1219         {
1220           gfc_status (" NAME=");
1221           gfc_show_expr (i->name);
1222         }
1223       if (i->access)
1224         {
1225           gfc_status (" ACCESS=");
1226           gfc_show_expr (i->access);
1227         }
1228       if (i->sequential)
1229         {
1230           gfc_status (" SEQUENTIAL=");
1231           gfc_show_expr (i->sequential);
1232         }
1233
1234       if (i->direct)
1235         {
1236           gfc_status (" DIRECT=");
1237           gfc_show_expr (i->direct);
1238         }
1239       if (i->form)
1240         {
1241           gfc_status (" FORM=");
1242           gfc_show_expr (i->form);
1243         }
1244       if (i->formatted)
1245         {
1246           gfc_status (" FORMATTED");
1247           gfc_show_expr (i->formatted);
1248         }
1249       if (i->unformatted)
1250         {
1251           gfc_status (" UNFORMATTED=");
1252           gfc_show_expr (i->unformatted);
1253         }
1254       if (i->recl)
1255         {
1256           gfc_status (" RECL=");
1257           gfc_show_expr (i->recl);
1258         }
1259       if (i->nextrec)
1260         {
1261           gfc_status (" NEXTREC=");
1262           gfc_show_expr (i->nextrec);
1263         }
1264       if (i->blank)
1265         {
1266           gfc_status (" BLANK=");
1267           gfc_show_expr (i->blank);
1268         }
1269       if (i->position)
1270         {
1271           gfc_status (" POSITION=");
1272           gfc_show_expr (i->position);
1273         }
1274       if (i->action)
1275         {
1276           gfc_status (" ACTION=");
1277           gfc_show_expr (i->action);
1278         }
1279       if (i->read)
1280         {
1281           gfc_status (" READ=");
1282           gfc_show_expr (i->read);
1283         }
1284       if (i->write)
1285         {
1286           gfc_status (" WRITE=");
1287           gfc_show_expr (i->write);
1288         }
1289       if (i->readwrite)
1290         {
1291           gfc_status (" READWRITE=");
1292           gfc_show_expr (i->readwrite);
1293         }
1294       if (i->delim)
1295         {
1296           gfc_status (" DELIM=");
1297           gfc_show_expr (i->delim);
1298         }
1299       if (i->pad)
1300         {
1301           gfc_status (" PAD=");
1302           gfc_show_expr (i->pad);
1303         }
1304
1305       if (i->err != NULL)
1306         gfc_status (" ERR=%d", i->err->value);
1307       break;
1308
1309     case EXEC_IOLENGTH:
1310       gfc_status ("IOLENGTH ");
1311       gfc_show_expr (c->expr);
1312       break;
1313
1314     case EXEC_READ:
1315       gfc_status ("READ");
1316       goto show_dt;
1317
1318     case EXEC_WRITE:
1319       gfc_status ("WRITE");
1320
1321     show_dt:
1322       dt = c->ext.dt;
1323       if (dt->io_unit)
1324         {
1325           gfc_status (" UNIT=");
1326           gfc_show_expr (dt->io_unit);
1327         }
1328
1329       if (dt->format_expr)
1330         {
1331           gfc_status (" FMT=");
1332           gfc_show_expr (dt->format_expr);
1333         }
1334
1335       if (dt->format_label != NULL)
1336         gfc_status (" FMT=%d", dt->format_label->value);
1337       if (dt->namelist)
1338         gfc_status (" NML=%s", dt->namelist->name);
1339       if (dt->iostat)
1340         {
1341           gfc_status (" IOSTAT=");
1342           gfc_show_expr (dt->iostat);
1343         }
1344       if (dt->size)
1345         {
1346           gfc_status (" SIZE=");
1347           gfc_show_expr (dt->size);
1348         }
1349       if (dt->rec)
1350         {
1351           gfc_status (" REC=");
1352           gfc_show_expr (dt->rec);
1353         }
1354       if (dt->advance)
1355         {
1356           gfc_status (" ADVANCE=");
1357           gfc_show_expr (dt->advance);
1358         }
1359
1360       break;
1361
1362     case EXEC_TRANSFER:
1363       gfc_status ("TRANSFER ");
1364       gfc_show_expr (c->expr);
1365       break;
1366
1367     case EXEC_DT_END:
1368       gfc_status ("DT_END");
1369       dt = c->ext.dt;
1370
1371       if (dt->err != NULL)
1372         gfc_status (" ERR=%d", dt->err->value);
1373       if (dt->end != NULL)
1374         gfc_status (" END=%d", dt->end->value);
1375       if (dt->eor != NULL)
1376         gfc_status (" EOR=%d", dt->eor->value);
1377       break;
1378
1379     default:
1380       gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1381     }
1382
1383   gfc_status_char ('\n');
1384 }
1385
1386
1387 /* Show and equivalence chain.  */
1388
1389 static void
1390 gfc_show_equiv (gfc_equiv *eq)
1391 {
1392   show_indent ();
1393   gfc_status ("Equivalence: ");
1394   while (eq)
1395     {
1396       gfc_show_expr (eq->expr);
1397       eq = eq->eq;
1398       if (eq)
1399         gfc_status (", ");
1400     }
1401 }
1402
1403
1404 /* Show a freakin' whole namespace.  */
1405
1406 void
1407 gfc_show_namespace (gfc_namespace * ns)
1408 {
1409   gfc_interface *intr;
1410   gfc_namespace *save;
1411   gfc_intrinsic_op op;
1412   gfc_equiv *eq;
1413   int i;
1414
1415   save = gfc_current_ns;
1416   show_level++;
1417
1418   show_indent ();
1419   gfc_status ("Namespace:");
1420
1421   if (ns != NULL)
1422     {
1423       i = 0;
1424       do
1425         {
1426           int l = i;
1427           while (i < GFC_LETTERS - 1
1428                  && gfc_compare_types(&ns->default_type[i+1],
1429                                       &ns->default_type[l]))
1430             i++;
1431
1432           if (i > l)
1433             gfc_status(" %c-%c: ", l+'A', i+'A');
1434           else
1435             gfc_status(" %c: ", l+'A');
1436
1437           gfc_show_typespec(&ns->default_type[l]);
1438           i++;
1439       } while (i < GFC_LETTERS);
1440
1441       if (ns->proc_name != NULL)
1442         {
1443           show_indent ();
1444           gfc_status ("procedure name = %s", ns->proc_name->name);
1445         }
1446
1447       gfc_current_ns = ns;
1448       gfc_traverse_symtree (ns, show_symtree);
1449
1450       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1451         {
1452           /* User operator interfaces */
1453           intr = ns->operator[op];
1454           if (intr == NULL)
1455             continue;
1456
1457           show_indent ();
1458           gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
1459
1460           for (; intr; intr = intr->next)
1461             gfc_status (" %s", intr->sym->name);
1462         }
1463
1464       if (ns->uop_root != NULL)
1465         {
1466           show_indent ();
1467           gfc_status ("User operators:\n");
1468           gfc_traverse_user_op (ns, show_uop);
1469         }
1470     }
1471
1472   for (eq = ns->equiv; eq; eq = eq->next)
1473     gfc_show_equiv (eq);
1474
1475   gfc_status_char ('\n');
1476   gfc_status_char ('\n');
1477
1478   gfc_show_code (0, ns->code);
1479
1480   for (ns = ns->contained; ns; ns = ns->sibling)
1481     {
1482       show_indent ();
1483       gfc_status ("CONTAINS\n");
1484       gfc_show_namespace (ns);
1485     }
1486
1487   show_level--;
1488   gfc_status_char ('\n');
1489   gfc_current_ns = save;
1490 }