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