gcc/fortran/dump-parse-tree.c

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