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
  65 static inline void
  66 show_indent (void)
  67 {
  68   gfc_status ("\n");
  69   code_indent (show_level, NULL);
  70 }
  71
  72
  73 /* Show type-specific information.  */
  74
  75 static void
  76 gfc_show_typespec (gfc_typespec * ts)
  77 {
  78
  79   gfc_status ("(%s ", gfc_basic_typename (ts->type));
  80
  81   switch (ts->type)
  82     {
  83     case BT_DERIVED:
  84       gfc_status ("%s", ts->derived->name);
  85       break;
  86
  87     case BT_CHARACTER:
  88       gfc_show_expr (ts->cl->length);
  89       break;
  90
  91     default:
  92       gfc_status ("%d", ts->kind);
  93       break;
  94     }
  95
  96   gfc_status (")");
  97 }
  98
  99
 100 /* Show an actual argument list.  */
 101
 102 static void
 103 gfc_show_actual_arglist (gfc_actual_arglist * a)
 104 {
 105
 106   gfc_status ("(");
 107
 108   for (; a; a = a->next)
 109     {
 110       gfc_status_char ('(');
 111       if (a->name != NULL)
 112         gfc_status ("%s = ", a->name);
 113       if (a->expr != NULL)
 114         gfc_show_expr (a->expr);
 115       else
 116         gfc_status ("(arg not-present)");
 117
 118       gfc_status_char (')');
 119       if (a->next != NULL)
 120         gfc_status (" ");
 121     }
 122
 123   gfc_status (")");
 124 }
 125
 126
 127 /* Show a gfc_array_spec array specification structure.  */
 128
 129 static void
 130 gfc_show_array_spec (gfc_array_spec * as)
 131 {
 132   const char *c;
 133   int i;
 134
 135   if (as == NULL)
 136     {
 137       gfc_status ("()");
 138       return;
 139     }
 140
 141   gfc_status ("(%d", as->rank);
 142
 143   if (as->rank != 0)
 144     {
 145       switch (as->type)
 146       {
 147         case AS_EXPLICIT:      c = "AS_EXPLICIT";      break;
 148         case AS_DEFERRED:      c = "AS_DEFERRED";      break;
 149         case AS_ASSUMED_SIZE:  c = "AS_ASSUMED_SIZE";  break;
 150         case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
 151         default:
 152           gfc_internal_error
 153                 ("gfc_show_array_spec(): Unhandled array shape type.");
 154       }
 155       gfc_status (" %s ", c);
 156
 157       for (i = 0; i < as->rank; i++)
 158         {
 159           gfc_show_expr (as->lower[i]);
 160           gfc_status_char (' ');
 161           gfc_show_expr (as->upper[i]);
 162           gfc_status_char (' ');
 163         }
 164     }
 165
 166   gfc_status (")");
 167 }
 168
 169
 170 /* Show a gfc_array_ref array reference structure.  */
 171
 172 static void
 173 gfc_show_array_ref (gfc_array_ref * ar)
 174 {
 175   int i;
 176
 177   gfc_status_char ('(');
 178
 179   switch (ar->type)
 180     {
 181     case AR_FULL:
 182       gfc_status ("FULL");
 183       break;
 184
 185     case AR_SECTION:
 186       for (i = 0; i < ar->dimen; i++)
 187         {
 188           /* There are two types of array sections: either the
 189              elements are identified by an integer array ('vector'),
 190              or by an index range. In the former case we only have to
 191              print the start expression which contains the vector, in
 192              the latter case we have to print any of lower and upper
 193              bound and the stride, if they're present.  */
 194
 195           if (ar->start[i] != NULL)
 196             gfc_show_expr (ar->start[i]);
 197
 198           if (ar->dimen_type[i] == DIMEN_RANGE)
 199             {
 200               gfc_status_char (':');
 201
 202               if (ar->end[i] != NULL)
 203                 gfc_show_expr (ar->end[i]);
 204
 205               if (ar->stride[i] != NULL)
 206                 {
 207                   gfc_status_char (':');
 208                   gfc_show_expr (ar->stride[i]);
 209                 }
 210             }
 211
 212           if (i != ar->dimen - 1)
 213             gfc_status (" , ");
 214         }
 215       break;
 216
 217     case AR_ELEMENT:
 218       for (i = 0; i < ar->dimen; i++)
 219         {
 220           gfc_show_expr (ar->start[i]);
 221           if (i != ar->dimen - 1)
 222             gfc_status (" , ");
 223         }
 224       break;
 225
 226     case AR_UNKNOWN:
 227       gfc_status ("UNKNOWN");
 228       break;
 229
 230     default:
 231       gfc_internal_error ("gfc_show_array_ref(): Unknown array reference");
 232     }
 233
 234   gfc_status_char (')');
 235 }
 236
 237
 238 /* Show a list of gfc_ref structures.  */
 239
 240 static void
 241 gfc_show_ref (gfc_ref * p)
 242 {
 243
 244   for (; p; p = p->next)
 245     switch (p->type)
 246       {
 247       case REF_ARRAY:
 248         gfc_show_array_ref (&p->u.ar);
 249         break;
 250
 251       case REF_COMPONENT:
 252         gfc_status (" %% %s", p->u.c.component->name);
 253         break;
 254
 255       case REF_SUBSTRING:
 256         gfc_status_char ('(');
 257         gfc_show_expr (p->u.ss.start);
 258         gfc_status_char (':');
 259         gfc_show_expr (p->u.ss.end);
 260         gfc_status_char (')');
 261         break;
 262
 263       default:
 264         gfc_internal_error ("gfc_show_ref(): Bad component code");
 265       }
 266 }
 267
 268
 269 /* Display a constructor.  Works recursively for array constructors.  */
 270
 271 static void
 272 gfc_show_constructor (gfc_constructor * c)
 273 {
 274
 275   for (; c; c = c->next)
 276     {
 277       if (c->iterator == NULL)
 278         gfc_show_expr (c->expr);
 279       else
 280         {
 281           gfc_status_char ('(');
 282           gfc_show_expr (c->expr);
 283
 284           gfc_status_char (' ');
 285           gfc_show_expr (c->iterator->var);
 286           gfc_status_char ('=');
 287           gfc_show_expr (c->iterator->start);
 288           gfc_status_char (',');
 289           gfc_show_expr (c->iterator->end);
 290           gfc_status_char (',');
 291           gfc_show_expr (c->iterator->step);
 292
 293           gfc_status_char (')');
 294         }
 295
 296       if (c->next != NULL)
 297         gfc_status (" , ");
 298     }
 299 }
 300
 301
 302 /* Show an expression.  */
 303
 304 static void
 305 gfc_show_expr (gfc_expr * p)
 306 {
 307   const char *c;
 308   int i;
 309
 310   if (p == NULL)
 311     {
 312       gfc_status ("()");
 313       return;
 314     }
 315
 316   switch (p->expr_type)
 317     {
 318     case EXPR_SUBSTRING:
 319       c = p->value.character.string;
 320
 321       for (i = 0; i < p->value.character.length; i++, c++)
 322         {
 323           if (*c == '\'')
 324             gfc_status ("''");
 325           else
 326             gfc_status ("%c", *c);
 327         }
 328
 329       gfc_show_ref (p->ref);
 330       break;
 331
 332     case EXPR_STRUCTURE:
 333       gfc_status ("%s(", p->ts.derived->name);
 334       gfc_show_constructor (p->value.constructor);
 335       gfc_status_char (')');
 336       break;
 337
 338     case EXPR_ARRAY:
 339       gfc_status ("(/ ");
 340       gfc_show_constructor (p->value.constructor);
 341       gfc_status (" /)");
 342
 343       gfc_show_ref (p->ref);
 344       break;
 345
 346     case EXPR_NULL:
 347       gfc_status ("NULL()");
 348       break;
 349
 350     case EXPR_CONSTANT:
 351       switch (p->ts.type)
 352         {
 353         case BT_INTEGER:
 354           mpz_out_str (stdout, 10, p->value.integer);
 355
 356           if (p->ts.kind != gfc_default_integer_kind)
 357             gfc_status ("_%d", p->ts.kind);
 358           break;
 359
 360         case BT_LOGICAL:
 361           if (p->value.logical)
 362             gfc_status (".true.");
 363           else
 364             gfc_status (".false.");
 365           break;
 366
 367         case BT_REAL:
 368           mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
 369           if (p->ts.kind != gfc_default_real_kind)
 370             gfc_status ("_%d", p->ts.kind);
 371           break;
 372
 373         case BT_CHARACTER:
 374           c = p->value.character.string;
 375
 376           gfc_status_char ('\'');
 377
 378           for (i = 0; i < p->value.character.length; i++, c++)
 379             {
 380               if (*c == '\'')
 381                 gfc_status ("''");
 382               else
 383                 gfc_status_char (*c);
 384             }
 385
 386           gfc_status_char ('\'');
 387
 388           break;
 389
 390         case BT_COMPLEX:
 391           gfc_status ("(complex ");
 392
 393           mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
 394           if (p->ts.kind != gfc_default_complex_kind)
 395             gfc_status ("_%d", p->ts.kind);
 396
 397           gfc_status (" ");
 398
 399           mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE);
 400           if (p->ts.kind != gfc_default_complex_kind)
 401             gfc_status ("_%d", p->ts.kind);
 402
 403           gfc_status (")");
 404           break;
 405
 406         default:
 407           gfc_status ("???");
 408           break;
 409         }
 410
 411       break;
 412
 413     case EXPR_VARIABLE:
 414       if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
 415         gfc_status ("%s:", p->symtree->n.sym->ns->proc_name->name);
 416       gfc_status ("%s", p->symtree->n.sym->name);
 417       gfc_show_ref (p->ref);
 418       break;
 419
 420     case EXPR_OP:
 421       gfc_status ("(");
 422       switch (p->value.op.operator)
 423         {
 424         case INTRINSIC_UPLUS:
 425           gfc_status ("U+ ");
 426           break;
 427         case INTRINSIC_UMINUS:
 428           gfc_status ("U- ");
 429           break;
 430         case INTRINSIC_PLUS:
 431           gfc_status ("+ ");
 432           break;
 433         case INTRINSIC_MINUS:
 434           gfc_status ("- ");
 435           break;
 436         case INTRINSIC_TIMES:
 437           gfc_status ("* ");
 438           break;
 439         case INTRINSIC_DIVIDE:
 440           gfc_status ("/ ");
 441           break;
 442         case INTRINSIC_POWER:
 443           gfc_status ("** ");
 444           break;
 445         case INTRINSIC_CONCAT:
 446           gfc_status ("// ");
 447           break;
 448         case INTRINSIC_AND:
 449           gfc_status ("AND ");
 450           break;
 451         case INTRINSIC_OR:
 452           gfc_status ("OR ");
 453           break;
 454         case INTRINSIC_EQV:
 455           gfc_status ("EQV ");
 456           break;
 457         case INTRINSIC_NEQV:
 458           gfc_status ("NEQV ");
 459           break;
 460         case INTRINSIC_EQ:
 461           gfc_status ("= ");
 462           break;
 463         case INTRINSIC_NE:
 464           gfc_status ("<> ");
 465           break;
 466         case INTRINSIC_GT:
 467           gfc_status ("> ");
 468           break;
 469         case INTRINSIC_GE:
 470           gfc_status (">= ");
 471           break;
 472         case INTRINSIC_LT:
 473           gfc_status ("< ");
 474           break;
 475         case INTRINSIC_LE:
 476           gfc_status ("<= ");
 477           break;
 478         case INTRINSIC_NOT:
 479           gfc_status ("NOT ");
 480           break;
 481
 482         default:
 483           gfc_internal_error
 484             ("gfc_show_expr(): Bad intrinsic in expression!");
 485         }
 486
 487       gfc_show_expr (p->value.op.op1);
 488
 489       if (p->value.op.op2)
 490         {
 491           gfc_status (" ");
 492           gfc_show_expr (p->value.op.op2);
 493         }
 494
 495       gfc_status (")");
 496       break;
 497
 498     case EXPR_FUNCTION:
 499       if (p->value.function.name == NULL)
 500         {
 501           gfc_status ("%s[", p->symtree->n.sym->name);
 502           gfc_show_actual_arglist (p->value.function.actual);
 503           gfc_status_char (']');
 504         }
 505       else
 506         {
 507           gfc_status ("%s[[", p->value.function.name);
 508           gfc_show_actual_arglist (p->value.function.actual);
 509           gfc_status_char (']');
 510           gfc_status_char (']');
 511         }
 512
 513       break;
 514
 515     default:
 516       gfc_internal_error ("gfc_show_expr(): Don't know how to show expr");
 517     }
 518 }
 519
 520
 521 /* Show symbol attributes.  The flavor and intent are followed by
 522    whatever single bit attributes are present.  */
 523
 524 static void
 525 gfc_show_attr (symbol_attribute * attr)
 526 {
 527
 528   gfc_status ("(%s %s %s %s", gfc_code2string (flavors, attr->flavor),
 529               gfc_intent_string (attr->intent),
 530               gfc_code2string (access_types, attr->access),
 531               gfc_code2string (procedures, attr->proc));
 532
 533   if (attr->allocatable)
 534     gfc_status (" ALLOCATABLE");
 535   if (attr->dimension)
 536     gfc_status (" DIMENSION");
 537   if (attr->external)
 538     gfc_status (" EXTERNAL");
 539   if (attr->intrinsic)
 540     gfc_status (" INTRINSIC");
 541   if (attr->optional)
 542     gfc_status (" OPTIONAL");
 543   if (attr->pointer)
 544     gfc_status (" POINTER");
 545   if (attr->save)
 546     gfc_status (" SAVE");
 547   if (attr->target)
 548     gfc_status (" TARGET");
 549   if (attr->dummy)
 550     gfc_status (" DUMMY");
 551   if (attr->result)
 552     gfc_status (" RESULT");
 553   if (attr->entry)
 554     gfc_status (" ENTRY");
 555
 556   if (attr->data)
 557     gfc_status (" DATA");
 558   if (attr->use_assoc)
 559     gfc_status (" USE-ASSOC");
 560   if (attr->in_namelist)
 561     gfc_status (" IN-NAMELIST");
 562   if (attr->in_common)
 563     gfc_status (" IN-COMMON");
 564
 565   if (attr->function)
 566     gfc_status (" FUNCTION");
 567   if (attr->subroutine)
 568     gfc_status (" SUBROUTINE");
 569   if (attr->implicit_type)
 570     gfc_status (" IMPLICIT-TYPE");
 571
 572   if (attr->sequence)
 573     gfc_status (" SEQUENCE");
 574   if (attr->elemental)
 575     gfc_status (" ELEMENTAL");
 576   if (attr->pure)
 577     gfc_status (" PURE");
 578   if (attr->recursive)
 579     gfc_status (" RECURSIVE");
 580
 581   gfc_status (")");
 582 }
 583
 584
 585 /* Show components of a derived type.  */
 586
 587 static void
 588 gfc_show_components (gfc_symbol * sym)
 589 {
 590   gfc_component *c;
 591
 592   for (c = sym->components; c; c = c->next)
 593     {
 594       gfc_status ("(%s ", c->name);
 595       gfc_show_typespec (&c->ts);
 596       if (c->pointer)
 597         gfc_status (" POINTER");
 598       if (c->dimension)
 599         gfc_status (" DIMENSION");
 600       gfc_status_char (' ');
 601       gfc_show_array_spec (c->as);
 602       gfc_status (")");
 603       if (c->next != NULL)
 604         gfc_status_char (' ');
 605     }
 606 }
 607
 608
 609 /* Show a symbol.  If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
 610    show the interface.  Information needed to reconstruct the list of
 611    specific interfaces associated with a generic symbol is done within
 612    that symbol.  */
 613
 614 static void
 615 gfc_show_symbol (gfc_symbol * sym)
 616 {
 617   gfc_formal_arglist *formal;
 618   gfc_interface *intr;
 619
 620   if (sym == NULL)
 621     return;
 622
 623   show_indent ();
 624
 625   gfc_status ("symbol %s ", sym->name);
 626   gfc_show_typespec (&sym->ts);
 627   gfc_show_attr (&sym->attr);
 628
 629   if (sym->value)
 630     {
 631       show_indent ();
 632       gfc_status ("value: ");
 633       gfc_show_expr (sym->value);
 634     }
 635
 636   if (sym->as)
 637     {
 638       show_indent ();
 639       gfc_status ("Array spec:");
 640       gfc_show_array_spec (sym->as);
 641     }
 642
 643   if (sym->generic)
 644     {
 645       show_indent ();
 646       gfc_status ("Generic interfaces:");
 647       for (intr = sym->generic; intr; intr = intr->next)
 648         gfc_status (" %s", intr->sym->name);
 649     }
 650
 651   if (sym->result)
 652     {
 653       show_indent ();
 654       gfc_status ("result: %s", sym->result->name);
 655     }
 656
 657   if (sym->components)
 658     {
 659       show_indent ();
 660       gfc_status ("components: ");
 661       gfc_show_components (sym);
 662     }
 663
 664   if (sym->formal)
 665     {
 666       show_indent ();
 667       gfc_status ("Formal arglist:");
 668
 669       for (formal = sym->formal; formal; formal = formal->next)
 670         {
 671           if (formal->sym != NULL)
 672             gfc_status (" %s", formal->sym->name);
 673           else
 674             gfc_status (" [Alt Return]");
 675         }
 676     }
 677
 678   if (sym->formal_ns)
 679     {
 680       show_indent ();
 681       gfc_status ("Formal namespace");
 682       gfc_show_namespace (sym->formal_ns);
 683     }
 684
 685   gfc_status_char ('\n');
 686 }
 687
 688
 689 /* Show a user-defined operator.  Just prints an operator
 690    and the name of the associated subroutine, really.  */
 691
 692 static void
 693 show_uop (gfc_user_op * uop)
 694 {
 695   gfc_interface *intr;
 696
 697   show_indent ();
 698   gfc_status ("%s:", uop->name);
 699
 700   for (intr = uop->operator; intr; intr = intr->next)
 701     gfc_status (" %s", intr->sym->name);
 702 }
 703
 704
 705 /* Workhorse function for traversing the user operator symtree.  */
 706
 707 static void
 708 traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
 709 {
 710
 711   if (st == NULL)
 712     return;
 713
 714   (*func) (st->n.uop);
 715
 716   traverse_uop (st->left, func);
 717   traverse_uop (st->right, func);
 718 }
 719
 720
 721 /* Traverse the tree of user operator nodes.  */
 722
 723 void
 724 gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
 725 {
 726
 727   traverse_uop (ns->uop_root, func);
 728 }
 729
 730
 731 /* Function to display a common block.  */
 732
 733 static void
 734 show_common (gfc_symtree * st)
 735 {
 736   gfc_symbol *s;
 737
 738   show_indent ();
 739   gfc_status ("common: /%s/ ", st->name);
 740
 741   s = st->n.common->head;
 742   while (s)
 743     {
 744       gfc_status ("%s", s->name);
 745       s = s->common_next;
 746       if (s)
 747         gfc_status (", ");
 748     }
 749   gfc_status_char ('\n');
 750 }
 751
 752
 753 /* Worker function to display the symbol tree.  */
 754
 755 static void
 756 show_symtree (gfc_symtree * st)
 757 {
 758
 759   show_indent ();
 760   gfc_status ("symtree: %s  Ambig %d", st->name, st->ambiguous);
 761
 762   if (st->n.sym->ns != gfc_current_ns)
 763     gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
 764   else
 765     gfc_show_symbol (st->n.sym);
 766 }
 767
 768
 769 /******************* Show gfc_code structures **************/
 770
 771
 772
 773 static void gfc_show_code_node (int level, gfc_code * c);
 774
 775 /* Show a list of code structures.  Mutually recursive with
 776    gfc_show_code_node().  */
 777
 778 static void
 779 gfc_show_code (int level, gfc_code * c)
 780 {
 781
 782   for (; c; c = c->next)
 783     gfc_show_code_node (level, c);
 784 }
 785
 786
 787 /* Show a single code node and everything underneath it if necessary.  */
 788
 789 static void
 790 gfc_show_code_node (int level, gfc_code * c)
 791 {
 792   gfc_forall_iterator *fa;
 793   gfc_open *open;
 794   gfc_case *cp;
 795   gfc_alloc *a;
 796   gfc_code *d;
 797   gfc_close *close;
 798   gfc_filepos *fp;
 799   gfc_inquire *i;
 800   gfc_dt *dt;
 801
 802   code_indent (level, c->here);
 803
 804   switch (c->op)
 805     {
 806     case EXEC_NOP:
 807       gfc_status ("NOP");
 808       break;
 809
 810     case EXEC_CONTINUE:
 811       gfc_status ("CONTINUE");
 812       break;
 813
 814     case EXEC_ENTRY:
 815       gfc_status ("ENTRY %s", c->ext.entry->sym->name);
 816       break;
 817
 818     case EXEC_ASSIGN:
 819       gfc_status ("ASSIGN ");
 820       gfc_show_expr (c->expr);
 821       gfc_status_char (' ');
 822       gfc_show_expr (c->expr2);
 823       break;
 824
 825     case EXEC_LABEL_ASSIGN:
 826       gfc_status ("LABEL ASSIGN ");
 827       gfc_show_expr (c->expr);
 828       gfc_status (" %d", c->label->value);
 829       break;
 830
 831     case EXEC_POINTER_ASSIGN:
 832       gfc_status ("POINTER ASSIGN ");
 833       gfc_show_expr (c->expr);
 834       gfc_status_char (' ');
 835       gfc_show_expr (c->expr2);
 836       break;
 837
 838     case EXEC_GOTO:
 839       gfc_status ("GOTO ");
 840       if (c->label)
 841         gfc_status ("%d", c->label->value);
 842       else
 843         {
 844           gfc_show_expr (c->expr);
 845           d = c->block;
 846           if (d != NULL)
 847             {
 848               gfc_status (", (");
 849               for (; d; d = d ->block)
 850                 {
 851                   code_indent (level, d->label);
 852                   if (d->block != NULL)
 853                     gfc_status_char (',');
 854                   else
 855                     gfc_status_char (')');
 856                 }
 857             }
 858         }
 859       break;
 860
 861     case EXEC_CALL:
 862       gfc_status ("CALL %s ", c->resolved_sym->name);
 863       gfc_show_actual_arglist (c->ext.actual);
 864       break;
 865
 866     case EXEC_RETURN:
 867       gfc_status ("RETURN ");
 868       if (c->expr)
 869         gfc_show_expr (c->expr);
 870       break;
 871
 872     case EXEC_PAUSE:
 873       gfc_status ("PAUSE ");
 874
 875       if (c->expr != NULL)
 876         gfc_show_expr (c->expr);
 877       else
 878         gfc_status ("%d", c->ext.stop_code);
 879
 880       break;
 881
 882     case EXEC_STOP:
 883       gfc_status ("STOP ");
 884
 885       if (c->expr != NULL)
 886         gfc_show_expr (c->expr);
 887       else
 888         gfc_status ("%d", c->ext.stop_code);
 889
 890       break;
 891
 892     case EXEC_ARITHMETIC_IF:
 893       gfc_status ("IF ");
 894       gfc_show_expr (c->expr);
 895       gfc_status (" %d, %d, %d",
 896                   c->label->value, c->label2->value, c->label3->value);
 897       break;
 898
 899     case EXEC_IF:
 900       d = c->block;
 901       gfc_status ("IF ");
 902       gfc_show_expr (d->expr);
 903       gfc_status_char ('\n');
 904       gfc_show_code (level + 1, d->next);
 905
 906       d = d->block;
 907       for (; d; d = d->block)
 908         {
 909           code_indent (level, 0);
 910
 911           if (d->expr == NULL)
 912             gfc_status ("ELSE\n");
 913           else
 914             {
 915               gfc_status ("ELSE IF ");
 916               gfc_show_expr (d->expr);
 917               gfc_status_char ('\n');
 918             }
 919
 920           gfc_show_code (level + 1, d->next);
 921         }
 922
 923       code_indent (level, c->label);
 924
 925       gfc_status ("ENDIF");
 926       break;
 927
 928     case EXEC_SELECT:
 929       d = c->block;
 930       gfc_status ("SELECT CASE ");
 931       gfc_show_expr (c->expr);
 932       gfc_status_char ('\n');
 933
 934       for (; d; d = d->block)
 935         {
 936           code_indent (level, 0);
 937
 938           gfc_status ("CASE ");
 939           for (cp = d->ext.case_list; cp; cp = cp->next)
 940             {
 941               gfc_status_char ('(');
 942               gfc_show_expr (cp->low);
 943               gfc_status_char (' ');
 944               gfc_show_expr (cp->high);
 945               gfc_status_char (')');
 946               gfc_status_char (' ');
 947             }
 948           gfc_status_char ('\n');
 949
 950           gfc_show_code (level + 1, d->next);
 951         }
 952
 953       code_indent (level, c->label);
 954       gfc_status ("END SELECT");
 955       break;
 956
 957     case EXEC_WHERE:
 958       gfc_status ("WHERE ");
 959
 960       d = c->block;
 961       gfc_show_expr (d->expr);
 962       gfc_status_char ('\n');
 963
 964       gfc_show_code (level + 1, d->next);
 965
 966       for (d = d->block; d; d = d->block)
 967         {
 968           code_indent (level, 0);
 969           gfc_status ("ELSE WHERE ");
 970           gfc_show_expr (d->expr);
 971           gfc_status_char ('\n');
 972           gfc_show_code (level + 1, d->next);
 973         }
 974
 975       code_indent (level, 0);
 976       gfc_status ("END WHERE");
 977       break;
 978
 979
 980     case EXEC_FORALL:
 981       gfc_status ("FORALL ");
 982       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
 983         {
 984           gfc_show_expr (fa->var);
 985           gfc_status_char (' ');
 986           gfc_show_expr (fa->start);
 987           gfc_status_char (':');
 988           gfc_show_expr (fa->end);
 989           gfc_status_char (':');
 990           gfc_show_expr (fa->stride);
 991
 992           if (fa->next != NULL)
 993             gfc_status_char (',');
 994         }
 995
 996       if (c->expr != NULL)
 997         {
 998           gfc_status_char (',');
 999           gfc_show_expr (c->expr);
1000         }
1001       gfc_status_char ('\n');
1002
1003       gfc_show_code (level + 1, c->block->next);
1004
1005       code_indent (level, 0);
1006       gfc_status ("END FORALL");
1007       break;
1008
1009     case EXEC_DO:
1010       gfc_status ("DO ");
1011
1012       gfc_show_expr (c->ext.iterator->var);
1013       gfc_status_char ('=');
1014       gfc_show_expr (c->ext.iterator->start);
1015       gfc_status_char (' ');
1016       gfc_show_expr (c->ext.iterator->end);
1017       gfc_status_char (' ');
1018       gfc_show_expr (c->ext.iterator->step);
1019       gfc_status_char ('\n');
1020
1021       gfc_show_code (level + 1, c->block->next);
1022
1023       code_indent (level, 0);
1024       gfc_status ("END DO");
1025       break;
1026
1027     case EXEC_DO_WHILE:
1028       gfc_status ("DO WHILE ");
1029       gfc_show_expr (c->expr);
1030       gfc_status_char ('\n');
1031
1032       gfc_show_code (level + 1, c->block->next);
1033
1034       code_indent (level, c->label);
1035       gfc_status ("END DO");
1036       break;
1037
1038     case EXEC_CYCLE:
1039       gfc_status ("CYCLE");
1040       if (c->symtree)
1041         gfc_status (" %s", c->symtree->n.sym->name);
1042       break;
1043
1044     case EXEC_EXIT:
1045       gfc_status ("EXIT");
1046       if (c->symtree)
1047         gfc_status (" %s", c->symtree->n.sym->name);
1048       break;
1049
1050     case EXEC_ALLOCATE:
1051       gfc_status ("ALLOCATE ");
1052       if (c->expr)
1053         {
1054           gfc_status (" STAT=");
1055           gfc_show_expr (c->expr);
1056         }
1057
1058       for (a = c->ext.alloc_list; a; a = a->next)
1059         {
1060           gfc_status_char (' ');
1061           gfc_show_expr (a->expr);
1062         }
1063
1064       break;
1065
1066     case EXEC_DEALLOCATE:
1067       gfc_status ("DEALLOCATE ");
1068       if (c->expr)
1069         {
1070           gfc_status (" STAT=");
1071           gfc_show_expr (c->expr);
1072         }
1073
1074       for (a = c->ext.alloc_list; a; a = a->next)
1075         {
1076           gfc_status_char (' ');
1077           gfc_show_expr (a->expr);
1078         }
1079
1080       break;
1081
1082     case EXEC_OPEN:
1083       gfc_status ("OPEN");
1084       open = c->ext.open;
1085
1086       if (open->unit)
1087         {
1088           gfc_status (" UNIT=");
1089           gfc_show_expr (open->unit);
1090         }
1091       if (open->iomsg)
1092         {
1093           gfc_status (" IOMSG=");
1094           gfc_show_expr (open->iomsg);
1095         }
1096       if (open->iostat)
1097         {
1098           gfc_status (" IOSTAT=");
1099           gfc_show_expr (open->iostat);
1100         }
1101       if (open->file)
1102         {
1103           gfc_status (" FILE=");
1104           gfc_show_expr (open->file);
1105         }
1106       if (open->status)
1107         {
1108           gfc_status (" STATUS=");
1109           gfc_show_expr (open->status);
1110         }
1111       if (open->access)
1112         {
1113           gfc_status (" ACCESS=");
1114           gfc_show_expr (open->access);
1115         }
1116       if (open->form)
1117         {
1118           gfc_status (" FORM=");
1119           gfc_show_expr (open->form);
1120         }
1121       if (open->recl)
1122         {
1123           gfc_status (" RECL=");
1124           gfc_show_expr (open->recl);
1125         }
1126       if (open->blank)
1127         {
1128           gfc_status (" BLANK=");
1129           gfc_show_expr (open->blank);
1130         }
1131       if (open->position)
1132         {
1133           gfc_status (" POSITION=");
1134           gfc_show_expr (open->position);
1135         }
1136       if (open->action)
1137         {
1138           gfc_status (" ACTION=");
1139           gfc_show_expr (open->action);
1140         }
1141       if (open->delim)
1142         {
1143           gfc_status (" DELIM=");
1144           gfc_show_expr (open->delim);
1145         }
1146       if (open->pad)
1147         {
1148           gfc_status (" PAD=");
1149           gfc_show_expr (open->pad);
1150         }
1151       if (open->err != NULL)
1152         gfc_status (" ERR=%d", open->err->value);
1153
1154       break;
1155
1156     case EXEC_CLOSE:
1157       gfc_status ("CLOSE");
1158       close = c->ext.close;
1159
1160       if (close->unit)
1161         {
1162           gfc_status (" UNIT=");
1163           gfc_show_expr (close->unit);
1164         }
1165       if (close->iomsg)
1166         {
1167           gfc_status (" IOMSG=");
1168           gfc_show_expr (close->iomsg);
1169         }
1170       if (close->iostat)
1171         {
1172           gfc_status (" IOSTAT=");
1173           gfc_show_expr (close->iostat);
1174         }
1175       if (close->status)
1176         {
1177           gfc_status (" STATUS=");
1178           gfc_show_expr (close->status);
1179         }
1180       if (close->err != NULL)
1181         gfc_status (" ERR=%d", close->err->value);
1182       break;
1183
1184     case EXEC_BACKSPACE:
1185       gfc_status ("BACKSPACE");
1186       goto show_filepos;
1187
1188     case EXEC_ENDFILE:
1189       gfc_status ("ENDFILE");
1190       goto show_filepos;
1191
1192     case EXEC_REWIND:
1193       gfc_status ("REWIND");
1194       goto show_filepos;
1195
1196     case EXEC_FLUSH:
1197       gfc_status ("FLUSH");
1198
1199     show_filepos:
1200       fp = c->ext.filepos;
1201
1202       if (fp->unit)
1203         {
1204           gfc_status (" UNIT=");
1205           gfc_show_expr (fp->unit);
1206         }
1207       if (fp->iomsg)
1208         {
1209           gfc_status (" IOMSG=");
1210           gfc_show_expr (fp->iomsg);
1211         }
1212       if (fp->iostat)
1213         {
1214           gfc_status (" IOSTAT=");
1215           gfc_show_expr (fp->iostat);
1216         }
1217       if (fp->err != NULL)
1218         gfc_status (" ERR=%d", fp->err->value);
1219       break;
1220
1221     case EXEC_INQUIRE:
1222       gfc_status ("INQUIRE");
1223       i = c->ext.inquire;
1224
1225       if (i->unit)
1226         {
1227           gfc_status (" UNIT=");
1228           gfc_show_expr (i->unit);
1229         }
1230       if (i->file)
1231         {
1232           gfc_status (" FILE=");
1233           gfc_show_expr (i->file);
1234         }
1235
1236       if (i->iomsg)
1237         {
1238           gfc_status (" IOMSG=");
1239           gfc_show_expr (i->iomsg);
1240         }
1241       if (i->iostat)
1242         {
1243           gfc_status (" IOSTAT=");
1244           gfc_show_expr (i->iostat);
1245         }
1246       if (i->exist)
1247         {
1248           gfc_status (" EXIST=");
1249           gfc_show_expr (i->exist);
1250         }
1251       if (i->opened)
1252         {
1253           gfc_status (" OPENED=");
1254           gfc_show_expr (i->opened);
1255         }
1256       if (i->number)
1257         {
1258           gfc_status (" NUMBER=");
1259           gfc_show_expr (i->number);
1260         }
1261       if (i->named)
1262         {
1263           gfc_status (" NAMED=");
1264           gfc_show_expr (i->named);
1265         }
1266       if (i->name)
1267         {
1268           gfc_status (" NAME=");
1269           gfc_show_expr (i->name);
1270         }
1271       if (i->access)
1272         {
1273           gfc_status (" ACCESS=");
1274           gfc_show_expr (i->access);
1275         }
1276       if (i->sequential)
1277         {
1278           gfc_status (" SEQUENTIAL=");
1279           gfc_show_expr (i->sequential);
1280         }
1281
1282       if (i->direct)
1283         {
1284           gfc_status (" DIRECT=");
1285           gfc_show_expr (i->direct);
1286         }
1287       if (i->form)
1288         {
1289           gfc_status (" FORM=");
1290           gfc_show_expr (i->form);
1291         }
1292       if (i->formatted)
1293         {
1294           gfc_status (" FORMATTED");
1295           gfc_show_expr (i->formatted);
1296         }
1297       if (i->unformatted)
1298         {
1299           gfc_status (" UNFORMATTED=");
1300           gfc_show_expr (i->unformatted);
1301         }
1302       if (i->recl)
1303         {
1304           gfc_status (" RECL=");
1305           gfc_show_expr (i->recl);
1306         }
1307       if (i->nextrec)
1308         {
1309           gfc_status (" NEXTREC=");
1310           gfc_show_expr (i->nextrec);
1311         }
1312       if (i->blank)
1313         {
1314           gfc_status (" BLANK=");
1315           gfc_show_expr (i->blank);
1316         }
1317       if (i->position)
1318         {
1319           gfc_status (" POSITION=");
1320           gfc_show_expr (i->position);
1321         }
1322       if (i->action)
1323         {
1324           gfc_status (" ACTION=");
1325           gfc_show_expr (i->action);
1326         }
1327       if (i->read)
1328         {
1329           gfc_status (" READ=");
1330           gfc_show_expr (i->read);
1331         }
1332       if (i->write)
1333         {
1334           gfc_status (" WRITE=");
1335           gfc_show_expr (i->write);
1336         }
1337       if (i->readwrite)
1338         {
1339           gfc_status (" READWRITE=");
1340           gfc_show_expr (i->readwrite);
1341         }
1342       if (i->delim)
1343         {
1344           gfc_status (" DELIM=");
1345           gfc_show_expr (i->delim);
1346         }
1347       if (i->pad)
1348         {
1349           gfc_status (" PAD=");
1350           gfc_show_expr (i->pad);
1351         }
1352
1353       if (i->err != NULL)
1354         gfc_status (" ERR=%d", i->err->value);
1355       break;
1356
1357     case EXEC_IOLENGTH:
1358       gfc_status ("IOLENGTH ");
1359       gfc_show_expr (c->expr);
1360       break;
1361
1362     case EXEC_READ:
1363       gfc_status ("READ");
1364       goto show_dt;
1365
1366     case EXEC_WRITE:
1367       gfc_status ("WRITE");
1368
1369     show_dt:
1370       dt = c->ext.dt;
1371       if (dt->io_unit)
1372         {
1373           gfc_status (" UNIT=");
1374           gfc_show_expr (dt->io_unit);
1375         }
1376
1377       if (dt->format_expr)
1378         {
1379           gfc_status (" FMT=");
1380           gfc_show_expr (dt->format_expr);
1381         }
1382
1383       if (dt->format_label != NULL)
1384         gfc_status (" FMT=%d", dt->format_label->value);
1385       if (dt->namelist)
1386         gfc_status (" NML=%s", dt->namelist->name);
1387
1388       if (dt->iomsg)
1389         {
1390           gfc_status (" IOMSG=");
1391           gfc_show_expr (dt->iomsg);
1392         }
1393       if (dt->iostat)
1394         {
1395           gfc_status (" IOSTAT=");
1396           gfc_show_expr (dt->iostat);
1397         }
1398       if (dt->size)
1399         {
1400           gfc_status (" SIZE=");
1401           gfc_show_expr (dt->size);
1402         }
1403       if (dt->rec)
1404         {
1405           gfc_status (" REC=");
1406           gfc_show_expr (dt->rec);
1407         }
1408       if (dt->advance)
1409         {
1410           gfc_status (" ADVANCE=");
1411           gfc_show_expr (dt->advance);
1412         }
1413
1414       break;
1415
1416     case EXEC_TRANSFER:
1417       gfc_status ("TRANSFER ");
1418       gfc_show_expr (c->expr);
1419       break;
1420
1421     case EXEC_DT_END:
1422       gfc_status ("DT_END");
1423       dt = c->ext.dt;
1424
1425       if (dt->err != NULL)
1426         gfc_status (" ERR=%d", dt->err->value);
1427       if (dt->end != NULL)
1428         gfc_status (" END=%d", dt->end->value);
1429       if (dt->eor != NULL)
1430         gfc_status (" EOR=%d", dt->eor->value);
1431       break;
1432
1433     default:
1434       gfc_internal_error ("gfc_show_code_node(): Bad statement code");
1435     }
1436
1437   gfc_status_char ('\n');
1438 }
1439
1440
1441 /* Show an equivalence chain.  */
1442
1443 static void
1444 gfc_show_equiv (gfc_equiv *eq)
1445 {
1446   show_indent ();
1447   gfc_status ("Equivalence: ");
1448   while (eq)
1449     {
1450       gfc_show_expr (eq->expr);
1451       eq = eq->eq;
1452       if (eq)
1453         gfc_status (", ");
1454     }
1455 }
1456
1457
1458 /* Show a freakin' whole namespace.  */
1459
1460 void
1461 gfc_show_namespace (gfc_namespace * ns)
1462 {
1463   gfc_interface *intr;
1464   gfc_namespace *save;
1465   gfc_intrinsic_op op;
1466   gfc_equiv *eq;
1467   int i;
1468
1469   save = gfc_current_ns;
1470   show_level++;
1471
1472   show_indent ();
1473   gfc_status ("Namespace:");
1474
1475   if (ns != NULL)
1476     {
1477       i = 0;
1478       do
1479         {
1480           int l = i;
1481           while (i < GFC_LETTERS - 1
1482                  && gfc_compare_types(&ns->default_type[i+1],
1483                                       &ns->default_type[l]))
1484             i++;
1485
1486           if (i > l)
1487             gfc_status(" %c-%c: ", l+'A', i+'A');
1488           else
1489             gfc_status(" %c: ", l+'A');
1490
1491           gfc_show_typespec(&ns->default_type[l]);
1492           i++;
1493       } while (i < GFC_LETTERS);
1494
1495       if (ns->proc_name != NULL)
1496         {
1497           show_indent ();
1498           gfc_status ("procedure name = %s", ns->proc_name->name);
1499         }
1500
1501       gfc_current_ns = ns;
1502       gfc_traverse_symtree (ns->common_root, show_common);
1503
1504       gfc_traverse_symtree (ns->sym_root, show_symtree);
1505
1506       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
1507         {
1508           /* User operator interfaces */
1509           intr = ns->operator[op];
1510           if (intr == NULL)
1511             continue;
1512
1513           show_indent ();
1514           gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
1515
1516           for (; intr; intr = intr->next)
1517             gfc_status (" %s", intr->sym->name);
1518         }
1519
1520       if (ns->uop_root != NULL)
1521         {
1522           show_indent ();
1523           gfc_status ("User operators:\n");
1524           gfc_traverse_user_op (ns, show_uop);
1525         }
1526     }
1527
1528   for (eq = ns->equiv; eq; eq = eq->next)
1529     gfc_show_equiv (eq);
1530
1531   gfc_status_char ('\n');
1532   gfc_status_char ('\n');
1533
1534   gfc_show_code (0, ns->code);
1535
1536   for (ns = ns->contained; ns; ns = ns->sibling)
1537     {
1538       show_indent ();
1539       gfc_status ("CONTAINS\n");
1540       gfc_show_namespace (ns);
1541     }
1542
1543   show_level--;
1544   gfc_status_char ('\n');
1545   gfc_current_ns = save;
1546 }