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