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