Merge tree-ssa-20020619-branch into mainline.

From-SVN: r81764

1 files changed, 1285 insertions, 0 deletions

diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
new file mode 100644
index 0000000..caec167
--- /dev/null
+++ b/libgfortran/io/format.c
@@ -0,0 +1,1285 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran 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.
+
+Libgfortran 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 Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+
+/* format.c-- parse a FORMAT string into a binary format suitable for
+ * interpretation during I/O statements */
+
+#include "config.h"
+#include <ctype.h>
+#include <string.h>
+#include "libgfortran.h"
+#include "io.h"
+
+
+
+/* Number of format nodes that we can store statically before we have
+ * to resort to dynamic allocation.  The root node is array[0]. */
+
+#define FARRAY_SIZE 200
+
+static fnode *avail, array[FARRAY_SIZE];
+
+/* Local variables for checking format strings.  The saved_token is
+ * used to back up by a single format token during the parsing process. */
+
+static char *format_string, *string;
+static const char *error;
+static format_token saved_token;
+static int value, format_string_len, reversion_ok;
+
+static fnode *saved_format, colon_node = { FMT_COLON };
+
+/* Error messages */
+
+static char posint_required[] = "Positive width required in format",
+  period_required[] = "Period required in format",
+  nonneg_required[] = "Nonnegative width required in format",
+  unexpected_element[] = "Unexpected element in format",
+  unexpected_end[] = "Unexpected end of format string",
+  bad_string[] = "Unterminated character constant in format",
+  bad_hollerith[] = "Hollerith constant extends past the end of the format",
+  reversion_error[] = "Exhausted data descriptors in format";
+
+
+/* next_char()-- Return the next character in the format string.
+ * Returns -1 when the string is done.  If the literal flag is set,
+ * spaces are significant, otherwise they are not. */
+
+static int
+next_char (int literal)
+{
+  int c;
+
+  do
+    {
+      if (format_string_len == 0)
+	return -1;
+
+      format_string_len--;
+      c = toupper (*format_string++);
+    }
+  while (c == ' ' && !literal);
+
+  return c;
+}
+
+
+/* unget_char()-- Back up one character position. */
+
+#define unget_char() { format_string--;  format_string_len++; }
+
+
+/* get_fnode()-- Allocate a new format node, inserting it into the
+ * current singly linked list.  These are initially allocated from the
+ * static buffer. */
+
+static fnode *
+get_fnode (fnode ** head, fnode ** tail, format_token t)
+{
+  fnode *f;
+
+  if (avail - array >= FARRAY_SIZE)
+    f = get_mem (sizeof (fnode));
+  else
+    {
+      f = avail++;
+      memset (f, '\0', sizeof (fnode));
+    }
+
+  if (*head == NULL)
+    *head = *tail = f;
+  else
+    {
+      (*tail)->next = f;
+      *tail = f;
+    }
+
+  f->format = t;
+  f->repeat = -1;
+  f->source = format_string;
+  return f;
+}
+
+
+/* free_fnode()-- Recursive function to free the given fnode and
+ * everything it points to.  We only have to actually free something
+ * if it is outside of the static array. */
+
+static void
+free_fnode (fnode * f)
+{
+  fnode *next;
+
+  for (; f; f = next)
+    {
+      next = f->next;
+
+      if (f->format == FMT_LPAREN)
+	free_fnode (f->u.child);
+      if (f < array || f >= array + FARRAY_SIZE)
+	free_mem (f);
+    }
+}
+
+
+/* free_fnodes()-- Free the current tree of fnodes.  We only have to
+ * traverse the tree if some nodes were allocated dynamically. */
+
+void
+free_fnodes (void)
+{
+
+  if (avail - array >= FARRAY_SIZE)
+    free_fnode (&array[0]);
+
+  avail = array;
+  memset(array, 0, sizeof(avail[0]) * FARRAY_SIZE);
+}
+
+
+/* format_lex()-- Simple lexical analyzer for getting the next token
+ * in a FORMAT string.  We support a one-level token pushback in the
+ * saved_token variable. */
+
+static format_token
+format_lex (void)
+{
+  format_token token;
+  int negative_flag;
+  char c, delim;
+
+  if (saved_token != FMT_NONE)
+    {
+      token = saved_token;
+      saved_token = FMT_NONE;
+      return token;
+    }
+
+  negative_flag = 0;
+  c = next_char (0);
+
+  switch (c)
+    {
+    case '-':
+      negative_flag = 1;
+      /* Fall Through */
+
+    case '+':
+      c = next_char (0);
+      if (!isdigit (c))
+	{
+	  token = FMT_UNKNOWN;
+	  break;
+	}
+
+      value = c - '0';
+
+      for (;;)
+	{
+	  c = next_char (0);
+	  if (!isdigit (c))
+	    break;
+
+	  value = 10 * value + c - '0';
+	}
+
+      unget_char ();
+
+      if (negative_flag)
+	value = -value;
+      token = FMT_SIGNED_INT;
+      break;
+
+    case '0':
+    case '1':
+    case '2':
+    case '3':
+    case '4':
+    case '5':
+    case '6':
+    case '7':
+    case '8':
+    case '9':
+      value = c - '0';
+
+      for (;;)
+	{
+	  c = next_char (0);
+	  if (!isdigit (c))
+	    break;
+
+	  value = 10 * value + c - '0';
+	}
+
+      unget_char ();
+      token = (value == 0) ? FMT_ZERO : FMT_POSINT;
+      break;
+
+    case '.':
+      token = FMT_PERIOD;
+      break;
+
+    case ',':
+      token = FMT_COMMA;
+      break;
+
+    case ':':
+      token = FMT_COLON;
+      break;
+
+    case '/':
+      token = FMT_SLASH;
+      break;
+
+    case '$':
+      token = FMT_DOLLAR;
+      break;
+
+    case 'T':
+      switch (next_char (0))
+	{
+	case 'L':
+	  token = FMT_TL;
+	  break;
+	case 'R':
+	  token = FMT_TR;
+	  break;
+	default:
+	  token = FMT_T;
+	  unget_char ();
+	  break;
+	}
+
+      break;
+
+    case '(':
+      token = FMT_LPAREN;
+      break;
+
+    case ')':
+      token = FMT_RPAREN;
+      break;
+
+    case 'X':
+      token = FMT_X;
+      break;
+
+    case 'S':
+      switch (next_char (0))
+	{
+	case 'S':
+	  token = FMT_SS;
+	  break;
+	case 'P':
+	  token = FMT_SP;
+	  break;
+	default:
+	  token = FMT_S;
+	  unget_char ();
+	  break;
+	}
+
+      break;
+
+    case 'B':
+      switch (next_char (0))
+	{
+	case 'N':
+	  token = FMT_BN;
+	  break;
+	case 'Z':
+	  token = FMT_BZ;
+	  break;
+	default:
+	  token = FMT_B;
+	  unget_char ();
+	  break;
+	}
+
+      break;
+
+    case '\'':
+    case '"':
+      delim = c;
+
+      string = format_string;
+      value = 0;		/* This is the length of the string */
+
+      for (;;)
+	{
+	  c = next_char (1);
+	  if (c == -1)
+	    {
+	      token = FMT_BADSTRING;
+	      error = bad_string;
+	      break;
+	    }
+
+	  if (c == delim)
+	    {
+	      c = next_char (1);
+
+	      if (c == -1)
+		{
+		  token = FMT_BADSTRING;
+		  error = bad_string;
+		  break;
+		}
+
+	      if (c != delim)
+		{
+		  unget_char ();
+		  token = FMT_STRING;
+		  break;
+		}
+	    }
+
+	  value++;
+	}
+
+      break;
+
+    case 'P':
+      token = FMT_P;
+      break;
+
+    case 'I':
+      token = FMT_I;
+      break;
+
+    case 'O':
+      token = FMT_O;
+      break;
+
+    case 'Z':
+      token = FMT_Z;
+      break;
+
+    case 'F':
+      token = FMT_F;
+      break;
+
+    case 'E':
+      switch (next_char (0))
+	{
+	case 'N':
+	  token = FMT_EN;
+	  break;
+	case 'S':
+	  token = FMT_ES;
+	  break;
+	default:
+	  token = FMT_E;
+	  unget_char ();
+	  break;
+	}
+
+      break;
+
+    case 'G':
+      token = FMT_G;
+      break;
+
+    case 'H':
+      token = FMT_H;
+      break;
+
+    case 'L':
+      token = FMT_L;
+      break;
+
+    case 'A':
+      token = FMT_A;
+      break;
+
+    case 'D':
+      token = FMT_D;
+      break;
+
+    case -1:
+      token = FMT_END;
+      break;
+
+    default:
+      token = FMT_UNKNOWN;
+      break;
+    }
+
+  return token;
+}
+
+
+/* parse_format_list()-- Parse a format list.  Assumes that a left
+ * paren has already been seen.  Returns a list representing the
+ * parenthesis node which contains the rest of the list. */
+
+static fnode *
+parse_format_list (void)
+{
+  fnode *head, *tail;
+  format_token t, u, t2;
+  int repeat;
+
+  head = tail = NULL;
+
+/* Get the next format item */
+
+format_item:
+  t = format_lex ();
+  switch (t)
+    {
+    case FMT_POSINT:
+      repeat = value;
+
+      t = format_lex ();
+      switch (t)
+	{
+	case FMT_LPAREN:
+	  get_fnode (&head, &tail, FMT_LPAREN);
+	  tail->repeat = repeat;
+	  tail->u.child = parse_format_list ();
+	  if (error != NULL)
+	    goto finished;
+
+	  goto between_desc;
+
+	case FMT_SLASH:
+	  get_fnode (&head, &tail, FMT_SLASH);
+	  tail->repeat = repeat;
+	  goto optional_comma;
+
+	case FMT_X:
+	  get_fnode (&head, &tail, FMT_X);
+	  tail->repeat = 1;
+	  tail->u.k = value;
+	  goto between_desc;
+
+	case FMT_P:
+	  goto p_descriptor;
+
+	default:
+	  goto data_desc;
+	}
+
+    case FMT_LPAREN:
+      get_fnode (&head, &tail, FMT_LPAREN);
+      tail->repeat = 1;
+      tail->u.child = parse_format_list ();
+      if (error != NULL)
+	goto finished;
+
+      goto between_desc;
+
+    case FMT_SIGNED_INT:	/* Signed integer can only precede a P format.  */
+    case FMT_ZERO:		/* Same for zero.  */
+      t = format_lex ();
+      if (t != FMT_P)
+	{
+	  error = "Expected P edit descriptor in format";
+	  goto finished;
+	}
+
+    p_descriptor:
+      get_fnode (&head, &tail, FMT_P);
+      tail->u.k = value;
+
+      t = format_lex ();
+      if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
+	  || t == FMT_G || t == FMT_E)
+	{
+	  repeat = 1;
+	  goto data_desc;
+	}
+
+      saved_token = t;
+      goto between_desc;
+
+    case FMT_P:		/* P and X require a prior number */
+      error = "P descriptor requires leading scale factor";
+      goto finished;
+
+    case FMT_X:
+/*
+   EXTENSION!
+
+   If we would be pedantic in the library, we would have to reject
+   an X descriptor without an integer prefix:
+
+      error = "X descriptor requires leading space count";
+      goto finished;
+
+   However, this is an extension supported by many Fortran compilers,
+   including Cray, HP, AIX, and IRIX.  Therefore, we allow it in the
+   runtime library, and make the front end reject it if the compiler
+   is in pedantic mode.  The interpretation of 'X' is '1X'.
+*/
+      get_fnode (&head, &tail, FMT_X);
+      tail->repeat = 1;
+      tail->u.k = 1;
+      goto between_desc;
+
+    case FMT_STRING:
+      get_fnode (&head, &tail, FMT_STRING);
+
+      tail->u.string.p = string;
+      tail->u.string.length = value;
+      tail->repeat = 1;
+      goto between_desc;
+
+    case FMT_S:
+    case FMT_SS:
+    case FMT_SP:
+    case FMT_BN:
+    case FMT_BZ:
+      get_fnode (&head, &tail, t);
+      goto between_desc;
+
+    case FMT_COLON:
+      get_fnode (&head, &tail, FMT_COLON);
+      goto optional_comma;
+
+    case FMT_SLASH:
+      get_fnode (&head, &tail, FMT_SLASH);
+      tail->repeat = 1;
+      tail->u.r = 1;
+      goto optional_comma;
+
+    case FMT_DOLLAR:
+      get_fnode (&head, &tail, FMT_DOLLAR);
+      goto between_desc;
+
+    case FMT_T:
+    case FMT_TL:
+    case FMT_TR:
+      t2 = format_lex ();
+      if (t2 != FMT_POSINT)
+	{
+	  error = posint_required;
+	  goto finished;
+	}
+      get_fnode (&head, &tail, t);
+      tail->u.n = value;
+      tail->repeat = 1;
+      goto between_desc;
+
+    case FMT_I:
+    case FMT_B:
+    case FMT_O:
+    case FMT_Z:
+    case FMT_E:
+    case FMT_EN:
+    case FMT_ES:
+    case FMT_D:
+    case FMT_L:
+    case FMT_A:
+    case FMT_F:
+    case FMT_G:
+      repeat = 1;
+      goto data_desc;
+
+    case FMT_H:
+      get_fnode (&head, &tail, FMT_STRING);
+
+      if (format_string_len < 1)
+	{
+	  error = bad_hollerith;
+	  goto finished;
+	}
+
+      tail->u.string.p = format_string;
+      tail->u.string.length = 1;
+      tail->repeat = 1;
+
+      format_string++;
+      format_string_len--;
+
+      goto between_desc;
+
+    case FMT_END:
+      error = unexpected_end;
+      goto finished;
+
+    case FMT_BADSTRING:
+      goto finished;
+
+    case FMT_RPAREN:
+      goto finished;
+
+    default:
+      error = unexpected_element;
+      goto finished;
+    }
+
+/* In this state, t must currently be a data descriptor.  Deal with
+ * things that can/must follow the descriptor */
+
+data_desc:
+  switch (t)
+    {
+    case FMT_P:
+      t = format_lex ();
+      if (t == FMT_POSINT)
+	{
+	  error = "Repeat count cannot follow P descriptor";
+	  goto finished;
+	}
+
+      saved_token = t;
+      get_fnode (&head, &tail, FMT_P);
+
+      goto optional_comma;
+
+    case FMT_L:
+      t = format_lex ();
+      if (t != FMT_POSINT)
+	{
+	  error = posint_required;
+	  goto finished;
+	}
+
+      get_fnode (&head, &tail, FMT_L);
+      tail->u.n = value;
+      tail->repeat = repeat;
+      break;
+
+    case FMT_A:
+      t = format_lex ();
+      if (t != FMT_POSINT)
+	{
+	  saved_token = t;
+	  value = -1;		/* Width not present */
+	}
+
+      get_fnode (&head, &tail, FMT_A);
+      tail->repeat = repeat;
+      tail->u.n = value;
+      break;
+
+    case FMT_D:
+    case FMT_E:
+    case FMT_F:
+    case FMT_G:
+    case FMT_EN:
+    case FMT_ES:
+      get_fnode (&head, &tail, t);
+      tail->repeat = repeat;
+
+      u = format_lex ();
+      if (t == FMT_F || g.mode == WRITING)
+	{
+	  if (u != FMT_POSINT && u != FMT_ZERO)
+	    {
+	      error = nonneg_required;
+	      goto finished;
+	    }
+	}
+      else
+	{
+	  if (u != FMT_POSINT)
+	    {
+	      error = posint_required;
+	      goto finished;
+	    }
+	}
+
+      tail->u.real.w = value;
+      t2 = t;
+      t = format_lex ();
+      if (t != FMT_PERIOD)
+	{
+	  error = period_required;
+	  goto finished;
+	}
+
+      t = format_lex ();
+      if (t != FMT_ZERO && t != FMT_POSINT)
+	{
+	  error = nonneg_required;
+	  goto finished;
+	}
+
+      tail->u.real.d = value;
+
+      if (t == FMT_D || t == FMT_F)
+	break;
+
+      tail->u.real.e = -1;
+
+/* Look for optional exponent */
+
+      t = format_lex ();
+      if (t != FMT_E)
+	saved_token = t;
+      else
+	{
+	  t = format_lex ();
+	  if (t != FMT_POSINT)
+	    {
+	      error = "Positive exponent width required in format";
+	      goto finished;
+	    }
+
+	  tail->u.real.e = value;
+	}
+
+      break;
+
+    case FMT_H:
+      if (repeat > format_string_len)
+	{
+	  error = bad_hollerith;
+	  goto finished;
+	}
+
+      get_fnode (&head, &tail, FMT_STRING);
+
+      tail->u.string.p = format_string;
+      tail->u.string.length = repeat;
+      tail->repeat = 1;
+
+      format_string += value;
+      format_string_len -= repeat;
+
+      break;
+
+    case FMT_I:
+    case FMT_B:
+    case FMT_O:
+    case FMT_Z:
+      get_fnode (&head, &tail, t);
+      tail->repeat = repeat;
+
+      t = format_lex ();
+
+      if (g.mode == READING)
+	{
+	  if (t != FMT_POSINT)
+	    {
+	      error = posint_required;
+	      goto finished;
+	    }
+	}
+      else
+	{
+	  if (t != FMT_ZERO && t != FMT_POSINT)
+	    {
+	      error = nonneg_required;
+	      goto finished;
+	    }
+	}
+
+      tail->u.integer.w = value;
+      tail->u.integer.m = -1;
+
+      t = format_lex ();
+      if (t != FMT_PERIOD)
+	{
+	  saved_token = t;
+	}
+      else
+	{
+	  t = format_lex ();
+	  if (t != FMT_ZERO && t != FMT_POSINT)
+	    {
+	      error = nonneg_required;
+	      goto finished;
+	    }
+
+	  tail->u.integer.m = value;
+	}
+
+      if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
+	{
+	  error = "Minimum digits exceeds field width";
+	  goto finished;
+	}
+
+      break;
+
+    default:
+      error = unexpected_element;
+      goto finished;
+    }
+
+/* Between a descriptor and what comes next */
+between_desc:
+  t = format_lex ();
+  switch (t)
+    {
+    case FMT_COMMA:
+      goto format_item;
+
+    case FMT_RPAREN:
+      goto finished;
+
+    case FMT_SLASH:
+      get_fnode (&head, &tail, FMT_SLASH);
+      tail->repeat = 1;
+
+      /* Fall Through */
+
+    case FMT_COLON:
+      goto optional_comma;
+
+    case FMT_END:
+      error = unexpected_end;
+      goto finished;
+
+    default:
+      error = "Missing comma in format";
+      goto finished;
+    }
+
+/* Optional comma is a weird between state where we've just finished
+ * reading a colon, slash or P descriptor. */
+
+optional_comma:
+  t = format_lex ();
+  switch (t)
+    {
+    case FMT_COMMA:
+      break;
+
+    case FMT_RPAREN:
+      goto finished;
+
+    default:			/* Assume that we have another format item */
+      saved_token = t;
+      break;
+    }
+
+  goto format_item;
+
+finished:
+  return head;
+}
+
+
+/* format_error()-- Generate an error message for a format statement.
+ * If the node that gives the location of the error is NULL, the error
+ * is assumed to happen at parse time, and the current location of the
+ * parser is shown.
+ *
+ * After freeing any dynamically allocated fnodes, generate a message
+ * showing where the problem is.  We take extra care to print only the
+ * relevant part of the format if it is longer than a standard 80
+ * column display. */
+
+void
+format_error (fnode * f, const char *message)
+{
+  int width, i, j, offset;
+  char *p, buffer[300];
+
+  if (f != NULL)
+    format_string = f->source;
+
+  free_fnodes ();
+
+  st_sprintf (buffer, "%s\n", message);
+
+  j = format_string - ioparm.format;
+
+  offset = (j > 60) ? j - 40 : 0;
+
+  j -= offset;
+  width = ioparm.format_len - offset;
+
+  if (width > 80)
+    width = 80;
+
+  /* Show the format */
+
+  p = strchr (buffer, '\0');
+
+  memcpy (p, ioparm.format + offset, width);
+
+  p += width;
+  *p++ = '\n';
+
+  /* Show where the problem is */
+
+  for (i = 1; i < j; i++)
+    *p++ = ' ';
+
+  *p++ = '^';
+  *p = '\0';
+
+  generate_error (ERROR_FORMAT, buffer);
+}
+
+
+/* parse_format()-- Parse a format string.  */
+
+void
+parse_format (void)
+{
+
+  format_string = ioparm.format;
+  format_string_len = ioparm.format_len;
+
+  saved_token = FMT_NONE;
+  error = NULL;
+
+/* Initialize variables used during traversal of the tree */
+
+  reversion_ok = 0;
+  g.reversion_flag = 0;
+  saved_format = NULL;
+
+/* Allocate the first format node as the root of the tree */
+
+  avail = array;
+
+  avail->format = FMT_LPAREN;
+  avail->repeat = 1;
+  avail++;
+
+  if (format_lex () == FMT_LPAREN)
+    array[0].u.child = parse_format_list ();
+  else
+    error = "Missing initial left parenthesis in format";
+
+  if (error)
+    format_error (NULL, error);
+}
+
+
+/* revert()-- Do reversion of the format.  Control reverts to the left
+ * parenthesis that matches the rightmost right parenthesis.  From our
+ * tree structure, we are looking for the rightmost parenthesis node
+ * at the second level, the first level always being a single
+ * parenthesis node.  If this node doesn't exit, we use the top
+ * level. */
+
+static void
+revert (void)
+{
+  fnode *f, *r;
+
+  g.reversion_flag = 1;
+
+  r = NULL;
+
+  for (f = array[0].u.child; f; f = f->next)
+    if (f->format == FMT_LPAREN)
+      r = f;
+
+  /* If r is NULL because no node was found, the whole tree will be used */
+
+  array[0].current = r;
+  array[0].count = 0;
+}
+
+
+/* next_format0()-- Get the next format node without worrying about
+ * reversion.  Returns NULL when we hit the end of the list.
+ * Parenthesis nodes are incremented after the list has been
+ * exhausted, other nodes are incremented before they are returned. */
+
+static fnode *
+next_format0 (fnode * f)
+{
+  fnode *r;
+
+  if (f == NULL)
+    return NULL;
+
+  if (f->format != FMT_LPAREN)
+    {
+      f->count++;
+      if (f->count <= f->repeat)
+	return f;
+
+      f->count = 0;
+      return NULL;
+    }
+
+  /* Deal with a parenthesis node */
+
+  for (; f->count < f->repeat; f->count++)
+    {
+      if (f->current == NULL)
+	f->current = f->u.child;
+
+      for (; f->current != NULL; f->current = f->current->next)
+	{
+	  r = next_format0 (f->current);
+	  if (r != NULL)
+	    return r;
+	}
+    }
+
+  f->count = 0;
+  return NULL;
+}
+
+
+/* next_format()-- Return the next format node.  If the format list
+ * ends up being exhausted, we do reversion.  Reversion is only
+ * allowed if the we've seen a data descriptor since the
+ * initialization or the last reversion.  We return NULL if the there
+ * are no more data descriptors to return (which is an error
+ * condition). */
+
+fnode *
+next_format (void)
+{
+  format_token t;
+  fnode *f;
+
+  if (saved_format != NULL)
+    {				/* Deal with a pushed-back format node */
+      f = saved_format;
+      saved_format = NULL;
+      goto done;
+    }
+
+  f = next_format0 (&array[0]);
+  if (f == NULL)
+    {
+      if (!reversion_ok)
+	{
+	  return NULL;
+	}
+
+      reversion_ok = 0;
+      revert ();
+
+      f = next_format0 (&array[0]);
+      if (f == NULL)
+	{
+	  format_error (NULL, reversion_error);
+	  return NULL;
+	}
+
+      /* Push the first reverted token and return a colon node in case
+       * there are no more data items. */
+
+      saved_format = f;
+      return &colon_node;
+    }
+
+  /* If this is a data edit descriptor, then reversion has become OK. */
+
+done:
+  t = f->format;
+
+  if (!reversion_ok &&
+      (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
+       t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
+       t == FMT_A || t == FMT_D))
+    reversion_ok = 1;
+  return f;
+}
+
+
+/* unget_format()-- Push the given format back so that it will be
+ * returned on the next call to next_format() without affecting
+ * counts.  This is necessary when we've encountered a data
+ * descriptor, but don't know what the data item is yet.  The format
+ * node is pushed back, and we return control to the main program,
+ * which calls the library back with the data item (or not). */
+
+void
+unget_format (fnode * f)
+{
+
+  saved_format = f;
+}
+
+
+
+
+#if 0
+
+static void dump_format1 (fnode * f);
+
+/* dump_format0()-- Dump a single format node */
+
+void
+dump_format0 (fnode * f)
+{
+  char *p;
+  int i;
+
+  switch (f->format)
+    {
+    case FMT_COLON:
+      st_printf (" :");
+      break;
+    case FMT_SLASH:
+      st_printf (" %d/", f->u.r);
+      break;
+    case FMT_DOLLAR:
+      st_printf (" $");
+      break;
+    case FMT_T:
+      st_printf (" T%d", f->u.n);
+      break;
+    case FMT_TR:
+      st_printf (" TR%d", f->u.n);
+      break;
+    case FMT_TL:
+      st_printf (" TL%d", f->u.n);
+      break;
+    case FMT_X:
+      st_printf (" %dX", f->u.n);
+      break;
+    case FMT_S:
+      st_printf (" S");
+      break;
+    case FMT_SS:
+      st_printf (" SS");
+      break;
+    case FMT_SP:
+      st_printf (" SP");
+      break;
+
+    case FMT_LPAREN:
+      if (f->repeat == 1)
+	st_printf (" (");
+      else
+	st_printf (" %d(", f->repeat);
+
+      dump_format1 (f->u.child);
+      st_printf (" )");
+      break;
+
+    case FMT_STRING:
+      st_printf (" '");
+      p = f->u.string.p;
+      for (i = f->u.string.length; i > 0; i--)
+	st_printf ("%c", *p++);
+
+      st_printf ("'");
+      break;
+
+    case FMT_P:
+      st_printf (" %dP", f->u.k);
+      break;
+    case FMT_I:
+      st_printf (" %dI%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
+      break;
+
+    case FMT_B:
+      st_printf (" %dB%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
+      break;
+
+    case FMT_O:
+      st_printf (" %dO%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
+      break;
+
+    case FMT_Z:
+      st_printf (" %dZ%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
+      break;
+
+    case FMT_BN:
+      st_printf (" BN");
+      break;
+    case FMT_BZ:
+      st_printf (" BZ");
+      break;
+    case FMT_D:
+      st_printf (" %dD%d.%d", f->repeat, f->u.real.w, f->u.real.d);
+      break;
+
+    case FMT_EN:
+      st_printf (" %dEN%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
+		 f->u.real.e);
+      break;
+
+    case FMT_ES:
+      st_printf (" %dES%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
+		 f->u.real.e);
+      break;
+
+    case FMT_F:
+      st_printf (" %dF%d.%d", f->repeat, f->u.real.w, f->u.real.d);
+      break;
+
+    case FMT_E:
+      st_printf (" %dE%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
+		 f->u.real.e);
+      break;
+
+    case FMT_G:
+      st_printf (" %dG%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
+		 f->u.real.e);
+      break;
+
+    case FMT_L:
+      st_printf (" %dL%d", f->repeat, f->u.w);
+      break;
+    case FMT_A:
+      st_printf (" %dA%d", f->repeat, f->u.w);
+      break;
+
+    default:
+      st_printf (" ???");
+      break;
+    }
+}
+
+
+/* dump_format1()-- Dump a string of format nodes */
+
+static void
+dump_format1 (fnode * f)
+{
+
+  for (; f; f = f->next)
+    dump_format1 (f);
+}
+
+/* dump_format()-- Dump the whole format node tree */
+
+void
+dump_format (void)
+{
+
+  st_printf ("format = ");
+  dump_format0 (&array[0]);
+  st_printf ("\n");
+}
+
+
+void
+next_test (void)
+{
+  fnode *f;
+  int i;
+
+  for (i = 0; i < 20; i++)
+    {
+      f = next_format ();
+      if (f == NULL)
+	{
+	  st_printf ("No format!\n");
+	  break;
+	}
+
+      dump_format1 (f);
+      st_printf ("\n");
+    }
+}
+
+#endif