Merge tree-ssa-20020619-branch into mainline.

From-SVN: r81764

1 files changed, 1459 insertions, 0 deletions

diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
new file mode 100644
index 0000000..1083c64
--- /dev/null
+++ b/gcc/fortran/dump-parse-tree.c
@@ -0,0 +1,1459 @@
+/* Parse tree dumper
+   Copyright (C) 2003 Free Software Foundation, Inc.
+   Contributed by Steven Bosscher
+
+This file is part of GNU G95.
+
+GNU G95 is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU G95 is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU G95; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+
+/* Actually this is just a collection of routines that used to be
+   scattered around the sources.  Now that they are all in a single
+   file, almost all of them can be static, and the other files don't
+   have this mess in them.
+
+   As a nice side-effect, this file can act as documentation of the
+   gfc_code and gfc_expr structures and all their friends and
+   relatives.
+
+   TODO: Dump DATA.  */
+
+#include "config.h"
+#include "gfortran.h"
+
+/* Keep track of indentation for symbol tree dumps.  */
+static int show_level = 0;
+
+
+/* Forward declaration because this one needs all, and all need
+   this one.  */
+static void gfc_show_expr (gfc_expr *);
+
+/* Do indentation for a specific level.  */
+
+static inline void
+code_indent (int level, gfc_st_label * label)
+{
+  int i;
+
+  if (label != NULL)
+    gfc_status ("%-5d ", label->value);
+  else
+    gfc_status ("      ");
+
+  for (i = 0; i < 2 * level; i++)
+    gfc_status_char (' ');
+}
+
+
+/* Simple indentation at the current level.  This one
+   is used to show symbols.  */
+static inline void
+show_indent (void)
+{
+  gfc_status ("\n");
+  code_indent (show_level, NULL);
+}
+
+
+/* Show type-specific information.  */
+static void
+gfc_show_typespec (gfc_typespec * ts)
+{
+
+  gfc_status ("(%s ", gfc_basic_typename (ts->type));
+
+  switch (ts->type)
+    {
+    case BT_DERIVED:
+      gfc_status ("%s", ts->derived->name);
+      break;
+
+    case BT_CHARACTER:
+      gfc_show_expr (ts->cl->length);
+      break;
+
+    default:
+      gfc_status ("%d", ts->kind);
+      break;
+    }
+
+  gfc_status (")");
+}
+
+
+/* Show an actual argument list.  */
+
+static void
+gfc_show_actual_arglist (gfc_actual_arglist * a)
+{
+
+  gfc_status ("(");
+
+  for (; a; a = a->next)
+    {
+      gfc_status_char ('(');
+      if (a->name[0] != '\0')
+	gfc_status ("%s = ", a->name);
+      if (a->expr != NULL)
+	gfc_show_expr (a->expr);
+      else
+	gfc_status ("(arg not-present)");
+
+      gfc_status_char (')');
+      if (a->next != NULL)
+	gfc_status (" ");
+    }
+
+  gfc_status (")");
+}
+
+
+/* Show an gfc_array_spec array specification structure.  */
+
+static void
+gfc_show_array_spec (gfc_array_spec * as)
+{
+  const char *c;
+  int i;
+
+  if (as == NULL)
+    {
+      gfc_status ("()");
+      return;
+    }
+
+  gfc_status ("(%d", as->rank);
+
+  if (as->rank != 0)
+    {
+      switch (as->type)
+      {
+	case AS_EXPLICIT:      c = "AS_EXPLICIT";      break;
+	case AS_DEFERRED:      c = "AS_DEFERRED";      break;
+	case AS_ASSUMED_SIZE:  c = "AS_ASSUMED_SIZE";  break;
+	case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
+	default:
+	  gfc_internal_error
+		("gfc_show_array_spec(): Unhandled array shape type.");
+      }
+      gfc_status (" %s ", c);
+
+      for (i = 0; i < as->rank; i++)
+	{
+	  gfc_show_expr (as->lower[i]);
+	  gfc_status_char (' ');
+	  gfc_show_expr (as->upper[i]);
+	  gfc_status_char (' ');
+	}
+    }
+
+  gfc_status (")");
+}
+
+
+/* Show an gfc_array_ref array reference structure.  */
+
+static void
+gfc_show_array_ref (gfc_array_ref * ar)
+{
+  int i;
+
+  gfc_status_char ('(');
+
+  switch (ar->type)
+    {
+    case AR_FULL:
+      gfc_status ("FULL");
+      break;
+
+    case AR_SECTION:
+      for (i = 0; i < ar->dimen; i++)
+	{
+	  if (ar->start[i] != NULL)
+	    gfc_show_expr (ar->start[i]);
+
+	  gfc_status_char (':');
+
+	  if (ar->end[i] != NULL)
+	    gfc_show_expr (ar->end[i]);
+
+	  if (ar->stride[i] != NULL)
+	    {
+	      gfc_status_char (':');
+	      gfc_show_expr (ar->stride[i]);
+	    }
+
+	  if (i != ar->dimen - 1)
+	    gfc_status (" , ");
+	}
+      break;
+
+    case AR_ELEMENT:
+      for (i = 0; i < ar->dimen; i++)
+	{
+	  gfc_show_expr (ar->start[i]);
+	  if (i != ar->dimen - 1)
+	    gfc_status (" , ");
+	}
+      break;
+
+    case AR_UNKNOWN:
+      gfc_status ("UNKNOWN");
+      break;
+
+    default:
+      gfc_internal_error ("gfc_show_array_ref(): Unknown array reference");
+    }
+
+  gfc_status_char (')');
+}
+
+
+/* Show a list of gfc_ref structures.  */
+
+static void
+gfc_show_ref (gfc_ref * p)
+{
+
+  for (; p; p = p->next)
+    switch (p->type)
+      {
+      case REF_ARRAY:
+	gfc_show_array_ref (&p->u.ar);
+	break;
+
+      case REF_COMPONENT:
+	gfc_status (" %% %s", p->u.c.component->name);
+	break;
+
+      case REF_SUBSTRING:
+	gfc_status_char ('(');
+	gfc_show_expr (p->u.ss.start);
+	gfc_status_char (':');
+	gfc_show_expr (p->u.ss.end);
+	gfc_status_char (')');
+	break;
+
+      default:
+	gfc_internal_error ("gfc_show_ref(): Bad component code");
+      }
+}
+
+
+/* Display a constructor.  Works recursively for array constructors.  */
+
+static void
+gfc_show_constructor (gfc_constructor * c)
+{
+
+  for (; c; c = c->next)
+    {
+      if (c->iterator == NULL)
+	gfc_show_expr (c->expr);
+      else
+	{
+	  gfc_status_char ('(');
+	  gfc_show_expr (c->expr);
+
+	  gfc_status_char (' ');
+	  gfc_show_expr (c->iterator->var);
+	  gfc_status_char ('=');
+	  gfc_show_expr (c->iterator->start);
+	  gfc_status_char (',');
+	  gfc_show_expr (c->iterator->end);
+	  gfc_status_char (',');
+	  gfc_show_expr (c->iterator->step);
+
+	  gfc_status_char (')');
+	}
+
+      if (c->next != NULL)
+	gfc_status (" , ");
+    }
+}
+
+
+/* Show an expression.  */
+
+static void
+gfc_show_expr (gfc_expr * p)
+{
+  const char *c;
+  int i;
+
+  if (p == NULL)
+    {
+      gfc_status ("()");
+      return;
+    }
+
+  switch (p->expr_type)
+    {
+    case EXPR_SUBSTRING:
+      c = p->value.character.string;
+
+      for (i = 0; i < p->value.character.length; i++, c++)
+	{
+	  if (*c == '\'')
+	    gfc_status ("''");
+	  else
+	    gfc_status ("%c", *c);
+	}
+
+      gfc_show_ref (p->ref);
+      break;
+
+    case EXPR_STRUCTURE:
+      gfc_status ("%s(", p->ts.derived->name);
+      gfc_show_constructor (p->value.constructor);
+      gfc_status_char (')');
+      break;
+
+    case EXPR_ARRAY:
+      gfc_status ("(/ ");
+      gfc_show_constructor (p->value.constructor);
+      gfc_status (" /)");
+
+      gfc_show_ref (p->ref);
+      break;
+
+    case EXPR_NULL:
+      gfc_status ("NULL()");
+      break;
+
+    case EXPR_CONSTANT:
+      switch (p->ts.type)
+	{
+	case BT_INTEGER:
+	  mpz_out_str (stdout, 10, p->value.integer);
+
+	  if (p->ts.kind != gfc_default_integer_kind ())
+	    gfc_status ("_%d", p->ts.kind);
+	  break;
+
+	case BT_LOGICAL:
+	  if (p->value.logical)
+	    gfc_status (".true.");
+	  else
+	    gfc_status (".false.");
+	  break;
+
+	case BT_REAL:
+	  mpf_out_str (stdout, 10, 0, p->value.real);
+	  if (p->ts.kind != gfc_default_real_kind ())
+	    gfc_status ("_%d", p->ts.kind);
+	  break;
+
+	case BT_CHARACTER:
+	  c = p->value.character.string;
+
+	  gfc_status_char ('\'');
+
+	  for (i = 0; i < p->value.character.length; i++, c++)
+	    {
+	      if (*c == '\'')
+		gfc_status ("''");
+	      else
+		gfc_status_char (*c);
+	    }
+
+	  gfc_status_char ('\'');
+
+	  break;
+
+	case BT_COMPLEX:
+	  gfc_status ("(complex ");
+
+	  mpf_out_str (stdout, 10, 0, p->value.complex.r);
+	  if (p->ts.kind != gfc_default_complex_kind ())
+	    gfc_status ("_%d", p->ts.kind);
+
+	  gfc_status (" ");
+
+	  mpf_out_str (stdout, 10, 0, p->value.complex.i);
+	  if (p->ts.kind != gfc_default_complex_kind ())
+	    gfc_status ("_%d", p->ts.kind);
+
+	  gfc_status (")");
+	  break;
+
+	default:
+	  gfc_status ("???");
+	  break;
+	}
+
+      break;
+
+    case EXPR_VARIABLE:
+      gfc_status ("%s", p->symtree->n.sym->name);
+      gfc_show_ref (p->ref);
+      break;
+
+    case EXPR_OP:
+      gfc_status ("(");
+      switch (p->operator)
+	{
+	case INTRINSIC_UPLUS:
+	  gfc_status ("U+ ");
+	  break;
+	case INTRINSIC_UMINUS:
+	  gfc_status ("U- ");
+	  break;
+	case INTRINSIC_PLUS:
+	  gfc_status ("+ ");
+	  break;
+	case INTRINSIC_MINUS:
+	  gfc_status ("- ");
+	  break;
+	case INTRINSIC_TIMES:
+	  gfc_status ("* ");
+	  break;
+	case INTRINSIC_DIVIDE:
+	  gfc_status ("/ ");
+	  break;
+	case INTRINSIC_POWER:
+	  gfc_status ("** ");
+	  break;
+	case INTRINSIC_CONCAT:
+	  gfc_status ("// ");
+	  break;
+	case INTRINSIC_AND:
+	  gfc_status ("AND ");
+	  break;
+	case INTRINSIC_OR:
+	  gfc_status ("OR ");
+	  break;
+	case INTRINSIC_EQV:
+	  gfc_status ("EQV ");
+	  break;
+	case INTRINSIC_NEQV:
+	  gfc_status ("NEQV ");
+	  break;
+	case INTRINSIC_EQ:
+	  gfc_status ("= ");
+	  break;
+	case INTRINSIC_NE:
+	  gfc_status ("<> ");
+	  break;
+	case INTRINSIC_GT:
+	  gfc_status ("> ");
+	  break;
+	case INTRINSIC_GE:
+	  gfc_status (">= ");
+	  break;
+	case INTRINSIC_LT:
+	  gfc_status ("< ");
+	  break;
+	case INTRINSIC_LE:
+	  gfc_status ("<= ");
+	  break;
+	case INTRINSIC_NOT:
+	  gfc_status ("NOT ");
+	  break;
+
+	default:
+	  gfc_internal_error
+	    ("gfc_show_expr(): Bad intrinsic in expression!");
+	}
+
+      gfc_show_expr (p->op1);
+
+      if (p->op2)
+	{
+	  gfc_status (" ");
+	  gfc_show_expr (p->op2);
+	}
+
+      gfc_status (")");
+      break;
+
+    case EXPR_FUNCTION:
+      if (p->value.function.name == NULL)
+	{
+	  gfc_status ("%s[", p->symtree->n.sym->name);
+	  gfc_show_actual_arglist (p->value.function.actual);
+	  gfc_status_char (']');
+	}
+      else
+	{
+	  gfc_status ("%s[[", p->value.function.name);
+	  gfc_show_actual_arglist (p->value.function.actual);
+	  gfc_status_char (']');
+	  gfc_status_char (']');
+	}
+
+      break;
+
+    default:
+      gfc_internal_error ("gfc_show_expr(): Don't know how to show expr");
+    }
+}
+
+
+/* Show symbol attributes.  The flavor and intent are followed by
+   whatever single bit attributes are present.  */
+
+static void
+gfc_show_attr (symbol_attribute * attr)
+{
+
+  gfc_status ("(%s %s %s %s", gfc_code2string (flavors, attr->flavor),
+	      gfc_intent_string (attr->intent),
+	      gfc_code2string (access_types, attr->access),
+	      gfc_code2string (procedures, attr->proc));
+
+  if (attr->allocatable)
+    gfc_status (" ALLOCATABLE");
+  if (attr->dimension)
+    gfc_status (" DIMENSION");
+  if (attr->external)
+    gfc_status (" EXTERNAL");
+  if (attr->intrinsic)
+    gfc_status (" INTRINSIC");
+  if (attr->optional)
+    gfc_status (" OPTIONAL");
+  if (attr->pointer)
+    gfc_status (" POINTER");
+  if (attr->save)
+    gfc_status (" SAVE");
+  if (attr->target)
+    gfc_status (" TARGET");
+  if (attr->dummy)
+    gfc_status (" DUMMY");
+  if (attr->common)
+    gfc_status (" COMMON");
+  if (attr->result)
+    gfc_status (" RESULT");
+  if (attr->entry)
+    gfc_status (" ENTRY");
+
+  if (attr->data)
+    gfc_status (" DATA");
+  if (attr->use_assoc)
+    gfc_status (" USE-ASSOC");
+  if (attr->in_namelist)
+    gfc_status (" IN-NAMELIST");
+  if (attr->in_common)
+    gfc_status (" IN-COMMON");
+  if (attr->saved_common)
+    gfc_status (" SAVED-COMMON");
+
+  if (attr->function)
+    gfc_status (" FUNCTION");
+  if (attr->subroutine)
+    gfc_status (" SUBROUTINE");
+  if (attr->implicit_type)
+    gfc_status (" IMPLICIT-TYPE");
+
+  if (attr->sequence)
+    gfc_status (" SEQUENCE");
+  if (attr->elemental)
+    gfc_status (" ELEMENTAL");
+  if (attr->pure)
+    gfc_status (" PURE");
+  if (attr->recursive)
+    gfc_status (" RECURSIVE");
+
+  gfc_status (")");
+}
+
+
+/* Show components of a derived type.  */
+
+static void
+gfc_show_components (gfc_symbol * sym)
+{
+  gfc_component *c;
+
+  for (c = sym->components; c; c = c->next)
+    {
+      gfc_status ("(%s ", c->name);
+      gfc_show_typespec (&c->ts);
+      if (c->pointer)
+	gfc_status (" POINTER");
+      if (c->dimension)
+	gfc_status (" DIMENSION");
+      gfc_status_char (' ');
+      gfc_show_array_spec (c->as);
+      gfc_status (")");
+      if (c->next != NULL)
+	gfc_status_char (' ');
+    }
+}
+
+
+/* Show a symbol.  If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
+   show the interface.  Information needed to reconstruct the list of
+   specific interfaces associated with a generic symbol is done within
+   that symbol.  */
+
+static void
+gfc_show_symbol (gfc_symbol * sym)
+{
+  gfc_formal_arglist *formal;
+  gfc_interface *intr;
+  gfc_symbol *s;
+
+  if (sym == NULL)
+    return;
+
+  show_indent ();
+
+  gfc_status ("symbol %s ", sym->name);
+  gfc_show_typespec (&sym->ts);
+  gfc_show_attr (&sym->attr);
+
+  if (sym->value)
+    {
+      show_indent ();
+      gfc_status ("value: ");
+      gfc_show_expr (sym->value);
+    }
+
+  if (sym->as)
+    {
+      show_indent ();
+      gfc_status ("Array spec:");
+      gfc_show_array_spec (sym->as);
+    }
+
+  if (sym->generic)
+    {
+      show_indent ();
+      gfc_status ("Generic interfaces:");
+      for (intr = sym->generic; intr; intr = intr->next)
+	gfc_status (" %s", intr->sym->name);
+    }
+
+  if (sym->common_head)
+    {
+      show_indent ();
+      gfc_status ("Common members:");
+      for (s = sym->common_head; s; s = s->common_next)
+	gfc_status (" %s", s->name);
+    }
+
+  if (sym->result)
+    {
+      show_indent ();
+      gfc_status ("result: %s", sym->result->name);
+    }
+
+  if (sym->components)
+    {
+      show_indent ();
+      gfc_status ("components: ");
+      gfc_show_components (sym);
+    }
+
+  if (sym->formal)
+    {
+      show_indent ();
+      gfc_status ("Formal arglist:");
+
+      for (formal = sym->formal; formal; formal = formal->next)
+	gfc_status (" %s", formal->sym->name);
+    }
+
+  if (sym->formal_ns)
+    {
+      show_indent ();
+      gfc_status ("Formal namespace");
+      gfc_show_namespace (sym->formal_ns);
+    }
+
+  gfc_status_char ('\n');
+}
+
+
+/* Show a user-defined operator.  Just prints an operator
+   and the name of the associated subroutine, really.  */
+static void
+show_uop (gfc_user_op * uop)
+{
+  gfc_interface *intr;
+
+  show_indent ();
+  gfc_status ("%s:", uop->name);
+
+  for (intr = uop->operator; intr; intr = intr->next)
+    gfc_status (" %s", intr->sym->name);
+}
+
+
+/* Workhorse function for traversing the user operator symtree.  */
+
+static void
+traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
+{
+
+  if (st == NULL)
+    return;
+
+  (*func) (st->n.uop);
+
+  traverse_uop (st->left, func);
+  traverse_uop (st->right, func);
+}
+
+
+/* Traverse the tree of user operator nodes.  */
+
+void
+gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
+{
+
+  traverse_uop (ns->uop_root, func);
+}
+
+
+/* Worker function to display the symbol tree.  */
+
+static void
+show_symtree (gfc_symtree * st)
+{
+
+  show_indent ();
+  gfc_status ("symtree: %s  Ambig %d", st->name, st->ambiguous);
+
+  if (st->n.sym->ns != gfc_current_ns)
+    gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
+  else
+    gfc_show_symbol (st->n.sym);
+}
+
+
+/******************* Show gfc_code structures **************/
+
+
+
+static void gfc_show_code_node (int level, gfc_code * c);
+
+/* Show a list of code structures.  Mutually recursive with
+   gfc_show_code_node().  */
+
+static void
+gfc_show_code (int level, gfc_code * c)
+{
+
+  for (; c; c = c->next)
+    gfc_show_code_node (level, c);
+}
+
+
+/* Show a single code node and everything underneath it if necessary.  */
+
+static void
+gfc_show_code_node (int level, gfc_code * c)
+{
+  gfc_forall_iterator *fa;
+  gfc_open *open;
+  gfc_case *cp;
+  gfc_alloc *a;
+  gfc_code *d;
+  gfc_close *close;
+  gfc_filepos *fp;
+  gfc_inquire *i;
+  gfc_dt *dt;
+
+  code_indent (level, c->here);
+
+  switch (c->op)
+    {
+    case EXEC_NOP:
+      gfc_status ("NOP");
+      break;
+
+    case EXEC_CONTINUE:
+      gfc_status ("CONTINUE");
+      break;
+
+    case EXEC_ASSIGN:
+      gfc_status ("ASSIGN ");
+      gfc_show_expr (c->expr);
+      gfc_status_char (' ');
+      gfc_show_expr (c->expr2);
+      break;
+    case EXEC_LABEL_ASSIGN:
+      gfc_status ("LABEL ASSIGN ");
+      gfc_show_expr (c->expr);
+      gfc_status (" %d", c->label->value);
+      break;
+
+    case EXEC_POINTER_ASSIGN:
+      gfc_status ("POINTER ASSIGN ");
+      gfc_show_expr (c->expr);
+      gfc_status_char (' ');
+      gfc_show_expr (c->expr2);
+      break;
+
+    case EXEC_GOTO:
+      gfc_status ("GOTO ");
+      if (c->label)
+        gfc_status ("%d", c->label->value);
+      else
+        {
+          gfc_show_expr (c->expr);
+          d = c->block;
+          if (d != NULL)
+            {
+              gfc_status (", (");
+              for (; d; d = d ->block)
+                {
+                  code_indent (level, d->label);
+                  if (d->block != NULL)
+                    gfc_status_char (',');
+                  else
+                    gfc_status_char (')');
+                }
+            }
+        }
+      break;
+
+    case EXEC_CALL:
+      gfc_status ("CALL %s ", c->resolved_sym->name);
+      gfc_show_actual_arglist (c->ext.actual);
+      break;
+
+    case EXEC_RETURN:
+      gfc_status ("RETURN ");
+      if (c->expr)
+	gfc_show_expr (c->expr);
+      break;
+
+    case EXEC_PAUSE:
+      gfc_status ("PAUSE ");
+
+      if (c->expr != NULL)
+        gfc_show_expr (c->expr);
+      else
+        gfc_status ("%d", c->ext.stop_code);
+
+      break;
+
+    case EXEC_STOP:
+      gfc_status ("STOP ");
+
+      if (c->expr != NULL)
+        gfc_show_expr (c->expr);
+      else
+        gfc_status ("%d", c->ext.stop_code);
+
+      break;
+
+    case EXEC_ARITHMETIC_IF:
+      gfc_status ("IF ");
+      gfc_show_expr (c->expr);
+      gfc_status (" %d, %d, %d",
+		  c->label->value, c->label2->value, c->label3->value);
+      break;
+
+    case EXEC_IF:
+      d = c->block;
+      gfc_status ("IF ");
+      gfc_show_expr (d->expr);
+      gfc_status_char ('\n');
+      gfc_show_code (level + 1, d->next);
+
+      d = d->block;
+      for (; d; d = d->block)
+	{
+	  code_indent (level, 0);
+
+	  if (d->expr == NULL)
+	    gfc_status ("ELSE\n");
+	  else
+	    {
+	      gfc_status ("ELSE IF ");
+	      gfc_show_expr (d->expr);
+	      gfc_status_char ('\n');
+	    }
+
+	  gfc_show_code (level + 1, d->next);
+	}
+
+      code_indent (level, c->label);
+
+      gfc_status ("ENDIF");
+      break;
+
+    case EXEC_SELECT:
+      d = c->block;
+      gfc_status ("SELECT CASE ");
+      gfc_show_expr (c->expr);
+      gfc_status_char ('\n');
+
+      for (; d; d = d->block)
+	{
+	  code_indent (level, 0);
+
+	  gfc_status ("CASE ");
+	  for (cp = d->ext.case_list; cp; cp = cp->next)
+	    {
+	      gfc_status_char ('(');
+	      gfc_show_expr (cp->low);
+	      gfc_status_char (' ');
+	      gfc_show_expr (cp->high);
+	      gfc_status_char (')');
+	      gfc_status_char (' ');
+	    }
+	  gfc_status_char ('\n');
+
+	  gfc_show_code (level + 1, d->next);
+	}
+
+      code_indent (level, c->label);
+      gfc_status ("END SELECT");
+      break;
+
+    case EXEC_WHERE:
+      gfc_status ("WHERE ");
+
+      d = c->block;
+      gfc_show_expr (d->expr);
+      gfc_status_char ('\n');
+
+      gfc_show_code (level + 1, d->next);
+
+      for (d = d->block; d; d = d->block)
+	{
+	  code_indent (level, 0);
+	  gfc_status ("ELSE WHERE ");
+	  gfc_show_expr (d->expr);
+	  gfc_status_char ('\n');
+	  gfc_show_code (level + 1, d->next);
+	}
+
+      code_indent (level, 0);
+      gfc_status ("END WHERE");
+      break;
+
+
+    case EXEC_FORALL:
+      gfc_status ("FORALL ");
+      for (fa = c->ext.forall_iterator; fa; fa = fa->next)
+	{
+	  gfc_show_expr (fa->var);
+	  gfc_status_char (' ');
+	  gfc_show_expr (fa->start);
+	  gfc_status_char (':');
+	  gfc_show_expr (fa->end);
+	  gfc_status_char (':');
+	  gfc_show_expr (fa->stride);
+
+	  if (fa->next != NULL)
+	    gfc_status_char (',');
+	}
+
+      if (c->expr != NULL)
+	{
+	  gfc_status_char (',');
+	  gfc_show_expr (c->expr);
+	}
+      gfc_status_char ('\n');
+
+      gfc_show_code (level + 1, c->block->next);
+
+      code_indent (level, 0);
+      gfc_status ("END FORALL");
+      break;
+
+    case EXEC_DO:
+      gfc_status ("DO ");
+
+      gfc_show_expr (c->ext.iterator->var);
+      gfc_status_char ('=');
+      gfc_show_expr (c->ext.iterator->start);
+      gfc_status_char (' ');
+      gfc_show_expr (c->ext.iterator->end);
+      gfc_status_char (' ');
+      gfc_show_expr (c->ext.iterator->step);
+      gfc_status_char ('\n');
+
+      gfc_show_code (level + 1, c->block->next);
+
+      code_indent (level, 0);
+      gfc_status ("END DO");
+      break;
+
+    case EXEC_DO_WHILE:
+      gfc_status ("DO WHILE ");
+      gfc_show_expr (c->expr);
+      gfc_status_char ('\n');
+
+      gfc_show_code (level + 1, c->block->next);
+
+      code_indent (level, c->label);
+      gfc_status ("END DO");
+      break;
+
+    case EXEC_CYCLE:
+      gfc_status ("CYCLE");
+      if (c->symtree)
+	gfc_status (" %s", c->symtree->n.sym->name);
+      break;
+
+    case EXEC_EXIT:
+      gfc_status ("EXIT");
+      if (c->symtree)
+	gfc_status (" %s", c->symtree->n.sym->name);
+      break;
+
+    case EXEC_ALLOCATE:
+      gfc_status ("ALLOCATE ");
+      if (c->expr)
+	{
+	  gfc_status (" STAT=");
+	  gfc_show_expr (c->expr);
+	}
+
+      for (a = c->ext.alloc_list; a; a = a->next)
+	{
+	  gfc_status_char (' ');
+	  gfc_show_expr (a->expr);
+	}
+
+      break;
+
+    case EXEC_DEALLOCATE:
+      gfc_status ("DEALLOCATE ");
+      if (c->expr)
+	{
+	  gfc_status (" STAT=");
+	  gfc_show_expr (c->expr);
+	}
+
+      for (a = c->ext.alloc_list; a; a = a->next)
+	{
+	  gfc_status_char (' ');
+	  gfc_show_expr (a->expr);
+	}
+
+      break;
+
+    case EXEC_OPEN:
+      gfc_status ("OPEN");
+      open = c->ext.open;
+
+      if (open->unit)
+	{
+	  gfc_status (" UNIT=");
+	  gfc_show_expr (open->unit);
+	}
+      if (open->iostat)
+	{
+	  gfc_status (" IOSTAT=");
+	  gfc_show_expr (open->iostat);
+	}
+      if (open->file)
+	{
+	  gfc_status (" FILE=");
+	  gfc_show_expr (open->file);
+	}
+      if (open->status)
+	{
+	  gfc_status (" STATUS=");
+	  gfc_show_expr (open->status);
+	}
+      if (open->access)
+	{
+	  gfc_status (" ACCESS=");
+	  gfc_show_expr (open->access);
+	}
+      if (open->form)
+	{
+	  gfc_status (" FORM=");
+	  gfc_show_expr (open->form);
+	}
+      if (open->recl)
+	{
+	  gfc_status (" RECL=");
+	  gfc_show_expr (open->recl);
+	}
+      if (open->blank)
+	{
+	  gfc_status (" BLANK=");
+	  gfc_show_expr (open->blank);
+	}
+      if (open->position)
+	{
+	  gfc_status (" POSITION=");
+	  gfc_show_expr (open->position);
+	}
+      if (open->action)
+	{
+	  gfc_status (" ACTION=");
+	  gfc_show_expr (open->action);
+	}
+      if (open->delim)
+	{
+	  gfc_status (" DELIM=");
+	  gfc_show_expr (open->delim);
+	}
+      if (open->pad)
+	{
+	  gfc_status (" PAD=");
+	  gfc_show_expr (open->pad);
+	}
+      if (open->err != NULL)
+	gfc_status (" ERR=%d", open->err->value);
+
+      break;
+
+    case EXEC_CLOSE:
+      gfc_status ("CLOSE");
+      close = c->ext.close;
+
+      if (close->unit)
+	{
+	  gfc_status (" UNIT=");
+	  gfc_show_expr (close->unit);
+	}
+      if (close->iostat)
+	{
+	  gfc_status (" IOSTAT=");
+	  gfc_show_expr (close->iostat);
+	}
+      if (close->status)
+	{
+	  gfc_status (" STATUS=");
+	  gfc_show_expr (close->status);
+	}
+      if (close->err != NULL)
+	gfc_status (" ERR=%d", close->err->value);
+      break;
+
+    case EXEC_BACKSPACE:
+      gfc_status ("BACKSPACE");
+      goto show_filepos;
+
+    case EXEC_ENDFILE:
+      gfc_status ("ENDFILE");
+      goto show_filepos;
+
+    case EXEC_REWIND:
+      gfc_status ("REWIND");
+
+    show_filepos:
+      fp = c->ext.filepos;
+
+      if (fp->unit)
+	{
+	  gfc_status (" UNIT=");
+	  gfc_show_expr (fp->unit);
+	}
+      if (fp->iostat)
+	{
+	  gfc_status (" IOSTAT=");
+	  gfc_show_expr (fp->iostat);
+	}
+      if (fp->err != NULL)
+	gfc_status (" ERR=%d", fp->err->value);
+      break;
+
+    case EXEC_INQUIRE:
+      gfc_status ("INQUIRE");
+      i = c->ext.inquire;
+
+      if (i->unit)
+	{
+	  gfc_status (" UNIT=");
+	  gfc_show_expr (i->unit);
+	}
+      if (i->file)
+	{
+	  gfc_status (" FILE=");
+	  gfc_show_expr (i->file);
+	}
+
+      if (i->iostat)
+	{
+	  gfc_status (" IOSTAT=");
+	  gfc_show_expr (i->iostat);
+	}
+      if (i->exist)
+	{
+	  gfc_status (" EXIST=");
+	  gfc_show_expr (i->exist);
+	}
+      if (i->opened)
+	{
+	  gfc_status (" OPENED=");
+	  gfc_show_expr (i->opened);
+	}
+      if (i->number)
+	{
+	  gfc_status (" NUMBER=");
+	  gfc_show_expr (i->number);
+	}
+      if (i->named)
+	{
+	  gfc_status (" NAMED=");
+	  gfc_show_expr (i->named);
+	}
+      if (i->name)
+	{
+	  gfc_status (" NAME=");
+	  gfc_show_expr (i->name);
+	}
+      if (i->access)
+	{
+	  gfc_status (" ACCESS=");
+	  gfc_show_expr (i->access);
+	}
+      if (i->sequential)
+	{
+	  gfc_status (" SEQUENTIAL=");
+	  gfc_show_expr (i->sequential);
+	}
+
+      if (i->direct)
+	{
+	  gfc_status (" DIRECT=");
+	  gfc_show_expr (i->direct);
+	}
+      if (i->form)
+	{
+	  gfc_status (" FORM=");
+	  gfc_show_expr (i->form);
+	}
+      if (i->formatted)
+	{
+	  gfc_status (" FORMATTED");
+	  gfc_show_expr (i->formatted);
+	}
+      if (i->unformatted)
+	{
+	  gfc_status (" UNFORMATTED=");
+	  gfc_show_expr (i->unformatted);
+	}
+      if (i->recl)
+	{
+	  gfc_status (" RECL=");
+	  gfc_show_expr (i->recl);
+	}
+      if (i->nextrec)
+	{
+	  gfc_status (" NEXTREC=");
+	  gfc_show_expr (i->nextrec);
+	}
+      if (i->blank)
+	{
+	  gfc_status (" BLANK=");
+	  gfc_show_expr (i->blank);
+	}
+      if (i->position)
+	{
+	  gfc_status (" POSITION=");
+	  gfc_show_expr (i->position);
+	}
+      if (i->action)
+	{
+	  gfc_status (" ACTION=");
+	  gfc_show_expr (i->action);
+	}
+      if (i->read)
+	{
+	  gfc_status (" READ=");
+	  gfc_show_expr (i->read);
+	}
+      if (i->write)
+	{
+	  gfc_status (" WRITE=");
+	  gfc_show_expr (i->write);
+	}
+      if (i->readwrite)
+	{
+	  gfc_status (" READWRITE=");
+	  gfc_show_expr (i->readwrite);
+	}
+      if (i->delim)
+	{
+	  gfc_status (" DELIM=");
+	  gfc_show_expr (i->delim);
+	}
+      if (i->pad)
+	{
+	  gfc_status (" PAD=");
+	  gfc_show_expr (i->pad);
+	}
+
+      if (i->err != NULL)
+	gfc_status (" ERR=%d", i->err->value);
+      break;
+
+    case EXEC_IOLENGTH:
+      gfc_status ("IOLENGTH ");
+      gfc_show_expr (c->expr);
+      break;
+
+    case EXEC_READ:
+      gfc_status ("READ");
+      goto show_dt;
+
+    case EXEC_WRITE:
+      gfc_status ("WRITE");
+
+    show_dt:
+      dt = c->ext.dt;
+      if (dt->io_unit)
+	{
+	  gfc_status (" UNIT=");
+	  gfc_show_expr (dt->io_unit);
+	}
+
+      if (dt->format_expr)
+	{
+	  gfc_status (" FMT=");
+	  gfc_show_expr (dt->format_expr);
+	}
+
+      if (dt->format_label != NULL)
+	gfc_status (" FMT=%d", dt->format_label->value);
+      if (dt->namelist)
+	gfc_status (" NML=%s", dt->namelist->name);
+      if (dt->iostat)
+	{
+	  gfc_status (" IOSTAT=");
+	  gfc_show_expr (dt->iostat);
+	}
+      if (dt->size)
+	{
+	  gfc_status (" SIZE=");
+	  gfc_show_expr (dt->size);
+	}
+      if (dt->rec)
+	{
+	  gfc_status (" REC=");
+	  gfc_show_expr (dt->rec);
+	}
+      if (dt->advance)
+	{
+	  gfc_status (" ADVANCE=");
+	  gfc_show_expr (dt->advance);
+	}
+
+      break;
+
+    case EXEC_TRANSFER:
+      gfc_status ("TRANSFER ");
+      gfc_show_expr (c->expr);
+      break;
+
+    case EXEC_DT_END:
+      gfc_status ("DT_END");
+      dt = c->ext.dt;
+
+      if (dt->err != NULL)
+	gfc_status (" ERR=%d", dt->err->value);
+      if (dt->end != NULL)
+	gfc_status (" END=%d", dt->end->value);
+      if (dt->eor != NULL)
+	gfc_status (" EOR=%d", dt->eor->value);
+      break;
+
+    default:
+      gfc_internal_error ("gfc_show_code_node(): Bad statement code");
+    }
+
+  gfc_status_char ('\n');
+}
+
+
+/* Show a freakin' whole namespace.  */
+
+void
+gfc_show_namespace (gfc_namespace * ns)
+{
+  gfc_interface *intr;
+  gfc_namespace *save;
+  gfc_intrinsic_op op;
+  int i;
+
+  save = gfc_current_ns;
+  show_level++;
+
+  show_indent ();
+  gfc_status ("Namespace:");
+
+  if (ns != NULL)
+    {
+      i = 0;
+      do
+	{
+	  int l = i;
+	  while (i < GFC_LETTERS - 1
+		 && gfc_compare_types(&ns->default_type[i+1],
+				      &ns->default_type[l]))
+	    i++;
+
+	  if (i > l)
+	    gfc_status(" %c-%c: ", l+'A', i+'A');
+	  else
+	    gfc_status(" %c: ", l+'A');
+
+	  gfc_show_typespec(&ns->default_type[l]);
+	  i++;
+      } while (i < GFC_LETTERS);
+
+      if (ns->proc_name != NULL)
+	{
+	  show_indent ();
+	  gfc_status ("procedure name = %s", ns->proc_name->name);
+	}
+
+      gfc_current_ns = ns;
+      gfc_traverse_symtree (ns, show_symtree);
+
+      for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
+	{
+	  /* User operator interfaces */
+	  intr = ns->operator[op];
+	  if (intr == NULL)
+	    continue;
+
+	  show_indent ();
+	  gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
+
+	  for (; intr; intr = intr->next)
+	    gfc_status (" %s", intr->sym->name);
+	}
+
+      if (ns->uop_root != NULL)
+	{
+	  show_indent ();
+	  gfc_status ("User operators:\n");
+	  gfc_traverse_user_op (ns, show_uop);
+	}
+    }
+
+  gfc_status_char ('\n');
+  gfc_status_char ('\n');
+
+  gfc_show_code (0, ns->code);
+
+  for (ns = ns->contained; ns; ns = ns->sibling)
+    {
+      show_indent ();
+      gfc_status ("CONTAINS\n");
+      gfc_show_namespace (ns);
+    }
+
+  show_level--;
+  gfc_status_char ('\n');
+  gfc_current_ns = save;
+}