gcc/fortran/dump-parse-tree.c

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