Check in gcc sources for prebuilt toolchains in Eclair.

15 files changed, 14649 insertions, 0 deletions

diff --git a/gcc-4.2.1/libgfortran/io/close.c b/gcc-4.2.1/libgfortran/io/close.c
new file mode 100644
index 000000000..66ea6c3fb
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/close.c
@@ -0,0 +1,108 @@
+/* Copyright (C) 2002, 2003, 2005 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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+#include "config.h"
+#include "libgfortran.h"
+#include "io.h"
+#include <limits.h>
+
+typedef enum
+{ CLOSE_DELETE, CLOSE_KEEP, CLOSE_UNSPECIFIED }
+close_status;
+
+static const st_option status_opt[] = {
+  {"keep", CLOSE_KEEP},
+  {"delete", CLOSE_DELETE},
+  {NULL, 0}
+};
+
+
+extern void st_close (st_parameter_close *);
+export_proto(st_close);
+
+void
+st_close (st_parameter_close *clp)
+{
+  close_status status;
+  gfc_unit *u;
+#if !HAVE_UNLINK_OPEN_FILE
+  char * path;
+
+  path = NULL;
+#endif
+
+  library_start (&clp->common);
+
+  status = !(clp->common.flags & IOPARM_CLOSE_HAS_STATUS) ? CLOSE_UNSPECIFIED :
+    find_option (&clp->common, clp->status, clp->status_len,
+		 status_opt, "Bad STATUS parameter in CLOSE statement");
+
+  if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+  {
+    library_end ();
+    return;
+  }
+
+  u = find_unit (clp->common.unit);
+  if (u != NULL)
+    {
+      if (u->flags.status == STATUS_SCRATCH)
+	{
+	  if (status == CLOSE_KEEP)
+	    generate_error (&clp->common, ERROR_BAD_OPTION,
+			    "Can't KEEP a scratch file on CLOSE");
+#if !HAVE_UNLINK_OPEN_FILE
+	  path = (char *) gfc_alloca (u->file_len + 1);
+          unpack_filename (path, u->file, u->file_len);
+#endif
+	}
+      else
+	{
+	  if (status == CLOSE_DELETE)
+            {
+#if HAVE_UNLINK_OPEN_FILE
+	      delete_file (u);
+#else
+	      path = (char *) gfc_alloca (u->file_len + 1);
+              unpack_filename (path, u->file, u->file_len);
+#endif
+            }
+	}
+
+      close_unit (u);
+
+#if !HAVE_UNLINK_OPEN_FILE
+      if (path != NULL)
+        unlink (path);
+#endif
+    }
+
+  /* CLOSE on unconnected unit is legal and a no-op: F95 std., 9.3.5. */ 
+  library_end ();
+}
diff --git a/gcc-4.2.1/libgfortran/io/file_pos.c b/gcc-4.2.1/libgfortran/io/file_pos.c
new file mode 100644
index 000000000..95f7d87c6
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/file_pos.c
@@ -0,0 +1,349 @@
+/* Copyright (C) 2002-2003, 2005, 2006 Free Software Foundation, Inc.
+   Contributed by Andy Vaught and Janne Blomqvist
+
+This file is part of the GNU Fortran 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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+#include "config.h"
+#include <string.h>
+#include "libgfortran.h"
+#include "io.h"
+
+/* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
+   ENDFILE, and REWIND as well as the FLUSH statement.  */
+
+
+/* formatted_backspace(fpp, u)-- Move the file back one line.  The
+   current position is after the newline that terminates the previous
+   record, and we have to sift backwards to find the newline before
+   that or the start of the file, whichever comes first.  */
+
+#define READ_CHUNK 4096
+
+static void
+formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
+{
+  gfc_offset base;
+  char *p;
+  int n;
+
+  base = file_position (u->s) - 1;
+
+  do
+    {
+      n = (base < READ_CHUNK) ? base : READ_CHUNK;
+      base -= n;
+
+      p = salloc_r_at (u->s, &n, base);
+      if (p == NULL)
+	goto io_error;
+
+      /* We have moved backwards from the current position, it should
+         not be possible to get a short read.  Because it is not
+         clear what to do about such thing, we ignore the possibility.  */
+
+      /* There is no memrchr() in the C library, so we have to do it
+         ourselves.  */
+
+      n--;
+      while (n >= 0)
+	{
+	  if (p[n] == '\n')
+	    {
+	      base += n + 1;
+	      goto done;
+	    }
+	  n--;
+	}
+
+    }
+  while (base != 0);
+
+  /* base is the new pointer.  Seek to it exactly.  */
+ done:
+  if (sseek (u->s, base) == FAILURE)
+    goto io_error;
+  u->last_record--;
+  u->endfile = NO_ENDFILE;
+
+  return;
+
+ io_error:
+  generate_error (&fpp->common, ERROR_OS, NULL);
+}
+
+
+/* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
+   sequential file.  We are guaranteed to be between records on entry and 
+   we have to shift to the previous record.  Loop over subrecords.  */
+
+static void
+unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
+{
+  gfc_offset m, new;
+  GFC_INTEGER_4 m4;
+  GFC_INTEGER_8 m8;
+  int length, length_read;
+  int continued;
+  char *p;
+
+  if (compile_options.record_marker == 0)
+    length = sizeof (GFC_INTEGER_4);
+  else
+    length = compile_options.record_marker;
+
+  do
+    {
+      length_read = length;
+
+      p = salloc_r_at (u->s, &length_read,
+		       file_position (u->s) - length);
+      if (p == NULL || length_read != length)
+	goto io_error;
+
+      /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
+      if (u->flags.convert == CONVERT_NATIVE)
+	{
+	  switch (length)
+	    {
+	    case sizeof(GFC_INTEGER_4):
+	      memcpy (&m4, p, sizeof (m4));
+	      m = m4;
+	      break;
+
+	    case sizeof(GFC_INTEGER_8):
+	      memcpy (&m8, p, sizeof (m8));
+	      m = m8;
+	      break;
+
+	    default:
+	      runtime_error ("Illegal value for record marker");
+	      break;
+	    }
+	}
+      else
+	{
+	  switch (length)
+	    {
+	    case sizeof(GFC_INTEGER_4):
+	      reverse_memcpy (&m4, p, sizeof (m4));
+	      m = m4;
+	      break;
+
+	    case sizeof(GFC_INTEGER_8):
+	      reverse_memcpy (&m8, p, sizeof (m8));
+	      m = m8;
+	      break;
+
+	    default:
+	      runtime_error ("Illegal value for record marker");
+	      break;
+	    }
+
+	}
+
+      continued = m < 0;
+      if (continued)
+	m = -m;
+
+      if ((new = file_position (u->s) - m - 2*length) < 0)
+	new = 0;
+
+      if (sseek (u->s, new) == FAILURE)
+	goto io_error;
+    } while (continued);
+
+  u->last_record--;
+  return;
+
+ io_error:
+  generate_error (&fpp->common, ERROR_OS, NULL);
+}
+
+
+extern void st_backspace (st_parameter_filepos *);
+export_proto(st_backspace);
+
+void
+st_backspace (st_parameter_filepos *fpp)
+{
+  gfc_unit *u;
+
+  library_start (&fpp->common);
+
+  u = find_unit (fpp->common.unit);
+  if (u == NULL)
+    {
+      generate_error (&fpp->common, ERROR_BAD_UNIT, NULL);
+      goto done;
+    }
+
+  /* Ignore direct access.  Non-advancing I/O is only allowed for formatted
+     sequential I/O and the next direct access transfer repositions the file 
+     anyway.  */
+
+  if (u->flags.access == ACCESS_DIRECT || u->flags.access == ACCESS_STREAM)
+    goto done;
+
+  /* Check for special cases involving the ENDFILE record first.  */
+
+  if (u->endfile == AFTER_ENDFILE)
+    {
+      u->endfile = AT_ENDFILE;
+      flush (u->s);
+      struncate (u->s);
+    }
+  else
+    {
+      if (file_position (u->s) == 0)
+	goto done;		/* Common special case */
+
+      if (u->mode == WRITING)
+	{
+	  flush (u->s);
+	  struncate (u->s);
+	  u->mode = READING;
+        }
+
+      if (u->flags.form == FORM_FORMATTED)
+	formatted_backspace (fpp, u);
+      else
+	unformatted_backspace (fpp, u);
+
+      u->endfile = NO_ENDFILE;
+      u->current_record = 0;
+      u->bytes_left = 0;
+    }
+
+ done:
+  if (u != NULL)
+    unlock_unit (u);
+
+  library_end ();
+}
+
+
+extern void st_endfile (st_parameter_filepos *);
+export_proto(st_endfile);
+
+void
+st_endfile (st_parameter_filepos *fpp)
+{
+  gfc_unit *u;
+
+  library_start (&fpp->common);
+
+  u = find_unit (fpp->common.unit);
+  if (u != NULL)
+    {
+      if (u->current_record)
+	{
+	  st_parameter_dt dtp;
+	  dtp.common = fpp->common;
+	  memset (&dtp.u.p, 0, sizeof (dtp.u.p));
+	  dtp.u.p.current_unit = u;
+	  next_record (&dtp, 1);
+	}
+
+      flush (u->s);
+      struncate (u->s);
+      u->endfile = AFTER_ENDFILE;
+      unlock_unit (u);
+    }
+
+  library_end ();
+}
+
+
+extern void st_rewind (st_parameter_filepos *);
+export_proto(st_rewind);
+
+void
+st_rewind (st_parameter_filepos *fpp)
+{
+  gfc_unit *u;
+
+  library_start (&fpp->common);
+
+  u = find_unit (fpp->common.unit);
+  if (u != NULL)
+    {
+      if (u->flags.access == ACCESS_DIRECT)
+	generate_error (&fpp->common, ERROR_BAD_OPTION,
+			"Cannot REWIND a file opened for DIRECT access");
+      else
+	{
+	  /* Flush the buffers.  If we have been writing to the file, the last
+	       written record is the last record in the file, so truncate the
+	       file now.  Reset to read mode so two consecutive rewind
+	       statements do not delete the file contents.  */
+	  flush (u->s);
+	  if (u->mode == WRITING && u->flags.access != ACCESS_STREAM)
+	    struncate (u->s);
+
+	  u->mode = READING;
+	  u->last_record = 0;
+	  if (sseek (u->s, 0) == FAILURE)
+	    generate_error (&fpp->common, ERROR_OS, NULL);
+
+	  u->endfile = NO_ENDFILE;
+	  u->current_record = 0;
+	  u->strm_pos = 1;
+	  u->read_bad = 0;
+	  test_endfile (u);
+	}
+      /* Update position for INQUIRE.  */
+      u->flags.position = POSITION_REWIND;
+      unlock_unit (u);
+    }
+
+  library_end ();
+}
+
+
+extern void st_flush (st_parameter_filepos *);
+export_proto(st_flush);
+
+void
+st_flush (st_parameter_filepos *fpp)
+{
+  gfc_unit *u;
+
+  library_start (&fpp->common);
+
+  u = find_unit (fpp->common.unit);
+  if (u != NULL)
+    {
+      flush (u->s);
+      unlock_unit (u);
+    }
+  else
+    /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */ 
+    generate_error (&fpp->common, ERROR_BAD_OPTION,
+			"Specified UNIT in FLUSH is not connected");
+
+  library_end ();
+}
diff --git a/gcc-4.2.1/libgfortran/io/format.c b/gcc-4.2.1/libgfortran/io/format.c
new file mode 100644
index 000000000..e1f7a7f56
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/format.c
@@ -0,0 +1,1137 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006
+   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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, 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"
+
+#define FARRAY_SIZE 64
+
+typedef struct fnode_array
+{
+  struct fnode_array *next;
+  fnode array[FARRAY_SIZE];
+}
+fnode_array;
+
+typedef struct format_data
+{
+  char *format_string, *string;
+  const char *error;
+  format_token saved_token;
+  int value, format_string_len, reversion_ok;
+  fnode *avail;
+  const fnode *saved_format;
+  fnode_array *last;
+  fnode_array array;
+}
+format_data;
+
+static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
+				  NULL };
+
+/* Error messages */
+
+static const 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 (format_data *fmt, int literal)
+{
+  int c;
+
+  do
+    {
+      if (fmt->format_string_len == 0)
+	return -1;
+
+      fmt->format_string_len--;
+      c = toupper (*fmt->format_string++);
+    }
+  while (c == ' ' && !literal);
+
+  return c;
+}
+
+
+/* unget_char()-- Back up one character position. */
+
+#define unget_char(fmt) \
+  { fmt->format_string--; fmt->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 (format_data *fmt, fnode **head, fnode **tail, format_token t)
+{
+  fnode *f;
+
+  if (fmt->avail == &fmt->last->array[FARRAY_SIZE])
+    {
+      fmt->last->next = get_mem (sizeof (fnode_array));
+      fmt->last = fmt->last->next;
+      fmt->last->next = NULL;
+      fmt->avail = &fmt->last->array[0];
+    }
+  f = fmt->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 = fmt->format_string;
+  return f;
+}
+
+
+/* free_format_data()-- Free all allocated format data.  */
+
+void
+free_format_data (st_parameter_dt *dtp)
+{
+  fnode_array *fa, *fa_next;
+  format_data *fmt = dtp->u.p.fmt;
+
+  if (fmt == NULL)
+    return;
+
+  for (fa = fmt->array.next; fa; fa = fa_next)
+    {
+      fa_next = fa->next;
+      free_mem (fa);
+    }
+
+  free_mem (fmt);
+  dtp->u.p.fmt = NULL;
+}
+
+
+/* format_lex()-- Simple lexical analyzer for getting the next token
+ * in a FORMAT string.  We support a one-level token pushback in the
+ * fmt->saved_token variable. */
+
+static format_token
+format_lex (format_data *fmt)
+{
+  format_token token;
+  int negative_flag;
+  int c;
+  char delim;
+
+  if (fmt->saved_token != FMT_NONE)
+    {
+      token = fmt->saved_token;
+      fmt->saved_token = FMT_NONE;
+      return token;
+    }
+
+  negative_flag = 0;
+  c = next_char (fmt, 0);
+
+  switch (c)
+    {
+    case '-':
+      negative_flag = 1;
+      /* Fall Through */
+
+    case '+':
+      c = next_char (fmt, 0);
+      if (!isdigit (c))
+	{
+	  token = FMT_UNKNOWN;
+	  break;
+	}
+
+      fmt->value = c - '0';
+
+      for (;;)
+	{
+	  c = next_char (fmt, 0);
+	  if (!isdigit (c))
+	    break;
+
+	  fmt->value = 10 * fmt->value + c - '0';
+	}
+
+      unget_char (fmt);
+
+      if (negative_flag)
+	fmt->value = -fmt->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':
+      fmt->value = c - '0';
+
+      for (;;)
+	{
+	  c = next_char (fmt, 0);
+	  if (!isdigit (c))
+	    break;
+
+	  fmt->value = 10 * fmt->value + c - '0';
+	}
+
+      unget_char (fmt);
+      token = (fmt->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 (fmt, 0))
+	{
+	case 'L':
+	  token = FMT_TL;
+	  break;
+	case 'R':
+	  token = FMT_TR;
+	  break;
+	default:
+	  token = FMT_T;
+	  unget_char (fmt);
+	  break;
+	}
+
+      break;
+
+    case '(':
+      token = FMT_LPAREN;
+      break;
+
+    case ')':
+      token = FMT_RPAREN;
+      break;
+
+    case 'X':
+      token = FMT_X;
+      break;
+
+    case 'S':
+      switch (next_char (fmt, 0))
+	{
+	case 'S':
+	  token = FMT_SS;
+	  break;
+	case 'P':
+	  token = FMT_SP;
+	  break;
+	default:
+	  token = FMT_S;
+	  unget_char (fmt);
+	  break;
+	}
+
+      break;
+
+    case 'B':
+      switch (next_char (fmt, 0))
+	{
+	case 'N':
+	  token = FMT_BN;
+	  break;
+	case 'Z':
+	  token = FMT_BZ;
+	  break;
+	default:
+	  token = FMT_B;
+	  unget_char (fmt);
+	  break;
+	}
+
+      break;
+
+    case '\'':
+    case '"':
+      delim = c;
+
+      fmt->string = fmt->format_string;
+      fmt->value = 0;		/* This is the length of the string */
+
+      for (;;)
+	{
+	  c = next_char (fmt, 1);
+	  if (c == -1)
+	    {
+	      token = FMT_BADSTRING;
+	      fmt->error = bad_string;
+	      break;
+	    }
+
+	  if (c == delim)
+	    {
+	      c = next_char (fmt, 1);
+
+	      if (c == -1)
+		{
+		  token = FMT_BADSTRING;
+		  fmt->error = bad_string;
+		  break;
+		}
+
+	      if (c != delim)
+		{
+		  unget_char (fmt);
+		  token = FMT_STRING;
+		  break;
+		}
+	    }
+
+	  fmt->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 (fmt, 0))
+	{
+	case 'N':
+	  token = FMT_EN;
+	  break;
+	case 'S':
+	  token = FMT_ES;
+	  break;
+	default:
+	  token = FMT_E;
+	  unget_char (fmt);
+	  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 (st_parameter_dt *dtp)
+{
+  fnode *head, *tail;
+  format_token t, u, t2;
+  int repeat;
+  format_data *fmt = dtp->u.p.fmt;
+
+  head = tail = NULL;
+
+  /* Get the next format item */
+ format_item:
+  t = format_lex (fmt);
+ format_item_1:
+  switch (t)
+    {
+    case FMT_POSINT:
+      repeat = fmt->value;
+
+      t = format_lex (fmt);
+      switch (t)
+	{
+	case FMT_LPAREN:
+	  get_fnode (fmt, &head, &tail, FMT_LPAREN);
+	  tail->repeat = repeat;
+	  tail->u.child = parse_format_list (dtp);
+	  if (fmt->error != NULL)
+	    goto finished;
+
+	  goto between_desc;
+
+	case FMT_SLASH:
+	  get_fnode (fmt, &head, &tail, FMT_SLASH);
+	  tail->repeat = repeat;
+	  goto optional_comma;
+
+	case FMT_X:
+	  get_fnode (fmt, &head, &tail, FMT_X);
+	  tail->repeat = 1;
+	  tail->u.k = fmt->value;
+	  goto between_desc;
+
+	case FMT_P:
+	  goto p_descriptor;
+
+	default:
+	  goto data_desc;
+	}
+
+    case FMT_LPAREN:
+      get_fnode (fmt, &head, &tail, FMT_LPAREN);
+      tail->repeat = 1;
+      tail->u.child = parse_format_list (dtp);
+      if (fmt->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 (fmt);
+      if (t != FMT_P)
+	{
+	  fmt->error = "Expected P edit descriptor in format";
+	  goto finished;
+	}
+
+    p_descriptor:
+      get_fnode (fmt, &head, &tail, FMT_P);
+      tail->u.k = fmt->value;
+      tail->repeat = 1;
+
+      t = format_lex (fmt);
+      if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
+	  || t == FMT_G || t == FMT_E)
+	{
+	  repeat = 1;
+	  goto data_desc;
+	}
+
+      fmt->saved_token = t;
+      goto optional_comma;
+
+    case FMT_P:		/* P and X require a prior number */
+      fmt->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:
+
+      fmt->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 (fmt, &head, &tail, FMT_X);
+      tail->repeat = 1;
+      tail->u.k = 1;
+      goto between_desc;
+
+    case FMT_STRING:
+      get_fnode (fmt, &head, &tail, FMT_STRING);
+
+      tail->u.string.p = fmt->string;
+      tail->u.string.length = fmt->value;
+      tail->repeat = 1;
+      goto optional_comma;
+
+    case FMT_S:
+    case FMT_SS:
+    case FMT_SP:
+    case FMT_BN:
+    case FMT_BZ:
+      get_fnode (fmt, &head, &tail, t);
+      tail->repeat = 1;
+      goto between_desc;
+
+    case FMT_COLON:
+      get_fnode (fmt, &head, &tail, FMT_COLON);
+      tail->repeat = 1;
+      goto optional_comma;
+
+    case FMT_SLASH:
+      get_fnode (fmt, &head, &tail, FMT_SLASH);
+      tail->repeat = 1;
+      tail->u.r = 1;
+      goto optional_comma;
+
+    case FMT_DOLLAR:
+      get_fnode (fmt, &head, &tail, FMT_DOLLAR);
+      tail->repeat = 1;
+      notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
+      goto between_desc;
+
+    case FMT_T:
+    case FMT_TL:
+    case FMT_TR:
+      t2 = format_lex (fmt);
+      if (t2 != FMT_POSINT)
+	{
+	  fmt->error = posint_required;
+	  goto finished;
+	}
+      get_fnode (fmt, &head, &tail, t);
+      tail->u.n = fmt->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 (fmt, &head, &tail, FMT_STRING);
+
+      if (fmt->format_string_len < 1)
+	{
+	  fmt->error = bad_hollerith;
+	  goto finished;
+	}
+
+      tail->u.string.p = fmt->format_string;
+      tail->u.string.length = 1;
+      tail->repeat = 1;
+
+      fmt->format_string++;
+      fmt->format_string_len--;
+
+      goto between_desc;
+
+    case FMT_END:
+      fmt->error = unexpected_end;
+      goto finished;
+
+    case FMT_BADSTRING:
+      goto finished;
+
+    case FMT_RPAREN:
+      goto finished;
+
+    default:
+      fmt->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 (fmt);
+      if (t == FMT_POSINT)
+	{
+	  fmt->error = "Repeat count cannot follow P descriptor";
+	  goto finished;
+	}
+
+      fmt->saved_token = t;
+      get_fnode (fmt, &head, &tail, FMT_P);
+
+      goto optional_comma;
+
+    case FMT_L:
+      t = format_lex (fmt);
+      if (t != FMT_POSINT)
+	{
+	  if (notification_std(GFC_STD_GNU) == ERROR)
+	    {
+	      fmt->error = posint_required;
+	      goto finished;
+	    }
+	  else
+	    {
+	      fmt->saved_token = t;
+	      fmt->value = 1;	/* Default width */
+	      notify_std (&dtp->common, GFC_STD_GNU, posint_required);
+	    }
+	}
+
+      get_fnode (fmt, &head, &tail, FMT_L);
+      tail->u.n = fmt->value;
+      tail->repeat = repeat;
+      break;
+
+    case FMT_A:
+      t = format_lex (fmt);
+      if (t != FMT_POSINT)
+	{
+	  fmt->saved_token = t;
+	  fmt->value = -1;		/* Width not present */
+	}
+
+      get_fnode (fmt, &head, &tail, FMT_A);
+      tail->repeat = repeat;
+      tail->u.n = fmt->value;
+      break;
+
+    case FMT_D:
+    case FMT_E:
+    case FMT_F:
+    case FMT_G:
+    case FMT_EN:
+    case FMT_ES:
+      get_fnode (fmt, &head, &tail, t);
+      tail->repeat = repeat;
+
+      u = format_lex (fmt);
+      if (t == FMT_F || dtp->u.p.mode == WRITING)
+	{
+	  if (u != FMT_POSINT && u != FMT_ZERO)
+	    {
+	      fmt->error = nonneg_required;
+	      goto finished;
+	    }
+	}
+      else
+	{
+	  if (u != FMT_POSINT)
+	    {
+	      fmt->error = posint_required;
+	      goto finished;
+	    }
+	}
+
+      tail->u.real.w = fmt->value;
+      t2 = t;
+      t = format_lex (fmt);
+      if (t != FMT_PERIOD)
+	{
+	  /* We treat a missing decimal descriptor as 0.  Note: This is only
+	     allowed if -std=legacy, otherwise an error occurs.  */
+	  if (compile_options.warn_std != 0)
+	    {
+	      fmt->error = period_required;
+	      goto finished;
+	    }
+	  fmt->saved_token = t;
+	  tail->u.real.d = 0;
+	  break;
+	}
+
+      t = format_lex (fmt);
+      if (t != FMT_ZERO && t != FMT_POSINT)
+	{
+	  fmt->error = nonneg_required;
+	  goto finished;
+	}
+
+      tail->u.real.d = fmt->value;
+
+      if (t == FMT_D || t == FMT_F)
+	break;
+
+      tail->u.real.e = -1;
+
+      /* Look for optional exponent */
+      t = format_lex (fmt);
+      if (t != FMT_E)
+	fmt->saved_token = t;
+      else
+	{
+	  t = format_lex (fmt);
+	  if (t != FMT_POSINT)
+	    {
+	      fmt->error = "Positive exponent width required in format";
+	      goto finished;
+	    }
+
+	  tail->u.real.e = fmt->value;
+	}
+
+      break;
+
+    case FMT_H:
+      if (repeat > fmt->format_string_len)
+	{
+	  fmt->error = bad_hollerith;
+	  goto finished;
+	}
+
+      get_fnode (fmt, &head, &tail, FMT_STRING);
+
+      tail->u.string.p = fmt->format_string;
+      tail->u.string.length = repeat;
+      tail->repeat = 1;
+
+      fmt->format_string += fmt->value;
+      fmt->format_string_len -= repeat;
+
+      break;
+
+    case FMT_I:
+    case FMT_B:
+    case FMT_O:
+    case FMT_Z:
+      get_fnode (fmt, &head, &tail, t);
+      tail->repeat = repeat;
+
+      t = format_lex (fmt);
+
+      if (dtp->u.p.mode == READING)
+	{
+	  if (t != FMT_POSINT)
+	    {
+	      fmt->error = posint_required;
+	      goto finished;
+	    }
+	}
+      else
+	{
+	  if (t != FMT_ZERO && t != FMT_POSINT)
+	    {
+	      fmt->error = nonneg_required;
+	      goto finished;
+	    }
+	}
+
+      tail->u.integer.w = fmt->value;
+      tail->u.integer.m = -1;
+
+      t = format_lex (fmt);
+      if (t != FMT_PERIOD)
+	{
+	  fmt->saved_token = t;
+	}
+      else
+	{
+	  t = format_lex (fmt);
+	  if (t != FMT_ZERO && t != FMT_POSINT)
+	    {
+	      fmt->error = nonneg_required;
+	      goto finished;
+	    }
+
+	  tail->u.integer.m = fmt->value;
+	}
+
+      if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
+	{
+	  fmt->error = "Minimum digits exceeds field width";
+	  goto finished;
+	}
+
+      break;
+
+    default:
+      fmt->error = unexpected_element;
+      goto finished;
+    }
+
+  /* Between a descriptor and what comes next */
+ between_desc:
+  t = format_lex (fmt);
+  switch (t)
+    {
+    case FMT_COMMA:
+      goto format_item;
+
+    case FMT_RPAREN:
+      goto finished;
+
+    case FMT_SLASH:
+      get_fnode (fmt, &head, &tail, FMT_SLASH);
+      tail->repeat = 1;
+      goto optional_comma;
+
+    case FMT_COLON:
+      get_fnode (fmt, &head, &tail, FMT_COLON);
+      tail->repeat = 1;
+      goto optional_comma;
+
+    case FMT_END:
+      fmt->error = unexpected_end;
+      goto finished;
+
+    default:
+      /* Assume a missing comma, this is a GNU extension */
+      goto format_item_1;
+    }
+
+  /* Optional comma is a weird between state where we've just finished
+     reading a colon, slash or P descriptor. */
+ optional_comma:
+  t = format_lex (fmt);
+  switch (t)
+    {
+    case FMT_COMMA:
+      break;
+
+    case FMT_RPAREN:
+      goto finished;
+
+    default:			/* Assume that we have another format item */
+      fmt->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.
+ *
+ * We 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 (st_parameter_dt *dtp, const fnode *f, const char *message)
+{
+  int width, i, j, offset;
+  char *p, buffer[300];
+  format_data *fmt = dtp->u.p.fmt;
+
+  if (f != NULL)
+    fmt->format_string = f->source;
+
+  st_sprintf (buffer, "%s\n", message);
+
+  j = fmt->format_string - dtp->format;
+
+  offset = (j > 60) ? j - 40 : 0;
+
+  j -= offset;
+  width = dtp->format_len - offset;
+
+  if (width > 80)
+    width = 80;
+
+  /* Show the format */
+
+  p = strchr (buffer, '\0');
+
+  memcpy (p, dtp->format + offset, width);
+
+  p += width;
+  *p++ = '\n';
+
+  /* Show where the problem is */
+
+  for (i = 1; i < j; i++)
+    *p++ = ' ';
+
+  *p++ = '^';
+  *p = '\0';
+
+  generate_error (&dtp->common, ERROR_FORMAT, buffer);
+}
+
+
+/* parse_format()-- Parse a format string.  */
+
+void
+parse_format (st_parameter_dt *dtp)
+{
+  format_data *fmt;
+
+  dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
+  fmt->format_string = dtp->format;
+  fmt->format_string_len = dtp->format_len;
+
+  fmt->string = NULL;
+  fmt->saved_token = FMT_NONE;
+  fmt->error = NULL;
+  fmt->value = 0;
+
+  /* Initialize variables used during traversal of the tree */
+
+  fmt->reversion_ok = 0;
+  fmt->saved_format = NULL;
+
+  /* Allocate the first format node as the root of the tree */
+
+  fmt->last = &fmt->array;
+  fmt->last->next = NULL;
+  fmt->avail = &fmt->array.array[0];
+
+  memset (fmt->avail, 0, sizeof (*fmt->avail));
+  fmt->avail->format = FMT_LPAREN;
+  fmt->avail->repeat = 1;
+  fmt->avail++;
+
+  if (format_lex (fmt) == FMT_LPAREN)
+    fmt->array.array[0].u.child = parse_format_list (dtp);
+  else
+    fmt->error = "Missing initial left parenthesis in format";
+
+  if (fmt->error)
+    format_error (dtp, NULL, fmt->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 (st_parameter_dt *dtp)
+{
+  fnode *f, *r;
+  format_data *fmt = dtp->u.p.fmt;
+
+  dtp->u.p.reversion_flag = 1;
+
+  r = NULL;
+
+  for (f = fmt->array.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 */
+
+  fmt->array.array[0].current = r;
+  fmt->array.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 const fnode *
+next_format0 (fnode * f)
+{
+  const 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 there
+ * are no more data descriptors to return (which is an error
+ * condition). */
+
+const fnode *
+next_format (st_parameter_dt *dtp)
+{
+  format_token t;
+  const fnode *f;
+  format_data *fmt = dtp->u.p.fmt;
+
+  if (fmt->saved_format != NULL)
+    {				/* Deal with a pushed-back format node */
+      f = fmt->saved_format;
+      fmt->saved_format = NULL;
+      goto done;
+    }
+
+  f = next_format0 (&fmt->array.array[0]);
+  if (f == NULL)
+    {
+      if (!fmt->reversion_ok)
+	return NULL;
+
+      fmt->reversion_ok = 0;
+      revert (dtp);
+
+      f = next_format0 (&fmt->array.array[0]);
+      if (f == NULL)
+	{
+	  format_error (dtp, NULL, reversion_error);
+	  return NULL;
+	}
+
+      /* Push the first reverted token and return a colon node in case
+       * there are no more data items. */
+
+      fmt->saved_format = f;
+      return &colon_node;
+    }
+
+  /* If this is a data edit descriptor, then reversion has become OK. */
+ done:
+  t = f->format;
+
+  if (!fmt->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))
+    fmt->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 (st_parameter_dt *dtp, const fnode *f)
+{
+  dtp->u.p.fmt->saved_format = f;
+}
+
diff --git a/gcc-4.2.1/libgfortran/io/inquire.c b/gcc-4.2.1/libgfortran/io/inquire.c
new file mode 100644
index 000000000..36e43c29b
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/inquire.c
@@ -0,0 +1,443 @@
+/* Copyright (C) 2002, 2003, 2005 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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+
+/* Implement the non-IOLENGTH variant of the INQUIRY statement */
+
+#include "config.h"
+#include "libgfortran.h"
+#include "io.h"
+
+
+static const char undefined[] = "UNDEFINED";
+
+
+/* inquire_via_unit()-- Inquiry via unit number.  The unit might not exist. */
+
+static void
+inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
+{
+  const char *p;
+  GFC_INTEGER_4 cf = iqp->common.flags;
+
+  if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
+    *iqp->exist = iqp->common.unit >= 0;
+
+  if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
+    *iqp->opened = (u != NULL);
+
+  if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
+    *iqp->number = (u != NULL) ? u->unit_number : -1;
+
+  if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
+    *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH);
+
+  if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0
+      && u != NULL && u->flags.status != STATUS_SCRATCH)
+    fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
+
+  if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.access)
+	  {
+	  case ACCESS_SEQUENTIAL:
+	    p = "SEQUENTIAL";
+	    break;
+	  case ACCESS_DIRECT:
+	    p = "DIRECT";
+	    break;
+	  case ACCESS_STREAM:
+	    p = "STREAM";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad access");
+	  }
+
+      cf_strcpy (iqp->access, iqp->access_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
+    {
+      if (u == NULL)
+	p = inquire_sequential (NULL, 0);
+      else
+	{
+          /* disallow an open direct access file to be accessed sequentially */
+          if (u->flags.access == ACCESS_DIRECT)
+            p = "NO";
+          else   
+            p = inquire_sequential (u->file, u->file_len);
+	}
+
+      cf_strcpy (iqp->sequential, iqp->sequential_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
+    {
+      p = (u == NULL) ? inquire_direct (NULL, 0) :
+	inquire_direct (u->file, u->file_len);
+
+      cf_strcpy (iqp->direct, iqp->direct_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.form)
+	  {
+	  case FORM_FORMATTED:
+	    p = "FORMATTED";
+	    break;
+	  case FORM_UNFORMATTED:
+	    p = "UNFORMATTED";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad form");
+	  }
+
+      cf_strcpy (iqp->form, iqp->form_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
+    {
+      p = (u == NULL) ? inquire_formatted (NULL, 0) :
+	inquire_formatted (u->file, u->file_len);
+
+      cf_strcpy (iqp->formatted, iqp->formatted_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
+    {
+      p = (u == NULL) ? inquire_unformatted (NULL, 0) :
+	inquire_unformatted (u->file, u->file_len);
+
+      cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
+    *iqp->recl_out = (u != NULL) ? u->recl : 0;
+
+  if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0)
+    *iqp->strm_pos_out = (u != NULL) ? u->strm_pos : 0;
+
+  if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
+    *iqp->nextrec = (u != NULL) ? u->last_record + 1 : 0;
+
+  if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.blank)
+	  {
+	  case BLANK_NULL:
+	    p = "NULL";
+	    break;
+	  case BLANK_ZERO:
+	    p = "ZERO";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
+	  }
+
+      cf_strcpy (iqp->blank, iqp->blank_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
+    {
+      if (u == NULL || u->flags.access == ACCESS_DIRECT)
+        p = undefined;
+      else
+        switch (u->flags.position)
+          {
+             case POSITION_REWIND:
+               p = "REWIND";
+               break;
+             case POSITION_APPEND:
+               p = "APPEND";
+               break;
+             case POSITION_ASIS:
+               p = "ASIS";
+               break;
+             default:
+               /* if not direct access, it must be
+                  either REWIND, APPEND, or ASIS.
+                  ASIS seems to be the best default */
+               p = "ASIS";
+               break;
+          }
+      cf_strcpy (iqp->position, iqp->position_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.action)
+	  {
+	  case ACTION_READ:
+	    p = "READ";
+	    break;
+	  case ACTION_WRITE:
+	    p = "WRITE";
+	    break;
+	  case ACTION_READWRITE:
+	    p = "READWRITE";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad action");
+	  }
+
+      cf_strcpy (iqp->action, iqp->action_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
+    {
+      p = (u == NULL) ? inquire_read (NULL, 0) :
+	inquire_read (u->file, u->file_len);
+
+      cf_strcpy (iqp->read, iqp->read_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
+    {
+      p = (u == NULL) ? inquire_write (NULL, 0) :
+	inquire_write (u->file, u->file_len);
+
+      cf_strcpy (iqp->write, iqp->write_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
+    {
+      p = (u == NULL) ? inquire_readwrite (NULL, 0) :
+	inquire_readwrite (u->file, u->file_len);
+
+      cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
+    {
+      if (u == NULL || u->flags.form != FORM_FORMATTED)
+	p = undefined;
+      else
+	switch (u->flags.delim)
+	  {
+	  case DELIM_NONE:
+	    p = "NONE";
+	    break;
+	  case DELIM_QUOTE:
+	    p = "QUOTE";
+	    break;
+	  case DELIM_APOSTROPHE:
+	    p = "APOSTROPHE";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
+	  }
+
+      cf_strcpy (iqp->delim, iqp->delim_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
+    {
+      if (u == NULL || u->flags.form != FORM_FORMATTED)
+	p = undefined;
+      else
+	switch (u->flags.pad)
+	  {
+	  case PAD_NO:
+	    p = "NO";
+	    break;
+	  case PAD_YES:
+	    p = "YES";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
+	  }
+
+      cf_strcpy (iqp->pad, iqp->pad_len, p);
+    }
+ 
+  if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.convert)
+	  {
+	    /*  l8_to_l4_offset is 0 for little-endian, 1 for big-endian.  */
+	  case CONVERT_NATIVE:
+	    p = l8_to_l4_offset ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
+	    break;
+
+	  case CONVERT_SWAP:
+	    p = l8_to_l4_offset ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
+	    break;
+
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
+	  }
+
+      cf_strcpy (iqp->convert, iqp->convert_len, p);
+    }
+}
+
+
+/* inquire_via_filename()-- Inquiry via filename.  This subroutine is
+ * only used if the filename is *not* connected to a unit number. */
+
+static void
+inquire_via_filename (st_parameter_inquire *iqp)
+{
+  const char *p;
+  GFC_INTEGER_4 cf = iqp->common.flags;
+
+  if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
+    *iqp->exist = file_exists (iqp->file, iqp->file_len);
+
+  if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
+    *iqp->opened = 0;
+
+  if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
+    *iqp->number = -1;
+
+  if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
+    *iqp->named = 1;
+
+  if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
+    fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
+
+  if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
+    cf_strcpy (iqp->access, iqp->access_len, undefined);
+
+  if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
+    {
+      p = inquire_sequential (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->sequential, iqp->sequential_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
+    {
+      p = inquire_direct (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->direct, iqp->direct_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
+    cf_strcpy (iqp->form, iqp->form_len, undefined);
+
+  if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
+    {
+      p = inquire_formatted (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->formatted, iqp->formatted_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
+    {
+      p = inquire_unformatted (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
+    *iqp->recl_out = 0;
+
+  if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
+    *iqp->nextrec = 0;
+
+  if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
+    cf_strcpy (iqp->blank, iqp->blank_len, undefined);
+
+  if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
+    cf_strcpy (iqp->position, iqp->position_len, undefined);
+
+  if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
+    cf_strcpy (iqp->access, iqp->access_len, undefined);
+
+  if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
+    {
+      p = inquire_read (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->read, iqp->read_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
+    {
+      p = inquire_write (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->write, iqp->write_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
+    {
+      p = inquire_read (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
+    cf_strcpy (iqp->delim, iqp->delim_len, undefined);
+
+  if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
+    cf_strcpy (iqp->pad, iqp->pad_len, undefined);
+}
+
+
+/* Library entry point for the INQUIRE statement (non-IOLENGTH
+   form).  */
+
+extern void st_inquire (st_parameter_inquire *);
+export_proto(st_inquire);
+
+void
+st_inquire (st_parameter_inquire *iqp)
+{
+  gfc_unit *u;
+
+  library_start (&iqp->common);
+
+  if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
+    {
+      u = find_unit (iqp->common.unit);
+      inquire_via_unit (iqp, u);
+    }
+  else
+    {
+      u = find_file (iqp->file, iqp->file_len);
+      if (u == NULL)
+	inquire_via_filename (iqp);
+      else
+	inquire_via_unit (iqp, u);
+    }
+  if (u != NULL)
+    unlock_unit (u);
+
+  library_end ();
+}
diff --git a/gcc-4.2.1/libgfortran/io/io.h b/gcc-4.2.1/libgfortran/io/io.h
new file mode 100644
index 000000000..4d227dd3b
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/io.h
@@ -0,0 +1,932 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006 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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+/* As a special exception, if you link this library with other files,
+   some of which are compiled with GCC, to produce an executable,
+   this library does not by itself cause the resulting executable
+   to be covered by the GNU General Public License.
+   This exception does not however invalidate any other reasons why
+   the executable file might be covered by the GNU General Public License.  */
+
+#ifndef GFOR_IO_H
+#define GFOR_IO_H
+
+/* IO library include.  */
+
+#include <setjmp.h>
+#include "libgfortran.h"
+
+#include <gthr.h>
+
+#define DEFAULT_TEMPDIR "/tmp"
+
+/* Basic types used in data transfers.  */
+
+typedef enum
+{ BT_NULL, BT_INTEGER, BT_LOGICAL, BT_CHARACTER, BT_REAL,
+  BT_COMPLEX
+}
+bt;
+
+
+struct st_parameter_dt;
+
+typedef struct stream
+{
+  char *(*alloc_w_at) (struct stream *, int *, gfc_offset);
+  char *(*alloc_r_at) (struct stream *, int *, gfc_offset);
+  try (*sfree) (struct stream *);
+  try (*close) (struct stream *);
+  try (*seek) (struct stream *, gfc_offset);
+  try (*truncate) (struct stream *);
+  int (*read) (struct stream *, void *, size_t *);
+  int (*write) (struct stream *, const void *, size_t *);
+  try (*set) (struct stream *, int, size_t);
+}
+stream;
+
+
+/* Macros for doing file I/O given a stream.  */
+
+#define sfree(s) ((s)->sfree)(s)
+#define sclose(s) ((s)->close)(s)
+
+#define salloc_r(s, len) ((s)->alloc_r_at)(s, len, -1)
+#define salloc_w(s, len) ((s)->alloc_w_at)(s, len, -1)
+
+#define salloc_r_at(s, len, where) ((s)->alloc_r_at)(s, len, where)
+#define salloc_w_at(s, len, where) ((s)->alloc_w_at)(s, len, where)
+
+#define sseek(s, pos) ((s)->seek)(s, pos)
+#define struncate(s) ((s)->truncate)(s)
+#define sread(s, buf, nbytes) ((s)->read)(s, buf, nbytes)
+#define swrite(s, buf, nbytes) ((s)->write)(s, buf, nbytes)
+
+#define sset(s, c, n) ((s)->set)(s, c, n)
+
+/* The array_loop_spec contains the variables for the loops over index ranges
+   that are encountered.  Since the variables can be negative, ssize_t
+   is used.  */
+
+typedef struct array_loop_spec
+{
+  /* Index counter for this dimension.  */
+  ssize_t idx;
+
+  /* Start for the index counter.  */
+  ssize_t start;
+
+  /* End for the index counter.  */
+  ssize_t end;
+
+  /* Step for the index counter.  */
+  ssize_t step;
+}
+array_loop_spec;
+
+/* Representation of a namelist object in libgfortran
+
+   Namelist Records
+      &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]].../
+     or
+      &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]]...&END
+
+   The object can be a fully qualified, compound name for an intrinsic
+   type, derived types or derived type components.  So, a substring
+   a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
+   read. Hence full information about the structure of the object has
+   to be available to list_read.c and write.
+
+   These requirements are met by the following data structures.
+
+   namelist_info type contains all the scalar information about the
+   object and arrays of descriptor_dimension and array_loop_spec types for
+   arrays.  */
+
+typedef struct namelist_type
+{
+
+  /* Object type, stored as GFC_DTYPE_xxxx.  */
+  bt type;
+
+  /* Object name.  */
+  char * var_name;
+
+  /* Address for the start of the object's data.  */
+  void * mem_pos;
+
+  /* Flag to show that a read is to be attempted for this node.  */
+  int touched;
+
+  /* Length of intrinsic type in bytes.  */
+  int len;
+
+  /* Rank of the object.  */
+  int var_rank;
+
+  /* Overall size of the object in bytes.  */
+  index_type size;
+
+  /* Length of character string.  */
+  index_type string_length;
+
+  descriptor_dimension * dim;
+  array_loop_spec * ls;
+  struct namelist_type * next;
+}
+namelist_info;
+
+/* Options for the OPEN statement.  */
+
+typedef enum
+{ ACCESS_SEQUENTIAL, ACCESS_DIRECT, ACCESS_APPEND, ACCESS_STREAM,
+  ACCESS_UNSPECIFIED
+}
+unit_access;
+
+typedef enum
+{ ACTION_READ, ACTION_WRITE, ACTION_READWRITE,
+  ACTION_UNSPECIFIED
+}
+unit_action;
+
+typedef enum
+{ BLANK_NULL, BLANK_ZERO, BLANK_UNSPECIFIED }
+unit_blank;
+
+typedef enum
+{ DELIM_NONE, DELIM_APOSTROPHE, DELIM_QUOTE,
+  DELIM_UNSPECIFIED
+}
+unit_delim;
+
+typedef enum
+{ FORM_FORMATTED, FORM_UNFORMATTED, FORM_UNSPECIFIED }
+unit_form;
+
+typedef enum
+{ POSITION_ASIS, POSITION_REWIND, POSITION_APPEND,
+  POSITION_UNSPECIFIED
+}
+unit_position;
+
+typedef enum
+{ STATUS_UNKNOWN, STATUS_OLD, STATUS_NEW, STATUS_SCRATCH,
+  STATUS_REPLACE, STATUS_UNSPECIFIED
+}
+unit_status;
+
+typedef enum
+{ PAD_YES, PAD_NO, PAD_UNSPECIFIED }
+unit_pad;
+
+typedef enum
+{ ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED }
+unit_advance;
+
+typedef enum
+{READING, WRITING}
+unit_mode;
+
+typedef enum
+{ CONVERT_NONE=-1, CONVERT_NATIVE, CONVERT_SWAP, CONVERT_BIG, CONVERT_LITTLE }
+unit_convert;
+
+#define CHARACTER1(name) \
+	      char * name; \
+	      gfc_charlen_type name ## _len
+#define CHARACTER2(name) \
+	      gfc_charlen_type name ## _len; \
+	      char * name
+
+#define IOPARM_LIBRETURN_MASK		(3 << 0)
+#define IOPARM_LIBRETURN_OK		(0 << 0)
+#define IOPARM_LIBRETURN_ERROR		(1 << 0)
+#define IOPARM_LIBRETURN_END		(2 << 0)
+#define IOPARM_LIBRETURN_EOR		(3 << 0)
+#define IOPARM_ERR			(1 << 2)
+#define IOPARM_END			(1 << 3)
+#define IOPARM_EOR			(1 << 4)
+#define IOPARM_HAS_IOSTAT		(1 << 5)
+#define IOPARM_HAS_IOMSG		(1 << 6)
+
+#define IOPARM_COMMON_MASK		((1 << 7) - 1)
+
+typedef struct st_parameter_common
+{
+  GFC_INTEGER_4 flags;
+  GFC_INTEGER_4 unit;
+  const char *filename;
+  GFC_INTEGER_4 line;
+  CHARACTER2 (iomsg);
+  GFC_INTEGER_4 *iostat;
+}
+st_parameter_common;
+
+#define IOPARM_OPEN_HAS_RECL_IN		(1 << 7)
+#define IOPARM_OPEN_HAS_FILE		(1 << 8)
+#define IOPARM_OPEN_HAS_STATUS		(1 << 9)
+#define IOPARM_OPEN_HAS_ACCESS		(1 << 10)
+#define IOPARM_OPEN_HAS_FORM		(1 << 11)
+#define IOPARM_OPEN_HAS_BLANK		(1 << 12)
+#define IOPARM_OPEN_HAS_POSITION	(1 << 13)
+#define IOPARM_OPEN_HAS_ACTION		(1 << 14)
+#define IOPARM_OPEN_HAS_DELIM		(1 << 15)
+#define IOPARM_OPEN_HAS_PAD		(1 << 16)
+#define IOPARM_OPEN_HAS_CONVERT		(1 << 17)
+
+typedef struct
+{
+  st_parameter_common common;
+  GFC_INTEGER_4 recl_in;
+  CHARACTER2 (file);
+  CHARACTER1 (status);
+  CHARACTER2 (access);
+  CHARACTER1 (form);
+  CHARACTER2 (blank);
+  CHARACTER1 (position);
+  CHARACTER2 (action);
+  CHARACTER1 (delim);
+  CHARACTER2 (pad);
+  CHARACTER1 (convert);
+}
+st_parameter_open;
+
+#define IOPARM_CLOSE_HAS_STATUS		(1 << 7)
+
+typedef struct
+{
+  st_parameter_common common;
+  CHARACTER1 (status);
+}
+st_parameter_close;
+
+typedef struct
+{
+  st_parameter_common common;
+}
+st_parameter_filepos;
+
+#define IOPARM_INQUIRE_HAS_EXIST	(1 << 7)
+#define IOPARM_INQUIRE_HAS_OPENED	(1 << 8)
+#define IOPARM_INQUIRE_HAS_NUMBER	(1 << 9)
+#define IOPARM_INQUIRE_HAS_NAMED	(1 << 10)
+#define IOPARM_INQUIRE_HAS_NEXTREC	(1 << 11)
+#define IOPARM_INQUIRE_HAS_RECL_OUT	(1 << 12)
+#define IOPARM_INQUIRE_HAS_STRM_POS_OUT (1 << 13)
+#define IOPARM_INQUIRE_HAS_FILE		(1 << 14)
+#define IOPARM_INQUIRE_HAS_ACCESS	(1 << 15)
+#define IOPARM_INQUIRE_HAS_FORM		(1 << 16)
+#define IOPARM_INQUIRE_HAS_BLANK	(1 << 17)
+#define IOPARM_INQUIRE_HAS_POSITION	(1 << 18)
+#define IOPARM_INQUIRE_HAS_ACTION	(1 << 19)
+#define IOPARM_INQUIRE_HAS_DELIM	(1 << 20)
+#define IOPARM_INQUIRE_HAS_PAD		(1 << 21)
+#define IOPARM_INQUIRE_HAS_NAME		(1 << 22)
+#define IOPARM_INQUIRE_HAS_SEQUENTIAL	(1 << 23)
+#define IOPARM_INQUIRE_HAS_DIRECT	(1 << 24)
+#define IOPARM_INQUIRE_HAS_FORMATTED	(1 << 25)
+#define IOPARM_INQUIRE_HAS_UNFORMATTED	(1 << 26)
+#define IOPARM_INQUIRE_HAS_READ		(1 << 27)
+#define IOPARM_INQUIRE_HAS_WRITE	(1 << 28)
+#define IOPARM_INQUIRE_HAS_READWRITE	(1 << 29)
+#define IOPARM_INQUIRE_HAS_CONVERT	(1 << 30)
+
+typedef struct
+{
+  st_parameter_common common;
+  GFC_INTEGER_4 *exist, *opened, *number, *named;
+  GFC_INTEGER_4 *nextrec, *recl_out;
+  GFC_IO_INT *strm_pos_out;
+  CHARACTER1 (file);
+  CHARACTER2 (access);
+  CHARACTER1 (form);
+  CHARACTER2 (blank);
+  CHARACTER1 (position);
+  CHARACTER2 (action);
+  CHARACTER1 (delim);
+  CHARACTER2 (pad);
+  CHARACTER1 (name);
+  CHARACTER2 (sequential);
+  CHARACTER1 (direct);
+  CHARACTER2 (formatted);
+  CHARACTER1 (unformatted);
+  CHARACTER2 (read);
+  CHARACTER1 (write);
+  CHARACTER2 (readwrite);
+  CHARACTER1 (convert);
+}
+st_parameter_inquire;
+
+struct gfc_unit;
+struct format_data;
+
+#define IOPARM_DT_LIST_FORMAT			(1 << 7)
+#define IOPARM_DT_NAMELIST_READ_MODE		(1 << 8)
+#define IOPARM_DT_HAS_REC			(1 << 9)
+#define IOPARM_DT_HAS_SIZE			(1 << 10)
+#define IOPARM_DT_HAS_IOLENGTH			(1 << 11)
+#define IOPARM_DT_HAS_FORMAT			(1 << 12)
+#define IOPARM_DT_HAS_ADVANCE			(1 << 13)
+#define IOPARM_DT_HAS_INTERNAL_UNIT		(1 << 14)
+#define IOPARM_DT_HAS_NAMELIST_NAME		(1 << 15)
+/* Internal use bit.  */
+#define IOPARM_DT_IONML_SET			(1 << 31)
+
+typedef struct st_parameter_dt
+{
+  st_parameter_common common;
+  GFC_IO_INT rec;
+  GFC_INTEGER_4 *size, *iolength;
+  gfc_array_char *internal_unit_desc;
+  CHARACTER1 (format);
+  CHARACTER2 (advance);
+  CHARACTER1 (internal_unit);
+  CHARACTER2 (namelist_name);
+  /* Private part of the structure.  The compiler just needs
+     to reserve enough space.  */
+  union
+    {
+      struct
+	{
+	  void (*transfer) (struct st_parameter_dt *, bt, void *, int,
+			    size_t, size_t);
+	  struct gfc_unit *current_unit;
+	  /* Item number in a formatted data transfer.  Also used in namelist
+	       read_logical as an index into line_buffer.  */
+	  int item_count;
+	  unit_mode mode;
+	  unit_blank blank_status;
+	  enum {SIGN_S, SIGN_SS, SIGN_SP} sign_status;
+	  int scale_factor;
+	  int max_pos; /* Maximum righthand column written to.  */
+	  /* Number of skips + spaces to be done for T and X-editing.  */
+	  int skips;
+	  /* Number of spaces to be done for T and X-editing.  */
+	  int pending_spaces;
+	  /* Whether an EOR condition was encountered. Value is:
+	       0 if no EOR was encountered
+	       1 if an EOR was encountered due to a 1-byte marker (LF)
+	       2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
+	  int sf_seen_eor;
+	  unit_advance advance_status;
+
+	  unsigned reversion_flag : 1; /* Format reversion has occurred.  */
+	  unsigned first_item : 1;
+	  unsigned seen_dollar : 1;
+	  unsigned eor_condition : 1;
+	  unsigned no_leading_blank : 1;
+	  unsigned char_flag : 1;
+	  unsigned input_complete : 1;
+	  unsigned at_eol : 1;
+	  unsigned comma_flag : 1;
+	  /* A namelist specific flag used in the list directed library
+	     to flag that calls are being made from namelist read (eg. to
+	     ignore comments or to treat '/' as a terminator)  */
+	  unsigned namelist_mode : 1;
+	  /* A namelist specific flag used in the list directed library
+	     to flag read errors and return, so that an attempt can be
+	     made to read a new object name.  */
+	  unsigned nml_read_error : 1;
+	  /* A sequential formatted read specific flag used to signal that a
+	     character string is being read so don't use commas to shorten a
+	     formatted field width.  */
+	  unsigned sf_read_comma : 1;
+          /* A namelist specific flag used to enable reading input from 
+	     line_buffer for logical reads.  */
+	  unsigned line_buffer_enabled : 1;
+	  /* An internal unit specific flag used to identify that the associated
+	     unit is internal.  */
+	  unsigned unit_is_internal : 1;
+	  /* An internal unit specific flag to signify an EOF condition for list
+	     directed read.  */
+	  unsigned at_eof : 1;
+	  /* 16 unused bits.  */
+
+	  char last_char;
+	  char nml_delim;
+
+	  int repeat_count;
+	  int saved_length;
+	  int saved_used;
+	  bt saved_type;
+	  char *saved_string;
+	  char *scratch;
+	  char *line_buffer;
+	  struct format_data *fmt;
+	  jmp_buf *eof_jump;
+	  namelist_info *ionml;
+	  /* A flag used to identify when a non-standard expanded namelist read
+	     has occurred.  */
+	  int expanded_read;
+	  /* Storage area for values except for strings.  Must be large
+	     enough to hold a complex value (two reals) of the largest
+	     kind.  */
+	  char value[32];
+	  gfc_offset size_used;
+	} p;
+      /* This pad size must be equal to the pad_size declared in
+	 trans-io.c (gfc_build_io_library_fndecls).  The above structure
+	 must be smaller or equal to this array.  */
+      char pad[16 * sizeof (char *) + 32 * sizeof (int)];
+    } u;
+}
+st_parameter_dt;
+
+/* Ensure st_parameter_dt's u.pad is bigger or equal to u.p.  */
+extern char check_st_parameter_dt[sizeof (((st_parameter_dt *) 0)->u.pad)
+				  >= sizeof (((st_parameter_dt *) 0)->u.p)
+				  ? 1 : -1];
+
+#undef CHARACTER1
+#undef CHARACTER2
+
+typedef struct
+{
+  unit_access access;
+  unit_action action;
+  unit_blank blank;
+  unit_delim delim;
+  unit_form form;
+  int is_notpadded;
+  unit_position position;
+  unit_status status;
+  unit_pad pad;
+  unit_convert convert;
+  int has_recl;
+}
+unit_flags;
+
+
+/* The default value of record length for preconnected units is defined
+   here. This value can be overriden by an environment variable.
+   Default value is 1 Gb.  */
+
+#define DEFAULT_RECL 1073741824
+
+
+typedef struct gfc_unit
+{
+  int unit_number;
+  stream *s;
+  
+  /* Treap links.  */
+  struct gfc_unit *left, *right;
+  int priority;
+
+  int read_bad, current_record;
+  enum
+  { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
+  endfile;
+
+  unit_mode mode;
+  unit_flags flags;
+
+  /* recl                 -- Record length of the file.
+     last_record          -- Last record number read or written
+     maxrec               -- Maximum record number in a direct access file
+     bytes_left           -- Bytes left in current record.
+     strm_pos             -- Current position in file for STREAM I/O.
+     recl_subrecord       -- Maximum length for subrecord.
+     bytes_left_subrecord -- Bytes left in current subrecord.  */
+  gfc_offset recl, last_record, maxrec, bytes_left, strm_pos,
+    recl_subrecord, bytes_left_subrecord;
+
+  /* Set to 1 if we have read a subrecord.  */
+
+  int continued;
+
+  __gthread_mutex_t lock;
+  /* Number of threads waiting to acquire this unit's lock.
+     When non-zero, close_unit doesn't only removes the unit
+     from the UNIT_ROOT tree, but doesn't free it and the
+     last of the waiting threads will do that.
+     This must be either atomically increased/decreased, or
+     always guarded by UNIT_LOCK.  */
+  int waiting;
+  /* Flag set by close_unit if the unit as been closed.
+     Must be manipulated under unit's lock.  */
+  int closed;
+
+  /* For traversing arrays */
+  array_loop_spec *ls;
+  int rank;
+
+  int file_len;
+  char *file;
+}
+gfc_unit;
+
+/* Format tokens.  Only about half of these can be stored in the
+   format nodes.  */
+
+typedef enum
+{
+  FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
+  FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL,
+  FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
+  FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
+  FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END
+}
+format_token;
+
+
+/* Format nodes.  A format string is converted into a tree of these
+   structures, which is traversed as part of a data transfer statement.  */
+
+typedef struct fnode
+{
+  format_token format;
+  int repeat;
+  struct fnode *next;
+  char *source;
+
+  union
+  {
+    struct
+    {
+      int w, d, e;
+    }
+    real;
+
+    struct
+    {
+      int length;
+      char *p;
+    }
+    string;
+
+    struct
+    {
+      int w, m;
+    }
+    integer;
+
+    int w;
+    int k;
+    int r;
+    int n;
+
+    struct fnode *child;
+  }
+  u;
+
+  /* Members for traversing the tree during data transfer.  */
+
+  int count;
+  struct fnode *current;
+
+}
+fnode;
+
+
+/* unix.c */
+
+extern int move_pos_offset (stream *, int);
+internal_proto(move_pos_offset);
+
+extern int compare_files (stream *, stream *);
+internal_proto(compare_files);
+
+extern stream *open_external (st_parameter_open *, unit_flags *);
+internal_proto(open_external);
+
+extern stream *open_internal (char *, int);
+internal_proto(open_internal);
+
+extern stream *input_stream (void);
+internal_proto(input_stream);
+
+extern stream *output_stream (void);
+internal_proto(output_stream);
+
+extern stream *error_stream (void);
+internal_proto(error_stream);
+
+extern int compare_file_filename (gfc_unit *, const char *, int);
+internal_proto(compare_file_filename);
+
+extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len);
+internal_proto(find_file);
+
+extern void flush_all_units (void);
+internal_proto(flush_all_units);
+
+extern int stream_at_bof (stream *);
+internal_proto(stream_at_bof);
+
+extern int stream_at_eof (stream *);
+internal_proto(stream_at_eof);
+
+extern int delete_file (gfc_unit *);
+internal_proto(delete_file);
+
+extern int file_exists (const char *file, gfc_charlen_type file_len);
+internal_proto(file_exists);
+
+extern const char *inquire_sequential (const char *, int);
+internal_proto(inquire_sequential);
+
+extern const char *inquire_direct (const char *, int);
+internal_proto(inquire_direct);
+
+extern const char *inquire_formatted (const char *, int);
+internal_proto(inquire_formatted);
+
+extern const char *inquire_unformatted (const char *, int);
+internal_proto(inquire_unformatted);
+
+extern const char *inquire_read (const char *, int);
+internal_proto(inquire_read);
+
+extern const char *inquire_write (const char *, int);
+internal_proto(inquire_write);
+
+extern const char *inquire_readwrite (const char *, int);
+internal_proto(inquire_readwrite);
+
+extern gfc_offset file_length (stream *);
+internal_proto(file_length);
+
+extern gfc_offset file_position (stream *);
+internal_proto(file_position);
+
+extern int is_seekable (stream *);
+internal_proto(is_seekable);
+
+extern int is_preconnected (stream *);
+internal_proto(is_preconnected);
+
+extern void flush_if_preconnected (stream *);
+internal_proto(flush_if_preconnected);
+
+extern void empty_internal_buffer(stream *);
+internal_proto(empty_internal_buffer);
+
+extern try flush (stream *);
+internal_proto(flush);
+
+extern int stream_isatty (stream *);
+internal_proto(stream_isatty);
+
+extern char * stream_ttyname (stream *);
+internal_proto(stream_ttyname);
+
+extern gfc_offset stream_offset (stream *s);
+internal_proto(stream_offset);
+
+extern int unpack_filename (char *, const char *, int);
+internal_proto(unpack_filename);
+
+/* unit.c */
+
+/* Maximum file offset, computed at library initialization time.  */
+extern gfc_offset max_offset;
+internal_proto(max_offset);
+
+/* Unit tree root.  */
+extern gfc_unit *unit_root;
+internal_proto(unit_root);
+
+extern __gthread_mutex_t unit_lock;
+internal_proto(unit_lock);
+
+extern int close_unit (gfc_unit *);
+internal_proto(close_unit);
+
+extern gfc_unit *get_internal_unit (st_parameter_dt *);
+internal_proto(get_internal_unit);
+
+extern void free_internal_unit (st_parameter_dt *);
+internal_proto(free_internal_unit);
+
+extern int is_internal_unit (st_parameter_dt *);
+internal_proto(is_internal_unit);
+
+extern int is_array_io (st_parameter_dt *);
+internal_proto(is_array_io);
+
+extern int is_stream_io (st_parameter_dt *);
+internal_proto(is_stream_io);
+
+extern gfc_unit *find_unit (int);
+internal_proto(find_unit);
+
+extern gfc_unit *find_or_create_unit (int);
+internal_proto(find_or_create_unit);
+
+extern gfc_unit *get_unit (st_parameter_dt *, int);
+internal_proto(get_unit);
+
+extern void unlock_unit (gfc_unit *);
+internal_proto(unlock_unit);
+
+/* open.c */
+
+extern void test_endfile (gfc_unit *);
+internal_proto(test_endfile);
+
+extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
+internal_proto(new_unit);
+
+/* format.c */
+
+extern void parse_format (st_parameter_dt *);
+internal_proto(parse_format);
+
+extern const fnode *next_format (st_parameter_dt *);
+internal_proto(next_format);
+
+extern void unget_format (st_parameter_dt *, const fnode *);
+internal_proto(unget_format);
+
+extern void format_error (st_parameter_dt *, const fnode *, const char *);
+internal_proto(format_error);
+
+extern void free_format_data (st_parameter_dt *);
+internal_proto(free_format_data);
+
+/* transfer.c */
+
+#define SCRATCH_SIZE 300
+
+extern const char *type_name (bt);
+internal_proto(type_name);
+
+extern void *read_block (st_parameter_dt *, int *);
+internal_proto(read_block);
+
+extern char *read_sf (st_parameter_dt *, int *, int);
+internal_proto(read_sf);
+
+extern void *write_block (st_parameter_dt *, int);
+internal_proto(write_block);
+
+extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *);
+internal_proto(next_array_record);
+
+extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *);
+internal_proto(init_loop_spec);
+
+extern void next_record (st_parameter_dt *, int);
+internal_proto(next_record);
+
+extern void reverse_memcpy (void *, const void *, size_t);
+internal_proto (reverse_memcpy);
+
+/* read.c */
+
+extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
+internal_proto(set_integer);
+
+extern GFC_UINTEGER_LARGEST max_value (int, int);
+internal_proto(max_value);
+
+extern int convert_real (st_parameter_dt *, void *, const char *, int);
+internal_proto(convert_real);
+
+extern void read_a (st_parameter_dt *, const fnode *, char *, int);
+internal_proto(read_a);
+
+extern void read_f (st_parameter_dt *, const fnode *, char *, int);
+internal_proto(read_f);
+
+extern void read_l (st_parameter_dt *, const fnode *, char *, int);
+internal_proto(read_l);
+
+extern void read_x (st_parameter_dt *, int);
+internal_proto(read_x);
+
+extern void read_radix (st_parameter_dt *, const fnode *, char *, int, int);
+internal_proto(read_radix);
+
+extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
+internal_proto(read_decimal);
+
+/* list_read.c */
+
+extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
+				 size_t);
+internal_proto(list_formatted_read);
+
+extern void finish_list_read (st_parameter_dt *);
+internal_proto(finish_list_read);
+
+extern void namelist_read (st_parameter_dt *);
+internal_proto(namelist_read);
+
+extern void namelist_write (st_parameter_dt *);
+internal_proto(namelist_write);
+
+/* write.c */
+
+extern void write_a (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_a);
+
+extern void write_b (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_b);
+
+extern void write_d (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_d);
+
+extern void write_e (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_e);
+
+extern void write_en (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_en);
+
+extern void write_es (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_es);
+
+extern void write_f (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_f);
+
+extern void write_i (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_i);
+
+extern void write_l (st_parameter_dt *, const fnode *, char *, int);
+internal_proto(write_l);
+
+extern void write_o (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_o);
+
+extern void write_x (st_parameter_dt *, int, int);
+internal_proto(write_x);
+
+extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_z);
+
+extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
+				  size_t);
+internal_proto(list_formatted_write);
+
+/* error.c */
+extern notification notification_std(int);
+internal_proto(notification_std);
+
+/* size_from_kind.c */
+extern size_t size_from_real_kind (int);
+internal_proto(size_from_real_kind);
+
+extern size_t size_from_complex_kind (int);
+internal_proto(size_from_complex_kind);
+
+/* lock.c */
+extern void free_ionml (st_parameter_dt *);
+internal_proto(free_ionml);
+
+static inline void
+inc_waiting_locked (gfc_unit *u)
+{
+#ifdef HAVE_SYNC_FETCH_AND_ADD
+  (void) __sync_fetch_and_add (&u->waiting, 1);
+#else
+  u->waiting++;
+#endif
+}
+
+static inline int
+predec_waiting_locked (gfc_unit *u)
+{
+#ifdef HAVE_SYNC_FETCH_AND_ADD
+  return __sync_add_and_fetch (&u->waiting, -1);
+#else
+  return --u->waiting;
+#endif
+}
+
+static inline void
+dec_waiting_unlocked (gfc_unit *u)
+{
+#ifdef HAVE_SYNC_FETCH_AND_ADD
+  (void) __sync_fetch_and_add (&u->waiting, -1);
+#else
+  __gthread_mutex_lock (&unit_lock);
+  u->waiting--;
+  __gthread_mutex_unlock (&unit_lock);
+#endif
+}
+
+#endif
+
+/* ../runtime/environ.c  This is here because we return unit_convert.  */
+
+unit_convert get_unformatted_convert (int);
+internal_proto(get_unformatted_convert);
diff --git a/gcc-4.2.1/libgfortran/io/list_read.c b/gcc-4.2.1/libgfortran/io/list_read.c
new file mode 100644
index 000000000..3203f3116
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/list_read.c
@@ -0,0 +1,2633 @@
+/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   Namelist input contributed by Paul Thomas
+
+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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+
+#include "config.h"
+#include <string.h>
+#include <ctype.h>
+#include "libgfortran.h"
+#include "io.h"
+
+
+/* List directed input.  Several parsing subroutines are practically
+   reimplemented from formatted input, the reason being that there are
+   all kinds of small differences between formatted and list directed
+   parsing.  */
+
+
+/* Subroutines for reading characters from the input.  Because a
+   repeat count is ambiguous with an integer, we have to read the
+   whole digit string before seeing if there is a '*' which signals
+   the repeat count.  Since we can have a lot of potential leading
+   zeros, we have to be able to back up by arbitrary amount.  Because
+   the input might not be seekable, we have to buffer the data
+   ourselves.  */
+
+#define CASE_DIGITS   case '0': case '1': case '2': case '3': case '4': \
+                      case '5': case '6': case '7': case '8': case '9'
+
+#define CASE_SEPARATORS  case ' ': case ',': case '/': case '\n': case '\t': \
+                         case '\r'
+
+/* This macro assumes that we're operating on a variable.  */
+
+#define is_separator(c) (c == '/' ||  c == ',' || c == '\n' || c == ' ' \
+                         || c == '\t' || c == '\r')
+
+/* Maximum repeat count.  Less than ten times the maximum signed int32.  */
+
+#define MAX_REPEAT 200000000
+
+
+/* Save a character to a string buffer, enlarging it as necessary.  */
+
+static void
+push_char (st_parameter_dt *dtp, char c)
+{
+  char *new;
+
+  if (dtp->u.p.saved_string == NULL)
+    {
+      if (dtp->u.p.scratch == NULL)
+	dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
+      dtp->u.p.saved_string = dtp->u.p.scratch;
+      memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
+      dtp->u.p.saved_length = SCRATCH_SIZE;
+      dtp->u.p.saved_used = 0;
+    }
+
+  if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
+    {
+      dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
+      new = get_mem (2 * dtp->u.p.saved_length);
+
+      memset (new, 0, 2 * dtp->u.p.saved_length);
+
+      memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
+      if (dtp->u.p.saved_string != dtp->u.p.scratch)
+	free_mem (dtp->u.p.saved_string);
+
+      dtp->u.p.saved_string = new;
+    }
+
+  dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
+}
+
+
+/* Free the input buffer if necessary.  */
+
+static void
+free_saved (st_parameter_dt *dtp)
+{
+  if (dtp->u.p.saved_string == NULL)
+    return;
+
+  if (dtp->u.p.saved_string != dtp->u.p.scratch)
+    free_mem (dtp->u.p.saved_string);
+
+  dtp->u.p.saved_string = NULL;
+  dtp->u.p.saved_used = 0;
+}
+
+
+/* Free the line buffer if necessary.  */
+
+static void
+free_line (st_parameter_dt *dtp)
+{
+  if (dtp->u.p.line_buffer == NULL)
+    return;
+
+  free_mem (dtp->u.p.line_buffer);
+  dtp->u.p.line_buffer = NULL;
+}
+
+
+static char
+next_char (st_parameter_dt *dtp)
+{
+  int length;
+  gfc_offset record;
+  char c, *p;
+
+  if (dtp->u.p.last_char != '\0')
+    {
+      dtp->u.p.at_eol = 0;
+      c = dtp->u.p.last_char;
+      dtp->u.p.last_char = '\0';
+      goto done;
+    }
+
+  /* Read from line_buffer if enabled.  */
+
+  if (dtp->u.p.line_buffer_enabled)
+    {
+      dtp->u.p.at_eol = 0;
+
+      c = dtp->u.p.line_buffer[dtp->u.p.item_count];
+      if (c != '\0' && dtp->u.p.item_count < 64)
+	{
+	  dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
+	  dtp->u.p.item_count++;
+	  goto done;
+	}
+
+        dtp->u.p.item_count = 0;
+	dtp->u.p.line_buffer_enabled = 0;
+    }    
+
+  /* Handle the end-of-record and end-of-file conditions for
+     internal array unit.  */
+  if (is_array_io(dtp))
+    {
+      if (dtp->u.p.at_eof)
+	longjmp (*dtp->u.p.eof_jump, 1);
+
+      /* Check for "end-of-record" condition.  */
+      if (dtp->u.p.current_unit->bytes_left == 0)
+	{
+	  c = '\n';
+	  record = next_array_record (dtp, dtp->u.p.current_unit->ls);
+
+	  /* Check for "end-of-file" condition.  */      
+	  if (record == 0)
+	    {
+	      dtp->u.p.at_eof = 1;
+	      goto done;
+	    }
+
+	  record *= dtp->u.p.current_unit->recl;
+	  if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+	    longjmp (*dtp->u.p.eof_jump, 1);
+
+	  dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+	  goto done;
+	}
+    }
+
+  /* Get the next character and handle end-of-record conditions.  */
+
+  length = 1;
+
+  p = salloc_r (dtp->u.p.current_unit->s, &length);
+  
+  if (is_stream_io (dtp))
+    dtp->u.p.current_unit->strm_pos++;
+
+  if (is_internal_unit(dtp))
+    {
+      if (is_array_io(dtp))
+	{
+	  /* End of record is handled in the next pass through, above.  The
+	     check for NULL here is cautionary.  */
+	  if (p == NULL)
+	    {
+	      generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
+	      return '\0';
+	    }
+
+	  dtp->u.p.current_unit->bytes_left--;
+	  c = *p;
+	}
+      else
+	{
+	  if (p == NULL)
+	    longjmp (*dtp->u.p.eof_jump, 1);
+	  if (length == 0)
+	    c = '\n';
+	  else
+	    c = *p;
+	}
+    }
+  else
+    {
+      if (p == NULL)
+	{
+	  generate_error (&dtp->common, ERROR_OS, NULL);
+	  return '\0';
+	}
+      if (length == 0)
+	longjmp (*dtp->u.p.eof_jump, 1);
+      c = *p;
+    }
+done:
+  dtp->u.p.at_eol = (c == '\n' || c == '\r');
+  return c;
+}
+
+
+/* Push a character back onto the input.  */
+
+static void
+unget_char (st_parameter_dt *dtp, char c)
+{
+  dtp->u.p.last_char = c;
+}
+
+
+/* Skip over spaces in the input.  Returns the nonspace character that
+   terminated the eating and also places it back on the input.  */
+
+static char
+eat_spaces (st_parameter_dt *dtp)
+{
+  char c;
+
+  do
+    {
+      c = next_char (dtp);
+    }
+  while (c == ' ' || c == '\t');
+
+  unget_char (dtp, c);
+  return c;
+}
+
+
+/* Skip over a separator.  Technically, we don't always eat the whole
+   separator.  This is because if we've processed the last input item,
+   then a separator is unnecessary.  Plus the fact that operating
+   systems usually deliver console input on a line basis.
+
+   The upshot is that if we see a newline as part of reading a
+   separator, we stop reading.  If there are more input items, we
+   continue reading the separator with finish_separator() which takes
+   care of the fact that we may or may not have seen a comma as part
+   of the separator.  */
+
+static void
+eat_separator (st_parameter_dt *dtp)
+{
+  char c, n;
+
+  eat_spaces (dtp);
+  dtp->u.p.comma_flag = 0;
+
+  c = next_char (dtp);
+  switch (c)
+    {
+    case ',':
+      dtp->u.p.comma_flag = 1;
+      eat_spaces (dtp);
+      break;
+
+    case '/':
+      dtp->u.p.input_complete = 1;
+      break;
+
+    case '\r':
+      n = next_char(dtp);
+      if (n == '\n')
+	dtp->u.p.at_eol = 1;
+      else
+	unget_char (dtp, n);
+      break;
+
+    case '\n':
+      dtp->u.p.at_eol = 1;
+      break;
+
+    case '!':
+      if (dtp->u.p.namelist_mode)
+	{			/* Eat a namelist comment.  */
+	  do
+	    c = next_char (dtp);
+	  while (c != '\n');
+
+	  break;
+	}
+
+      /* Fall Through...  */
+
+    default:
+      unget_char (dtp, c);
+      break;
+    }
+}
+
+
+/* Finish processing a separator that was interrupted by a newline.
+   If we're here, then another data item is present, so we finish what
+   we started on the previous line.  */
+
+static void
+finish_separator (st_parameter_dt *dtp)
+{
+  char c;
+
+ restart:
+  eat_spaces (dtp);
+
+  c = next_char (dtp);
+  switch (c)
+    {
+    case ',':
+      if (dtp->u.p.comma_flag)
+	unget_char (dtp, c);
+      else
+	{
+	  c = eat_spaces (dtp);
+	  if (c == '\n' || c == '\r')
+	    goto restart;
+	}
+
+      break;
+
+    case '/':
+      dtp->u.p.input_complete = 1;
+      if (!dtp->u.p.namelist_mode)
+	return;
+      break;
+
+    case '\n':
+    case '\r':
+      goto restart;
+
+    case '!':
+      if (dtp->u.p.namelist_mode)
+	{
+	  do
+	    c = next_char (dtp);
+	  while (c != '\n');
+
+	  goto restart;
+	}
+
+    default:
+      unget_char (dtp, c);
+      break;
+    }
+}
+
+
+/* This function reads characters through to the end of the current line and
+   just ignores them.  */
+
+static void
+eat_line (st_parameter_dt *dtp)
+{
+  char c;
+  if (!is_internal_unit (dtp))
+    do
+      c = next_char (dtp);
+    while (c != '\n');
+}
+
+
+/* This function is needed to catch bad conversions so that namelist can
+   attempt to see if dtp->u.p.saved_string contains a new object name rather
+   than a bad value.  */
+
+static int
+nml_bad_return (st_parameter_dt *dtp, char c)
+{
+  if (dtp->u.p.namelist_mode)
+    {
+      dtp->u.p.nml_read_error = 1;
+      unget_char (dtp, c);
+      return 1;
+    }
+  return 0;
+}
+
+/* Convert an unsigned string to an integer.  The length value is -1
+   if we are working on a repeat count.  Returns nonzero if we have a
+   range problem.  As a side effect, frees the dtp->u.p.saved_string.  */
+
+static int
+convert_integer (st_parameter_dt *dtp, int length, int negative)
+{
+  char c, *buffer, message[100];
+  int m;
+  GFC_INTEGER_LARGEST v, max, max10;
+
+  buffer = dtp->u.p.saved_string;
+  v = 0;
+
+  max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
+  max10 = max / 10;
+
+  for (;;)
+    {
+      c = *buffer++;
+      if (c == '\0')
+	break;
+      c -= '0';
+
+      if (v > max10)
+	goto overflow;
+      v = 10 * v;
+
+      if (v > max - c)
+	goto overflow;
+      v += c;
+    }
+
+  m = 0;
+
+  if (length != -1)
+    {
+      if (negative)
+	v = -v;
+      set_integer (dtp->u.p.value, v, length);
+    }
+  else
+    {
+      dtp->u.p.repeat_count = v;
+
+      if (dtp->u.p.repeat_count == 0)
+	{
+	  st_sprintf (message, "Zero repeat count in item %d of list input",
+		      dtp->u.p.item_count);
+
+	  generate_error (&dtp->common, ERROR_READ_VALUE, message);
+	  m = 1;
+	}
+    }
+
+  free_saved (dtp);
+  return m;
+
+ overflow:
+  if (length == -1)
+    st_sprintf (message, "Repeat count overflow in item %d of list input",
+		dtp->u.p.item_count);
+  else
+    st_sprintf (message, "Integer overflow while reading item %d",
+		dtp->u.p.item_count);
+
+  free_saved (dtp);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
+
+  return 1;
+}
+
+
+/* Parse a repeat count for logical and complex values which cannot
+   begin with a digit.  Returns nonzero if we are done, zero if we
+   should continue on.  */
+
+static int
+parse_repeat (st_parameter_dt *dtp)
+{
+  char c, message[100];
+  int repeat;
+
+  c = next_char (dtp);
+  switch (c)
+    {
+    CASE_DIGITS:
+      repeat = c - '0';
+      break;
+
+    CASE_SEPARATORS:
+      unget_char (dtp, c);
+      eat_separator (dtp);
+      return 1;
+
+    default:
+      unget_char (dtp, c);
+      return 0;
+    }
+
+  for (;;)
+    {
+      c = next_char (dtp);
+      switch (c)
+	{
+	CASE_DIGITS:
+	  repeat = 10 * repeat + c - '0';
+
+	  if (repeat > MAX_REPEAT)
+	    {
+	      st_sprintf (message,
+			  "Repeat count overflow in item %d of list input",
+			  dtp->u.p.item_count);
+
+	      generate_error (&dtp->common, ERROR_READ_VALUE, message);
+	      return 1;
+	    }
+
+	  break;
+
+	case '*':
+	  if (repeat == 0)
+	    {
+	      st_sprintf (message,
+			  "Zero repeat count in item %d of list input",
+			  dtp->u.p.item_count);
+
+	      generate_error (&dtp->common, ERROR_READ_VALUE, message);
+	      return 1;
+	    }
+
+	  goto done;
+
+	default:
+	  goto bad_repeat;
+	}
+    }
+
+ done:
+  dtp->u.p.repeat_count = repeat;
+  return 0;
+
+ bad_repeat:
+
+  eat_line (dtp);
+  free_saved (dtp);
+  st_sprintf (message, "Bad repeat count in item %d of list input",
+	      dtp->u.p.item_count);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
+  return 1;
+}
+
+
+/* To read a logical we have to look ahead in the input stream to make sure
+    there is not an equal sign indicating a variable name.  To do this we use 
+    line_buffer to point to a temporary buffer, pushing characters there for
+    possible later reading. */
+
+static void
+l_push_char (st_parameter_dt *dtp, char c)
+{
+  if (dtp->u.p.line_buffer == NULL)
+    {
+      dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
+      memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
+    }
+
+  dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
+}
+
+
+/* Read a logical character on the input.  */
+
+static void
+read_logical (st_parameter_dt *dtp, int length)
+{
+  char c, message[100];
+  int i, v;
+
+  if (parse_repeat (dtp))
+    return;
+
+  c = tolower (next_char (dtp));
+  l_push_char (dtp, c);
+  switch (c)
+    {
+    case 't':
+      v = 1;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+
+      if (!is_separator(c))
+	goto possible_name;
+
+      unget_char (dtp, c);
+      break;
+    case 'f':
+      v = 0;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+
+      if (!is_separator(c))
+	goto possible_name;
+
+      unget_char (dtp, c);
+      break;
+    case '.':
+      c = tolower (next_char (dtp));
+      switch (c)
+	{
+	  case 't':
+	    v = 1;
+	    break;
+	  case 'f':
+	    v = 0;
+	    break;
+	  default:
+	    goto bad_logical;
+	}
+
+      break;
+
+    CASE_SEPARATORS:
+      unget_char (dtp, c);
+      eat_separator (dtp);
+      return;			/* Null value.  */
+
+    default:
+      goto bad_logical;
+    }
+
+  dtp->u.p.saved_type = BT_LOGICAL;
+  dtp->u.p.saved_length = length;
+
+  /* Eat trailing garbage.  */
+  do
+    {
+      c = next_char (dtp);
+    }
+  while (!is_separator (c));
+
+  unget_char (dtp, c);
+  eat_separator (dtp);
+  dtp->u.p.item_count = 0;
+  dtp->u.p.line_buffer_enabled = 0;
+  set_integer ((int *) dtp->u.p.value, v, length);
+  free_line (dtp);
+
+  return;
+
+ possible_name:
+
+  for(i = 0; i < 63; i++)
+    {
+      c = next_char (dtp);
+      if (is_separator(c))
+	{
+	  /* All done if this is not a namelist read.  */
+	  if (!dtp->u.p.namelist_mode)
+	    goto logical_done;
+
+	  unget_char (dtp, c);
+	  eat_separator (dtp);
+	  c = next_char (dtp);
+	  if (c != '=')
+	    {
+	      unget_char (dtp, c);
+	      goto logical_done;
+	    }
+	}
+ 
+      l_push_char (dtp, c);
+      if (c == '=')
+	{
+	  dtp->u.p.nml_read_error = 1;
+	  dtp->u.p.line_buffer_enabled = 1;
+	  dtp->u.p.item_count = 0;
+	  return;
+	}
+      
+    }
+
+ bad_logical:
+
+  free_line (dtp);
+
+  if (nml_bad_return (dtp, c))
+    return;
+
+  eat_line (dtp);
+  free_saved (dtp);
+  st_sprintf (message, "Bad logical value while reading item %d",
+	      dtp->u.p.item_count);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
+  return;
+
+ logical_done:
+
+  dtp->u.p.item_count = 0;
+  dtp->u.p.line_buffer_enabled = 0;
+  dtp->u.p.saved_type = BT_LOGICAL;
+  dtp->u.p.saved_length = length;
+  set_integer ((int *) dtp->u.p.value, v, length);
+  free_saved (dtp);
+  free_line (dtp);
+}
+
+
+/* Reading integers is tricky because we can actually be reading a
+   repeat count.  We have to store the characters in a buffer because
+   we could be reading an integer that is larger than the default int
+   used for repeat counts.  */
+
+static void
+read_integer (st_parameter_dt *dtp, int length)
+{
+  char c, message[100];
+  int negative;
+
+  negative = 0;
+
+  c = next_char (dtp);
+  switch (c)
+    {
+    case '-':
+      negative = 1;
+      /* Fall through...  */
+
+    case '+':
+      c = next_char (dtp);
+      goto get_integer;
+
+    CASE_SEPARATORS:		/* Single null.  */
+      unget_char (dtp, c);
+      eat_separator (dtp);
+      return;
+
+    CASE_DIGITS:
+      push_char (dtp, c);
+      break;
+
+    default:
+      goto bad_integer;
+    }
+
+  /* Take care of what may be a repeat count.  */
+
+  for (;;)
+    {
+      c = next_char (dtp);
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (dtp, c);
+	  break;
+
+	case '*':
+	  push_char (dtp, '\0');
+	  goto repeat;
+
+	CASE_SEPARATORS:	/* Not a repeat count.  */
+	  goto done;
+
+	default:
+	  goto bad_integer;
+	}
+    }
+
+ repeat:
+  if (convert_integer (dtp, -1, 0))
+    return;
+
+  /* Get the real integer.  */
+
+  c = next_char (dtp);
+  switch (c)
+    {
+    CASE_DIGITS:
+      break;
+
+    CASE_SEPARATORS:
+      unget_char (dtp, c);
+      eat_separator (dtp);
+      return;
+
+    case '-':
+      negative = 1;
+      /* Fall through...  */
+
+    case '+':
+      c = next_char (dtp);
+      break;
+    }
+
+ get_integer:
+  if (!isdigit (c))
+    goto bad_integer;
+  push_char (dtp, c);
+
+  for (;;)
+    {
+      c = next_char (dtp);
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (dtp, c);
+	  break;
+
+	CASE_SEPARATORS:
+	  goto done;
+
+	default:
+	  goto bad_integer;
+	}
+    }
+
+ bad_integer:
+
+  if (nml_bad_return (dtp, c))
+    return;
+  
+  eat_line (dtp);
+  free_saved (dtp);
+  st_sprintf (message, "Bad integer for item %d in list input",
+	      dtp->u.p.item_count);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
+
+  return;
+
+ done:
+  unget_char (dtp, c);
+  eat_separator (dtp);
+
+  push_char (dtp, '\0');
+  if (convert_integer (dtp, length, negative))
+    {
+       free_saved (dtp);
+       return;
+    }
+
+  free_saved (dtp);
+  dtp->u.p.saved_type = BT_INTEGER;
+}
+
+
+/* Read a character variable.  */
+
+static void
+read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
+{
+  char c, quote, message[100];
+
+  quote = ' ';			/* Space means no quote character.  */
+
+  c = next_char (dtp);
+  switch (c)
+    {
+    CASE_DIGITS:
+      push_char (dtp, c);
+      break;
+
+    CASE_SEPARATORS:
+      unget_char (dtp, c);		/* NULL value.  */
+      eat_separator (dtp);
+      return;
+
+    case '"':
+    case '\'':
+      quote = c;
+      goto get_string;
+
+    default:
+      if (dtp->u.p.namelist_mode)
+	{
+	  unget_char (dtp,c);
+	  return;
+	}
+      push_char (dtp, c);
+      goto get_string;
+    }
+
+  /* Deal with a possible repeat count.  */
+
+  for (;;)
+    {
+      c = next_char (dtp);
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (dtp, c);
+	  break;
+
+	CASE_SEPARATORS:
+	  unget_char (dtp, c);
+	  goto done;		/* String was only digits!  */
+
+	case '*':
+	  push_char (dtp, '\0');
+	  goto got_repeat;
+
+	default:
+	  push_char (dtp, c);
+	  goto get_string;	/* Not a repeat count after all.  */
+	}
+    }
+
+ got_repeat:
+  if (convert_integer (dtp, -1, 0))
+    return;
+
+  /* Now get the real string.  */
+
+  c = next_char (dtp);
+  switch (c)
+    {
+    CASE_SEPARATORS:
+      unget_char (dtp, c);		/* Repeated NULL values.  */
+      eat_separator (dtp);
+      return;
+
+    case '"':
+    case '\'':
+      quote = c;
+      break;
+
+    default:
+      push_char (dtp, c);
+      break;
+    }
+
+ get_string:
+  for (;;)
+    {
+      c = next_char (dtp);
+      switch (c)
+	{
+	case '"':
+	case '\'':
+	  if (c != quote)
+	    {
+	      push_char (dtp, c);
+	      break;
+	    }
+
+	  /* See if we have a doubled quote character or the end of
+	     the string.  */
+
+	  c = next_char (dtp);
+	  if (c == quote)
+	    {
+	      push_char (dtp, quote);
+	      break;
+	    }
+
+	  unget_char (dtp, c);
+	  goto done;
+
+	CASE_SEPARATORS:
+	  if (quote == ' ')
+	    {
+	      unget_char (dtp, c);
+	      goto done;
+	    }
+
+	  if (c != '\n' && c != '\r')
+	    push_char (dtp, c);
+	  break;
+
+	default:
+	  push_char (dtp, c);
+	  break;
+	}
+    }
+
+  /* At this point, we have to have a separator, or else the string is
+     invalid.  */
+ done:
+  c = next_char (dtp);
+  if (is_separator (c))
+    {
+      unget_char (dtp, c);
+      eat_separator (dtp);
+      dtp->u.p.saved_type = BT_CHARACTER;
+    }
+  else
+    {
+      free_saved (dtp);
+      st_sprintf (message, "Invalid string input in item %d",
+		  dtp->u.p.item_count);
+      generate_error (&dtp->common, ERROR_READ_VALUE, message);
+    }
+}
+
+
+/* Parse a component of a complex constant or a real number that we
+   are sure is already there.  This is a straight real number parser.  */
+
+static int
+parse_real (st_parameter_dt *dtp, void *buffer, int length)
+{
+  char c, message[100];
+  int m, seen_dp;
+
+  c = next_char (dtp);
+  if (c == '-' || c == '+')
+    {
+      push_char (dtp, c);
+      c = next_char (dtp);
+    }
+
+  if (!isdigit (c) && c != '.')
+    goto bad;
+
+  push_char (dtp, c);
+
+  seen_dp = (c == '.') ? 1 : 0;
+
+  for (;;)
+    {
+      c = next_char (dtp);
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (dtp, c);
+	  break;
+
+	case '.':
+	  if (seen_dp)
+	    goto bad;
+
+	  seen_dp = 1;
+	  push_char (dtp, c);
+	  break;
+
+	case 'e':
+	case 'E':
+	case 'd':
+	case 'D':
+	  push_char (dtp, 'e');
+	  goto exp1;
+
+	case '-':
+	case '+':
+	  push_char (dtp, 'e');
+	  push_char (dtp, c);
+	  c = next_char (dtp);
+	  goto exp2;
+
+	CASE_SEPARATORS:
+	  unget_char (dtp, c);
+	  goto done;
+
+	default:
+	  goto done;
+	}
+    }
+
+ exp1:
+  c = next_char (dtp);
+  if (c != '-' && c != '+')
+    push_char (dtp, '+');
+  else
+    {
+      push_char (dtp, c);
+      c = next_char (dtp);
+    }
+
+ exp2:
+  if (!isdigit (c))
+    goto bad;
+  push_char (dtp, c);
+
+  for (;;)
+    {
+      c = next_char (dtp);
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (dtp, c);
+	  break;
+
+	CASE_SEPARATORS:
+	  unget_char (dtp, c);
+	  goto done;
+
+	default:
+	  goto done;
+	}
+    }
+
+ done:
+  unget_char (dtp, c);
+  push_char (dtp, '\0');
+
+  m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
+  free_saved (dtp);
+
+  return m;
+
+ bad:
+
+  if (nml_bad_return (dtp, c))
+    return 0;
+
+  eat_line (dtp);
+  free_saved (dtp);
+  st_sprintf (message, "Bad floating point number for item %d",
+	      dtp->u.p.item_count);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
+
+  return 1;
+}
+
+
+/* Reading a complex number is straightforward because we can tell
+   what it is right away.  */
+
+static void
+read_complex (st_parameter_dt *dtp, int kind, size_t size)
+{
+  char message[100];
+  char c;
+
+  if (parse_repeat (dtp))
+    return;
+
+  c = next_char (dtp);
+  switch (c)
+    {
+    case '(':
+      break;
+
+    CASE_SEPARATORS:
+      unget_char (dtp, c);
+      eat_separator (dtp);
+      return;
+
+    default:
+      goto bad_complex;
+    }
+
+  eat_spaces (dtp);
+  if (parse_real (dtp, dtp->u.p.value, kind))
+    return;
+
+eol_1:
+  eat_spaces (dtp);
+  c = next_char (dtp);
+  if (c == '\n' || c== '\r')
+    goto eol_1;
+  else
+    unget_char (dtp, c);
+
+  if (next_char (dtp) != ',')
+    goto bad_complex;
+
+eol_2:
+  eat_spaces (dtp);
+  c = next_char (dtp);
+  if (c == '\n' || c== '\r')
+    goto eol_2;
+  else
+    unget_char (dtp, c);
+
+  if (parse_real (dtp, dtp->u.p.value + size / 2, kind))
+    return;
+
+  eat_spaces (dtp);
+  if (next_char (dtp) != ')')
+    goto bad_complex;
+
+  c = next_char (dtp);
+  if (!is_separator (c))
+    goto bad_complex;
+
+  unget_char (dtp, c);
+  eat_separator (dtp);
+
+  free_saved (dtp);
+  dtp->u.p.saved_type = BT_COMPLEX;
+  return;
+
+ bad_complex:
+
+  if (nml_bad_return (dtp, c))
+    return;
+
+  eat_line (dtp);
+  free_saved (dtp);
+  st_sprintf (message, "Bad complex value in item %d of list input",
+	      dtp->u.p.item_count);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
+}
+
+
+/* Parse a real number with a possible repeat count.  */
+
+static void
+read_real (st_parameter_dt *dtp, int length)
+{
+  char c, message[100];
+  int seen_dp;
+
+  seen_dp = 0;
+
+  c = next_char (dtp);
+  switch (c)
+    {
+    CASE_DIGITS:
+      push_char (dtp, c);
+      break;
+
+    case '.':
+      push_char (dtp, c);
+      seen_dp = 1;
+      break;
+
+    case '+':
+    case '-':
+      goto got_sign;
+
+    CASE_SEPARATORS:
+      unget_char (dtp, c);		/* Single null.  */
+      eat_separator (dtp);
+      return;
+
+    default:
+      goto bad_real;
+    }
+
+  /* Get the digit string that might be a repeat count.  */
+
+  for (;;)
+    {
+      c = next_char (dtp);
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (dtp, c);
+	  break;
+
+	case '.':
+          if (seen_dp)
+            goto bad_real;
+
+	  seen_dp = 1;
+	  push_char (dtp, c);
+	  goto real_loop;
+
+	case 'E':
+	case 'e':
+	case 'D':
+	case 'd':
+	  goto exp1;
+
+	case '+':
+	case '-':
+	  push_char (dtp, 'e');
+	  push_char (dtp, c);
+	  c = next_char (dtp);
+	  goto exp2;
+
+	case '*':
+	  push_char (dtp, '\0');
+	  goto got_repeat;
+
+	CASE_SEPARATORS:
+          if (c != '\n' &&  c != ',' && c != '\r')
+	    unget_char (dtp, c);
+	  goto done;
+
+	default:
+	  goto bad_real;
+	}
+    }
+
+ got_repeat:
+  if (convert_integer (dtp, -1, 0))
+    return;
+
+  /* Now get the number itself.  */
+
+  c = next_char (dtp);
+  if (is_separator (c))
+    {				/* Repeated null value.  */
+      unget_char (dtp, c);
+      eat_separator (dtp);
+      return;
+    }
+
+  if (c != '-' && c != '+')
+    push_char (dtp, '+');
+  else
+    {
+    got_sign:
+      push_char (dtp, c);
+      c = next_char (dtp);
+    }
+
+  if (!isdigit (c) && c != '.')
+    goto bad_real;
+
+  if (c == '.')
+    {
+      if (seen_dp)
+        goto bad_real;
+      else
+        seen_dp = 1;
+    }
+
+  push_char (dtp, c);
+
+ real_loop:
+  for (;;)
+    {
+      c = next_char (dtp);
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (dtp, c);
+	  break;
+
+	CASE_SEPARATORS:
+	  goto done;
+
+	case '.':
+	  if (seen_dp)
+	    goto bad_real;
+
+	  seen_dp = 1;
+	  push_char (dtp, c);
+	  break;
+
+	case 'E':
+	case 'e':
+	case 'D':
+	case 'd':
+	  goto exp1;
+
+	case '+':
+	case '-':
+	  push_char (dtp, 'e');
+	  push_char (dtp, c);
+	  c = next_char (dtp);
+	  goto exp2;
+
+	default:
+	  goto bad_real;
+	}
+    }
+
+ exp1:
+  push_char (dtp, 'e');
+
+  c = next_char (dtp);
+  if (c != '+' && c != '-')
+    push_char (dtp, '+');
+  else
+    {
+      push_char (dtp, c);
+      c = next_char (dtp);
+    }
+
+ exp2:
+  if (!isdigit (c))
+    goto bad_real;
+  push_char (dtp, c);
+
+  for (;;)
+    {
+      c = next_char (dtp);
+
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (dtp, c);
+	  break;
+
+	CASE_SEPARATORS:
+	  goto done;
+
+	default:
+	  goto bad_real;
+	}
+    }
+
+ done:
+  unget_char (dtp, c);
+  eat_separator (dtp);
+  push_char (dtp, '\0');
+  if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
+    return;
+
+  free_saved (dtp);
+  dtp->u.p.saved_type = BT_REAL;
+  return;
+
+ bad_real:
+
+  if (nml_bad_return (dtp, c))
+    return;
+
+  eat_line (dtp);
+  free_saved (dtp);
+  st_sprintf (message, "Bad real number in item %d of list input",
+	      dtp->u.p.item_count);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
+}
+
+
+/* Check the current type against the saved type to make sure they are
+   compatible.  Returns nonzero if incompatible.  */
+
+static int
+check_type (st_parameter_dt *dtp, bt type, int len)
+{
+  char message[100];
+
+  if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
+    {
+      st_sprintf (message, "Read type %s where %s was expected for item %d",
+		  type_name (dtp->u.p.saved_type), type_name (type),
+		  dtp->u.p.item_count);
+
+      generate_error (&dtp->common, ERROR_READ_VALUE, message);
+      return 1;
+    }
+
+  if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
+    return 0;
+
+  if (dtp->u.p.saved_length != len)
+    {
+      st_sprintf (message,
+		  "Read kind %d %s where kind %d is required for item %d",
+		  dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
+		  dtp->u.p.item_count);
+      generate_error (&dtp->common, ERROR_READ_VALUE, message);
+      return 1;
+    }
+
+  return 0;
+}
+
+
+/* Top level data transfer subroutine for list reads.  Because we have
+   to deal with repeat counts, the data item is always saved after
+   reading, usually in the dtp->u.p.value[] array.  If a repeat count is
+   greater than one, we copy the data item multiple times.  */
+
+static void
+list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
+			    size_t size)
+{
+  char c;
+  int m;
+  jmp_buf eof_jump;
+
+  dtp->u.p.namelist_mode = 0;
+
+  dtp->u.p.eof_jump = &eof_jump;
+  if (setjmp (eof_jump))
+    {
+      generate_error (&dtp->common, ERROR_END, NULL);
+      goto cleanup;
+    }
+
+  if (dtp->u.p.first_item)
+    {
+      dtp->u.p.first_item = 0;
+      dtp->u.p.input_complete = 0;
+      dtp->u.p.repeat_count = 1;
+      dtp->u.p.at_eol = 0;
+
+      c = eat_spaces (dtp);
+      if (is_separator (c))
+	{
+	  /* Found a null value.  */
+	  eat_separator (dtp);
+	  dtp->u.p.repeat_count = 0;
+
+	  /* eat_separator sets this flag if the separator was a comma.  */
+	  if (dtp->u.p.comma_flag)
+	    goto cleanup;
+
+	  /* eat_separator sets this flag if the separator was a \n or \r.  */
+	  if (dtp->u.p.at_eol)
+	    finish_separator (dtp);
+	  else
+	    goto cleanup;
+	}
+
+    }
+  else
+    {
+      if (dtp->u.p.input_complete)
+	goto cleanup;
+
+      if (dtp->u.p.repeat_count > 0)
+	{
+	  if (check_type (dtp, type, kind))
+	    return;
+	  goto set_value;
+	}
+
+      if (dtp->u.p.at_eol)
+	finish_separator (dtp);
+      else
+        {
+	  eat_spaces (dtp);
+          /* Trailing spaces prior to end of line.  */
+	  if (dtp->u.p.at_eol)
+	    finish_separator (dtp);
+        }
+
+      dtp->u.p.saved_type = BT_NULL;
+      dtp->u.p.repeat_count = 1;
+    }
+
+  switch (type)
+    {
+    case BT_INTEGER:
+      read_integer (dtp, kind);
+      break;
+    case BT_LOGICAL:
+      read_logical (dtp, kind);
+      break;
+    case BT_CHARACTER:
+      read_character (dtp, kind);
+      break;
+    case BT_REAL:
+      read_real (dtp, kind);
+      break;
+    case BT_COMPLEX:
+      read_complex (dtp, kind, size);
+      break;
+    default:
+      internal_error (&dtp->common, "Bad type for list read");
+    }
+
+  if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
+    dtp->u.p.saved_length = size;
+
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    goto cleanup;
+
+ set_value:
+  switch (dtp->u.p.saved_type)
+    {
+    case BT_COMPLEX:
+    case BT_INTEGER:
+    case BT_REAL:
+    case BT_LOGICAL:
+      memcpy (p, dtp->u.p.value, size);
+      break;
+
+    case BT_CHARACTER:
+      if (dtp->u.p.saved_string)
+       {
+	  m = ((int) size < dtp->u.p.saved_used)
+	      ? (int) size : dtp->u.p.saved_used;
+	  memcpy (p, dtp->u.p.saved_string, m);
+       }
+      else
+	/* Just delimiters encountered, nothing to copy but SPACE.  */
+        m = 0;
+
+      if (m < (int) size)
+	memset (((char *) p) + m, ' ', size - m);
+      break;
+
+    case BT_NULL:
+      break;
+    }
+
+  if (--dtp->u.p.repeat_count <= 0)
+    free_saved (dtp);
+
+cleanup:
+  dtp->u.p.eof_jump = NULL;
+}
+
+
+void
+list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
+		     size_t size, size_t nelems)
+{
+  size_t elem;
+  char *tmp;
+
+  tmp = (char *) p;
+
+  /* Big loop over all the elements.  */
+  for (elem = 0; elem < nelems; elem++)
+    {
+      dtp->u.p.item_count++;
+      list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
+    }
+}
+
+
+/* Finish a list read.  */
+
+void
+finish_list_read (st_parameter_dt *dtp)
+{
+  char c;
+
+  free_saved (dtp);
+
+  if (dtp->u.p.at_eol)
+    {
+      dtp->u.p.at_eol = 0;
+      return;
+    }
+
+  do
+    {
+      c = next_char (dtp);
+    }
+  while (c != '\n');
+}
+
+/*			NAMELIST INPUT
+
+void namelist_read (st_parameter_dt *dtp)
+calls:
+   static void nml_match_name (char *name, int len)
+   static int nml_query (st_parameter_dt *dtp)
+   static int nml_get_obj_data (st_parameter_dt *dtp,
+				namelist_info **prev_nl, char *)
+calls:
+      static void nml_untouch_nodes (st_parameter_dt *dtp)
+      static namelist_info * find_nml_node (st_parameter_dt *dtp,
+					    char * var_name)
+      static int nml_parse_qualifier(descriptor_dimension * ad,
+				     array_loop_spec * ls, int rank, char *)
+      static void nml_touch_nodes (namelist_info * nl)
+      static int nml_read_obj (namelist_info *nl, index_type offset,
+			       namelist_info **prev_nl, char *,
+			       index_type clow, index_type chigh)
+calls:
+      -itself-  */
+
+/* Inputs a rank-dimensional qualifier, which can contain
+   singlets, doublets, triplets or ':' with the standard meanings.  */
+
+static try
+nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
+		     array_loop_spec *ls, int rank, char *parse_err_msg)
+{
+  int dim;
+  int indx;
+  int neg;
+  int null_flag;
+  int is_array_section;
+  char c;
+
+  is_array_section = 0;
+  dtp->u.p.expanded_read = 0;
+
+  /* The next character in the stream should be the '('.  */
+
+  c = next_char (dtp);
+
+  /* Process the qualifier, by dimension and triplet.  */
+
+  for (dim=0; dim < rank; dim++ )
+    {
+      for (indx=0; indx<3; indx++)
+	{
+	  free_saved (dtp);
+	  eat_spaces (dtp);
+	  neg = 0;
+
+	  /* Process a potential sign.  */
+	  c = next_char (dtp);
+	  switch (c)
+	    {
+	    case '-':
+	      neg = 1;
+	      break;
+
+	    case '+':
+	      break;
+
+	    default:
+	      unget_char (dtp, c);
+	      break;
+	    }
+
+	  /* Process characters up to the next ':' , ',' or ')'.  */
+	  for (;;)
+	    {
+	      c = next_char (dtp);
+
+	      switch (c)
+		{
+		case ':':
+                  is_array_section = 1;
+		  break;
+
+		case ',': case ')':
+		  if ((c==',' && dim == rank -1)
+		      || (c==')' && dim < rank -1))
+		    {
+		      st_sprintf (parse_err_msg,
+				  "Bad number of index fields");
+		      goto err_ret;
+		    }
+		  break;
+
+		CASE_DIGITS:
+		  push_char (dtp, c);
+		  continue;
+
+		case ' ': case '\t':
+		  eat_spaces (dtp);
+		  c = next_char (dtp);
+		  break;
+
+		default:
+		  st_sprintf (parse_err_msg, "Bad character in index");
+		  goto err_ret;
+		}
+
+	      if ((c == ',' || c == ')') && indx == 0
+		  && dtp->u.p.saved_string == 0)
+		{
+		  st_sprintf (parse_err_msg, "Null index field");
+		  goto err_ret;
+		}
+
+	      if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
+		  || (indx == 2 && dtp->u.p.saved_string == 0))
+		{
+		  st_sprintf(parse_err_msg, "Bad index triplet");
+		  goto err_ret;
+		}
+
+	      /* If '( : ? )' or '( ? : )' break and flag read failure.  */
+	      null_flag = 0;
+	      if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
+		  || (indx==1 && dtp->u.p.saved_string == 0))
+		{
+		  null_flag = 1;
+		  break;
+		}
+
+	      /* Now read the index.  */
+	      if (convert_integer (dtp, sizeof(ssize_t), neg))
+		{
+		  st_sprintf (parse_err_msg, "Bad integer in index");
+		  goto err_ret;
+		}
+	      break;
+	    }
+
+	  /* Feed the index values to the triplet arrays.  */
+	  if (!null_flag)
+	    {
+	      if (indx == 0)
+		memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
+	      if (indx == 1)
+		memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
+	      if (indx == 2)
+		memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
+	    }
+
+	  /* Singlet or doublet indices.  */
+	  if (c==',' || c==')')
+	    {
+	      if (indx == 0)
+		{
+		  memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
+
+		  /*  If -std=f95/2003 or an array section is specified,
+		      do not allow excess data to be processed.  */
+                  if (is_array_section == 1
+		      || compile_options.allow_std < GFC_STD_GNU)
+		    ls[dim].end = ls[dim].start;
+		  else
+		    dtp->u.p.expanded_read = 1;
+		}
+	      break;
+	    }
+	}
+
+      /* Check the values of the triplet indices.  */
+      if ((ls[dim].start > (ssize_t)ad[dim].ubound)
+	  || (ls[dim].start < (ssize_t)ad[dim].lbound)
+	  || (ls[dim].end > (ssize_t)ad[dim].ubound)
+	  || (ls[dim].end < (ssize_t)ad[dim].lbound))
+	{
+	  st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
+	  goto err_ret;
+	}
+      if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
+	  || (ls[dim].step == 0))
+	{
+	  st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
+	  goto err_ret;
+	}
+
+      /* Initialise the loop index counter.  */
+      ls[dim].idx = ls[dim].start;
+    }
+  eat_spaces (dtp);
+  return SUCCESS;
+
+err_ret:
+
+  return FAILURE;
+}
+
+static namelist_info *
+find_nml_node (st_parameter_dt *dtp, char * var_name)
+{
+  namelist_info * t = dtp->u.p.ionml;
+  while (t != NULL)
+    {
+      if (strcmp (var_name, t->var_name) == 0)
+	{
+	  t->touched = 1;
+	  return t;
+	}
+      t = t->next;
+    }
+  return NULL;
+}
+
+/* Visits all the components of a derived type that have
+   not explicitly been identified in the namelist input.
+   touched is set and the loop specification initialised
+   to default values  */
+
+static void
+nml_touch_nodes (namelist_info * nl)
+{
+  index_type len = strlen (nl->var_name) + 1;
+  int dim;
+  char * ext_name = (char*)get_mem (len + 1);
+  strcpy (ext_name, nl->var_name);
+  strcat (ext_name, "%");
+  for (nl = nl->next; nl; nl = nl->next)
+    {
+      if (strncmp (nl->var_name, ext_name, len) == 0)
+	{
+	  nl->touched = 1;
+	  for (dim=0; dim < nl->var_rank; dim++)
+	    {
+	      nl->ls[dim].step = 1;
+	      nl->ls[dim].end = nl->dim[dim].ubound;
+	      nl->ls[dim].start = nl->dim[dim].lbound;
+	      nl->ls[dim].idx = nl->ls[dim].start;
+	    }
+	}
+      else
+	break;
+    }
+  free_mem (ext_name);
+  return;
+}
+
+/* Resets touched for the entire list of nml_nodes, ready for a
+   new object.  */
+
+static void
+nml_untouch_nodes (st_parameter_dt *dtp)
+{
+  namelist_info * t;
+  for (t = dtp->u.p.ionml; t; t = t->next)
+    t->touched = 0;
+  return;
+}
+
+/* Attempts to input name to namelist name.  Returns
+   dtp->u.p.nml_read_error = 1 on no match.  */
+
+static void
+nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
+{
+  index_type i;
+  char c;
+  dtp->u.p.nml_read_error = 0;
+  for (i = 0; i < len; i++)
+    {
+      c = next_char (dtp);
+      if (tolower (c) != tolower (name[i]))
+	{
+	  dtp->u.p.nml_read_error = 1;
+	  break;
+	}
+    }
+}
+
+/* If the namelist read is from stdin, output the current state of the
+   namelist to stdout.  This is used to implement the non-standard query
+   features, ? and =?. If c == '=' the full namelist is printed. Otherwise
+   the names alone are printed.  */
+
+static void
+nml_query (st_parameter_dt *dtp, char c)
+{
+  gfc_unit * temp_unit;
+  namelist_info * nl;
+  index_type len;
+  char * p;
+
+  if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
+    return;
+
+  /* Store the current unit and transfer to stdout.  */
+
+  temp_unit = dtp->u.p.current_unit;
+  dtp->u.p.current_unit = find_unit (options.stdout_unit);
+
+  if (dtp->u.p.current_unit)
+    {
+      dtp->u.p.mode = WRITING;
+      next_record (dtp, 0);
+
+      /* Write the namelist in its entirety.  */
+
+      if (c == '=')
+	namelist_write (dtp);
+
+      /* Or write the list of names.  */
+
+      else
+	{
+
+	  /* "&namelist_name\n"  */
+
+	  len = dtp->namelist_name_len;
+#ifdef HAVE_CRLF
+	  p = write_block (dtp, len + 3);
+#else
+	  p = write_block (dtp, len + 2);
+#endif
+	  if (!p)
+	    goto query_return;
+	  memcpy (p, "&", 1);
+	  memcpy ((char*)(p + 1), dtp->namelist_name, len);
+#ifdef HAVE_CRLF
+	  memcpy ((char*)(p + len + 1), "\r\n", 2);
+#else
+	  memcpy ((char*)(p + len + 1), "\n", 1);
+#endif
+	  for (nl = dtp->u.p.ionml; nl; nl = nl->next)
+	    {
+
+	      /* " var_name\n"  */
+
+	      len = strlen (nl->var_name);
+#ifdef HAVE_CRLF
+	      p = write_block (dtp, len + 3);
+#else
+	      p = write_block (dtp, len + 2);
+#endif
+	      if (!p)
+		goto query_return;
+	      memcpy (p, " ", 1);
+	      memcpy ((char*)(p + 1), nl->var_name, len);
+#ifdef HAVE_CRLF
+	      memcpy ((char*)(p + len + 1), "\r\n", 2);
+#else
+	      memcpy ((char*)(p + len + 1), "\n", 1);
+#endif
+	    }
+
+	  /* "&end\n"  */
+
+#ifdef HAVE_CRLF
+	  p = write_block (dtp, 6);
+#else
+	  p = write_block (dtp, 5);
+#endif
+	  if (!p)
+	    goto query_return;
+#ifdef HAVE_CRLF
+	  memcpy (p, "&end\r\n", 6);
+#else
+	  memcpy (p, "&end\n", 5);
+#endif
+	}
+
+      /* Flush the stream to force immediate output.  */
+
+      flush (dtp->u.p.current_unit->s);
+      unlock_unit (dtp->u.p.current_unit);
+    }
+
+query_return:
+
+  /* Restore the current unit.  */
+
+  dtp->u.p.current_unit = temp_unit;
+  dtp->u.p.mode = READING;
+  return;
+}
+
+/* Reads and stores the input for the namelist object nl.  For an array,
+   the function loops over the ranges defined by the loop specification.
+   This default to all the data or to the specification from a qualifier.
+   nml_read_obj recursively calls itself to read derived types. It visits
+   all its own components but only reads data for those that were touched
+   when the name was parsed.  If a read error is encountered, an attempt is
+   made to return to read a new object name because the standard allows too
+   little data to be available.  On the other hand, too much data is an
+   error.  */
+
+static try
+nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
+	      namelist_info **pprev_nl, char *nml_err_msg,
+	      index_type clow, index_type chigh)
+{
+
+  namelist_info * cmp;
+  char * obj_name;
+  int nml_carry;
+  int len;
+  int dim;
+  index_type dlen;
+  index_type m;
+  index_type obj_name_len;
+  void * pdata;
+
+  /* This object not touched in name parsing.  */
+
+  if (!nl->touched)
+    return SUCCESS;
+
+  dtp->u.p.repeat_count = 0;
+  eat_spaces (dtp);
+
+  len = nl->len;
+  switch (nl->type)
+  {
+
+    case GFC_DTYPE_INTEGER:
+    case GFC_DTYPE_LOGICAL:
+      dlen = len;
+      break;
+
+    case GFC_DTYPE_REAL:
+      dlen = size_from_real_kind (len);
+      break;
+
+    case GFC_DTYPE_COMPLEX:
+      dlen = size_from_complex_kind (len);
+      break;
+
+    case GFC_DTYPE_CHARACTER:
+      dlen = chigh ? (chigh - clow + 1) : nl->string_length;
+      break;
+
+    default:
+      dlen = 0;
+    }
+
+  do
+    {
+
+      /* Update the pointer to the data, using the current index vector  */
+
+      pdata = (void*)(nl->mem_pos + offset);
+      for (dim = 0; dim < nl->var_rank; dim++)
+	pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
+		 nl->dim[dim].stride * nl->size);
+
+      /* Reset the error flag and try to read next value, if
+	 dtp->u.p.repeat_count=0  */
+
+      dtp->u.p.nml_read_error = 0;
+      nml_carry = 0;
+      if (--dtp->u.p.repeat_count <= 0)
+	{
+	  if (dtp->u.p.input_complete)
+	    return SUCCESS;
+	  if (dtp->u.p.at_eol)
+	    finish_separator (dtp);
+	  if (dtp->u.p.input_complete)
+	    return SUCCESS;
+
+	  /* GFC_TYPE_UNKNOWN through for nulls and is detected
+	     after the switch block.  */
+
+	  dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
+	  free_saved (dtp);
+
+          switch (nl->type)
+	  {
+	  case GFC_DTYPE_INTEGER:
+	      read_integer (dtp, len);
+              break;
+
+	  case GFC_DTYPE_LOGICAL:
+	      read_logical (dtp, len);
+              break;
+
+	  case GFC_DTYPE_CHARACTER:
+	      read_character (dtp, len);
+              break;
+
+	  case GFC_DTYPE_REAL:
+	      read_real (dtp, len);
+              break;
+
+	  case GFC_DTYPE_COMPLEX:
+              read_complex (dtp, len, dlen);
+              break;
+
+	  case GFC_DTYPE_DERIVED:
+	    obj_name_len = strlen (nl->var_name) + 1;
+	    obj_name = get_mem (obj_name_len+1);
+	    strcpy (obj_name, nl->var_name);
+	    strcat (obj_name, "%");
+
+	    /* If reading a derived type, disable the expanded read warning
+	       since a single object can have multiple reads.  */
+	    dtp->u.p.expanded_read = 0;
+
+	    /* Now loop over the components. Update the component pointer
+	       with the return value from nml_write_obj.  This loop jumps
+	       past nested derived types by testing if the potential
+	       component name contains '%'.  */
+
+	    for (cmp = nl->next;
+		 cmp &&
+		   !strncmp (cmp->var_name, obj_name, obj_name_len) &&
+		   !strchr (cmp->var_name + obj_name_len, '%');
+		 cmp = cmp->next)
+	      {
+
+		if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
+				  pprev_nl, nml_err_msg, clow, chigh)
+		    == FAILURE)
+		  {
+		    free_mem (obj_name);
+		    return FAILURE;
+		  }
+
+		if (dtp->u.p.input_complete)
+		  {
+		    free_mem (obj_name);
+		    return SUCCESS;
+		  }
+	      }
+
+	    free_mem (obj_name);
+	    goto incr_idx;
+
+          default:
+	    st_sprintf (nml_err_msg, "Bad type for namelist object %s",
+			nl->var_name);
+	    internal_error (&dtp->common, nml_err_msg);
+	    goto nml_err_ret;
+          }
+        }
+
+      /* The standard permits array data to stop short of the number of
+	 elements specified in the loop specification.  In this case, we
+	 should be here with dtp->u.p.nml_read_error != 0.  Control returns to
+	 nml_get_obj_data and an attempt is made to read object name.  */
+
+      *pprev_nl = nl;
+      if (dtp->u.p.nml_read_error)
+	{
+	  dtp->u.p.expanded_read = 0;
+	  return SUCCESS;
+	}
+
+      if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
+	{
+	  dtp->u.p.expanded_read = 0;
+	  goto incr_idx;
+	}
+
+      /* Note the switch from GFC_DTYPE_type to BT_type at this point.
+	 This comes about because the read functions return BT_types.  */
+
+      switch (dtp->u.p.saved_type)
+      {
+
+	case BT_COMPLEX:
+	case BT_REAL:
+	case BT_INTEGER:
+	case BT_LOGICAL:
+	  memcpy (pdata, dtp->u.p.value, dlen);
+	  break;
+
+	case BT_CHARACTER:
+	  m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
+	  pdata = (void*)( pdata + clow - 1 );
+	  memcpy (pdata, dtp->u.p.saved_string, m);
+	  if (m < dlen)
+	    memset ((void*)( pdata + m ), ' ', dlen - m);
+	  break;
+
+	default:
+	  break;
+      }
+
+      /* Warn if a non-standard expanded read occurs. A single read of a
+	 single object is acceptable.  If a second read occurs, issue a warning
+	 and set the flag to zero to prevent further warnings.  */
+      if (dtp->u.p.expanded_read == 2)
+	{
+	  notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
+	  dtp->u.p.expanded_read = 0;
+	}
+
+      /* If the expanded read warning flag is set, increment it,
+	 indicating that a single read has occurred.  */
+      if (dtp->u.p.expanded_read >= 1)
+	dtp->u.p.expanded_read++;
+
+      /* Break out of loop if scalar.  */
+      if (!nl->var_rank)
+	break;
+
+      /* Now increment the index vector.  */
+
+incr_idx:
+
+      nml_carry = 1;
+      for (dim = 0; dim < nl->var_rank; dim++)
+	{
+	  nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
+	  nml_carry = 0;
+	  if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
+	      ||
+	      ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
+	    {
+	      nl->ls[dim].idx = nl->ls[dim].start;
+	      nml_carry = 1;
+	    }
+        }
+    } while (!nml_carry);
+
+  if (dtp->u.p.repeat_count > 1)
+    {
+       st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
+		   nl->var_name );
+       goto nml_err_ret;
+    }
+  return SUCCESS;
+
+nml_err_ret:
+
+  return FAILURE;
+}
+
+/* Parses the object name, including array and substring qualifiers.  It
+   iterates over derived type components, touching those components and
+   setting their loop specifications, if there is a qualifier.  If the
+   object is itself a derived type, its components and subcomponents are
+   touched.  nml_read_obj is called at the end and this reads the data in
+   the manner specified by the object name.  */
+
+static try
+nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
+		  char *nml_err_msg)
+{
+  char c;
+  namelist_info * nl;
+  namelist_info * first_nl = NULL;
+  namelist_info * root_nl = NULL;
+  int dim;
+  int component_flag;
+  char parse_err_msg[30];
+  index_type clow, chigh;
+
+  /* Look for end of input or object name.  If '?' or '=?' are encountered
+     in stdin, print the node names or the namelist to stdout.  */
+
+  eat_separator (dtp);
+  if (dtp->u.p.input_complete)
+    return SUCCESS;
+
+  if (dtp->u.p.at_eol)
+    finish_separator (dtp);
+  if (dtp->u.p.input_complete)
+    return SUCCESS;
+
+  c = next_char (dtp);
+  switch (c)
+    {
+    case '=':
+      c = next_char (dtp);
+      if (c != '?')
+	{
+	  st_sprintf (nml_err_msg, "namelist read: misplaced = sign");
+	  goto nml_err_ret;
+	}
+      nml_query (dtp, '=');
+      return SUCCESS;
+
+    case '?':
+      nml_query (dtp, '?');
+      return SUCCESS;
+
+    case '$':
+    case '&':
+      nml_match_name (dtp, "end", 3);
+      if (dtp->u.p.nml_read_error)
+	{
+	  st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
+	  goto nml_err_ret;
+	}
+    case '/':
+      dtp->u.p.input_complete = 1;
+      return SUCCESS;
+
+    default :
+      break;
+    }
+
+  /* Untouch all nodes of the namelist and reset the flag that is set for
+     derived type components.  */
+
+  nml_untouch_nodes (dtp);
+  component_flag = 0;
+
+  /* Get the object name - should '!' and '\n' be permitted separators?  */
+
+get_name:
+
+  free_saved (dtp);
+
+  do
+    {
+      push_char (dtp, tolower(c));
+      c = next_char (dtp);
+    } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
+
+  unget_char (dtp, c);
+
+  /* Check that the name is in the namelist and get pointer to object.
+     Three error conditions exist: (i) An attempt is being made to
+     identify a non-existent object, following a failed data read or
+     (ii) The object name does not exist or (iii) Too many data items
+     are present for an object.  (iii) gives the same error message
+     as (i)  */
+
+  push_char (dtp, '\0');
+
+  if (component_flag)
+    {
+      size_t var_len = strlen (root_nl->var_name);
+      size_t saved_len
+	= dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
+      char ext_name[var_len + saved_len + 1];
+
+      memcpy (ext_name, root_nl->var_name, var_len);
+      if (dtp->u.p.saved_string)
+	memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
+      ext_name[var_len + saved_len] = '\0';
+      nl = find_nml_node (dtp, ext_name);
+    }
+  else
+    nl = find_nml_node (dtp, dtp->u.p.saved_string);
+
+  if (nl == NULL)
+    {
+      if (dtp->u.p.nml_read_error && *pprev_nl)
+	st_sprintf (nml_err_msg, "Bad data for namelist object %s",
+		    (*pprev_nl)->var_name);
+
+      else
+	st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
+		    dtp->u.p.saved_string);
+
+      goto nml_err_ret;
+    }
+
+  /* Get the length, data length, base pointer and rank of the variable.
+     Set the default loop specification first.  */
+
+  for (dim=0; dim < nl->var_rank; dim++)
+    {
+      nl->ls[dim].step = 1;
+      nl->ls[dim].end = nl->dim[dim].ubound;
+      nl->ls[dim].start = nl->dim[dim].lbound;
+      nl->ls[dim].idx = nl->ls[dim].start;
+    }
+
+/* Check to see if there is a qualifier: if so, parse it.*/
+
+  if (c == '(' && nl->var_rank)
+    {
+      if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
+			       parse_err_msg) == FAILURE)
+	{
+	  st_sprintf (nml_err_msg, "%s for namelist variable %s",
+		      parse_err_msg, nl->var_name);
+	  goto nml_err_ret;
+	}
+      c = next_char (dtp);
+      unget_char (dtp, c);
+    }
+
+  /* Now parse a derived type component. The root namelist_info address
+     is backed up, as is the previous component level.  The  component flag
+     is set and the iteration is made by jumping back to get_name.  */
+
+  if (c == '%')
+    {
+
+      if (nl->type != GFC_DTYPE_DERIVED)
+	{
+	  st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
+		      nl->var_name);
+	  goto nml_err_ret;
+	}
+
+      if (!component_flag)
+	first_nl = nl;
+
+      root_nl = nl;
+      component_flag = 1;
+      c = next_char (dtp);
+      goto get_name;
+
+    }
+
+  /* Parse a character qualifier, if present.  chigh = 0 is a default
+     that signals that the string length = string_length.  */
+
+  clow = 1;
+  chigh = 0;
+
+  if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
+    {
+      descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
+      array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
+
+      if (nml_parse_qualifier (dtp, chd, ind, 1, parse_err_msg) == FAILURE)
+	{
+	  st_sprintf (nml_err_msg, "%s for namelist variable %s",
+		      parse_err_msg, nl->var_name);
+	  goto nml_err_ret;
+	}
+
+      clow = ind[0].start;
+      chigh = ind[0].end;
+
+      if (ind[0].step != 1)
+	{
+	  st_sprintf (nml_err_msg,
+		      "Bad step in substring for namelist object %s",
+		      nl->var_name);
+	  goto nml_err_ret;
+	}
+
+      c = next_char (dtp);
+      unget_char (dtp, c);
+    }
+
+  /* If a derived type touch its components and restore the root
+     namelist_info if we have parsed a qualified derived type
+     component.  */
+
+  if (nl->type == GFC_DTYPE_DERIVED)
+    nml_touch_nodes (nl);
+  if (component_flag)
+    nl = first_nl;
+
+  /*make sure no extraneous qualifiers are there.*/
+
+  if (c == '(')
+    {
+      st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
+		  " namelist object %s", nl->var_name);
+      goto nml_err_ret;
+    }
+
+/* According to the standard, an equal sign MUST follow an object name. The
+   following is possibly lax - it allows comments, blank lines and so on to
+   intervene.  eat_spaces (dtp); c = next_char (dtp); would be compliant*/
+
+  free_saved (dtp);
+
+  eat_separator (dtp);
+  if (dtp->u.p.input_complete)
+    return SUCCESS;
+
+  if (dtp->u.p.at_eol)
+    finish_separator (dtp);
+  if (dtp->u.p.input_complete)
+    return SUCCESS;
+
+  c = next_char (dtp);
+
+  if (c != '=')
+    {
+      st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
+		  nl->var_name);
+      goto nml_err_ret;
+    }
+
+  if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
+    goto nml_err_ret;
+
+  return SUCCESS;
+
+nml_err_ret:
+
+  return FAILURE;
+}
+
+/* Entry point for namelist input.  Goes through input until namelist name
+  is matched.  Then cycles through nml_get_obj_data until the input is
+  completed or there is an error.  */
+
+void
+namelist_read (st_parameter_dt *dtp)
+{
+  char c;
+  jmp_buf eof_jump;
+  char nml_err_msg[100];
+  /* Pointer to the previously read object, in case attempt is made to read
+     new object name.  Should this fail, error message can give previous
+     name.  */
+  namelist_info *prev_nl = NULL;
+
+  dtp->u.p.namelist_mode = 1;
+  dtp->u.p.input_complete = 0;
+  dtp->u.p.expanded_read = 0;
+
+  dtp->u.p.eof_jump = &eof_jump;
+  if (setjmp (eof_jump))
+    {
+      dtp->u.p.eof_jump = NULL;
+      generate_error (&dtp->common, ERROR_END, NULL);
+      return;
+    }
+
+  /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
+     Exit on success or EOF. If '?' or '=?' encountered in stdin, print
+     node names or namelist on stdout.  */
+
+find_nml_name:
+  switch (c = next_char (dtp))
+    {
+    case '$':
+    case '&':
+          break;
+
+    case '!':
+      eat_line (dtp);
+      goto find_nml_name;
+
+    case '=':
+      c = next_char (dtp);
+      if (c == '?')
+	nml_query (dtp, '=');
+      else
+	unget_char (dtp, c);
+      goto find_nml_name;
+
+    case '?':
+      nml_query (dtp, '?');
+
+    default:
+      goto find_nml_name;
+    }
+
+  /* Match the name of the namelist.  */
+
+  nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
+
+  if (dtp->u.p.nml_read_error)
+    goto find_nml_name;
+
+  /* Ready to read namelist objects.  If there is an error in input
+     from stdin, output the error message and continue.  */
+
+  while (!dtp->u.p.input_complete)
+    {
+      if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
+	{
+	  gfc_unit *u;
+
+	  if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
+	    goto nml_err_ret;
+
+	  u = find_unit (options.stderr_unit);
+	  st_printf ("%s\n", nml_err_msg);
+	  if (u != NULL)
+	    {
+	      flush (u->s);
+	      unlock_unit (u);
+	    }
+        }
+
+   }
+
+  dtp->u.p.eof_jump = NULL;
+  free_saved (dtp);
+  free_line (dtp);
+  return;
+
+  /* All namelist error calls return from here */
+
+nml_err_ret:
+
+  dtp->u.p.eof_jump = NULL;
+  free_saved (dtp);
+  free_line (dtp);
+  generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);
+  return;
+}
diff --git a/gcc-4.2.1/libgfortran/io/lock.c b/gcc-4.2.1/libgfortran/io/lock.c
new file mode 100644
index 000000000..c39188f9d
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/lock.c
@@ -0,0 +1,72 @@
+/* Thread/recursion locking
+   Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org> and 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 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+#include "config.h"
+#include <string.h>
+#include "libgfortran.h"
+#include "io.h"
+
+/* library_start()-- Called with a library call is entered.  */
+
+void
+library_start (st_parameter_common *cmp)
+{
+  if ((cmp->flags & IOPARM_HAS_IOSTAT) != 0)
+    *cmp->iostat = ERROR_OK;
+
+  cmp->flags &= ~IOPARM_LIBRETURN_MASK;
+}
+
+
+void
+free_ionml (st_parameter_dt *dtp)
+{
+  namelist_info * t1, *t2;
+
+  /* Delete the namelist, if it exists.  */
+
+  if (dtp->u.p.ionml != NULL)
+    {
+      t1 = dtp->u.p.ionml;
+      while (t1 != NULL)
+	{
+	  t2 = t1;
+	  t1 = t1->next;
+	  free_mem (t2->var_name);
+	  if (t2->var_rank)
+	    {
+	     free_mem (t2->dim);
+	     free_mem (t2->ls);
+	    }
+	  free_mem (t2);
+	}
+    }
+  dtp->u.p.ionml = NULL;
+}
diff --git a/gcc-4.2.1/libgfortran/io/open.c b/gcc-4.2.1/libgfortran/io/open.c
new file mode 100644
index 000000000..aca540768
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/open.c
@@ -0,0 +1,670 @@
+/* Copyright (C) 2002, 2003, 2004, 2005
+   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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+#include "config.h"
+#include <unistd.h>
+#include <stdio.h>
+#include <string.h>
+#include "libgfortran.h"
+#include "io.h"
+
+
+static const st_option access_opt[] = {
+  {"sequential", ACCESS_SEQUENTIAL},
+  {"direct", ACCESS_DIRECT},
+  {"append", ACCESS_APPEND},
+  {"stream", ACCESS_STREAM},
+  {NULL, 0}
+};
+
+static const st_option action_opt[] =
+{
+  { "read", ACTION_READ},
+  { "write", ACTION_WRITE},
+  { "readwrite", ACTION_READWRITE},
+  { NULL, 0}
+};
+
+static const st_option blank_opt[] =
+{
+  { "null", BLANK_NULL},
+  { "zero", BLANK_ZERO},
+  { NULL, 0}
+};
+
+static const st_option delim_opt[] =
+{
+  { "none", DELIM_NONE},
+  { "apostrophe", DELIM_APOSTROPHE},
+  { "quote", DELIM_QUOTE},
+  { NULL, 0}
+};
+
+static const st_option form_opt[] =
+{
+  { "formatted", FORM_FORMATTED},
+  { "unformatted", FORM_UNFORMATTED},
+  { NULL, 0}
+};
+
+static const st_option position_opt[] =
+{
+  { "asis", POSITION_ASIS},
+  { "rewind", POSITION_REWIND},
+  { "append", POSITION_APPEND},
+  { NULL, 0}
+};
+
+static const st_option status_opt[] =
+{
+  { "unknown", STATUS_UNKNOWN},
+  { "old", STATUS_OLD},
+  { "new", STATUS_NEW},
+  { "replace", STATUS_REPLACE},
+  { "scratch", STATUS_SCRATCH},
+  { NULL, 0}
+};
+
+static const st_option pad_opt[] =
+{
+  { "yes", PAD_YES},
+  { "no", PAD_NO},
+  { NULL, 0}
+};
+
+static const st_option convert_opt[] =
+{
+  { "native", CONVERT_NATIVE},
+  { "swap", CONVERT_SWAP},
+  { "big_endian", CONVERT_BIG},
+  { "little_endian", CONVERT_LITTLE},
+  { NULL, 0}
+};
+
+/* Given a unit, test to see if the file is positioned at the terminal
+   point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
+   This prevents us from changing the state from AFTER_ENDFILE to
+   AT_ENDFILE.  */
+
+void
+test_endfile (gfc_unit * u)
+{
+  if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
+    u->endfile = AT_ENDFILE;
+}
+
+
+/* Change the modes of a file, those that are allowed * to be
+   changed.  */
+
+static void
+edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
+{
+  /* Complain about attempts to change the unchangeable.  */
+
+  if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD && 
+      u->flags.status != flags->status)
+    generate_error (&opp->common, ERROR_BAD_OPTION,
+		    "Cannot change STATUS parameter in OPEN statement");
+
+  if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
+    generate_error (&opp->common, ERROR_BAD_OPTION,
+		    "Cannot change ACCESS parameter in OPEN statement");
+
+  if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
+    generate_error (&opp->common, ERROR_BAD_OPTION,
+		    "Cannot change FORM parameter in OPEN statement");
+
+  if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
+      && opp->recl_in != u->recl)
+    generate_error (&opp->common, ERROR_BAD_OPTION,
+		    "Cannot change RECL parameter in OPEN statement");
+
+  if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
+    generate_error (&opp->common, ERROR_BAD_OPTION,
+		    "Cannot change ACTION parameter in OPEN statement");
+
+  /* Status must be OLD if present.  */
+
+  if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
+      flags->status != STATUS_UNKNOWN)
+    {
+      if (flags->status == STATUS_SCRATCH)
+	notify_std (&opp->common, GFC_STD_GNU,
+		    "OPEN statement must have a STATUS of OLD or UNKNOWN");
+      else
+	generate_error (&opp->common, ERROR_BAD_OPTION,
+		    "OPEN statement must have a STATUS of OLD or UNKNOWN");
+    }
+
+  if (u->flags.form == FORM_UNFORMATTED)
+    {
+      if (flags->delim != DELIM_UNSPECIFIED)
+	generate_error (&opp->common, ERROR_OPTION_CONFLICT,
+			"DELIM parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->blank != BLANK_UNSPECIFIED)
+	generate_error (&opp->common, ERROR_OPTION_CONFLICT,
+			"BLANK parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->pad != PAD_UNSPECIFIED)
+	generate_error (&opp->common, ERROR_OPTION_CONFLICT,
+			"PAD parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+    }
+
+  if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
+    {
+      /* Change the changeable:  */
+      if (flags->blank != BLANK_UNSPECIFIED)
+	u->flags.blank = flags->blank;
+      if (flags->delim != DELIM_UNSPECIFIED)
+	u->flags.delim = flags->delim;
+      if (flags->pad != PAD_UNSPECIFIED)
+	u->flags.pad = flags->pad;
+    }
+
+  /* Reposition the file if necessary.  */
+
+  switch (flags->position)
+    {
+    case POSITION_UNSPECIFIED:
+    case POSITION_ASIS:
+      break;
+
+    case POSITION_REWIND:
+      if (sseek (u->s, 0) == FAILURE)
+	goto seek_error;
+
+      u->current_record = 0;
+      u->last_record = 0;
+
+      test_endfile (u);		/* We might be at the end.  */
+      break;
+
+    case POSITION_APPEND:
+      if (sseek (u->s, file_length (u->s)) == FAILURE)
+	goto seek_error;
+
+      if (flags->access != ACCESS_STREAM)
+	u->current_record = 0;
+
+      u->endfile = AT_ENDFILE;	/* We are at the end.  */
+      break;
+
+    seek_error:
+      generate_error (&opp->common, ERROR_OS, NULL);
+      break;
+    }
+
+  unlock_unit (u);
+}
+
+
+/* Open an unused unit.  */
+
+gfc_unit *
+new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
+{
+  gfc_unit *u2;
+  stream *s;
+  char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
+
+  /* Change unspecifieds to defaults.  Leave (flags->action ==
+     ACTION_UNSPECIFIED) alone so open_external() can set it based on
+     what type of open actually works.  */
+
+  if (flags->access == ACCESS_UNSPECIFIED)
+    flags->access = ACCESS_SEQUENTIAL;
+
+  if (flags->form == FORM_UNSPECIFIED)
+    flags->form = (flags->access == ACCESS_SEQUENTIAL)
+      ? FORM_FORMATTED : FORM_UNFORMATTED;
+
+
+  if (flags->delim == DELIM_UNSPECIFIED)
+    flags->delim = DELIM_NONE;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (&opp->common, ERROR_OPTION_CONFLICT,
+			  "DELIM parameter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto fail;
+	}
+    }
+
+  if (flags->blank == BLANK_UNSPECIFIED)
+    flags->blank = BLANK_NULL;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (&opp->common, ERROR_OPTION_CONFLICT,
+			  "BLANK parameter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto fail;
+	}
+    }
+
+  if (flags->pad == PAD_UNSPECIFIED)
+    flags->pad = PAD_YES;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (&opp->common, ERROR_OPTION_CONFLICT,
+			  "PAD parameter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto fail;
+	}
+    }
+
+  if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
+   {
+     generate_error (&opp->common, ERROR_OPTION_CONFLICT,
+                     "ACCESS parameter conflicts with SEQUENTIAL access in "
+                     "OPEN statement");
+     goto fail;
+   }
+  else
+   if (flags->position == POSITION_UNSPECIFIED)
+     flags->position = POSITION_ASIS;
+
+
+  if (flags->status == STATUS_UNSPECIFIED)
+    flags->status = STATUS_UNKNOWN;
+
+  /* Checks.  */
+
+  if (flags->access == ACCESS_DIRECT
+      && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
+    {
+      generate_error (&opp->common, ERROR_MISSING_OPTION,
+		      "Missing RECL parameter in OPEN statement");
+      goto fail;
+    }
+
+  if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
+    {
+      generate_error (&opp->common, ERROR_BAD_OPTION,
+		      "RECL parameter is non-positive in OPEN statement");
+      goto fail;
+    }
+
+  switch (flags->status)
+    {
+    case STATUS_SCRATCH:
+      if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
+	{
+	  opp->file = NULL;
+	  break;
+	}
+
+      generate_error (&opp->common, ERROR_BAD_OPTION,
+		      "FILE parameter must not be present in OPEN statement");
+      goto fail;
+
+    case STATUS_OLD:
+    case STATUS_NEW:
+    case STATUS_REPLACE:
+    case STATUS_UNKNOWN:
+      if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
+	break;
+
+      opp->file = tmpname;
+      opp->file_len = sprintf(opp->file, "fort.%d", opp->common.unit);
+      break;
+
+    default:
+      internal_error (&opp->common, "new_unit(): Bad status");
+    }
+
+  /* Make sure the file isn't already open someplace else.
+     Do not error if opening file preconnected to stdin, stdout, stderr.  */
+
+  u2 = NULL;
+  if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
+    u2 = find_file (opp->file, opp->file_len);
+  if (u2 != NULL
+      && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
+      && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
+      && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
+    {
+      unlock_unit (u2);
+      generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL);
+      goto cleanup;
+    }
+
+  if (u2 != NULL)
+    unlock_unit (u2);
+
+  /* Open file.  */
+
+  s = open_external (opp, flags);
+  if (s == NULL)
+    {
+      generate_error (&opp->common, ERROR_OS, NULL);
+      goto cleanup;
+    }
+
+  if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
+    flags->status = STATUS_OLD;
+
+  /* Create the unit structure.  */
+
+  u->file = get_mem (opp->file_len);
+  if (u->unit_number != opp->common.unit)
+    internal_error (&opp->common, "Unit number changed");
+  u->s = s;
+  u->flags = *flags;
+  u->read_bad = 0;
+  u->endfile = NO_ENDFILE;
+  u->last_record = 0;
+  u->current_record = 0;
+  u->mode = READING;
+  u->maxrec = 0;
+  u->bytes_left = 0;
+
+  if (flags->position == POSITION_APPEND)
+    {
+      if (sseek (u->s, file_length (u->s)) == FAILURE)
+	generate_error (&opp->common, ERROR_OS, NULL);
+      u->endfile = AT_ENDFILE;
+    }
+
+  /* Unspecified recl ends up with a processor dependent value.  */
+
+  if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
+    {
+      u->flags.has_recl = 1;
+      u->recl = opp->recl_in;
+      u->recl_subrecord = u->recl;
+      u->bytes_left = u->recl;
+    }
+  else
+    {
+      u->flags.has_recl = 0;
+      u->recl = max_offset;
+      if (compile_options.max_subrecord_length)
+	{
+	  u->recl_subrecord = compile_options.max_subrecord_length;
+	}
+      else
+	{
+	  switch (compile_options.record_marker)
+	    {
+	    case 0:
+	      /* Fall through */
+	    case sizeof (GFC_INTEGER_4):
+	      u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
+	      break;
+
+	    case sizeof (GFC_INTEGER_8):
+	      u->recl_subrecord = max_offset - 16;
+	      break;
+
+	    default:
+	      runtime_error ("Illegal value for record marker");
+	      break;
+	    }
+	}
+    }
+
+  /* If the file is direct access, calculate the maximum record number
+     via a division now instead of letting the multiplication overflow
+     later.  */
+
+  if (flags->access == ACCESS_DIRECT)
+    u->maxrec = max_offset / u->recl;
+  
+  if (flags->access == ACCESS_STREAM)
+    {
+      u->maxrec = max_offset;
+      u->recl = 1;
+      u->strm_pos = 1;
+    }
+
+  memmove (u->file, opp->file, opp->file_len);
+  u->file_len = opp->file_len;
+
+  /* Curiously, the standard requires that the
+     position specifier be ignored for new files so a newly connected
+     file starts out that the initial point.  We still need to figure
+     out if the file is at the end or not.  */
+
+  test_endfile (u);
+
+  if (flags->status == STATUS_SCRATCH && opp->file != NULL)
+    free_mem (opp->file);
+  return u;
+
+ cleanup:
+
+  /* Free memory associated with a temporary filename.  */
+
+  if (flags->status == STATUS_SCRATCH && opp->file != NULL)
+    free_mem (opp->file);
+
+ fail:
+
+  close_unit (u);
+  return NULL;
+}
+
+
+/* Open a unit which is already open.  This involves changing the
+   modes or closing what is there now and opening the new file.  */
+
+static void
+already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
+{
+  if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
+    {
+      edit_modes (opp, u, flags);
+      return;
+    }
+
+  /* If the file is connected to something else, close it and open a
+     new unit.  */
+
+  if (!compare_file_filename (u, opp->file, opp->file_len))
+    {
+#if !HAVE_UNLINK_OPEN_FILE
+      char *path = NULL;
+      if (u->file && u->flags.status == STATUS_SCRATCH)
+	{
+	  path = (char *) gfc_alloca (u->file_len + 1);
+	  unpack_filename (path, u->file, u->file_len);
+	}
+#endif
+
+      if (sclose (u->s) == FAILURE)
+	{
+	  unlock_unit (u);
+	  generate_error (&opp->common, ERROR_OS,
+			  "Error closing file in OPEN statement");
+	  return;
+	}
+
+      u->s = NULL;
+      if (u->file)
+	free_mem (u->file);
+      u->file = NULL;
+      u->file_len = 0;
+
+#if !HAVE_UNLINK_OPEN_FILE
+      if (path != NULL)
+	unlink (path);
+#endif
+
+      u = new_unit (opp, u, flags);
+      if (u != NULL)
+	unlock_unit (u);
+      return;
+    }
+
+  edit_modes (opp, u, flags);
+}
+
+
+/* Open file.  */
+
+extern void st_open (st_parameter_open *opp);
+export_proto(st_open);
+
+void
+st_open (st_parameter_open *opp)
+{
+  unit_flags flags;
+  gfc_unit *u = NULL;
+  GFC_INTEGER_4 cf = opp->common.flags;
+  unit_convert conv;
+ 
+  library_start (&opp->common);
+
+  /* Decode options.  */
+
+  flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
+    find_option (&opp->common, opp->access, opp->access_len,
+		 access_opt, "Bad ACCESS parameter in OPEN statement");
+
+  flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
+    find_option (&opp->common, opp->action, opp->action_len,
+		 action_opt, "Bad ACTION parameter in OPEN statement");
+
+  flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
+    find_option (&opp->common, opp->blank, opp->blank_len,
+		 blank_opt, "Bad BLANK parameter in OPEN statement");
+
+  flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
+    find_option (&opp->common, opp->delim, opp->delim_len,
+		 delim_opt, "Bad DELIM parameter in OPEN statement");
+
+  flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
+    find_option (&opp->common, opp->pad, opp->pad_len,
+		 pad_opt, "Bad PAD parameter in OPEN statement");
+
+  flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
+    find_option (&opp->common, opp->form, opp->form_len,
+		 form_opt, "Bad FORM parameter in OPEN statement");
+
+  flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
+    find_option (&opp->common, opp->position, opp->position_len,
+		 position_opt, "Bad POSITION parameter in OPEN statement");
+
+  flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
+    find_option (&opp->common, opp->status, opp->status_len,
+		 status_opt, "Bad STATUS parameter in OPEN statement");
+
+  /* First, we check wether the convert flag has been set via environment
+     variable.  This overrides the convert tag in the open statement.  */
+
+  conv = get_unformatted_convert (opp->common.unit);
+
+  if (conv == CONVERT_NONE)
+    {
+      /* Nothing has been set by environment variable, check the convert tag.  */
+      if (cf & IOPARM_OPEN_HAS_CONVERT)
+	conv = find_option (&opp->common, opp->convert, opp->convert_len,
+			    convert_opt,
+			    "Bad CONVERT parameter in OPEN statement");
+      else
+	conv = compile_options.convert;
+    }
+  
+  /* We use l8_to_l4_offset, which is 0 on little-endian machines
+     and 1 on big-endian machines.  */
+  switch (conv)
+    {
+    case CONVERT_NATIVE:
+    case CONVERT_SWAP:
+      break;
+      
+    case CONVERT_BIG:
+      conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
+      break;
+      
+    case CONVERT_LITTLE:
+      conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
+      break;
+      
+    default:
+      internal_error (&opp->common, "Illegal value for CONVERT");
+      break;
+    }
+
+  flags.convert = conv;
+
+  if (opp->common.unit < 0)
+    generate_error (&opp->common, ERROR_BAD_OPTION,
+		    "Bad unit number in OPEN statement");
+
+  if (flags.position != POSITION_UNSPECIFIED
+      && flags.access == ACCESS_DIRECT)
+    generate_error (&opp->common, ERROR_BAD_OPTION,
+		    "Cannot use POSITION with direct access files");
+
+  if (flags.access == ACCESS_APPEND)
+    {
+      if (flags.position != POSITION_UNSPECIFIED
+	  && flags.position != POSITION_APPEND)
+	generate_error (&opp->common, ERROR_BAD_OPTION,
+			"Conflicting ACCESS and POSITION flags in"
+			" OPEN statement");
+
+      notify_std (&opp->common, GFC_STD_GNU,
+		  "Extension: APPEND as a value for ACCESS in OPEN statement");
+      flags.access = ACCESS_SEQUENTIAL;
+      flags.position = POSITION_APPEND;
+    }
+
+  if (flags.position == POSITION_UNSPECIFIED)
+    flags.position = POSITION_ASIS;
+
+  if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
+    {
+      u = find_or_create_unit (opp->common.unit);
+
+      if (u->s == NULL)
+	{
+	  u = new_unit (opp, u, &flags);
+	  if (u != NULL)
+	    unlock_unit (u);
+	}
+      else
+	already_open (opp, u, &flags);
+    }
+
+  library_end ();
+}
diff --git a/gcc-4.2.1/libgfortran/io/read.c b/gcc-4.2.1/libgfortran/io/read.c
new file mode 100644
index 000000000..9477425e6
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/read.c
@@ -0,0 +1,857 @@
+/* Copyright (C) 2002, 2003, 2005 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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+
+#include "config.h"
+#include <string.h>
+#include <errno.h>
+#include <ctype.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include "libgfortran.h"
+#include "io.h"
+
+/* read.c -- Deal with formatted reads */
+
+/* set_integer()-- All of the integer assignments come here to
+ * actually place the value into memory.  */
+
+void
+set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
+{
+  switch (length)
+    {
+#ifdef HAVE_GFC_INTEGER_16
+    case 16:
+      {
+	GFC_INTEGER_16 tmp = value;
+	memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+#endif
+    case 8:
+      {
+	GFC_INTEGER_8 tmp = value;
+	memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+    case 4:
+      {
+	GFC_INTEGER_4 tmp = value;
+	memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+    case 2:
+      {
+	GFC_INTEGER_2 tmp = value;
+	memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+    case 1:
+      {
+	GFC_INTEGER_1 tmp = value;
+	memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+    default:
+      internal_error (NULL, "Bad integer kind");
+    }
+}
+
+
+/* max_value()-- Given a length (kind), return the maximum signed or
+ * unsigned value */
+
+GFC_UINTEGER_LARGEST
+max_value (int length, int signed_flag)
+{
+  GFC_UINTEGER_LARGEST value;
+  int n;
+
+  switch (length)
+    {
+#if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
+    case 16:
+    case 10:
+      value = 1;
+      for (n = 1; n < 4 * length; n++)
+        value = (value << 2) + 3;
+      if (! signed_flag)
+        value = 2*value+1;
+      break;
+#endif
+    case 8:
+      value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
+      break;
+    case 4:
+      value = signed_flag ? 0x7fffffff : 0xffffffff;
+      break;
+    case 2:
+      value = signed_flag ? 0x7fff : 0xffff;
+      break;
+    case 1:
+      value = signed_flag ? 0x7f : 0xff;
+      break;
+    default:
+      internal_error (NULL, "Bad integer kind");
+    }
+
+  return value;
+}
+
+
+/* convert_real()-- Convert a character representation of a floating
+ * point number to the machine number.  Returns nonzero if there is a
+ * range problem during conversion.  TODO: handle not-a-numbers and
+ * infinities.  */
+
+int
+convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
+{
+  errno = 0;
+
+  switch (length)
+    {
+    case 4:
+      {
+	GFC_REAL_4 tmp =
+#if defined(HAVE_STRTOF)
+	  strtof (buffer, NULL);
+#else
+	  (GFC_REAL_4) strtod (buffer, NULL);
+#endif
+	memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+    case 8:
+      {
+	GFC_REAL_8 tmp = strtod (buffer, NULL);
+	memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+#if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
+    case 10:
+      {
+	GFC_REAL_10 tmp = strtold (buffer, NULL);
+	memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+#endif
+#if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
+    case 16:
+      {
+	GFC_REAL_16 tmp = strtold (buffer, NULL);
+	memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+#endif
+    default:
+      internal_error (&dtp->common, "Unsupported real kind during IO");
+    }
+
+  if (errno != 0 && errno != EINVAL)
+    {
+      generate_error (&dtp->common, ERROR_READ_VALUE,
+		      "Range error during floating point read");
+      return 1;
+    }
+
+  return 0;
+}
+
+
+/* read_l()-- Read a logical value */
+
+void
+read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
+{
+  char *p;
+  int w;
+
+  w = f->u.w;
+  p = read_block (dtp, &w);
+  if (p == NULL)
+    return;
+
+  while (*p == ' ')
+    {
+      if (--w == 0)
+	goto bad;
+      p++;
+    }
+
+  if (*p == '.')
+    {
+      if (--w == 0)
+	goto bad;
+      p++;
+    }
+
+  switch (*p)
+    {
+    case 't':
+    case 'T':
+      set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
+      break;
+    case 'f':
+    case 'F':
+      set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
+      break;
+    default:
+    bad:
+      generate_error (&dtp->common, ERROR_READ_VALUE,
+		      "Bad value on logical read");
+      break;
+    }
+}
+
+
+/* read_a()-- Read a character record.  This one is pretty easy. */
+
+void
+read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
+{
+  char *source;
+  int w, m, n;
+
+  w = f->u.w;
+  if (w == -1) /* '(A)' edit descriptor  */
+    w = length;
+
+  dtp->u.p.sf_read_comma = 0;
+  source = read_block (dtp, &w);
+  dtp->u.p.sf_read_comma = 1;
+  if (source == NULL)
+    return;
+  if (w > length)
+     source += (w - length);
+
+  m = (w > length) ? length : w;
+  memcpy (p, source, m);
+
+  n = length - w;
+  if (n > 0)
+    memset (p + m, ' ', n);
+}
+
+
+/* eat_leading_spaces()-- Given a character pointer and a width,
+ * ignore the leading spaces.  */
+
+static char *
+eat_leading_spaces (int *width, char *p)
+{
+  for (;;)
+    {
+      if (*width == 0 || *p != ' ')
+	break;
+
+      (*width)--;
+      p++;
+    }
+
+  return p;
+}
+
+
+static char
+next_char (st_parameter_dt *dtp, char **p, int *w)
+{
+  char c, *q;
+
+  if (*w == 0)
+    return '\0';
+
+  q = *p;
+  c = *q++;
+  *p = q;
+
+  (*w)--;
+
+  if (c != ' ')
+    return c;
+  if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
+    return ' ';  /* return a blank to signal a null */ 
+
+  /* At this point, the rest of the field has to be trailing blanks */
+
+  while (*w > 0)
+    {
+      if (*q++ != ' ')
+	return '?';
+      (*w)--;
+    }
+
+  *p = q;
+  return '\0';
+}
+
+
+/* read_decimal()-- Read a decimal integer value.  The values here are
+ * signed values. */
+
+void
+read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
+{
+  GFC_UINTEGER_LARGEST value, maxv, maxv_10;
+  GFC_INTEGER_LARGEST v;
+  int w, negative;
+  char c, *p;
+
+  w = f->u.w;
+  p = read_block (dtp, &w);
+  if (p == NULL)
+    return;
+
+  p = eat_leading_spaces (&w, p);
+  if (w == 0)
+    {
+      set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
+      return;
+    }
+
+  maxv = max_value (length, 1);
+  maxv_10 = maxv / 10;
+
+  negative = 0;
+  value = 0;
+
+  switch (*p)
+    {
+    case '-':
+      negative = 1;
+      /* Fall through */
+
+    case '+':
+      p++;
+      if (--w == 0)
+	goto bad;
+      /* Fall through */
+
+    default:
+      break;
+    }
+
+  /* At this point we have a digit-string */
+  value = 0;
+
+  for (;;)
+    {
+      c = next_char (dtp, &p, &w);
+      if (c == '\0')
+	break;
+	
+      if (c == ' ')
+        {
+	  if (dtp->u.p.blank_status == BLANK_NULL) continue;
+	  if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
+        }
+        
+      if (c < '0' || c > '9')
+	goto bad;
+
+      if (value > maxv_10)
+	goto overflow;
+
+      c -= '0';
+      value = 10 * value;
+
+      if (value > maxv - c)
+	goto overflow;
+      value += c;
+    }
+
+  v = value;
+  if (negative)
+    v = -v;
+
+  set_integer (dest, v, length);
+  return;
+
+ bad:
+  generate_error (&dtp->common, ERROR_READ_VALUE,
+		  "Bad value during integer read");
+  return;
+
+ overflow:
+  generate_error (&dtp->common, ERROR_READ_OVERFLOW,
+		  "Value overflowed during integer read");
+  return;
+}
+
+
+/* read_radix()-- This function reads values for non-decimal radixes.
+ * The difference here is that we treat the values here as unsigned
+ * values for the purposes of overflow.  If minus sign is present and
+ * the top bit is set, the value will be incorrect. */
+
+void
+read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
+	    int radix)
+{
+  GFC_UINTEGER_LARGEST value, maxv, maxv_r;
+  GFC_INTEGER_LARGEST v;
+  int w, negative;
+  char c, *p;
+
+  w = f->u.w;
+  p = read_block (dtp, &w);
+  if (p == NULL)
+    return;
+
+  p = eat_leading_spaces (&w, p);
+  if (w == 0)
+    {
+      set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
+      return;
+    }
+
+  maxv = max_value (length, 0);
+  maxv_r = maxv / radix;
+
+  negative = 0;
+  value = 0;
+
+  switch (*p)
+    {
+    case '-':
+      negative = 1;
+      /* Fall through */
+
+    case '+':
+      p++;
+      if (--w == 0)
+	goto bad;
+      /* Fall through */
+
+    default:
+      break;
+    }
+
+  /* At this point we have a digit-string */
+  value = 0;
+
+  for (;;)
+    {
+      c = next_char (dtp, &p, &w);
+      if (c == '\0')
+	break;
+      if (c == ' ')
+        {
+	  if (dtp->u.p.blank_status == BLANK_NULL) continue;
+	  if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
+        }
+
+      switch (radix)
+	{
+	case 2:
+	  if (c < '0' || c > '1')
+	    goto bad;
+	  break;
+
+	case 8:
+	  if (c < '0' || c > '7')
+	    goto bad;
+	  break;
+
+	case 16:
+	  switch (c)
+	    {
+	    case '0':
+	    case '1':
+	    case '2':
+	    case '3':
+	    case '4':
+	    case '5':
+	    case '6':
+	    case '7':
+	    case '8':
+	    case '9':
+	      break;
+
+	    case 'a':
+	    case 'b':
+	    case 'c':
+	    case 'd':
+	    case 'e':
+	    case 'f':
+	      c = c - 'a' + '9' + 1;
+	      break;
+
+	    case 'A':
+	    case 'B':
+	    case 'C':
+	    case 'D':
+	    case 'E':
+	    case 'F':
+	      c = c - 'A' + '9' + 1;
+	      break;
+
+	    default:
+	      goto bad;
+	    }
+
+	  break;
+	}
+
+      if (value > maxv_r)
+	goto overflow;
+
+      c -= '0';
+      value = radix * value;
+
+      if (maxv - c < value)
+	goto overflow;
+      value += c;
+    }
+
+  v = value;
+  if (negative)
+    v = -v;
+
+  set_integer (dest, v, length);
+  return;
+
+ bad:
+  generate_error (&dtp->common, ERROR_READ_VALUE,
+		  "Bad value during integer read");
+  return;
+
+ overflow:
+  generate_error (&dtp->common, ERROR_READ_OVERFLOW,
+		  "Value overflowed during integer read");
+  return;
+}
+
+
+/* read_f()-- Read a floating point number with F-style editing, which
+   is what all of the other floating point descriptors behave as.  The
+   tricky part is that optional spaces are allowed after an E or D,
+   and the implicit decimal point if a decimal point is not present in
+   the input.  */
+
+void
+read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
+{
+  int w, seen_dp, exponent;
+  int exponent_sign, val_sign;
+  int ndigits;
+  int edigits;
+  int i;
+  char *p, *buffer;
+  char *digits;
+  char scratch[SCRATCH_SIZE];
+
+  val_sign = 1;
+  seen_dp = 0;
+  w = f->u.w;
+  p = read_block (dtp, &w);
+  if (p == NULL)
+    return;
+
+  p = eat_leading_spaces (&w, p);
+  if (w == 0)
+    goto zero;
+
+  /* Optional sign */
+
+  if (*p == '-' || *p == '+')
+    {
+      if (*p == '-')
+        val_sign = -1;
+      p++;
+      w--;
+    }
+
+  exponent_sign = 1;
+  p = eat_leading_spaces (&w, p);
+  if (w == 0)
+    goto zero;
+
+  /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
+     is required at this point */
+
+  if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D'
+      && *p != 'e' && *p != 'E')
+    goto bad_float;
+
+  /* Remember the position of the first digit.  */
+  digits = p;
+  ndigits = 0;
+
+  /* Scan through the string to find the exponent.  */
+  while (w > 0)
+    {
+      switch (*p)
+	{
+	case '.':
+	  if (seen_dp)
+	    goto bad_float;
+	  seen_dp = 1;
+	  /* Fall through */
+
+	case '0':
+	case '1':
+	case '2':
+	case '3':
+	case '4':
+	case '5':
+	case '6':
+	case '7':
+	case '8':
+	case '9':
+	case ' ':
+	  ndigits++;
+	  p++;
+	  w--;
+	  break;
+
+	case '-':
+	  exponent_sign = -1;
+	  /* Fall through */
+
+	case '+':
+	  p++;
+	  w--;
+	  goto exp2;
+
+	case 'd':
+	case 'e':
+	case 'D':
+	case 'E':
+	  p++;
+	  w--;
+	  goto exp1;
+
+	default:
+	  goto bad_float;
+	}
+    }
+
+  /* No exponent has been seen, so we use the current scale factor */
+  exponent = -dtp->u.p.scale_factor;
+  goto done;
+
+ bad_float:
+  generate_error (&dtp->common, ERROR_READ_VALUE,
+		  "Bad value during floating point read");
+  return;
+
+  /* The value read is zero */
+ zero:
+  switch (length)
+    {
+      case 4:
+	*((GFC_REAL_4 *) dest) = 0;
+	break;
+
+      case 8:
+	*((GFC_REAL_8 *) dest) = 0;
+	break;
+
+#ifdef HAVE_GFC_REAL_10
+      case 10:
+	*((GFC_REAL_10 *) dest) = 0;
+	break;
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+      case 16:
+	*((GFC_REAL_16 *) dest) = 0;
+	break;
+#endif
+
+      default:
+	internal_error (&dtp->common, "Unsupported real kind during IO");
+    }
+  return;
+
+  /* At this point the start of an exponent has been found */
+ exp1:
+  while (w > 0 && *p == ' ')
+    {
+      w--;
+      p++;
+    }
+
+  switch (*p)
+    {
+    case '-':
+      exponent_sign = -1;
+      /* Fall through */
+
+    case '+':
+      p++;
+      w--;
+      break;
+    }
+
+  if (w == 0)
+    goto bad_float;
+
+  /* At this point a digit string is required.  We calculate the value
+     of the exponent in order to take account of the scale factor and
+     the d parameter before explict conversion takes place. */
+ exp2:
+  if (!isdigit (*p))
+    goto bad_float;
+
+  exponent = *p - '0';
+  p++;
+  w--;
+
+  if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
+    {
+      while (w > 0 && isdigit (*p))
+        {
+          exponent = 10 * exponent + *p - '0';
+          p++;
+          w--;
+        }
+        
+      /* Only allow trailing blanks */
+
+      while (w > 0)
+        {
+          if (*p != ' ')
+  	  goto bad_float;
+          p++;
+          w--;
+        }
+    }    
+  else  /* BZ or BN status is enabled */
+    {
+      while (w > 0)
+        {
+          if (*p == ' ')
+            {
+	      if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
+	      if (dtp->u.p.blank_status == BLANK_NULL)
+                {
+                  p++;
+                  w--;
+                  continue;
+                }
+            }
+          else if (!isdigit (*p))
+            goto bad_float;
+
+          exponent = 10 * exponent + *p - '0';
+          p++;
+          w--;
+        }
+    }
+
+  exponent = exponent * exponent_sign;
+
+ done:
+  /* Use the precision specified in the format if no decimal point has been
+     seen.  */
+  if (!seen_dp)
+    exponent -= f->u.real.d;
+
+  if (exponent > 0)
+    {
+      edigits = 2;
+      i = exponent;
+    }
+  else
+    {
+      edigits = 3;
+      i = -exponent;
+    }
+
+  while (i >= 10)
+    {
+      i /= 10;
+      edigits++;
+    }
+
+  i = ndigits + edigits + 1;
+  if (val_sign < 0)
+    i++;
+
+  if (i < SCRATCH_SIZE) 
+    buffer = scratch;
+  else
+    buffer = get_mem (i);
+
+  /* Reformat the string into a temporary buffer.  As we're using atof it's
+     easiest to just leave the decimal point in place.  */
+  p = buffer;
+  if (val_sign < 0)
+    *(p++) = '-';
+  for (; ndigits > 0; ndigits--)
+    {
+      if (*digits == ' ')
+        {
+	  if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
+	  if (dtp->u.p.blank_status == BLANK_NULL)
+            {
+              digits++;
+              continue;
+            } 
+        }
+      *p = *digits;
+      p++;
+      digits++;
+    }
+  *(p++) = 'e';
+  sprintf (p, "%d", exponent);
+
+  /* Do the actual conversion.  */
+  convert_real (dtp, dest, buffer, length);
+
+  if (buffer != scratch)
+     free_mem (buffer);
+
+  return;
+}
+
+
+/* read_x()-- Deal with the X/TR descriptor.  We just read some data
+ * and never look at it. */
+
+void
+read_x (st_parameter_dt *dtp, int n)
+{
+  if (!is_stream_io (dtp))
+    {
+      if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
+	  && dtp->u.p.current_unit->bytes_left < n)
+	n = dtp->u.p.current_unit->bytes_left;
+
+      dtp->u.p.sf_read_comma = 0;
+      if (n > 0)
+	read_sf (dtp, &n, 1);
+      dtp->u.p.sf_read_comma = 1;
+    }
+  else
+    dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
+}
diff --git a/gcc-4.2.1/libgfortran/io/size_from_kind.c b/gcc-4.2.1/libgfortran/io/size_from_kind.c
new file mode 100644
index 000000000..033b554c6
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/size_from_kind.c
@@ -0,0 +1,90 @@
+/* Copyright (C) 2005 Free Software Foundation, Inc.
+   Contributed by Janne Blomqvist
+
+This file is part of the GNU Fortran 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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+
+/* This file contains utility functions for determining the size of a
+   variable given its kind. */
+
+#include "config.h"
+#include "libgfortran.h"
+#include "io.h"
+
+size_t
+size_from_real_kind (int kind)
+{
+  switch (kind)
+    {
+#ifdef HAVE_GFC_REAL_4
+    case 4:
+      return sizeof (GFC_REAL_4);
+#endif
+#ifdef HAVE_GFC_REAL_8
+    case 8:
+      return sizeof (GFC_REAL_8);
+#endif
+#ifdef HAVE_GFC_REAL_10
+    case 10:
+      return sizeof (GFC_REAL_10);
+#endif
+#ifdef HAVE_GFC_REAL_16
+    case 16:
+      return sizeof (GFC_REAL_16);
+#endif
+    default:
+      return kind;
+    }
+}
+
+
+size_t
+size_from_complex_kind (int kind)
+{
+  switch (kind)
+    {
+#ifdef HAVE_GFC_COMPLEX_4
+    case 4:
+      return sizeof (GFC_COMPLEX_4);
+#endif
+#ifdef HAVE_GFC_COMPLEX_8
+    case 8:
+      return sizeof (GFC_COMPLEX_8);
+#endif
+#ifdef HAVE_GFC_COMPLEX_10
+    case 10:
+      return sizeof (GFC_COMPLEX_10);
+#endif
+#ifdef HAVE_GFC_COMPLEX_16
+    case 16:
+      return sizeof (GFC_COMPLEX_16);
+#endif
+    default:
+      return 2 * kind;
+    }
+}
+
diff --git a/gcc-4.2.1/libgfortran/io/transfer.c b/gcc-4.2.1/libgfortran/io/transfer.c
new file mode 100644
index 000000000..d1cd01c77
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/transfer.c
@@ -0,0 +1,2910 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   Namelist transfer functions contributed by Paul Thomas
+
+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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+
+/* transfer.c -- Top level handling of data transfer statements.  */
+
+#include "config.h"
+#include <string.h>
+#include <assert.h>
+#include "libgfortran.h"
+#include "io.h"
+
+
+/* Calling conventions:  Data transfer statements are unlike other
+   library calls in that they extend over several calls.
+
+   The first call is always a call to st_read() or st_write().  These
+   subroutines return no status unless a namelist read or write is
+   being done, in which case there is the usual status.  No further
+   calls are necessary in this case.
+
+   For other sorts of data transfer, there are zero or more data
+   transfer statement that depend on the format of the data transfer
+   statement.
+
+      transfer_integer
+      transfer_logical
+      transfer_character
+      transfer_real
+      transfer_complex
+
+    These subroutines do not return status.
+
+    The last call is a call to st_[read|write]_done().  While
+    something can easily go wrong with the initial st_read() or
+    st_write(), an error inhibits any data from actually being
+    transferred.  */
+
+extern void transfer_integer (st_parameter_dt *, void *, int);
+export_proto(transfer_integer);
+
+extern void transfer_real (st_parameter_dt *, void *, int);
+export_proto(transfer_real);
+
+extern void transfer_logical (st_parameter_dt *, void *, int);
+export_proto(transfer_logical);
+
+extern void transfer_character (st_parameter_dt *, void *, int);
+export_proto(transfer_character);
+
+extern void transfer_complex (st_parameter_dt *, void *, int);
+export_proto(transfer_complex);
+
+extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
+			    gfc_charlen_type);
+export_proto(transfer_array);
+
+static void us_read (st_parameter_dt *, int);
+static void us_write (st_parameter_dt *, int);
+static void next_record_r_unf (st_parameter_dt *, int);
+static void next_record_w_unf (st_parameter_dt *, int);
+
+static const st_option advance_opt[] = {
+  {"yes", ADVANCE_YES},
+  {"no", ADVANCE_NO},
+  {NULL, 0}
+};
+
+
+typedef enum
+{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
+  FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
+}
+file_mode;
+
+
+static file_mode
+current_mode (st_parameter_dt *dtp)
+{
+  file_mode m;
+
+  m = FORM_UNSPECIFIED;
+
+  if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+    {
+      m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
+	FORMATTED_DIRECT : UNFORMATTED_DIRECT;
+    }
+  else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+    {
+      m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
+	FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
+    }
+  else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
+    {
+      m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
+	FORMATTED_STREAM : UNFORMATTED_STREAM;
+    }
+
+  return m;
+}
+
+
+/* Mid level data transfer statements.  These subroutines do reading
+   and writing in the style of salloc_r()/salloc_w() within the
+   current record.  */
+
+/* When reading sequential formatted records we have a problem.  We
+   don't know how long the line is until we read the trailing newline,
+   and we don't want to read too much.  If we read too much, we might
+   have to do a physical seek backwards depending on how much data is
+   present, and devices like terminals aren't seekable and would cause
+   an I/O error.
+
+   Given this, the solution is to read a byte at a time, stopping if
+   we hit the newline.  For small allocations, we use a static buffer.
+   For larger allocations, we are forced to allocate memory on the
+   heap.  Hopefully this won't happen very often.  */
+
+char *
+read_sf (st_parameter_dt *dtp, int *length, int no_error)
+{
+  char *base, *p, *q;
+  int n, readlen, crlf;
+  gfc_offset pos;
+
+  if (*length > SCRATCH_SIZE)
+    dtp->u.p.line_buffer = get_mem (*length);
+  p = base = dtp->u.p.line_buffer;
+
+  /* If we have seen an eor previously, return a length of 0.  The
+     caller is responsible for correctly padding the input field.  */
+  if (dtp->u.p.sf_seen_eor)
+    {
+      *length = 0;
+      return base;
+    }
+
+  readlen = 1;
+  n = 0;
+
+  do
+    {
+      if (is_internal_unit (dtp))
+	{
+	  /* readlen may be modified inside salloc_r if
+	     is_internal_unit (dtp) is true.  */
+	  readlen = 1;
+	}
+
+      q = salloc_r (dtp->u.p.current_unit->s, &readlen);
+      if (q == NULL)
+	break;
+
+      /* If we have a line without a terminating \n, drop through to
+	 EOR below.  */
+      if (readlen < 1 && n == 0)
+	{
+	  if (no_error)
+	    break;
+	  generate_error (&dtp->common, ERROR_END, NULL);
+	  return NULL;
+	}
+
+      if (readlen < 1 || *q == '\n' || *q == '\r')
+	{
+	  /* Unexpected end of line.  */
+
+	  /* If we see an EOR during non-advancing I/O, we need to skip
+	     the rest of the I/O statement.  Set the corresponding flag.  */
+	  if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
+	    dtp->u.p.eor_condition = 1;
+
+	  crlf = 0;
+	  /* If we encounter a CR, it might be a CRLF.  */
+	  if (*q == '\r') /* Probably a CRLF */
+	    {
+	      readlen = 1;
+	      pos = stream_offset (dtp->u.p.current_unit->s);
+	      q = salloc_r (dtp->u.p.current_unit->s, &readlen);
+	      if (*q != '\n' && readlen == 1) /* Not a CRLF after all.  */
+		sseek (dtp->u.p.current_unit->s, pos);
+	      else
+		crlf = 1;
+	    }
+
+	  /* Without padding, terminate the I/O statement without assigning
+	     the value.  With padding, the value still needs to be assigned,
+	     so we can just continue with a short read.  */
+	  if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+	    {
+	      if (no_error)
+		break;
+	      generate_error (&dtp->common, ERROR_EOR, NULL);
+	      return NULL;
+	    }
+
+	  *length = n;
+	  dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
+	  break;
+	}
+      /*  Short circuit the read if a comma is found during numeric input.
+	  The flag is set to zero during character reads so that commas in
+	  strings are not ignored  */
+      if (*q == ',')
+	if (dtp->u.p.sf_read_comma == 1)
+	  {
+	    notify_std (&dtp->common, GFC_STD_GNU,
+			"Comma in formatted numeric read.");
+	    *length = n;
+	    break;
+	  }
+
+      n++;
+      *p++ = *q;
+      dtp->u.p.sf_seen_eor = 0;
+    }
+  while (n < *length);
+  dtp->u.p.current_unit->bytes_left -= *length;
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used += (gfc_offset) *length;
+
+  return base;
+}
+
+
+/* Function for reading the next couple of bytes from the current
+   file, advancing the current position.  We return a pointer to a
+   buffer containing the bytes.  We return NULL on end of record or
+   end of file.
+
+   If the read is short, then it is because the current record does not
+   have enough data to satisfy the read request and the file was
+   opened with PAD=YES.  The caller must assume tailing spaces for
+   short reads.  */
+
+void *
+read_block (st_parameter_dt *dtp, int *length)
+{
+  char *source;
+  int nread;
+
+  if (is_stream_io (dtp))
+    {
+      if (sseek (dtp->u.p.current_unit->s,
+		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
+	{
+	  generate_error (&dtp->common, ERROR_END, NULL);
+	  return NULL;
+	}
+    }
+  else
+    {
+      if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
+	{
+	  /* For preconnected units with default record length, set bytes left
+	   to unit record length and proceed, otherwise error.  */
+	  if (dtp->u.p.current_unit->unit_number == options.stdin_unit
+	      && dtp->u.p.current_unit->recl == DEFAULT_RECL)
+          dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+	  else
+	    {
+	      if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+		{
+		  /* Not enough data left.  */
+		  generate_error (&dtp->common, ERROR_EOR, NULL);
+		  return NULL;
+		}
+	    }
+
+	  if (dtp->u.p.current_unit->bytes_left == 0)
+	    {
+	      dtp->u.p.current_unit->endfile = AT_ENDFILE;
+	      generate_error (&dtp->common, ERROR_END, NULL);
+	      return NULL;
+	    }
+
+	  *length = dtp->u.p.current_unit->bytes_left;
+	}
+    }
+
+  if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
+      (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
+       dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
+    {
+      source = read_sf (dtp, length, 0);
+      dtp->u.p.current_unit->strm_pos +=
+	(gfc_offset) (*length + dtp->u.p.sf_seen_eor);
+      return source;
+    }
+  dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
+
+  nread = *length;
+  source = salloc_r (dtp->u.p.current_unit->s, &nread);
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used += (gfc_offset) nread;
+
+  if (nread != *length)
+    {				/* Short read, this shouldn't happen.  */
+      if (dtp->u.p.current_unit->flags.pad == PAD_YES)
+	*length = nread;
+      else
+	{
+	  generate_error (&dtp->common, ERROR_EOR, NULL);
+	  source = NULL;
+	}
+    }
+
+  dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
+
+  return source;
+}
+
+
+/* Reads a block directly into application data space.  This is for
+   unformatted files.  */
+
+static void
+read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
+{
+  size_t to_read_record;
+  size_t have_read_record;
+  size_t to_read_subrecord;
+  size_t have_read_subrecord;
+  int short_record;
+
+  if (is_stream_io (dtp))
+    {
+      if (sseek (dtp->u.p.current_unit->s,
+		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
+	{
+	  generate_error (&dtp->common, ERROR_END, NULL);
+	  return;
+	}
+
+      to_read_record = *nbytes;
+      have_read_record = to_read_record;
+      if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0)
+	{
+	  generate_error (&dtp->common, ERROR_OS, NULL);
+	  return;
+	}
+
+      dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record; 
+
+      if (to_read_record != have_read_record)
+	{
+	  /* Short read,  e.g. if we hit EOF.  For stream files,
+	   we have to set the end-of-file condition.  */
+	  generate_error (&dtp->common, ERROR_END, NULL);
+	  return;
+	}
+      return;
+    }
+
+  if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+    {
+      if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
+	{
+	  short_record = 1;
+	  to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
+	  *nbytes = to_read_record;
+	}
+
+      else
+	{
+	  short_record = 0;
+	  to_read_record = *nbytes;
+	}
+
+      dtp->u.p.current_unit->bytes_left -= to_read_record;
+
+      if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0)
+	{
+	  generate_error (&dtp->common, ERROR_OS, NULL);
+	  return;
+	}
+
+      if (to_read_record != *nbytes)  
+	{
+	  /* Short read, e.g. if we hit EOF.  Apparently, we read
+	   more than was written to the last record.  */
+	  *nbytes = to_read_record;
+	  return;
+	}
+
+      if (short_record)
+	{
+	  generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
+	  return;
+	}
+      return;
+    }
+
+  /* Unformatted sequential.  We loop over the subrecords, reading
+     until the request has been fulfilled or the record has run out
+     of continuation subrecords.  */
+
+  if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
+    {
+      generate_error (&dtp->common, ERROR_END, NULL);
+      return;
+    }
+
+  /* Check whether we exceed the total record length.  */
+
+  if (dtp->u.p.current_unit->flags.has_recl
+      && (*nbytes > (size_t) dtp->u.p.current_unit->bytes_left))
+    {
+      to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
+      short_record = 1;
+    }
+  else
+    {
+      to_read_record = *nbytes;
+      short_record = 0;
+    }
+  have_read_record = 0;
+
+  while(1)
+    {
+      if (dtp->u.p.current_unit->bytes_left_subrecord
+	  < (gfc_offset) to_read_record)
+	{
+	  to_read_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
+	  to_read_record -= to_read_subrecord;
+	}
+      else
+	{
+	  to_read_subrecord = to_read_record;
+	  to_read_record = 0;
+	}
+
+      dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
+
+      have_read_subrecord = to_read_subrecord;
+      if (sread (dtp->u.p.current_unit->s, buf + have_read_record,
+		 &have_read_subrecord) != 0)
+	{
+	  generate_error (&dtp->common, ERROR_OS, NULL);
+	  return;
+	}
+
+      have_read_record += have_read_subrecord;
+
+      if (to_read_subrecord != have_read_subrecord)  
+			
+	{
+	  /* Short read, e.g. if we hit EOF.  This means the record
+	     structure has been corrupted, or the trailing record
+	     marker would still be present.  */
+
+	  *nbytes = have_read_record;
+	  generate_error (&dtp->common, ERROR_CORRUPT_FILE, NULL);
+	  return;
+	}
+
+      if (to_read_record > 0)
+	{
+	  if (dtp->u.p.current_unit->continued)
+	    {
+	      next_record_r_unf (dtp, 0);
+	      us_read (dtp, 1);
+	    }
+	  else
+	    {
+	      /* Let's make sure the file position is correctly pre-positioned
+		 for the next read statement.  */
+
+	      dtp->u.p.current_unit->current_record = 0;
+	      next_record_r_unf (dtp, 0);
+	      generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
+	      return;
+	    }
+	}
+      else
+	{
+	  /* Normal exit, the read request has been fulfilled.  */
+	  break;
+	}
+    }
+
+  dtp->u.p.current_unit->bytes_left -= have_read_record;
+  if (short_record)
+    {
+      generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
+      return;
+    }
+  return;
+}
+
+
+/* Function for writing a block of bytes to the current file at the
+   current position, advancing the file pointer. We are given a length
+   and return a pointer to a buffer that the caller must (completely)
+   fill in.  Returns NULL on error.  */
+
+void *
+write_block (st_parameter_dt *dtp, int length)
+{
+  char *dest;
+
+  if (is_stream_io (dtp))
+    {
+      if (sseek (dtp->u.p.current_unit->s,
+		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
+	{
+	  generate_error (&dtp->common, ERROR_OS, NULL);
+	  return NULL;
+	}
+    }
+  else
+    {
+      if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
+	{
+	  /* For preconnected units with default record length, set bytes left
+	     to unit record length and proceed, otherwise error.  */
+	  if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
+		|| dtp->u.p.current_unit->unit_number == options.stderr_unit)
+		&& dtp->u.p.current_unit->recl == DEFAULT_RECL)
+	    dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+	  else
+	    {
+	      generate_error (&dtp->common, ERROR_EOR, NULL);
+	      return NULL;
+	    }
+	}
+
+      dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
+    }
+
+  dest = salloc_w (dtp->u.p.current_unit->s, &length);
+
+  if (dest == NULL)
+    {
+      generate_error (&dtp->common, ERROR_END, NULL);
+      return NULL;
+    }
+
+  if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
+    generate_error (&dtp->common, ERROR_END, NULL);
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used += (gfc_offset) length;
+
+  dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
+
+  return dest;
+}
+
+
+/* High level interface to swrite(), taking care of errors.  This is only
+   called for unformatted files.  There are three cases to consider:
+   Stream I/O, unformatted direct, unformatted sequential.  */
+
+static try
+write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
+{
+
+  size_t have_written, to_write_subrecord;
+  int short_record;
+
+
+  /* Stream I/O.  */
+
+  if (is_stream_io (dtp))
+    {
+      if (sseek (dtp->u.p.current_unit->s,
+		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
+	{
+	  generate_error (&dtp->common, ERROR_OS, NULL);
+	  return FAILURE;
+	}
+
+      if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
+	{
+	  generate_error (&dtp->common, ERROR_OS, NULL);
+	  return FAILURE;
+	}
+
+      dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes; 
+
+      return SUCCESS;
+    }
+
+  /* Unformatted direct access.  */
+
+  if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+    {
+      if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
+	{
+	  generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
+	  return FAILURE;
+	}
+
+      if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
+	{
+	  generate_error (&dtp->common, ERROR_OS, NULL);
+	  return FAILURE;
+	}
+
+      dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
+      dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
+
+      return SUCCESS;
+
+    }
+
+  /* Unformatted sequential.  */
+
+  have_written = 0;
+
+  if (dtp->u.p.current_unit->flags.has_recl
+      && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
+    {
+      nbytes = dtp->u.p.current_unit->bytes_left;
+      short_record = 1;
+    }
+  else
+    {
+      short_record = 0;
+    }
+
+  while (1)
+    {
+
+      to_write_subrecord =
+	(size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
+	(size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
+
+      dtp->u.p.current_unit->bytes_left_subrecord -=
+	(gfc_offset) to_write_subrecord;
+
+      if (swrite (dtp->u.p.current_unit->s, buf + have_written,
+		  &to_write_subrecord) != 0)
+	{
+	  generate_error (&dtp->common, ERROR_OS, NULL);
+	  return FAILURE;
+	}
+
+      dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord; 
+      nbytes -= to_write_subrecord;
+      have_written += to_write_subrecord;
+
+      if (nbytes == 0)
+	break;
+
+      next_record_w_unf (dtp, 1);
+      us_write (dtp, 1);
+    }
+  dtp->u.p.current_unit->bytes_left -= have_written;
+  if (short_record)
+    {
+      generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
+      return FAILURE;
+    }
+  return SUCCESS;
+}
+
+
+/* Master function for unformatted reads.  */
+
+static void
+unformatted_read (st_parameter_dt *dtp, bt type,
+		  void *dest, int kind,
+		  size_t size, size_t nelems)
+{
+  size_t i, sz;
+
+  /* Currently, character implies size=1.  */
+  if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
+      || size == 1 || type == BT_CHARACTER)
+    {
+      sz = size * nelems;
+      read_block_direct (dtp, dest, &sz);
+    }
+  else
+    {
+      char buffer[16];
+      char *p;
+      
+      /* Break up complex into its constituent reals.  */
+      if (type == BT_COMPLEX)
+	{
+	  nelems *= 2;
+	  size /= 2;
+	}
+      p = dest;
+      
+      /* By now, all complex variables have been split into their
+	 constituent reals.  For types with padding, we only need to
+	 read kind bytes.  We don't care about the contents
+	 of the padding.  If we hit a short record, then sz is
+	 adjusted accordingly, making later reads no-ops.  */
+      
+      if (type == BT_REAL || type == BT_COMPLEX)
+	sz = size_from_real_kind (kind);
+      else
+	sz = kind;
+
+      for (i=0; i<nelems; i++)
+	{
+ 	  read_block_direct (dtp, buffer, &sz);
+ 	  reverse_memcpy (p, buffer, sz);
+ 	  p += size;
+ 	}
+    }
+}
+
+
+/* Master function for unformatted writes.  */
+
+static void
+unformatted_write (st_parameter_dt *dtp, bt type,
+		   void *source, int kind,
+		   size_t size, size_t nelems)
+{
+  if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE ||
+      size == 1 || type == BT_CHARACTER)
+    {
+      size *= nelems;
+
+      write_buf (dtp, source, size);
+    }
+  else
+    {
+      char buffer[16];
+      char *p;
+      size_t i, sz;
+  
+      /* Break up complex into its constituent reals.  */
+      if (type == BT_COMPLEX)
+	{
+	  nelems *= 2;
+	  size /= 2;
+	}      
+
+      p = source;
+
+      /* By now, all complex variables have been split into their
+	 constituent reals.  For types with padding, we only need to
+	 read kind bytes.  We don't care about the contents
+	 of the padding.  */
+
+      if (type == BT_REAL || type == BT_COMPLEX)
+	sz = size_from_real_kind (kind);
+      else
+	sz = kind;
+
+      for (i=0; i<nelems; i++)
+	{
+	  reverse_memcpy(buffer, p, size);
+ 	  p+= size;
+	  write_buf (dtp, buffer, sz);
+	}
+    }
+}
+
+
+/* Return a pointer to the name of a type.  */
+
+const char *
+type_name (bt type)
+{
+  const char *p;
+
+  switch (type)
+    {
+    case BT_INTEGER:
+      p = "INTEGER";
+      break;
+    case BT_LOGICAL:
+      p = "LOGICAL";
+      break;
+    case BT_CHARACTER:
+      p = "CHARACTER";
+      break;
+    case BT_REAL:
+      p = "REAL";
+      break;
+    case BT_COMPLEX:
+      p = "COMPLEX";
+      break;
+    default:
+      internal_error (NULL, "type_name(): Bad type");
+    }
+
+  return p;
+}
+
+
+/* Write a constant string to the output.
+   This is complicated because the string can have doubled delimiters
+   in it.  The length in the format node is the true length.  */
+
+static void
+write_constant_string (st_parameter_dt *dtp, const fnode *f)
+{
+  char c, delimiter, *p, *q;
+  int length;
+
+  length = f->u.string.length;
+  if (length == 0)
+    return;
+
+  p = write_block (dtp, length);
+  if (p == NULL)
+    return;
+
+  q = f->u.string.p;
+  delimiter = q[-1];
+
+  for (; length > 0; length--)
+    {
+      c = *p++ = *q++;
+      if (c == delimiter && c != 'H' && c != 'h')
+	q++;			/* Skip the doubled delimiter.  */
+    }
+}
+
+
+/* Given actual and expected types in a formatted data transfer, make
+   sure they agree.  If not, an error message is generated.  Returns
+   nonzero if something went wrong.  */
+
+static int
+require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
+{
+  char buffer[100];
+
+  if (actual == expected)
+    return 0;
+
+  st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
+	      type_name (expected), dtp->u.p.item_count, type_name (actual));
+
+  format_error (dtp, f, buffer);
+  return 1;
+}
+
+
+/* This subroutine is the main loop for a formatted data transfer
+   statement.  It would be natural to implement this as a coroutine
+   with the user program, but C makes that awkward.  We loop,
+   processing format elements.  When we actually have to transfer
+   data instead of just setting flags, we return control to the user
+   program which calls a subroutine that supplies the address and type
+   of the next element, then comes back here to process it.  */
+
+static void
+formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
+			   size_t size)
+{
+  char scratch[SCRATCH_SIZE];
+  int pos, bytes_used;
+  const fnode *f;
+  format_token t;
+  int n;
+  int consume_data_flag;
+
+  /* Change a complex data item into a pair of reals.  */
+
+  n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
+  if (type == BT_COMPLEX)
+    {
+      type = BT_REAL;
+      size /= 2;
+    }
+
+  /* If there's an EOR condition, we simulate finalizing the transfer
+     by doing nothing.  */
+  if (dtp->u.p.eor_condition)
+    return;
+
+  /* Set this flag so that commas in reads cause the read to complete before
+     the entire field has been read.  The next read field will start right after
+     the comma in the stream.  (Set to 0 for character reads).  */
+  dtp->u.p.sf_read_comma = 1;
+
+  dtp->u.p.line_buffer = scratch;
+  for (;;)
+    {
+      /* If reversion has occurred and there is another real data item,
+	 then we have to move to the next record.  */
+      if (dtp->u.p.reversion_flag && n > 0)
+	{
+	  dtp->u.p.reversion_flag = 0;
+	  next_record (dtp, 0);
+	}
+
+      consume_data_flag = 1 ;
+      if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+	break;
+
+      f = next_format (dtp);
+      if (f == NULL)
+	{
+	  /* No data descriptors left.  */
+	  if (n > 0)
+	    generate_error (&dtp->common, ERROR_FORMAT,
+		"Insufficient data descriptors in format after reversion");
+	  return;
+	}
+
+      /* Now discharge T, TR and X movements to the right.  This is delayed
+	 until a data producing format to suppress trailing spaces.  */
+	 
+      t = f->format;
+      if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
+	&& ((n>0 && (  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))
+	    || t == FMT_STRING))
+	{
+	  if (dtp->u.p.skips > 0)
+	    {
+	      write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
+	      dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
+				       - dtp->u.p.current_unit->bytes_left);
+	    }
+	  if (dtp->u.p.skips < 0)
+	    {
+	      move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+	      dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
+	    }
+	  dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+	}
+
+      bytes_used = (int)(dtp->u.p.current_unit->recl
+			 - dtp->u.p.current_unit->bytes_left);
+
+      switch (t)
+	{
+	case FMT_I:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_INTEGER, type, f))
+	    return;
+
+	  if (dtp->u.p.mode == READING)
+	    read_decimal (dtp, f, p, len);
+	  else
+	    write_i (dtp, f, p, len);
+
+	  break;
+
+	case FMT_B:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_INTEGER, type, f))
+	    return;
+
+	  if (dtp->u.p.mode == READING)
+	    read_radix (dtp, f, p, len, 2);
+	  else
+	    write_b (dtp, f, p, len);
+
+	  break;
+
+	case FMT_O:
+	  if (n == 0)
+	    goto need_data;
+
+	  if (dtp->u.p.mode == READING)
+	    read_radix (dtp, f, p, len, 8);
+	  else
+	    write_o (dtp, f, p, len);
+
+	  break;
+
+	case FMT_Z:
+	  if (n == 0)
+	    goto need_data;
+
+	  if (dtp->u.p.mode == READING)
+	    read_radix (dtp, f, p, len, 16);
+	  else
+	    write_z (dtp, f, p, len);
+
+	  break;
+
+	case FMT_A:
+	  if (n == 0)
+	    goto need_data;
+
+	  if (dtp->u.p.mode == READING)
+	    read_a (dtp, f, p, len);
+	  else
+	    write_a (dtp, f, p, len);
+
+	  break;
+
+	case FMT_L:
+	  if (n == 0)
+	    goto need_data;
+
+	  if (dtp->u.p.mode == READING)
+	    read_l (dtp, f, p, len);
+	  else
+	    write_l (dtp, f, p, len);
+
+	  break;
+
+	case FMT_D:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+
+	  if (dtp->u.p.mode == READING)
+	    read_f (dtp, f, p, len);
+	  else
+	    write_d (dtp, f, p, len);
+
+	  break;
+
+	case FMT_E:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+
+	  if (dtp->u.p.mode == READING)
+	    read_f (dtp, f, p, len);
+	  else
+	    write_e (dtp, f, p, len);
+	  break;
+
+	case FMT_EN:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+
+	  if (dtp->u.p.mode == READING)
+	    read_f (dtp, f, p, len);
+	  else
+	    write_en (dtp, f, p, len);
+
+	  break;
+
+	case FMT_ES:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+
+	  if (dtp->u.p.mode == READING)
+	    read_f (dtp, f, p, len);
+	  else
+	    write_es (dtp, f, p, len);
+
+	  break;
+
+	case FMT_F:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+
+	  if (dtp->u.p.mode == READING)
+	    read_f (dtp, f, p, len);
+	  else
+	    write_f (dtp, f, p, len);
+
+	  break;
+
+	case FMT_G:
+	  if (n == 0)
+	    goto need_data;
+	  if (dtp->u.p.mode == READING)
+	    switch (type)
+	      {
+	      case BT_INTEGER:
+		read_decimal (dtp, f, p, len);
+		break;
+	      case BT_LOGICAL:
+		read_l (dtp, f, p, len);
+		break;
+	      case BT_CHARACTER:
+		read_a (dtp, f, p, len);
+		break;
+	      case BT_REAL:
+		read_f (dtp, f, p, len);
+		break;
+	      default:
+		goto bad_type;
+	      }
+	  else
+	    switch (type)
+	      {
+	      case BT_INTEGER:
+		write_i (dtp, f, p, len);
+		break;
+	      case BT_LOGICAL:
+		write_l (dtp, f, p, len);
+		break;
+	      case BT_CHARACTER:
+		write_a (dtp, f, p, len);
+		break;
+	      case BT_REAL:
+		write_d (dtp, f, p, len);
+		break;
+	      default:
+	      bad_type:
+		internal_error (&dtp->common,
+				"formatted_transfer(): Bad type");
+	      }
+
+	  break;
+
+	case FMT_STRING:
+	  consume_data_flag = 0 ;
+	  if (dtp->u.p.mode == READING)
+	    {
+	      format_error (dtp, f, "Constant string in input format");
+	      return;
+	    }
+	  write_constant_string (dtp, f);
+	  break;
+
+	/* Format codes that don't transfer data.  */
+	case FMT_X:
+	case FMT_TR:
+	  consume_data_flag = 0;
+
+	  pos = bytes_used + f->u.n + dtp->u.p.skips;
+	  dtp->u.p.skips = f->u.n + dtp->u.p.skips;
+	  dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
+
+	  /* Writes occur just before the switch on f->format, above, so
+	     that trailing blanks are suppressed, unless we are doing a
+	     non-advancing write in which case we want to output the blanks
+	     now.  */
+	  if (dtp->u.p.mode == WRITING
+	      && dtp->u.p.advance_status == ADVANCE_NO)
+	    {
+	      write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
+	      dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+	    }
+
+	  if (dtp->u.p.mode == READING)
+	    read_x (dtp, f->u.n);
+
+	  break;
+
+	case FMT_TL:
+	case FMT_T:
+	  consume_data_flag = 0;
+
+	  if (f->format == FMT_TL)
+	    {
+
+	      /* Handle the special case when no bytes have been used yet.
+	         Cannot go below zero. */
+	      if (bytes_used == 0)
+		{
+		  dtp->u.p.pending_spaces -= f->u.n;
+		  dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0
+					    : dtp->u.p.pending_spaces;
+		  dtp->u.p.skips -= f->u.n;
+		  dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
+		}
+
+	      pos = bytes_used - f->u.n;
+	    }
+	  else /* FMT_T */
+	    {
+	      if (dtp->u.p.mode == READING)
+		pos = f->u.n - 1;
+	      else
+		pos = f->u.n - dtp->u.p.pending_spaces - 1;
+	    }
+
+	  /* Standard 10.6.1.1: excessive left tabbing is reset to the
+	     left tab limit.  We do not check if the position has gone
+	     beyond the end of record because a subsequent tab could
+	     bring us back again.  */
+	  pos = pos < 0 ? 0 : pos;
+
+	  dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
+	  dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
+				    + pos - dtp->u.p.max_pos;
+
+	  if (dtp->u.p.skips == 0)
+	    break;
+
+	  /* Writes occur just before the switch on f->format, above, so that
+	     trailing blanks are suppressed.  */
+	  if (dtp->u.p.mode == READING)
+	    {
+	      /* Adjust everything for end-of-record condition */
+	      if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
+		{
+		  if (dtp->u.p.sf_seen_eor == 2)
+		    {
+		      /* The EOR was a CRLF (two bytes wide).  */
+		      dtp->u.p.current_unit->bytes_left -= 2;
+		      dtp->u.p.skips -= 2;
+		    }
+		  else
+		    {
+		      /* The EOR marker was only one byte wide.  */
+		      dtp->u.p.current_unit->bytes_left--;
+		      dtp->u.p.skips--;
+		    }
+		  bytes_used = pos;
+		  dtp->u.p.sf_seen_eor = 0;
+		}
+	      if (dtp->u.p.skips < 0)
+		{
+		  move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+		  dtp->u.p.current_unit->bytes_left
+		    -= (gfc_offset) dtp->u.p.skips;
+		  dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+		}
+	      else
+		read_x (dtp, dtp->u.p.skips);
+	    }
+
+	  break;
+
+	case FMT_S:
+	  consume_data_flag = 0 ;
+	  dtp->u.p.sign_status = SIGN_S;
+	  break;
+
+	case FMT_SS:
+	  consume_data_flag = 0 ;
+	  dtp->u.p.sign_status = SIGN_SS;
+	  break;
+
+	case FMT_SP:
+	  consume_data_flag = 0 ;
+	  dtp->u.p.sign_status = SIGN_SP;
+	  break;
+
+	case FMT_BN:
+	  consume_data_flag = 0 ;
+	  dtp->u.p.blank_status = BLANK_NULL;
+	  break;
+
+	case FMT_BZ:
+	  consume_data_flag = 0 ;
+	  dtp->u.p.blank_status = BLANK_ZERO;
+	  break;
+
+	case FMT_P:
+	  consume_data_flag = 0 ;
+	  dtp->u.p.scale_factor = f->u.k;
+	  break;
+
+	case FMT_DOLLAR:
+	  consume_data_flag = 0 ;
+	  dtp->u.p.seen_dollar = 1;
+	  break;
+
+	case FMT_SLASH:
+	  consume_data_flag = 0 ;
+	  dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+	  next_record (dtp, 0);
+	  break;
+
+	case FMT_COLON:
+	  /* A colon descriptor causes us to exit this loop (in
+	     particular preventing another / descriptor from being
+	     processed) unless there is another data item to be
+	     transferred.  */
+	  consume_data_flag = 0 ;
+	  if (n == 0)
+	    return;
+	  break;
+
+	default:
+	  internal_error (&dtp->common, "Bad format node");
+	}
+
+      /* Free a buffer that we had to allocate during a sequential
+	 formatted read of a block that was larger than the static
+	 buffer.  */
+
+      if (dtp->u.p.line_buffer != scratch)
+	{
+	  free_mem (dtp->u.p.line_buffer);
+	  dtp->u.p.line_buffer = scratch;
+	}
+
+      /* Adjust the item count and data pointer.  */
+
+      if ((consume_data_flag > 0) && (n > 0))
+      {
+	n--;
+	p = ((char *) p) + size;
+      }
+
+      if (dtp->u.p.mode == READING)
+	dtp->u.p.skips = 0;
+
+      pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
+      dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
+
+    }
+
+  return;
+
+  /* Come here when we need a data descriptor but don't have one.  We
+     push the current format node back onto the input, then return and
+     let the user program call us back with the data.  */
+ need_data:
+  unget_format (dtp, f);
+}
+
+static void
+formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
+		    size_t size, size_t nelems)
+{
+  size_t elem;
+  char *tmp;
+
+  tmp = (char *) p;
+
+  /* Big loop over all the elements.  */
+  for (elem = 0; elem < nelems; elem++)
+    {
+      dtp->u.p.item_count++;
+      formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
+    }
+}
+
+
+
+/* Data transfer entry points.  The type of the data entity is
+   implicit in the subroutine call.  This prevents us from having to
+   share a common enum with the compiler.  */
+
+void
+transfer_integer (st_parameter_dt *dtp, void *p, int kind)
+{
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+  dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
+}
+
+
+void
+transfer_real (st_parameter_dt *dtp, void *p, int kind)
+{
+  size_t size;
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+  size = size_from_real_kind (kind);
+  dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
+}
+
+
+void
+transfer_logical (st_parameter_dt *dtp, void *p, int kind)
+{
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+  dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
+}
+
+
+void
+transfer_character (st_parameter_dt *dtp, void *p, int len)
+{
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+  /* Currently we support only 1 byte chars, and the library is a bit
+     confused of character kind vs. length, so we kludge it by setting
+     kind = length.  */
+  dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
+}
+
+
+void
+transfer_complex (st_parameter_dt *dtp, void *p, int kind)
+{
+  size_t size;
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+  size = size_from_complex_kind (kind);
+  dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
+}
+
+
+void
+transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+		gfc_charlen_type charlen)
+{
+  index_type count[GFC_MAX_DIMENSIONS];
+  index_type extent[GFC_MAX_DIMENSIONS];
+  index_type stride[GFC_MAX_DIMENSIONS];
+  index_type stride0, rank, size, type, n;
+  size_t tsize;
+  char *data;
+  bt iotype;
+
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+
+  type = GFC_DESCRIPTOR_TYPE (desc);
+  size = GFC_DESCRIPTOR_SIZE (desc);
+
+  /* FIXME: What a kludge: Array descriptors and the IO library use
+     different enums for types.  */
+  switch (type)
+    {
+    case GFC_DTYPE_UNKNOWN:
+      iotype = BT_NULL;  /* Is this correct?  */
+      break;
+    case GFC_DTYPE_INTEGER:
+      iotype = BT_INTEGER;
+      break;
+    case GFC_DTYPE_LOGICAL:
+      iotype = BT_LOGICAL;
+      break;
+    case GFC_DTYPE_REAL:
+      iotype = BT_REAL;
+      break;
+    case GFC_DTYPE_COMPLEX:
+      iotype = BT_COMPLEX;
+      break;
+    case GFC_DTYPE_CHARACTER:
+      iotype = BT_CHARACTER;
+      /* FIXME: Currently dtype contains the charlen, which is
+	 clobbered if charlen > 2**24. That's why we use a separate
+	 argument for the charlen. However, if we want to support
+	 non-8-bit charsets we need to fix dtype to contain
+	 sizeof(chartype) and fix the code below.  */
+      size = charlen;
+      kind = charlen;
+      break;
+    case GFC_DTYPE_DERIVED:
+      internal_error (&dtp->common,
+		"Derived type I/O should have been handled via the frontend.");
+      break;
+    default:
+      internal_error (&dtp->common, "transfer_array(): Bad type");
+    }
+
+  rank = GFC_DESCRIPTOR_RANK (desc);
+  for (n = 0; n < rank; n++)
+    {
+      count[n] = 0;
+      stride[n] = desc->dim[n].stride;
+      extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
+
+      /* If the extent of even one dimension is zero, then the entire
+	 array section contains zero elements, so we return.  */
+      if (extent[n] <= 0)
+	return;
+    }
+
+  stride0 = stride[0];
+
+  /* If the innermost dimension has stride 1, we can do the transfer
+     in contiguous chunks.  */
+  if (stride0 == 1)
+    tsize = extent[0];
+  else
+    tsize = 1;
+
+  data = GFC_DESCRIPTOR_DATA (desc);
+
+  while (data)
+    {
+      dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
+      data += stride0 * size * tsize;
+      count[0] += tsize;
+      n = 0;
+      while (count[n] == extent[n])
+	{
+	  count[n] = 0;
+	  data -= stride[n] * extent[n] * size;
+	  n++;
+	  if (n == rank)
+	    {
+	      data = NULL;
+	      break;
+	    }
+	  else
+	    {
+	      count[n]++;
+	      data += stride[n] * size;
+	    }
+	}
+    }
+}
+
+
+/* Preposition a sequential unformatted file while reading.  */
+
+static void
+us_read (st_parameter_dt *dtp, int continued)
+{
+  char *p;
+  int n;
+  int nr;
+  GFC_INTEGER_4 i4;
+  GFC_INTEGER_8 i8;
+  gfc_offset i;
+
+  if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
+    return;
+
+  if (compile_options.record_marker == 0)
+    n = sizeof (GFC_INTEGER_4);
+  else
+    n = compile_options.record_marker;
+
+  nr = n;
+
+  p = salloc_r (dtp->u.p.current_unit->s, &n);
+
+  if (n == 0)
+    {
+      dtp->u.p.current_unit->endfile = AT_ENDFILE;
+      return;  /* end of file */
+    }
+
+  if (p == NULL || n != nr)
+    {
+      generate_error (&dtp->common, ERROR_BAD_US, NULL);
+      return;
+    }
+
+  /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
+  if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
+    {
+      switch (nr)
+	{
+	case sizeof(GFC_INTEGER_4):
+	  memcpy (&i4, p, sizeof (i4));
+	  i = i4;
+	  break;
+
+	case sizeof(GFC_INTEGER_8):
+	  memcpy (&i8, p, sizeof (i8));
+	  i = i8;
+	  break;
+
+	default:
+	  runtime_error ("Illegal value for record marker");
+	  break;
+	}
+    }
+  else
+      switch (nr)
+	{
+	case sizeof(GFC_INTEGER_4):
+	  reverse_memcpy (&i4, p, sizeof (i4));
+	  i = i4;
+	  break;
+
+	case sizeof(GFC_INTEGER_8):
+	  reverse_memcpy (&i8, p, sizeof (i8));
+	  i = i8;
+	  break;
+
+	default:
+	  runtime_error ("Illegal value for record marker");
+	  break;
+	}
+
+  if (i >= 0)
+    {
+      dtp->u.p.current_unit->bytes_left_subrecord = i;
+      dtp->u.p.current_unit->continued = 0;
+    }
+  else
+    {
+      dtp->u.p.current_unit->bytes_left_subrecord = -i;
+      dtp->u.p.current_unit->continued = 1;
+    }
+
+  if (! continued)
+    dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+}
+
+
+/* Preposition a sequential unformatted file while writing.  This
+   amount to writing a bogus length that will be filled in later.  */
+
+static void
+us_write (st_parameter_dt *dtp, int continued)
+{
+  size_t nbytes;
+  gfc_offset dummy;
+
+  dummy = 0;
+
+  if (compile_options.record_marker == 0)
+    nbytes = sizeof (GFC_INTEGER_4);
+  else
+    nbytes = compile_options.record_marker ;
+
+  if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
+    generate_error (&dtp->common, ERROR_OS, NULL);
+
+  /* For sequential unformatted, if RECL= was not specified in the OPEN
+     we write until we have more bytes than can fit in the subrecord
+     markers, then we write a new subrecord.  */
+  
+  dtp->u.p.current_unit->bytes_left_subrecord =
+    dtp->u.p.current_unit->recl_subrecord;
+  dtp->u.p.current_unit->continued = continued;
+}
+
+
+/* Position to the next record prior to transfer.  We are assumed to
+   be before the next record.  We also calculate the bytes in the next
+   record.  */
+
+static void
+pre_position (st_parameter_dt *dtp)
+{
+  if (dtp->u.p.current_unit->current_record)
+    return;			/* Already positioned.  */
+
+  switch (current_mode (dtp))
+    {
+    case FORMATTED_STREAM:
+    case UNFORMATTED_STREAM:
+      /* There are no records with stream I/O.  Set the default position
+	 to the beginning of the file if no position was specified.  */
+      if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
+        dtp->u.p.current_unit->strm_pos = 1;
+      break;
+    
+    case UNFORMATTED_SEQUENTIAL:
+      if (dtp->u.p.mode == READING)
+	us_read (dtp, 0);
+      else
+	us_write (dtp, 0);
+
+      break;
+
+    case FORMATTED_SEQUENTIAL:
+    case FORMATTED_DIRECT:
+    case UNFORMATTED_DIRECT:
+      dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+      break;
+    }
+
+  dtp->u.p.current_unit->current_record = 1;
+}
+
+
+/* Initialize things for a data transfer.  This code is common for
+   both reading and writing.  */
+
+static void
+data_transfer_init (st_parameter_dt *dtp, int read_flag)
+{
+  unit_flags u_flags;  /* Used for creating a unit if needed.  */
+  GFC_INTEGER_4 cf = dtp->common.flags;
+  namelist_info *ionml;
+
+  ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
+  memset (&dtp->u.p, 0, sizeof (dtp->u.p));
+  dtp->u.p.ionml = ionml;
+  dtp->u.p.mode = read_flag ? READING : WRITING;
+
+  if ((cf & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used = 0;  /* Initialize the count.  */
+
+  dtp->u.p.current_unit = get_unit (dtp, 1);
+  if (dtp->u.p.current_unit->s == NULL)
+  {  /* Open the unit with some default flags.  */
+     st_parameter_open opp;
+     unit_convert conv;
+
+     if (dtp->common.unit < 0)
+     {
+       close_unit (dtp->u.p.current_unit);
+       dtp->u.p.current_unit = NULL;
+       generate_error (&dtp->common, ERROR_BAD_OPTION,
+		       "Bad unit number in OPEN statement");
+       return;
+     }
+     memset (&u_flags, '\0', sizeof (u_flags));
+     u_flags.access = ACCESS_SEQUENTIAL;
+     u_flags.action = ACTION_READWRITE;
+
+     /* Is it unformatted?  */
+     if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
+		 | IOPARM_DT_IONML_SET)))
+       u_flags.form = FORM_UNFORMATTED;
+     else
+       u_flags.form = FORM_UNSPECIFIED;
+
+     u_flags.delim = DELIM_UNSPECIFIED;
+     u_flags.blank = BLANK_UNSPECIFIED;
+     u_flags.pad = PAD_UNSPECIFIED;
+     u_flags.status = STATUS_UNKNOWN;
+
+     conv = get_unformatted_convert (dtp->common.unit);
+
+     if (conv == CONVERT_NONE)
+       conv = compile_options.convert;
+
+     /* We use l8_to_l4_offset, which is 0 on little-endian machines
+	and 1 on big-endian machines.  */
+     switch (conv)
+       {
+       case CONVERT_NATIVE:
+       case CONVERT_SWAP:
+	 break;
+	 
+       case CONVERT_BIG:
+	 conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
+	 break;
+      
+       case CONVERT_LITTLE:
+	 conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
+	 break;
+	 
+       default:
+	 internal_error (&opp.common, "Illegal value for CONVERT");
+	 break;
+       }
+
+     u_flags.convert = conv;
+
+     opp.common = dtp->common;
+     opp.common.flags &= IOPARM_COMMON_MASK;
+     dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
+     dtp->common.flags &= ~IOPARM_COMMON_MASK;
+     dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
+     if (dtp->u.p.current_unit == NULL)
+       return;
+  }
+
+  /* Check the action.  */
+
+  if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
+    {
+      generate_error (&dtp->common, ERROR_BAD_ACTION,
+		      "Cannot read from file opened for WRITE");
+      return;
+    }
+
+  if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
+    {
+      generate_error (&dtp->common, ERROR_BAD_ACTION,
+		      "Cannot write to file opened for READ");
+      return;
+    }
+
+  dtp->u.p.first_item = 1;
+
+  /* Check the format.  */
+
+  if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
+    parse_format (dtp);
+
+  if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
+      && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
+	 != 0)
+    {
+      generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+		      "Format present for UNFORMATTED data transfer");
+      return;
+    }
+
+  if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
+     {
+	if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
+	   generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+		    "A format cannot be specified with a namelist");
+     }
+  else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
+	   !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
+    {
+      generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+		      "Missing format for FORMATTED data transfer");
+    }
+
+  if (is_internal_unit (dtp)
+      && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+    {
+      generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+		      "Internal file cannot be accessed by UNFORMATTED "
+		      "data transfer");
+      return;
+    }
+
+  /* Check the record or position number.  */
+
+  if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
+      && (cf & IOPARM_DT_HAS_REC) == 0)
+    {
+      generate_error (&dtp->common, ERROR_MISSING_OPTION,
+		      "Direct access data transfer requires record number");
+      return;
+    }
+
+  if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
+      && (cf & IOPARM_DT_HAS_REC) != 0)
+    {
+      generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+		      "Record number not allowed for sequential access data transfer");
+      return;
+    }
+
+  /* Process the ADVANCE option.  */
+
+  dtp->u.p.advance_status
+    = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
+      find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
+		   "Bad ADVANCE parameter in data transfer statement");
+
+  if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
+    {
+      if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+	{
+	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+			  "ADVANCE specification conflicts with sequential access");
+	  return;
+	}
+
+      if (is_internal_unit (dtp))
+	{
+	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+			  "ADVANCE specification conflicts with internal file");
+	  return;
+	}
+
+      if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
+	  != IOPARM_DT_HAS_FORMAT)
+	{
+	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+			  "ADVANCE specification requires an explicit format");
+	  return;
+	}
+    }
+
+  if (read_flag)
+    {
+      if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
+	{
+	  generate_error (&dtp->common, ERROR_MISSING_OPTION,
+			  "EOR specification requires an ADVANCE specification "
+			  "of NO");
+	  return;
+	}
+
+      if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
+	{
+	  generate_error (&dtp->common, ERROR_MISSING_OPTION,
+			  "SIZE specification requires an ADVANCE specification of NO");
+	  return;
+	}
+    }
+  else
+    {				/* Write constraints.  */
+      if ((cf & IOPARM_END) != 0)
+	{
+	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+			  "END specification cannot appear in a write statement");
+	  return;
+	}
+
+      if ((cf & IOPARM_EOR) != 0)
+	{
+	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+			  "EOR specification cannot appear in a write statement");
+	  return;
+	}
+
+      if ((cf & IOPARM_DT_HAS_SIZE) != 0)
+	{
+	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
+			  "SIZE specification cannot appear in a write statement");
+	  return;
+	}
+    }
+
+  if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
+    dtp->u.p.advance_status = ADVANCE_YES;
+
+  /* Sanity checks on the record number.  */
+  if ((cf & IOPARM_DT_HAS_REC) != 0)
+    {
+      if (dtp->rec <= 0)
+	{
+	  generate_error (&dtp->common, ERROR_BAD_OPTION,
+			  "Record number must be positive");
+	  return;
+	}
+
+      if (dtp->rec >= dtp->u.p.current_unit->maxrec)
+	{
+	  generate_error (&dtp->common, ERROR_BAD_OPTION,
+			  "Record number too large");
+	  return;
+	}
+
+      /* Check to see if we might be reading what we wrote before  */
+
+      if (dtp->u.p.mode == READING
+	  && dtp->u.p.current_unit->mode == WRITING
+	  && !is_internal_unit (dtp))
+	 flush(dtp->u.p.current_unit->s);
+
+      /* Check whether the record exists to be read.  Only
+	 a partial record needs to exist.  */
+
+      if (dtp->u.p.mode == READING && (dtp->rec -1)
+	  * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
+	{
+	  generate_error (&dtp->common, ERROR_BAD_OPTION,
+			  "Non-existing record number");
+	  return;
+	}
+
+      /* Position the file.  */
+      if (!is_stream_io (dtp))
+	{
+	  if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
+		     * dtp->u.p.current_unit->recl) == FAILURE)
+	    {
+	      generate_error (&dtp->common, ERROR_OS, NULL);
+	      return;
+	    }
+	}
+      else
+	dtp->u.p.current_unit->strm_pos = dtp->rec;
+
+    }
+
+  /* Overwriting an existing sequential file ?
+     it is always safe to truncate the file on the first write */
+  if (dtp->u.p.mode == WRITING
+      && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
+      && dtp->u.p.current_unit->last_record == 0 
+      && !is_preconnected(dtp->u.p.current_unit->s))
+	struncate(dtp->u.p.current_unit->s);
+
+  /* Bugware for badly written mixed C-Fortran I/O.  */
+  flush_if_preconnected(dtp->u.p.current_unit->s);
+
+  dtp->u.p.current_unit->mode = dtp->u.p.mode;
+
+  /* Set the initial value of flags.  */
+
+  dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
+  dtp->u.p.sign_status = SIGN_S;
+
+  pre_position (dtp);
+
+  /* Set up the subroutine that will handle the transfers.  */
+
+  if (read_flag)
+    {
+      if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+	dtp->u.p.transfer = unformatted_read;
+      else
+	{
+	  if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+	    dtp->u.p.transfer = list_formatted_read;
+	  else
+	    dtp->u.p.transfer = formatted_transfer;
+	}
+    }
+  else
+    {
+      if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+	dtp->u.p.transfer = unformatted_write;
+      else
+	{
+	  if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+	    dtp->u.p.transfer = list_formatted_write;
+	  else
+	    dtp->u.p.transfer = formatted_transfer;
+	}
+    }
+
+  /* Make sure that we don't do a read after a nonadvancing write.  */
+
+  if (read_flag)
+    {
+      if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
+	{
+	  generate_error (&dtp->common, ERROR_BAD_OPTION,
+			  "Cannot READ after a nonadvancing WRITE");
+	  return;
+	}
+    }
+  else
+    {
+      if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
+	dtp->u.p.current_unit->read_bad = 1;
+    }
+
+  /* Start the data transfer if we are doing a formatted transfer.  */
+  if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
+      && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
+      && dtp->u.p.ionml == NULL)
+    formatted_transfer (dtp, 0, NULL, 0, 0, 1);
+}
+
+/* Initialize an array_loop_spec given the array descriptor.  The function
+   returns the index of the last element of the array.  */
+   
+gfc_offset
+init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
+{
+  int rank = GFC_DESCRIPTOR_RANK(desc);
+  int i;
+  gfc_offset index; 
+
+  index = 1;
+  for (i=0; i<rank; i++)
+    {
+      ls[i].idx = desc->dim[i].lbound;
+      ls[i].start = desc->dim[i].lbound;
+      ls[i].end = desc->dim[i].ubound;
+      ls[i].step = desc->dim[i].stride;
+      
+      index += (desc->dim[i].ubound - desc->dim[i].lbound)
+                      * desc->dim[i].stride;
+    }
+  return index;
+}
+
+/* Determine the index to the next record in an internal unit array by
+   by incrementing through the array_loop_spec.  TODO:  Implement handling
+   negative strides. */
+   
+gfc_offset
+next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
+{
+  int i, carry;
+  gfc_offset index;
+  
+  carry = 1;
+  index = 0;
+  
+  for (i = 0; i < dtp->u.p.current_unit->rank; i++)
+    {
+      if (carry)
+        {
+          ls[i].idx++;
+          if (ls[i].idx > ls[i].end)
+            {
+              ls[i].idx = ls[i].start;
+              carry = 1;
+            }
+          else
+            carry = 0;
+        }
+      index = index + (ls[i].idx - ls[i].start) * ls[i].step;
+    }
+
+  return index;
+}
+
+
+
+/* Skip to the end of the current record, taking care of an optional
+   record marker of size bytes.  If the file is not seekable, we
+   read chunks of size MAX_READ until we get to the right
+   position.  */
+
+#define MAX_READ 4096
+
+static void
+skip_record (st_parameter_dt *dtp, size_t bytes)
+{
+  gfc_offset new;
+  int rlength, length;
+  char *p;
+
+  dtp->u.p.current_unit->bytes_left_subrecord += bytes;
+  if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
+    return;
+
+  if (is_seekable (dtp->u.p.current_unit->s))
+    {
+      new = file_position (dtp->u.p.current_unit->s)
+	+ dtp->u.p.current_unit->bytes_left_subrecord;
+
+      /* Direct access files do not generate END conditions,
+	 only I/O errors.  */
+      if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
+	generate_error (&dtp->common, ERROR_OS, NULL);
+    }
+  else
+    {			/* Seek by reading data.  */
+      while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
+	{
+	  rlength = length =
+	    (MAX_READ > dtp->u.p.current_unit->bytes_left_subrecord) ?
+	    MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
+
+	  p = salloc_r (dtp->u.p.current_unit->s, &rlength);
+	  if (p == NULL)
+	    {
+	      generate_error (&dtp->common, ERROR_OS, NULL);
+	      return;
+	    }
+
+	  dtp->u.p.current_unit->bytes_left_subrecord -= length;
+	}
+    }
+
+}
+
+#undef MAX_READ
+
+/* Advance to the next record reading unformatted files, taking
+   care of subrecords.  If complete_record is nonzero, we loop
+   until all subrecords are cleared.  */
+
+static void
+next_record_r_unf (st_parameter_dt *dtp, int complete_record)
+{
+  size_t bytes;
+
+  bytes =  compile_options.record_marker == 0 ?
+    sizeof (GFC_INTEGER_4) : compile_options.record_marker;
+
+  while(1)
+    {
+
+      /* Skip over tail */
+
+      skip_record (dtp, bytes);
+
+      if ( ! (complete_record && dtp->u.p.current_unit->continued))
+	return;
+
+      us_read (dtp, 1);
+    }
+}
+
+/* Space to the next record for read mode.  */
+
+static void
+next_record_r (st_parameter_dt *dtp)
+{
+  gfc_offset record;
+  int length, bytes_left;
+  char *p;
+
+  switch (current_mode (dtp))
+    {
+    /* No records in unformatted STREAM I/O.  */
+    case UNFORMATTED_STREAM:
+      return;
+    
+    case UNFORMATTED_SEQUENTIAL:
+      next_record_r_unf (dtp, 1);
+      dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+      break;
+
+    case FORMATTED_DIRECT:
+    case UNFORMATTED_DIRECT:
+      skip_record (dtp, 0);
+      break;
+
+    case FORMATTED_STREAM:
+    case FORMATTED_SEQUENTIAL:
+      length = 1;
+      /* sf_read has already terminated input because of an '\n'  */
+      if (dtp->u.p.sf_seen_eor)
+	{
+	  dtp->u.p.sf_seen_eor = 0;
+	  break;
+	}
+
+      if (is_internal_unit (dtp))
+	{
+	  if (is_array_io (dtp))
+	    {
+	      record = next_array_record (dtp, dtp->u.p.current_unit->ls);
+
+	      /* Now seek to this record.  */
+	      record = record * dtp->u.p.current_unit->recl;
+	      if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+		{
+		  generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
+		  break;
+		}
+	      dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+	    }
+	  else  
+	    {
+	      bytes_left = (int) dtp->u.p.current_unit->bytes_left;
+	      p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
+	      if (p != NULL)
+		dtp->u.p.current_unit->bytes_left
+		  = dtp->u.p.current_unit->recl;
+	    } 
+	  break;
+	}
+      else do
+	{
+	  p = salloc_r (dtp->u.p.current_unit->s, &length);
+
+	  if (p == NULL)
+	    {
+	      generate_error (&dtp->common, ERROR_OS, NULL);
+	      break;
+	    }
+
+	  if (length == 0)
+	    {
+	      dtp->u.p.current_unit->endfile = AT_ENDFILE;
+	      break;
+	    }
+
+	  if (is_stream_io (dtp))
+	    dtp->u.p.current_unit->strm_pos++;
+	}
+      while (*p != '\n');
+
+      break;
+    }
+
+  if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+    test_endfile (dtp->u.p.current_unit);
+}
+
+
+/* Small utility function to write a record marker, taking care of
+   byte swapping and of choosing the correct size.  */
+
+inline static int
+write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
+{
+  size_t len;
+  GFC_INTEGER_4 buf4;
+  GFC_INTEGER_8 buf8;
+  char p[sizeof (GFC_INTEGER_8)];
+
+  if (compile_options.record_marker == 0)
+    len = sizeof (GFC_INTEGER_4);
+  else
+    len = compile_options.record_marker;
+
+  /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
+  if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
+    {
+      switch (len)
+	{
+	case sizeof (GFC_INTEGER_4):
+	  buf4 = buf;
+	  return swrite (dtp->u.p.current_unit->s, &buf4, &len);
+	  break;
+
+	case sizeof (GFC_INTEGER_8):
+	  buf8 = buf;
+	  return swrite (dtp->u.p.current_unit->s, &buf8, &len);
+	  break;
+
+	default:
+	  runtime_error ("Illegal value for record marker");
+	  break;
+	}
+    }
+  else
+    {
+      switch (len)
+	{
+	case sizeof (GFC_INTEGER_4):
+	  buf4 = buf;
+	  reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
+	  return swrite (dtp->u.p.current_unit->s, p, &len);
+	  break;
+
+	case sizeof (GFC_INTEGER_8):
+	  buf8 = buf;
+	  reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
+	  return swrite (dtp->u.p.current_unit->s, p, &len);
+	  break;
+
+	default:
+	  runtime_error ("Illegal value for record marker");
+	  break;
+	}
+    }
+
+}
+
+/* Position to the next (sub)record in write mode for
+   unformatted sequential files.  */
+
+static void
+next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
+{
+  gfc_offset c, m, m_write;
+  size_t record_marker;
+
+  /* Bytes written.  */
+  m = dtp->u.p.current_unit->recl_subrecord
+    - dtp->u.p.current_unit->bytes_left_subrecord;
+  c = file_position (dtp->u.p.current_unit->s);
+
+  /* Write the length tail.  If we finish a record containing
+     subrecords, we write out the negative length.  */
+
+  if (dtp->u.p.current_unit->continued)
+    m_write = -m;
+  else
+    m_write = m;
+
+  if (write_us_marker (dtp, m_write) != 0)
+    goto io_error;
+
+  if (compile_options.record_marker == 0)
+    record_marker = sizeof (GFC_INTEGER_4);
+  else
+    record_marker = compile_options.record_marker;
+
+  /* Seek to the head and overwrite the bogus length with the real
+     length.  */
+
+  if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
+      == FAILURE)
+    goto io_error;
+
+  if (next_subrecord)
+    m_write = -m;
+  else
+    m_write = m;
+
+  if (write_us_marker (dtp, m_write) != 0)
+    goto io_error;
+
+  /* Seek past the end of the current record.  */
+
+  if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
+    goto io_error;
+
+  return;
+
+ io_error:
+  generate_error (&dtp->common, ERROR_OS, NULL);
+  return;
+
+}
+
+/* Position to the next record in write mode.  */
+
+static void
+next_record_w (st_parameter_dt *dtp, int done)
+{
+  gfc_offset m, record, max_pos;
+  int length;
+  char *p;
+
+  /* Zero counters for X- and T-editing.  */
+  max_pos = dtp->u.p.max_pos;
+  dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+
+  switch (current_mode (dtp))
+    {
+    /* No records in unformatted STREAM I/O.  */
+    case UNFORMATTED_STREAM:
+      return;
+
+    case FORMATTED_DIRECT:
+      if (dtp->u.p.current_unit->bytes_left == 0)
+	break;
+
+      if (sset (dtp->u.p.current_unit->s, ' ', 
+		dtp->u.p.current_unit->bytes_left) == FAILURE)
+	goto io_error;
+
+      break;
+
+    case UNFORMATTED_DIRECT:
+      if (sfree (dtp->u.p.current_unit->s) == FAILURE)
+	goto io_error;
+      break;
+
+    case UNFORMATTED_SEQUENTIAL:
+      next_record_w_unf (dtp, 0);
+      dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+      break;
+
+    case FORMATTED_STREAM:
+    case FORMATTED_SEQUENTIAL:
+
+      if (is_internal_unit (dtp))
+	{
+	  if (is_array_io (dtp))
+	    {
+	      length = (int) dtp->u.p.current_unit->bytes_left;
+	      
+	      /* If the farthest position reached is greater than current
+	      position, adjust the position and set length to pad out
+	      whats left.  Otherwise just pad whats left.
+	      (for character array unit) */
+	      m = dtp->u.p.current_unit->recl
+			- dtp->u.p.current_unit->bytes_left;
+	      if (max_pos > m)
+		{
+		  length = (int) (max_pos - m);
+		  p = salloc_w (dtp->u.p.current_unit->s, &length);
+		  length = (int) (dtp->u.p.current_unit->recl - max_pos);
+		}
+
+	      if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
+		{
+		  generate_error (&dtp->common, ERROR_END, NULL);
+		  return;
+		}
+
+	      /* Now that the current record has been padded out,
+		 determine where the next record in the array is. */
+	      record = next_array_record (dtp, dtp->u.p.current_unit->ls);
+	      if (record == 0)
+		dtp->u.p.current_unit->endfile = AT_ENDFILE;
+	      
+	      /* Now seek to this record */
+	      record = record * dtp->u.p.current_unit->recl;
+
+	      if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+		{
+		  generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
+		  return;
+		}
+
+	      dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+	    }
+	  else
+	    {
+	      length = 1;
+
+	      /* If this is the last call to next_record move to the farthest
+		 position reached and set length to pad out the remainder
+		 of the record. (for character scaler unit) */
+	      if (done)
+		{
+		  m = dtp->u.p.current_unit->recl
+			- dtp->u.p.current_unit->bytes_left;
+		  if (max_pos > m)
+		    {
+		      length = (int) (max_pos - m);
+		      p = salloc_w (dtp->u.p.current_unit->s, &length);
+		      length = (int) (dtp->u.p.current_unit->recl - max_pos);
+		    }
+		  else
+		    length = (int) dtp->u.p.current_unit->bytes_left;
+		}
+
+	      if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
+		{
+		  generate_error (&dtp->common, ERROR_END, NULL);
+		  return;
+		}
+	    }
+	}
+      else
+	{
+
+	  /* If this is the last call to next_record move to the farthest
+	  position reached in preparation for completing the record.
+	  (for file unit) */
+	  if (done)
+	    {
+	      m = dtp->u.p.current_unit->recl -
+			dtp->u.p.current_unit->bytes_left;
+	      if (max_pos > m)
+		{
+		  length = (int) (max_pos - m);
+		  p = salloc_w (dtp->u.p.current_unit->s, &length);
+		}
+ 	    }
+	  size_t len;
+	  const char crlf[] = "\r\n";
+#ifdef HAVE_CRLF
+	  len = 2;
+#else
+	  len = 1;
+#endif
+	  if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
+	    goto io_error;
+	  
+	  if (is_stream_io (dtp))
+	    dtp->u.p.current_unit->strm_pos += len;
+	}
+
+      break;
+
+    io_error:
+      generate_error (&dtp->common, ERROR_OS, NULL);
+      break;
+    }
+}
+
+/* Position to the next record, which means moving to the end of the
+   current record.  This can happen under several different
+   conditions.  If the done flag is not set, we get ready to process
+   the next record.  */
+
+void
+next_record (st_parameter_dt *dtp, int done)
+{
+  gfc_offset fp; /* File position.  */
+
+  dtp->u.p.current_unit->read_bad = 0;
+
+  if (dtp->u.p.mode == READING)
+    next_record_r (dtp);
+  else
+    next_record_w (dtp, done);
+
+  if (!is_stream_io (dtp))
+    {
+      /* keep position up to date for INQUIRE */
+      dtp->u.p.current_unit->flags.position = POSITION_ASIS;
+      dtp->u.p.current_unit->current_record = 0;
+      if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+	{
+	  fp = file_position (dtp->u.p.current_unit->s);
+	  /* Calculate next record, rounding up partial records.  */
+	  dtp->u.p.current_unit->last_record =
+	    (fp + dtp->u.p.current_unit->recl - 1) /
+	      dtp->u.p.current_unit->recl;
+	}
+      else
+	dtp->u.p.current_unit->last_record++;
+    }
+
+  if (!done)
+    pre_position (dtp);
+}
+
+
+/* Finalize the current data transfer.  For a nonadvancing transfer,
+   this means advancing to the next record.  For internal units close the
+   stream associated with the unit.  */
+
+static void
+finalize_transfer (st_parameter_dt *dtp)
+{
+  jmp_buf eof_jump;
+  GFC_INTEGER_4 cf = dtp->common.flags;
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    *dtp->size = (GFC_INTEGER_4) dtp->u.p.size_used;
+
+  if (dtp->u.p.eor_condition)
+    {
+      generate_error (&dtp->common, ERROR_EOR, NULL);
+      return;
+    }
+
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+
+  if ((dtp->u.p.ionml != NULL)
+      && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
+    {
+       if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
+	 namelist_read (dtp);
+       else
+	 namelist_write (dtp);
+    }
+
+  dtp->u.p.transfer = NULL;
+  if (dtp->u.p.current_unit == NULL)
+    return;
+
+  dtp->u.p.eof_jump = &eof_jump;
+  if (setjmp (eof_jump))
+    {
+      generate_error (&dtp->common, ERROR_END, NULL);
+      return;
+    }
+
+  if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
+    {
+      finish_list_read (dtp);
+      sfree (dtp->u.p.current_unit->s);
+      return;
+    }
+
+  if (is_stream_io (dtp))
+    {
+      if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
+	next_record (dtp, 1);
+      flush (dtp->u.p.current_unit->s);
+      sfree (dtp->u.p.current_unit->s);
+      return;
+    }
+
+  dtp->u.p.current_unit->current_record = 0;
+
+  if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
+    {
+      dtp->u.p.seen_dollar = 0;
+      sfree (dtp->u.p.current_unit->s);
+      return;
+    }
+
+  if (dtp->u.p.advance_status == ADVANCE_NO)
+    {
+      flush (dtp->u.p.current_unit->s);
+      return;
+    }
+
+  next_record (dtp, 1);
+  sfree (dtp->u.p.current_unit->s);
+}
+
+/* Transfer function for IOLENGTH. It doesn't actually do any
+   data transfer, it just updates the length counter.  */
+
+static void
+iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), 
+		   void *dest __attribute__ ((unused)),
+		   int kind __attribute__((unused)), 
+		   size_t size, size_t nelems)
+{
+  if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
+    *dtp->iolength += (GFC_INTEGER_4) size * nelems;
+}
+
+
+/* Initialize the IOLENGTH data transfer. This function is in essence
+   a very much simplified version of data_transfer_init(), because it
+   doesn't have to deal with units at all.  */
+
+static void
+iolength_transfer_init (st_parameter_dt *dtp)
+{
+  if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
+    *dtp->iolength = 0;
+
+  memset (&dtp->u.p, 0, sizeof (dtp->u.p));
+
+  /* Set up the subroutine that will handle the transfers.  */
+
+  dtp->u.p.transfer = iolength_transfer;
+}
+
+
+/* Library entry point for the IOLENGTH form of the INQUIRE
+   statement. The IOLENGTH form requires no I/O to be performed, but
+   it must still be a runtime library call so that we can determine
+   the iolength for dynamic arrays and such.  */
+
+extern void st_iolength (st_parameter_dt *);
+export_proto(st_iolength);
+
+void
+st_iolength (st_parameter_dt *dtp)
+{
+  library_start (&dtp->common);
+  iolength_transfer_init (dtp);
+}
+
+extern void st_iolength_done (st_parameter_dt *);
+export_proto(st_iolength_done);
+
+void
+st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
+{
+  free_ionml (dtp);
+  if (dtp->u.p.scratch != NULL)
+    free_mem (dtp->u.p.scratch);
+  library_end ();
+}
+
+
+/* The READ statement.  */
+
+extern void st_read (st_parameter_dt *);
+export_proto(st_read);
+
+void
+st_read (st_parameter_dt *dtp)
+{
+  library_start (&dtp->common);
+
+  data_transfer_init (dtp, 1);
+
+  /* Handle complications dealing with the endfile record.  It is
+     significant that this is the only place where ERROR_END is
+     generated.  Reading an end of file elsewhere is either end of
+     record or an I/O error. */
+
+  if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+    switch (dtp->u.p.current_unit->endfile)
+      {
+      case NO_ENDFILE:
+	break;
+
+      case AT_ENDFILE:
+	if (!is_internal_unit (dtp))
+	  {
+	    generate_error (&dtp->common, ERROR_END, NULL);
+	    dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
+	    dtp->u.p.current_unit->current_record = 0;
+	  }
+	break;
+
+      case AFTER_ENDFILE:
+	generate_error (&dtp->common, ERROR_ENDFILE, NULL);
+	dtp->u.p.current_unit->current_record = 0;
+	break;
+      }
+}
+
+extern void st_read_done (st_parameter_dt *);
+export_proto(st_read_done);
+
+void
+st_read_done (st_parameter_dt *dtp)
+{
+  finalize_transfer (dtp);
+  free_format_data (dtp);
+  free_ionml (dtp);
+  if (dtp->u.p.scratch != NULL)
+    free_mem (dtp->u.p.scratch);
+  if (dtp->u.p.current_unit != NULL)
+    unlock_unit (dtp->u.p.current_unit);
+
+  free_internal_unit (dtp);
+  
+  library_end ();
+}
+
+extern void st_write (st_parameter_dt *);
+export_proto(st_write);
+
+void
+st_write (st_parameter_dt *dtp)
+{
+  library_start (&dtp->common);
+  data_transfer_init (dtp, 0);
+}
+
+extern void st_write_done (st_parameter_dt *);
+export_proto(st_write_done);
+
+void
+st_write_done (st_parameter_dt *dtp)
+{
+  finalize_transfer (dtp);
+
+  /* Deal with endfile conditions associated with sequential files.  */
+
+  if (dtp->u.p.current_unit != NULL 
+      && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+    switch (dtp->u.p.current_unit->endfile)
+      {
+      case AT_ENDFILE:		/* Remain at the endfile record.  */
+	break;
+
+      case AFTER_ENDFILE:
+	dtp->u.p.current_unit->endfile = AT_ENDFILE;	/* Just at it now.  */
+	break;
+
+      case NO_ENDFILE:
+	/* Get rid of whatever is after this record.  */
+        if (!is_internal_unit (dtp))
+	  {
+	    flush (dtp->u.p.current_unit->s);
+	    if (struncate (dtp->u.p.current_unit->s) == FAILURE)
+	      generate_error (&dtp->common, ERROR_OS, NULL);
+	  }
+	dtp->u.p.current_unit->endfile = AT_ENDFILE;
+	break;
+      }
+
+  free_format_data (dtp);
+  free_ionml (dtp);
+  if (dtp->u.p.scratch != NULL)
+    free_mem (dtp->u.p.scratch);
+  if (dtp->u.p.current_unit != NULL)
+    unlock_unit (dtp->u.p.current_unit);
+  
+  free_internal_unit (dtp);
+
+  library_end ();
+}
+
+/* Receives the scalar information for namelist objects and stores it
+   in a linked list of namelist_info types.  */
+
+extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
+			    GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
+export_proto(st_set_nml_var);
+
+
+void
+st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
+		GFC_INTEGER_4 len, gfc_charlen_type string_length,
+		GFC_INTEGER_4 dtype)
+{
+  namelist_info *t1 = NULL;
+  namelist_info *nml;
+
+  nml = (namelist_info*) get_mem (sizeof (namelist_info));
+
+  nml->mem_pos = var_addr;
+
+  nml->var_name = (char*) get_mem (strlen (var_name) + 1);
+  strcpy (nml->var_name, var_name);
+
+  nml->len = (int) len;
+  nml->string_length = (index_type) string_length;
+
+  nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
+  nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
+  nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
+
+  if (nml->var_rank > 0)
+    {
+      nml->dim = (descriptor_dimension*)
+		   get_mem (nml->var_rank * sizeof (descriptor_dimension));
+      nml->ls = (array_loop_spec*)
+		  get_mem (nml->var_rank * sizeof (array_loop_spec));
+    }
+  else
+    {
+      nml->dim = NULL;
+      nml->ls = NULL;
+    }
+
+  nml->next = NULL;
+
+  if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
+    {
+      dtp->common.flags |= IOPARM_DT_IONML_SET;
+      dtp->u.p.ionml = nml;
+    }
+  else
+    {
+      for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
+      t1->next = nml;
+    }
+}
+
+/* Store the dimensional information for the namelist object.  */
+extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
+				GFC_INTEGER_4, GFC_INTEGER_4,
+				GFC_INTEGER_4);
+export_proto(st_set_nml_var_dim);
+
+void
+st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
+		    GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
+		    GFC_INTEGER_4 ubound)
+{
+  namelist_info * nml;
+  int n;
+
+  n = (int)n_dim;
+
+  for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
+
+  nml->dim[n].stride = (ssize_t)stride;
+  nml->dim[n].lbound = (ssize_t)lbound;
+  nml->dim[n].ubound = (ssize_t)ubound;
+}
+
+/* Reverse memcpy - used for byte swapping.  */
+
+void reverse_memcpy (void *dest, const void *src, size_t n)
+{
+  char *d, *s;
+  size_t i;
+
+  d = (char *) dest;
+  s = (char *) src + n - 1;
+
+  /* Write with ascending order - this is likely faster
+     on modern architectures because of write combining.  */
+  for (i=0; i<n; i++)
+      *(d++) = *(s--);
+}
diff --git a/gcc-4.2.1/libgfortran/io/unit.c b/gcc-4.2.1/libgfortran/io/unit.c
new file mode 100644
index 000000000..90e6d85f6
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/unit.c
@@ -0,0 +1,656 @@
+/* Copyright (C) 2002, 2003, 2005 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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+#include "config.h"
+#include <stdlib.h>
+#include <string.h>
+#include "libgfortran.h"
+#include "io.h"
+
+
+/* IO locking rules:
+   UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
+   Concurrent use of different units should be supported, so
+   each unit has its own lock, LOCK.
+   Open should be atomic with its reopening of units and list_read.c
+   in several places needs find_unit another unit while holding stdin
+   unit's lock, so it must be possible to acquire UNIT_LOCK while holding
+   some unit's lock.  Therefore to avoid deadlocks, it is forbidden
+   to acquire unit's private locks while holding UNIT_LOCK, except
+   for freshly created units (where no other thread can get at their
+   address yet) or when using just trylock rather than lock operation.
+   In addition to unit's private lock each unit has a WAITERS counter
+   and CLOSED flag.  WAITERS counter must be either only
+   atomically incremented/decremented in all places (if atomic builtins
+   are supported), or protected by UNIT_LOCK in all places (otherwise).
+   CLOSED flag must be always protected by unit's LOCK.
+   After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
+   WAITERS must be incremented to avoid concurrent close from freeing
+   the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
+   Unit freeing is always done under UNIT_LOCK.  If close_unit sees any
+   WAITERS, it doesn't free the unit but instead sets the CLOSED flag
+   and the thread that decrements WAITERS to zero while CLOSED flag is
+   set is responsible for freeing it (while holding UNIT_LOCK).
+   flush_all_units operation is iterating over the unit tree with
+   increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
+   flush each unit (and therefore needs the unit's LOCK held as well).
+   To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
+   remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
+   unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
+   the smallest UNIT_NUMBER above the last one flushed.
+
+   If find_unit/find_or_create_unit/find_file/get_unit routines return
+   non-NULL, the returned unit has its private lock locked and when the
+   caller is done with it, it must call either unlock_unit or close_unit
+   on it.  unlock_unit or close_unit must be always called only with the
+   private lock held.  */
+
+/* Subroutines related to units */
+
+
+#define CACHE_SIZE 3
+static gfc_unit *unit_cache[CACHE_SIZE];
+gfc_offset max_offset;
+gfc_unit *unit_root;
+#ifdef __GTHREAD_MUTEX_INIT
+__gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
+#else
+__gthread_mutex_t unit_lock;
+#endif
+
+/* This implementation is based on Stefan Nilsson's article in the
+ * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
+
+/* pseudo_random()-- Simple linear congruential pseudorandom number
+ * generator.  The period of this generator is 44071, which is plenty
+ * for our purposes.  */
+
+static int
+pseudo_random (void)
+{
+  static int x0 = 5341;
+
+  x0 = (22611 * x0 + 10) % 44071;
+  return x0;
+}
+
+
+/* rotate_left()-- Rotate the treap left */
+
+static gfc_unit *
+rotate_left (gfc_unit * t)
+{
+  gfc_unit *temp;
+
+  temp = t->right;
+  t->right = t->right->left;
+  temp->left = t;
+
+  return temp;
+}
+
+
+/* rotate_right()-- Rotate the treap right */
+
+static gfc_unit *
+rotate_right (gfc_unit * t)
+{
+  gfc_unit *temp;
+
+  temp = t->left;
+  t->left = t->left->right;
+  temp->right = t;
+
+  return temp;
+}
+
+
+
+static int
+compare (int a, int b)
+{
+  if (a < b)
+    return -1;
+  if (a > b)
+    return 1;
+
+  return 0;
+}
+
+
+/* insert()-- Recursive insertion function.  Returns the updated treap. */
+
+static gfc_unit *
+insert (gfc_unit *new, gfc_unit *t)
+{
+  int c;
+
+  if (t == NULL)
+    return new;
+
+  c = compare (new->unit_number, t->unit_number);
+
+  if (c < 0)
+    {
+      t->left = insert (new, t->left);
+      if (t->priority < t->left->priority)
+	t = rotate_right (t);
+    }
+
+  if (c > 0)
+    {
+      t->right = insert (new, t->right);
+      if (t->priority < t->right->priority)
+	t = rotate_left (t);
+    }
+
+  if (c == 0)
+    internal_error (NULL, "insert(): Duplicate key found!");
+
+  return t;
+}
+
+
+/* insert_unit()-- Create a new node, insert it into the treap.  */
+
+static gfc_unit *
+insert_unit (int n)
+{
+  gfc_unit *u = get_mem (sizeof (gfc_unit));
+  memset (u, '\0', sizeof (gfc_unit));
+  u->unit_number = n;
+#ifdef __GTHREAD_MUTEX_INIT
+  {
+    __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
+    u->lock = tmp;
+  }
+#else
+  __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
+#endif
+  __gthread_mutex_lock (&u->lock);
+  u->priority = pseudo_random ();
+  unit_root = insert (u, unit_root);
+  return u;
+}
+
+
+static gfc_unit *
+delete_root (gfc_unit * t)
+{
+  gfc_unit *temp;
+
+  if (t->left == NULL)
+    return t->right;
+  if (t->right == NULL)
+    return t->left;
+
+  if (t->left->priority > t->right->priority)
+    {
+      temp = rotate_right (t);
+      temp->right = delete_root (t);
+    }
+  else
+    {
+      temp = rotate_left (t);
+      temp->left = delete_root (t);
+    }
+
+  return temp;
+}
+
+
+/* delete_treap()-- Delete an element from a tree.  The 'old' value
+ * does not necessarily have to point to the element to be deleted, it
+ * must just point to a treap structure with the key to be deleted.
+ * Returns the new root node of the tree. */
+
+static gfc_unit *
+delete_treap (gfc_unit * old, gfc_unit * t)
+{
+  int c;
+
+  if (t == NULL)
+    return NULL;
+
+  c = compare (old->unit_number, t->unit_number);
+
+  if (c < 0)
+    t->left = delete_treap (old, t->left);
+  if (c > 0)
+    t->right = delete_treap (old, t->right);
+  if (c == 0)
+    t = delete_root (t);
+
+  return t;
+}
+
+
+/* delete_unit()-- Delete a unit from a tree */
+
+static void
+delete_unit (gfc_unit * old)
+{
+  unit_root = delete_treap (old, unit_root);
+}
+
+
+/* get_external_unit()-- Given an integer, return a pointer to the unit
+ * structure.  Returns NULL if the unit does not exist,
+ * otherwise returns a locked unit. */
+
+static gfc_unit *
+get_external_unit (int n, int do_create)
+{
+  gfc_unit *p;
+  int c, created = 0;
+
+  __gthread_mutex_lock (&unit_lock);
+retry:
+  for (c = 0; c < CACHE_SIZE; c++)
+    if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
+      {
+	p = unit_cache[c];
+	goto found;
+      }
+
+  p = unit_root;
+  while (p != NULL)
+    {
+      c = compare (n, p->unit_number);
+      if (c < 0)
+	p = p->left;
+      if (c > 0)
+	p = p->right;
+      if (c == 0)
+	break;
+    }
+
+  if (p == NULL && do_create)
+    {
+      p = insert_unit (n);
+      created = 1;
+    }
+
+  if (p != NULL)
+    {
+      for (c = 0; c < CACHE_SIZE - 1; c++)
+	unit_cache[c] = unit_cache[c + 1];
+
+      unit_cache[CACHE_SIZE - 1] = p;
+    }
+
+  if (created)
+    {
+      /* Newly created units have their lock held already
+	 from insert_unit.  Just unlock UNIT_LOCK and return.  */
+      __gthread_mutex_unlock (&unit_lock);
+      return p;
+    }
+
+found:
+  if (p != NULL)
+    {
+      /* Fast path.  */
+      if (! __gthread_mutex_trylock (&p->lock))
+	{
+	  /* assert (p->closed == 0); */
+	  __gthread_mutex_unlock (&unit_lock);
+	  return p;
+	}
+
+      inc_waiting_locked (p);
+    }
+
+  __gthread_mutex_unlock (&unit_lock);
+
+  if (p != NULL)
+    {
+      __gthread_mutex_lock (&p->lock);
+      if (p->closed)
+	{
+	  __gthread_mutex_lock (&unit_lock);
+	  __gthread_mutex_unlock (&p->lock);
+	  if (predec_waiting_locked (p) == 0)
+	    free_mem (p);
+	  goto retry;
+	}
+
+      dec_waiting_unlocked (p);
+    }
+  return p;
+}
+
+
+gfc_unit *
+find_unit (int n)
+{
+  return get_external_unit (n, 0);
+}
+
+
+gfc_unit *
+find_or_create_unit (int n)
+{
+  return get_external_unit (n, 1);
+}
+
+
+gfc_unit *
+get_internal_unit (st_parameter_dt *dtp)
+{
+  gfc_unit * iunit;
+
+  /* Allocate memory for a unit structure.  */
+
+  iunit = get_mem (sizeof (gfc_unit));
+  if (iunit == NULL)
+    {
+      generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
+      return NULL;
+    }
+
+  memset (iunit, '\0', sizeof (gfc_unit));
+#ifdef __GTHREAD_MUTEX_INIT
+  {
+    __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
+    iunit->lock = tmp;
+  }
+#else
+  __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock);
+#endif
+  __gthread_mutex_lock (&iunit->lock);
+
+  iunit->recl = dtp->internal_unit_len;
+  
+  /* For internal units we set the unit number to -1.
+     Otherwise internal units can be mistaken for a pre-connected unit or
+     some other file I/O unit.  */
+  iunit->unit_number = -1;
+
+  /* Set up the looping specification from the array descriptor, if any.  */
+
+  if (is_array_io (dtp))
+    {
+      iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
+      iunit->ls = (array_loop_spec *)
+	get_mem (iunit->rank * sizeof (array_loop_spec));
+      dtp->internal_unit_len *=
+	init_loop_spec (dtp->internal_unit_desc, iunit->ls);
+    }
+
+  /* Set initial values for unit parameters.  */
+
+  iunit->s = open_internal (dtp->internal_unit, dtp->internal_unit_len);
+  iunit->bytes_left = iunit->recl;
+  iunit->last_record=0;
+  iunit->maxrec=0;
+  iunit->current_record=0;
+  iunit->read_bad = 0;
+
+  /* Set flags for the internal unit.  */
+
+  iunit->flags.access = ACCESS_SEQUENTIAL;
+  iunit->flags.action = ACTION_READWRITE;
+  iunit->flags.form = FORM_FORMATTED;
+  iunit->flags.pad = PAD_YES;
+  iunit->flags.status = STATUS_UNSPECIFIED;
+  iunit->endfile = NO_ENDFILE;
+
+  /* Initialize the data transfer parameters.  */
+
+  dtp->u.p.advance_status = ADVANCE_YES;
+  dtp->u.p.blank_status = BLANK_UNSPECIFIED;
+  dtp->u.p.seen_dollar = 0;
+  dtp->u.p.skips = 0;
+  dtp->u.p.pending_spaces = 0;
+  dtp->u.p.max_pos = 0;
+  dtp->u.p.at_eof = 0;
+
+  /* This flag tells us the unit is assigned to internal I/O.  */
+  
+  dtp->u.p.unit_is_internal = 1;
+
+  return iunit;
+}
+
+
+/* free_internal_unit()-- Free memory allocated for internal units if any.  */
+void
+free_internal_unit (st_parameter_dt *dtp)
+{
+  if (!is_internal_unit (dtp))
+    return;
+
+  if (dtp->u.p.current_unit->ls != NULL)
+      free_mem (dtp->u.p.current_unit->ls);
+  
+  sclose (dtp->u.p.current_unit->s);
+
+  if (dtp->u.p.current_unit != NULL)
+    free_mem (dtp->u.p.current_unit);
+}
+
+
+/* get_unit()-- Returns the unit structure associated with the integer
+ * unit or the internal file. */
+
+gfc_unit *
+get_unit (st_parameter_dt *dtp, int do_create)
+{
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
+    return get_internal_unit(dtp);
+
+  /* Has to be an external unit */
+
+  dtp->u.p.unit_is_internal = 0;
+  dtp->internal_unit_desc = NULL;
+
+  return get_external_unit (dtp->common.unit, do_create);
+}
+
+
+/* is_internal_unit()-- Determine if the current unit is internal or not */
+
+int
+is_internal_unit (st_parameter_dt *dtp)
+{
+  return dtp->u.p.unit_is_internal;
+}
+
+
+/* is_array_io ()-- Determine if the I/O is to/from an array */
+
+int
+is_array_io (st_parameter_dt *dtp)
+{
+  return dtp->internal_unit_desc != NULL;
+}
+
+
+/* is_stream_io () -- Determine if I/O is access="stream" mode */
+
+int
+is_stream_io (st_parameter_dt *dtp)
+{
+  return dtp->u.p.current_unit->flags.access == ACCESS_STREAM;
+}
+
+
+/*************************/
+/* Initialize everything */
+
+void
+init_units (void)
+{
+  gfc_unit *u;
+  unsigned int i;
+
+#ifndef __GTHREAD_MUTEX_INIT
+  __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
+#endif
+
+  if (options.stdin_unit >= 0)
+    {				/* STDIN */
+      u = insert_unit (options.stdin_unit);
+      u->s = input_stream ();
+
+      u->flags.action = ACTION_READ;
+
+      u->flags.access = ACCESS_SEQUENTIAL;
+      u->flags.form = FORM_FORMATTED;
+      u->flags.status = STATUS_OLD;
+      u->flags.blank = BLANK_NULL;
+      u->flags.pad = PAD_YES;
+      u->flags.position = POSITION_ASIS;
+
+      u->recl = options.default_recl;
+      u->endfile = NO_ENDFILE;
+
+      __gthread_mutex_unlock (&u->lock);
+    }
+
+  if (options.stdout_unit >= 0)
+    {				/* STDOUT */
+      u = insert_unit (options.stdout_unit);
+      u->s = output_stream ();
+
+      u->flags.action = ACTION_WRITE;
+
+      u->flags.access = ACCESS_SEQUENTIAL;
+      u->flags.form = FORM_FORMATTED;
+      u->flags.status = STATUS_OLD;
+      u->flags.blank = BLANK_NULL;
+      u->flags.position = POSITION_ASIS;
+
+      u->recl = options.default_recl;
+      u->endfile = AT_ENDFILE;
+
+      __gthread_mutex_unlock (&u->lock);
+    }
+
+  if (options.stderr_unit >= 0)
+    {				/* STDERR */
+      u = insert_unit (options.stderr_unit);
+      u->s = error_stream ();
+
+      u->flags.action = ACTION_WRITE;
+
+      u->flags.access = ACCESS_SEQUENTIAL;
+      u->flags.form = FORM_FORMATTED;
+      u->flags.status = STATUS_OLD;
+      u->flags.blank = BLANK_NULL;
+      u->flags.position = POSITION_ASIS;
+
+      u->recl = options.default_recl;
+      u->endfile = AT_ENDFILE;
+
+      __gthread_mutex_unlock (&u->lock);
+    }
+
+  /* Calculate the maximum file offset in a portable manner.
+   * max will be the largest signed number for the type gfc_offset.
+   *
+   * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
+
+  max_offset = 0;
+  for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
+    max_offset = max_offset + ((gfc_offset) 1 << i);
+}
+
+
+static int
+close_unit_1 (gfc_unit *u, int locked)
+{
+  int i, rc;
+
+  rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
+
+  u->closed = 1;
+  if (!locked)
+    __gthread_mutex_lock (&unit_lock);
+
+  for (i = 0; i < CACHE_SIZE; i++)
+    if (unit_cache[i] == u)
+      unit_cache[i] = NULL;
+
+  delete_unit (u);
+
+  if (u->file)
+    free_mem (u->file);
+  u->file = NULL;
+  u->file_len = 0;
+
+  if (!locked)
+    __gthread_mutex_unlock (&u->lock);
+
+  /* If there are any threads waiting in find_unit for this unit,
+     avoid freeing the memory, the last such thread will free it
+     instead.  */
+  if (u->waiting == 0)
+    free_mem (u);
+
+  if (!locked)
+    __gthread_mutex_unlock (&unit_lock);
+
+  return rc;
+}
+
+void
+unlock_unit (gfc_unit *u)
+{
+  __gthread_mutex_unlock (&u->lock);
+}
+
+/* close_unit()-- Close a unit.  The stream is closed, and any memory
+ * associated with the stream is freed.  Returns nonzero on I/O error.
+ * Should be called with the u->lock locked. */
+
+int
+close_unit (gfc_unit *u)
+{
+  return close_unit_1 (u, 0);
+}
+
+
+/* close_units()-- Delete units on completion.  We just keep deleting
+ * the root of the treap until there is nothing left.
+ * Not sure what to do with locking here.  Some other thread might be
+ * holding some unit's lock and perhaps hold it indefinitely
+ * (e.g. waiting for input from some pipe) and close_units shouldn't
+ * delay the program too much.  */
+
+void
+close_units (void)
+{
+  __gthread_mutex_lock (&unit_lock);
+  while (unit_root != NULL)
+    close_unit_1 (unit_root, 1);
+  __gthread_mutex_unlock (&unit_lock);
+}
diff --git a/gcc-4.2.1/libgfortran/io/unix.c b/gcc-4.2.1/libgfortran/io/unix.c
new file mode 100644
index 000000000..34d196fec
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/unix.c
@@ -0,0 +1,1831 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2007
+   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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+/* Unix stream I/O module */
+
+#include "config.h"
+#include <stdlib.h>
+#include <limits.h>
+
+#include <unistd.h>
+#include <stdio.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <assert.h>
+
+#include <string.h>
+#include <errno.h>
+
+#include "libgfortran.h"
+#include "io.h"
+#include "unix.h"
+
+#ifndef SSIZE_MAX
+#define SSIZE_MAX SHRT_MAX
+#endif
+
+#ifndef PATH_MAX
+#define PATH_MAX 1024
+#endif
+
+#ifndef PROT_READ
+#define PROT_READ 1
+#endif
+
+#ifndef PROT_WRITE
+#define PROT_WRITE 2
+#endif
+
+/* These flags aren't defined on all targets (mingw32), so provide them
+   here.  */
+#ifndef S_IRGRP
+#define S_IRGRP 0
+#endif
+
+#ifndef S_IWGRP
+#define S_IWGRP 0
+#endif
+
+#ifndef S_IROTH
+#define S_IROTH 0
+#endif
+
+#ifndef S_IWOTH
+#define S_IWOTH 0
+#endif
+
+/* This implementation of stream I/O is based on the paper:
+ *
+ *  "Exploiting the advantages of mapped files for stream I/O",
+ *  O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
+ *  USENIX conference", p. 27-42.
+ *
+ * It differs in a number of ways from the version described in the
+ * paper.  First of all, threads are not an issue during I/O and we
+ * also don't have to worry about having multiple regions, since
+ * fortran's I/O model only allows you to be one place at a time.
+ *
+ * On the other hand, we have to be able to writing at the end of a
+ * stream, read from the start of a stream or read and write blocks of
+ * bytes from an arbitrary position.  After opening a file, a pointer
+ * to a stream structure is returned, which is used to handle file
+ * accesses until the file is closed.
+ *
+ * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
+ * pointer to a block of memory that mirror the file at position
+ * 'where' that is 'len' bytes long.  The len integer is updated to
+ * reflect how many bytes were actually read.  The only reason for a
+ * short read is end of file.  The file pointer is updated.  The
+ * pointer is valid until the next call to salloc_*.
+ *
+ * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
+ * a pointer to a block of memory that is updated to reflect the state
+ * of the file.  The length of the buffer is always equal to that
+ * requested.  The buffer must be completely set by the caller.  When
+ * data has been written, the sfree() function must be called to
+ * indicate that the caller is done writing data to the buffer.  This
+ * may or may not cause a physical write.
+ *
+ * Short forms of these are salloc_r() and salloc_w() which drop the
+ * 'where' parameter and use the current file pointer. */
+
+
+/*move_pos_offset()--  Move the record pointer right or left
+ *relative to current position */
+
+int
+move_pos_offset (stream* st, int pos_off)
+{
+  unix_stream * str = (unix_stream*)st;
+  if (pos_off < 0)
+    {
+      str->logical_offset += pos_off;
+
+      if (str->dirty_offset + str->ndirty > str->logical_offset)
+        {
+          if (str->ndirty + pos_off > 0)
+            str->ndirty += pos_off;
+          else
+            {
+              str->dirty_offset +=  pos_off + pos_off;
+              str->ndirty = 0;
+            }
+        }
+
+    return pos_off;
+  }
+  return 0;
+}
+
+
+/* fix_fd()-- Given a file descriptor, make sure it is not one of the
+ * standard descriptors, returning a non-standard descriptor.  If the
+ * user specifies that system errors should go to standard output,
+ * then closes standard output, we don't want the system errors to a
+ * file that has been given file descriptor 1 or 0.  We want to send
+ * the error to the invalid descriptor. */
+
+static int
+fix_fd (int fd)
+{
+  int input, output, error;
+
+  input = output = error = 0;
+
+  /* Unix allocates the lowest descriptors first, so a loop is not
+     required, but this order is. */
+
+  if (fd == STDIN_FILENO)
+    {
+      fd = dup (fd);
+      input = 1;
+    }
+  if (fd == STDOUT_FILENO)
+    {
+      fd = dup (fd);
+      output = 1;
+    }
+  if (fd == STDERR_FILENO)
+    {
+      fd = dup (fd);
+      error = 1;
+    }
+
+  if (input)
+    close (STDIN_FILENO);
+  if (output)
+    close (STDOUT_FILENO);
+  if (error)
+    close (STDERR_FILENO);
+
+  return fd;
+}
+
+int
+is_preconnected (stream * s)
+{
+  int fd;
+
+  fd = ((unix_stream *) s)->fd;
+  if (fd == STDIN_FILENO || fd == STDOUT_FILENO || fd == STDERR_FILENO)
+    return 1;
+  else
+    return 0;
+}
+
+/* If the stream corresponds to a preconnected unit, we flush the
+   corresponding C stream.  This is bugware for mixed C-Fortran codes
+   where the C code doesn't flush I/O before returning.  */
+void
+flush_if_preconnected (stream * s)
+{
+  int fd;
+
+  fd = ((unix_stream *) s)->fd;
+  if (fd == STDIN_FILENO)
+    fflush (stdin);
+  else if (fd == STDOUT_FILENO)
+    fflush (stdout);
+  else if (fd == STDERR_FILENO)
+    fflush (stderr);
+}
+
+
+/* Reset a stream after reading/writing. Assumes that the buffers have
+   been flushed.  */
+
+inline static void
+reset_stream (unix_stream * s, size_t bytes_rw)
+{
+  s->physical_offset += bytes_rw;
+  s->logical_offset = s->physical_offset;
+  if (s->file_length != -1 && s->physical_offset > s->file_length)
+    s->file_length = s->physical_offset;
+}
+
+
+/* Read bytes into a buffer, allowing for short reads.  If the nbytes
+ * argument is less on return than on entry, it is because we've hit
+ * the end of file. */
+
+static int
+do_read (unix_stream * s, void * buf, size_t * nbytes)
+{
+  ssize_t trans;
+  size_t bytes_left;
+  char *buf_st;
+  int status;
+
+  status = 0;
+  bytes_left = *nbytes;
+  buf_st = (char *) buf;
+
+  /* We must read in a loop since some systems don't restart system
+     calls in case of a signal.  */
+  while (bytes_left > 0)
+    {
+      /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
+	 so we must read in chunks smaller than SSIZE_MAX.  */
+      trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
+      trans = read (s->fd, buf_st, trans);
+      if (trans < 0)
+	{
+	  if (errno == EINTR)
+	    continue;
+	  else
+	    {
+	      status = errno;
+	      break;
+	    }
+	}
+      else if (trans == 0) /* We hit EOF.  */
+	break;
+      buf_st += trans;
+      bytes_left -= trans;
+    }
+
+  *nbytes -= bytes_left;
+  return status;
+}
+
+
+/* Write a buffer to a stream, allowing for short writes.  */
+
+static int
+do_write (unix_stream * s, const void * buf, size_t * nbytes)
+{
+  ssize_t trans;
+  size_t bytes_left;
+  char *buf_st;
+  int status;
+
+  status = 0;
+  bytes_left = *nbytes;
+  buf_st = (char *) buf;
+
+  /* We must write in a loop since some systems don't restart system
+     calls in case of a signal.  */
+  while (bytes_left > 0)
+    {
+      /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
+	 so we must write in chunks smaller than SSIZE_MAX.  */
+      trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
+      trans = write (s->fd, buf_st, trans);
+      if (trans < 0)
+	{
+	  if (errno == EINTR)
+	    continue;
+	  else
+	    {
+	      status = errno;
+	      break;
+	    }
+	}
+      buf_st += trans;
+      bytes_left -= trans;
+    }
+
+  *nbytes -= bytes_left;
+  return status;
+}
+
+
+/* get_oserror()-- Get the most recent operating system error.  For
+ * unix, this is errno. */
+
+const char *
+get_oserror (void)
+{
+  return strerror (errno);
+}
+
+
+/* sys_exit()-- Terminate the program with an exit code */
+
+void
+sys_exit (int code)
+{
+  exit (code);
+}
+
+
+/*********************************************************************
+    File descriptor stream functions
+*********************************************************************/
+
+
+/* fd_flush()-- Write bytes that need to be written */
+
+static try
+fd_flush (unix_stream * s)
+{
+  size_t writelen;
+
+  if (s->ndirty == 0)
+    return SUCCESS;
+  
+  if (s->file_length != -1 && s->physical_offset != s->dirty_offset &&
+      lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
+    return FAILURE;
+
+  writelen = s->ndirty;
+  if (do_write (s, s->buffer + (s->dirty_offset - s->buffer_offset),
+		&writelen) != 0)
+    return FAILURE;
+
+  s->physical_offset = s->dirty_offset + writelen;
+
+  /* don't increment file_length if the file is non-seekable */
+  if (s->file_length != -1 && s->physical_offset > s->file_length)
+      s->file_length = s->physical_offset; 
+
+  s->ndirty -= writelen;
+  if (s->ndirty != 0)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+/* fd_alloc()-- Arrange a buffer such that the salloc() request can be
+ * satisfied.  This subroutine gets the buffer ready for whatever is
+ * to come next. */
+
+static void
+fd_alloc (unix_stream * s, gfc_offset where,
+	  int *len __attribute__ ((unused)))
+{
+  char *new_buffer;
+  int n, read_len;
+
+  if (*len <= BUFFER_SIZE)
+    {
+      new_buffer = s->small_buffer;
+      read_len = BUFFER_SIZE;
+    }
+  else
+    {
+      new_buffer = get_mem (*len);
+      read_len = *len;
+    }
+
+  /* Salvage bytes currently within the buffer.  This is important for
+   * devices that cannot seek. */
+
+  if (s->buffer != NULL && s->buffer_offset <= where &&
+      where <= s->buffer_offset + s->active)
+    {
+
+      n = s->active - (where - s->buffer_offset);
+      memmove (new_buffer, s->buffer + (where - s->buffer_offset), n);
+
+      s->active = n;
+    }
+  else
+    {				/* new buffer starts off empty */
+      s->active = 0;
+    }
+
+  s->buffer_offset = where;
+
+  /* free the old buffer if necessary */
+
+  if (s->buffer != NULL && s->buffer != s->small_buffer)
+    free_mem (s->buffer);
+
+  s->buffer = new_buffer;
+  s->len = read_len;
+}
+
+
+/* fd_alloc_r_at()-- Allocate a stream buffer for reading.  Either
+ * we've already buffered the data or we need to load it.  Returns
+ * NULL on I/O error. */
+
+static char *
+fd_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
+{
+  gfc_offset m;
+
+  if (where == -1)
+    where = s->logical_offset;
+
+  if (s->buffer != NULL && s->buffer_offset <= where &&
+      where + *len <= s->buffer_offset + s->active)
+    {
+
+      /* Return a position within the current buffer */
+
+      s->logical_offset = where + *len;
+      return s->buffer + where - s->buffer_offset;
+    }
+
+  fd_alloc (s, where, len);
+
+  m = where + s->active;
+
+  if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
+    return NULL;
+
+  /* do_read() hangs on read from terminals for *BSD-systems.  Only
+     use read() in that case.  */
+
+  if (s->special_file)
+    {
+      ssize_t n;
+
+      n = read (s->fd, s->buffer + s->active, s->len - s->active);
+      if (n < 0)
+	return NULL;
+
+      s->physical_offset = m + n;
+      s->active += n;
+    }
+  else
+    {
+      size_t n;
+
+      n = s->len - s->active;
+      if (do_read (s, s->buffer + s->active, &n) != 0)
+	return NULL;
+
+      s->physical_offset = m + n;
+      s->active += n;
+    }
+
+  if (s->active < *len)
+    *len = s->active;		/* Bytes actually available */
+
+  s->logical_offset = where + *len;
+
+  return s->buffer;
+}
+
+
+/* fd_alloc_w_at()-- Allocate a stream buffer for writing.  Either
+ * we've already buffered the data or we need to load it. */
+
+static char *
+fd_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
+{
+  gfc_offset n;
+
+  if (where == -1)
+    where = s->logical_offset;
+
+  if (s->buffer == NULL || s->buffer_offset > where ||
+      where + *len > s->buffer_offset + s->len)
+    {
+
+      if (fd_flush (s) == FAILURE)
+	return NULL;
+      fd_alloc (s, where, len);
+    }
+
+  /* Return a position within the current buffer */
+  if (s->ndirty == 0 
+      || where > s->dirty_offset + s->ndirty    
+      || s->dirty_offset > where + *len)
+    {  /* Discontiguous blocks, start with a clean buffer.  */  
+        /* Flush the buffer.  */  
+       if (s->ndirty != 0)    
+         fd_flush (s);  
+       s->dirty_offset = where;  
+       s->ndirty = *len;
+    }
+  else
+    {  
+      gfc_offset start;  /* Merge with the existing data.  */  
+      if (where < s->dirty_offset)    
+        start = where;  
+      else    
+        start = s->dirty_offset;  
+      if (where + *len > s->dirty_offset + s->ndirty)    
+        s->ndirty = where + *len - start;  
+      else    
+        s->ndirty = s->dirty_offset + s->ndirty - start;  
+        s->dirty_offset = start;
+    }
+
+  s->logical_offset = where + *len;
+
+  /* Don't increment file_length if the file is non-seekable.  */
+
+  if (s->file_length != -1 && s->logical_offset > s->file_length)
+     s->file_length = s->logical_offset;
+
+  n = s->logical_offset - s->buffer_offset;
+  if (n > s->active)
+    s->active = n;
+
+  return s->buffer + where - s->buffer_offset;
+}
+
+
+static try
+fd_sfree (unix_stream * s)
+{
+  if (s->ndirty != 0 &&
+      (s->buffer != s->small_buffer || options.all_unbuffered ||
+       s->unbuffered))
+    return fd_flush (s);
+
+  return SUCCESS;
+}
+
+
+static try
+fd_seek (unix_stream * s, gfc_offset offset)
+{
+
+  if (s->file_length == -1)
+    return SUCCESS;
+
+  if (s->physical_offset == offset) /* Are we lucky and avoid syscall?  */
+    {
+      s->logical_offset = offset;
+      return SUCCESS;
+    }
+
+  s->physical_offset = s->logical_offset = offset;
+  s->active = 0;
+
+  return (lseek (s->fd, offset, SEEK_SET) < 0) ? FAILURE : SUCCESS;
+}
+
+
+/* truncate_file()-- Given a unit, truncate the file at the current
+ * position.  Sets the physical location to the new end of the file.
+ * Returns nonzero on error. */
+
+static try
+fd_truncate (unix_stream * s)
+{
+  /* Non-seekable files, like terminals and fifo's fail the lseek so just
+     return success, there is nothing to truncate.  If its not a pipe there
+     is a real problem.  */
+  if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
+    {
+      if (errno == ESPIPE)
+	return SUCCESS;
+      else
+	return FAILURE;
+    }
+
+  /* Using ftruncate on a seekable special file (like /dev/null)
+     is undefined, so we treat it as if the ftruncate succeeded.  */
+#ifdef HAVE_FTRUNCATE
+  if (s->special_file || ftruncate (s->fd, s->logical_offset))
+#else
+#ifdef HAVE_CHSIZE
+  if (s->special_file || chsize (s->fd, s->logical_offset))
+#endif
+#endif
+    {
+      s->physical_offset = s->file_length = 0;
+      return SUCCESS;
+    }
+
+  s->physical_offset = s->file_length = s->logical_offset;
+  s->active = 0;
+  return SUCCESS;
+}
+
+
+/* Similar to memset(), but operating on a stream instead of a string.
+   Takes care of not using too much memory.  */
+
+static try
+fd_sset (unix_stream * s, int c, size_t n)
+{
+  size_t bytes_left;
+  int trans;
+  void *p;
+
+  bytes_left = n;
+
+  while (bytes_left > 0)
+    {
+      /* memset() in chunks of BUFFER_SIZE.  */
+      trans = (bytes_left < BUFFER_SIZE) ? bytes_left : BUFFER_SIZE;
+
+      p = fd_alloc_w_at (s, &trans, -1);
+      if (p)
+	  memset (p, c, trans);
+      else
+	return FAILURE;
+
+      bytes_left -= trans;
+    }
+
+  return SUCCESS;
+}
+
+
+/* Stream read function. Avoids using a buffer for big reads. The
+   interface is like POSIX read(), but the nbytes argument is a
+   pointer; on return it contains the number of bytes written. The
+   function return value is the status indicator (0 for success).  */
+
+static int
+fd_read (unix_stream * s, void * buf, size_t * nbytes)
+{
+  void *p;
+  int tmp, status;
+
+  if (*nbytes < BUFFER_SIZE && !s->unbuffered)
+    {
+      tmp = *nbytes;
+      p = fd_alloc_r_at (s, &tmp, -1);
+      if (p)
+	{
+	  *nbytes = tmp;
+	  memcpy (buf, p, *nbytes);
+	  return 0;
+	}
+      else
+	{
+	  *nbytes = 0;
+	  return errno;
+	}
+    }
+
+  /* If the request is bigger than BUFFER_SIZE we flush the buffers
+     and read directly.  */
+  if (fd_flush (s) == FAILURE)
+    {
+      *nbytes = 0;
+      return errno;
+    }
+
+  if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
+    {
+      *nbytes = 0;
+      return errno;
+    }
+
+  status = do_read (s, buf, nbytes);
+  reset_stream (s, *nbytes);
+  return status;
+}
+
+
+/* Stream write function. Avoids using a buffer for big writes. The
+   interface is like POSIX write(), but the nbytes argument is a
+   pointer; on return it contains the number of bytes written. The
+   function return value is the status indicator (0 for success).  */
+
+static int
+fd_write (unix_stream * s, const void * buf, size_t * nbytes)
+{
+  void *p;
+  int tmp, status;
+
+  if (*nbytes < BUFFER_SIZE && !s->unbuffered)
+    {
+      tmp = *nbytes;
+      p = fd_alloc_w_at (s, &tmp, -1);
+      if (p)
+	{
+	  *nbytes = tmp;
+	  memcpy (p, buf, *nbytes);
+	  return 0;
+	}
+      else
+	{
+	  *nbytes = 0;
+	  return errno;
+	}
+    }
+
+  /* If the request is bigger than BUFFER_SIZE we flush the buffers
+     and write directly.  */
+  if (fd_flush (s) == FAILURE)
+    {
+      *nbytes = 0;
+      return errno;
+    }
+
+  if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
+    {
+      *nbytes = 0;
+      return errno;
+    }
+
+  status =  do_write (s, buf, nbytes);
+  reset_stream (s, *nbytes);
+  return status;
+}
+
+
+static try
+fd_close (unix_stream * s)
+{
+  if (fd_flush (s) == FAILURE)
+    return FAILURE;
+
+  if (s->buffer != NULL && s->buffer != s->small_buffer)
+    free_mem (s->buffer);
+
+  if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO)
+    {
+      if (close (s->fd) < 0)
+        return FAILURE;
+    }
+
+  free_mem (s);
+
+  return SUCCESS;
+}
+
+
+static void
+fd_open (unix_stream * s)
+{
+  if (isatty (s->fd))
+    s->unbuffered = 1;
+
+  s->st.alloc_r_at = (void *) fd_alloc_r_at;
+  s->st.alloc_w_at = (void *) fd_alloc_w_at;
+  s->st.sfree = (void *) fd_sfree;
+  s->st.close = (void *) fd_close;
+  s->st.seek = (void *) fd_seek;
+  s->st.truncate = (void *) fd_truncate;
+  s->st.read = (void *) fd_read;
+  s->st.write = (void *) fd_write;
+  s->st.set = (void *) fd_sset;
+
+  s->buffer = NULL;
+}
+
+
+
+
+/*********************************************************************
+  memory stream functions - These are used for internal files
+
+  The idea here is that a single stream structure is created and all
+  requests must be satisfied from it.  The location and size of the
+  buffer is the character variable supplied to the READ or WRITE
+  statement.
+
+*********************************************************************/
+
+
+static char *
+mem_alloc_r_at (unix_stream * s, int *len, gfc_offset where)
+{
+  gfc_offset n;
+
+  if (where == -1)
+    where = s->logical_offset;
+
+  if (where < s->buffer_offset || where > s->buffer_offset + s->active)
+    return NULL;
+
+  s->logical_offset = where + *len;
+
+  n = s->buffer_offset + s->active - where;
+  if (*len > n)
+    *len = n;
+
+  return s->buffer + (where - s->buffer_offset);
+}
+
+
+static char *
+mem_alloc_w_at (unix_stream * s, int *len, gfc_offset where)
+{
+  gfc_offset m;
+
+  assert (*len >= 0);  /* Negative values not allowed. */
+  
+  if (where == -1)
+    where = s->logical_offset;
+
+  m = where + *len;
+
+  if (where < s->buffer_offset)
+    return NULL;
+
+  if (m > s->file_length)
+    return NULL;
+
+  s->logical_offset = m;
+
+  return s->buffer + (where - s->buffer_offset);
+}
+
+
+/* Stream read function for internal units. This is not actually used
+   at the moment, as all internal IO is formatted and the formatted IO
+   routines use mem_alloc_r_at.  */
+
+static int
+mem_read (unix_stream * s, void * buf, size_t * nbytes)
+{
+  void *p;
+  int tmp;
+
+  tmp = *nbytes;
+  p = mem_alloc_r_at (s, &tmp, -1);
+  if (p)
+    {
+      *nbytes = tmp;
+      memcpy (buf, p, *nbytes);
+      return 0;
+    }
+  else
+    {
+      *nbytes = 0;
+      return errno;
+    }
+}
+
+
+/* Stream write function for internal units. This is not actually used
+   at the moment, as all internal IO is formatted and the formatted IO
+   routines use mem_alloc_w_at.  */
+
+static int
+mem_write (unix_stream * s, const void * buf, size_t * nbytes)
+{
+  void *p;
+  int tmp;
+
+  errno = 0;
+
+  tmp = *nbytes;
+  p = mem_alloc_w_at (s, &tmp, -1);
+  if (p)
+    {
+      *nbytes = tmp;
+      memcpy (p, buf, *nbytes);
+      return 0;
+    }
+  else
+    {
+      *nbytes = 0;
+      return errno;
+    }
+}
+
+
+static int
+mem_seek (unix_stream * s, gfc_offset offset)
+{
+  if (offset > s->file_length)
+    {
+      errno = ESPIPE;
+      return FAILURE;
+    }
+
+  s->logical_offset = offset;
+  return SUCCESS;
+}
+
+
+static try
+mem_set (unix_stream * s, int c, size_t n)
+{
+  void *p;
+  int len;
+
+  len = n;
+  
+  p = mem_alloc_w_at (s, &len, -1);
+  if (p)
+    {
+      memset (p, c, len);
+      return SUCCESS;
+    }
+  else
+    return FAILURE;
+}
+
+
+static int
+mem_truncate (unix_stream * s __attribute__ ((unused)))
+{
+  return SUCCESS;
+}
+
+
+static try
+mem_close (unix_stream * s)
+{
+  if (s != NULL)
+    free_mem (s);
+
+  return SUCCESS;
+}
+
+
+static try
+mem_sfree (unix_stream * s __attribute__ ((unused)))
+{
+  return SUCCESS;
+}
+
+
+
+/*********************************************************************
+  Public functions -- A reimplementation of this module needs to
+  define functional equivalents of the following.
+*********************************************************************/
+
+/* empty_internal_buffer()-- Zero the buffer of Internal file */
+
+void
+empty_internal_buffer(stream *strm)
+{
+  unix_stream * s = (unix_stream *) strm;
+  memset(s->buffer, ' ', s->file_length);
+}
+
+/* open_internal()-- Returns a stream structure from an internal file */
+
+stream *
+open_internal (char *base, int length)
+{
+  unix_stream *s;
+
+  s = get_mem (sizeof (unix_stream));
+  memset (s, '\0', sizeof (unix_stream));
+
+  s->buffer = base;
+  s->buffer_offset = 0;
+
+  s->logical_offset = 0;
+  s->active = s->file_length = length;
+
+  s->st.alloc_r_at = (void *) mem_alloc_r_at;
+  s->st.alloc_w_at = (void *) mem_alloc_w_at;
+  s->st.sfree = (void *) mem_sfree;
+  s->st.close = (void *) mem_close;
+  s->st.seek = (void *) mem_seek;
+  s->st.truncate = (void *) mem_truncate;
+  s->st.read = (void *) mem_read;
+  s->st.write = (void *) mem_write;
+  s->st.set = (void *) mem_set;
+
+  return (stream *) s;
+}
+
+
+/* fd_to_stream()-- Given an open file descriptor, build a stream
+ * around it. */
+
+static stream *
+fd_to_stream (int fd, int prot)
+{
+  struct stat statbuf;
+  unix_stream *s;
+
+  s = get_mem (sizeof (unix_stream));
+  memset (s, '\0', sizeof (unix_stream));
+
+  s->fd = fd;
+  s->buffer_offset = 0;
+  s->physical_offset = 0;
+  s->logical_offset = 0;
+  s->prot = prot;
+
+  /* Get the current length of the file. */
+
+  fstat (fd, &statbuf);
+
+  if (lseek (fd, 0, SEEK_CUR) == (off_t) -1)
+    s->file_length = -1;
+  else
+    s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
+
+  s->special_file = !S_ISREG (statbuf.st_mode);
+
+  fd_open (s);
+
+  return (stream *) s;
+}
+
+
+/* Given the Fortran unit number, convert it to a C file descriptor.  */
+
+int
+unit_to_fd (int unit)
+{
+  gfc_unit *us;
+  int fd;
+
+  us = find_unit (unit);
+  if (us == NULL)
+    return -1;
+
+  fd = ((unix_stream *) us->s)->fd;
+  unlock_unit (us);
+  return fd;
+}
+
+
+/* unpack_filename()-- Given a fortran string and a pointer to a
+ * buffer that is PATH_MAX characters, convert the fortran string to a
+ * C string in the buffer.  Returns nonzero if this is not possible.  */
+
+int
+unpack_filename (char *cstring, const char *fstring, int len)
+{
+  len = fstrlen (fstring, len);
+  if (len >= PATH_MAX)
+    return 1;
+
+  memmove (cstring, fstring, len);
+  cstring[len] = '\0';
+
+  return 0;
+}
+
+
+/* tempfile()-- Generate a temporary filename for a scratch file and
+ * open it.  mkstemp() opens the file for reading and writing, but the
+ * library mode prevents anything that is not allowed.  The descriptor
+ * is returned, which is -1 on error.  The template is pointed to by 
+ * opp->file, which is copied into the unit structure
+ * and freed later. */
+
+static int
+tempfile (st_parameter_open *opp)
+{
+  const char *tempdir;
+  char *template;
+  int fd;
+
+  tempdir = getenv ("GFORTRAN_TMPDIR");
+  if (tempdir == NULL)
+    tempdir = getenv ("TMP");
+  if (tempdir == NULL)
+    tempdir = getenv ("TEMP");
+  if (tempdir == NULL)
+    tempdir = DEFAULT_TEMPDIR;
+
+  template = get_mem (strlen (tempdir) + 20);
+
+  st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
+
+#ifdef HAVE_MKSTEMP
+
+  fd = mkstemp (template);
+
+#else /* HAVE_MKSTEMP */
+
+  if (mktemp (template))
+    do
+#if defined(HAVE_CRLF) && defined(O_BINARY)
+      fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
+                 S_IREAD | S_IWRITE);
+#else
+      fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
+#endif
+    while (!(fd == -1 && errno == EEXIST) && mktemp (template));
+  else
+    fd = -1;
+
+#endif /* HAVE_MKSTEMP */
+
+  if (fd < 0)
+    free_mem (template);
+  else
+    {
+      opp->file = template;
+      opp->file_len = strlen (template);	/* Don't include trailing nul */
+    }
+
+  return fd;
+}
+
+
+/* regular_file()-- Open a regular file.
+ * Change flags->action if it is ACTION_UNSPECIFIED on entry,
+ * unless an error occurs.
+ * Returns the descriptor, which is less than zero on error. */
+
+static int
+regular_file (st_parameter_open *opp, unit_flags *flags)
+{
+  char path[PATH_MAX + 1];
+  int mode;
+  int rwflag;
+  int crflag;
+  int fd;
+
+  if (unpack_filename (path, opp->file, opp->file_len))
+    {
+      errno = ENOENT;		/* Fake an OS error */
+      return -1;
+    }
+
+  rwflag = 0;
+
+  switch (flags->action)
+    {
+    case ACTION_READ:
+      rwflag = O_RDONLY;
+      break;
+
+    case ACTION_WRITE:
+      rwflag = O_WRONLY;
+      break;
+
+    case ACTION_READWRITE:
+    case ACTION_UNSPECIFIED:
+      rwflag = O_RDWR;
+      break;
+
+    default:
+      internal_error (&opp->common, "regular_file(): Bad action");
+    }
+
+  switch (flags->status)
+    {
+    case STATUS_NEW:
+      crflag = O_CREAT | O_EXCL;
+      break;
+
+    case STATUS_OLD:		/* open will fail if the file does not exist*/
+      crflag = 0;
+      break;
+
+    case STATUS_UNKNOWN:
+    case STATUS_SCRATCH:
+      crflag = O_CREAT;
+      break;
+
+    case STATUS_REPLACE:
+      crflag = O_CREAT | O_TRUNC;
+      break;
+
+    default:
+      internal_error (&opp->common, "regular_file(): Bad status");
+    }
+
+  /* rwflag |= O_LARGEFILE; */
+
+#if defined(HAVE_CRLF) && defined(O_BINARY)
+  crflag |= O_BINARY;
+#endif
+
+  mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
+  fd = open (path, rwflag | crflag, mode);
+  if (flags->action != ACTION_UNSPECIFIED)
+    return fd;
+
+  if (fd >= 0)
+    {
+      flags->action = ACTION_READWRITE;
+      return fd;
+    }
+  if (errno != EACCES && errno != EROFS)
+     return fd;
+
+  /* retry for read-only access */
+  rwflag = O_RDONLY;
+  fd = open (path, rwflag | crflag, mode);
+  if (fd >=0)
+    {
+      flags->action = ACTION_READ;
+      return fd;               /* success */
+    }
+  
+  if (errno != EACCES)
+    return fd;                 /* failure */
+
+  /* retry for write-only access */
+  rwflag = O_WRONLY;
+  fd = open (path, rwflag | crflag, mode);
+  if (fd >=0)
+    {
+      flags->action = ACTION_WRITE;
+      return fd;               /* success */
+    }
+  return fd;                   /* failure */
+}
+
+
+/* open_external()-- Open an external file, unix specific version.
+ * Change flags->action if it is ACTION_UNSPECIFIED on entry.
+ * Returns NULL on operating system error. */
+
+stream *
+open_external (st_parameter_open *opp, unit_flags *flags)
+{
+  int fd, prot;
+
+  if (flags->status == STATUS_SCRATCH)
+    {
+      fd = tempfile (opp);
+      if (flags->action == ACTION_UNSPECIFIED)
+        flags->action = ACTION_READWRITE;
+
+#if HAVE_UNLINK_OPEN_FILE
+      /* We can unlink scratch files now and it will go away when closed. */
+      if (fd >= 0)
+	unlink (opp->file);
+#endif
+    }
+  else
+    {
+      /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
+       * if it succeeds */
+      fd = regular_file (opp, flags);
+    }
+
+  if (fd < 0)
+    return NULL;
+  fd = fix_fd (fd);
+
+  switch (flags->action)
+    {
+    case ACTION_READ:
+      prot = PROT_READ;
+      break;
+
+    case ACTION_WRITE:
+      prot = PROT_WRITE;
+      break;
+
+    case ACTION_READWRITE:
+      prot = PROT_READ | PROT_WRITE;
+      break;
+
+    default:
+      internal_error (&opp->common, "open_external(): Bad action");
+    }
+
+  return fd_to_stream (fd, prot);
+}
+
+
+/* input_stream()-- Return a stream pointer to the default input stream.
+ * Called on initialization. */
+
+stream *
+input_stream (void)
+{
+  return fd_to_stream (STDIN_FILENO, PROT_READ);
+}
+
+
+/* output_stream()-- Return a stream pointer to the default output stream.
+ * Called on initialization. */
+
+stream *
+output_stream (void)
+{
+#if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
+  setmode (STDOUT_FILENO, O_BINARY);
+#endif
+  return fd_to_stream (STDOUT_FILENO, PROT_WRITE);
+}
+
+
+/* error_stream()-- Return a stream pointer to the default error stream.
+ * Called on initialization. */
+
+stream *
+error_stream (void)
+{
+#if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
+  setmode (STDERR_FILENO, O_BINARY);
+#endif
+  return fd_to_stream (STDERR_FILENO, PROT_WRITE);
+}
+
+/* init_error_stream()-- Return a pointer to the error stream.  This
+ * subroutine is called when the stream is needed, rather than at
+ * initialization.  We want to work even if memory has been seriously
+ * corrupted. */
+
+stream *
+init_error_stream (unix_stream *error)
+{
+  memset (error, '\0', sizeof (*error));
+
+  error->fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
+
+  error->st.alloc_w_at = (void *) fd_alloc_w_at;
+  error->st.sfree = (void *) fd_sfree;
+
+  error->unbuffered = 1;
+  error->buffer = error->small_buffer;
+
+  return (stream *) error;
+}
+
+
+/* compare_file_filename()-- Given an open stream and a fortran string
+ * that is a filename, figure out if the file is the same as the
+ * filename. */
+
+int
+compare_file_filename (gfc_unit *u, const char *name, int len)
+{
+  char path[PATH_MAX + 1];
+  struct stat st1;
+#ifdef HAVE_WORKING_STAT
+  struct stat st2;
+#endif
+
+  if (unpack_filename (path, name, len))
+    return 0;			/* Can't be the same */
+
+  /* If the filename doesn't exist, then there is no match with the
+   * existing file. */
+
+  if (stat (path, &st1) < 0)
+    return 0;
+
+#ifdef HAVE_WORKING_STAT
+  fstat (((unix_stream *) (u->s))->fd, &st2);
+  return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
+#else
+  if (len != u->file_len)
+    return 0;
+  return (memcmp(path, u->file, len) == 0);
+#endif
+}
+
+
+#ifdef HAVE_WORKING_STAT
+# define FIND_FILE0_DECL struct stat *st
+# define FIND_FILE0_ARGS st
+#else
+# define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len
+# define FIND_FILE0_ARGS file, file_len
+#endif
+
+/* find_file0()-- Recursive work function for find_file() */
+
+static gfc_unit *
+find_file0 (gfc_unit *u, FIND_FILE0_DECL)
+{
+  gfc_unit *v;
+
+  if (u == NULL)
+    return NULL;
+
+#ifdef HAVE_WORKING_STAT
+  if (u->s != NULL
+      && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
+      st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
+    return u;
+#else
+  if (compare_string (u->file_len, u->file, file_len, file) == 0)
+    return u;
+#endif
+
+  v = find_file0 (u->left, FIND_FILE0_ARGS);
+  if (v != NULL)
+    return v;
+
+  v = find_file0 (u->right, FIND_FILE0_ARGS);
+  if (v != NULL)
+    return v;
+
+  return NULL;
+}
+
+
+/* find_file()-- Take the current filename and see if there is a unit
+ * that has the file already open.  Returns a pointer to the unit if so. */
+
+gfc_unit *
+find_file (const char *file, gfc_charlen_type file_len)
+{
+  char path[PATH_MAX + 1];
+  struct stat st[2];
+  gfc_unit *u;
+
+  if (unpack_filename (path, file, file_len))
+    return NULL;
+
+  if (stat (path, &st[0]) < 0)
+    return NULL;
+
+  __gthread_mutex_lock (&unit_lock);
+retry:
+  u = find_file0 (unit_root, FIND_FILE0_ARGS);
+  if (u != NULL)
+    {
+      /* Fast path.  */
+      if (! __gthread_mutex_trylock (&u->lock))
+	{
+	  /* assert (u->closed == 0); */
+	  __gthread_mutex_unlock (&unit_lock);
+	  return u;
+	}
+
+      inc_waiting_locked (u);
+    }
+  __gthread_mutex_unlock (&unit_lock);
+  if (u != NULL)
+    {
+      __gthread_mutex_lock (&u->lock);
+      if (u->closed)
+	{
+	  __gthread_mutex_lock (&unit_lock);
+	  __gthread_mutex_unlock (&u->lock);
+	  if (predec_waiting_locked (u) == 0)
+	    free_mem (u);
+	  goto retry;
+	}
+
+      dec_waiting_unlocked (u);
+    }
+  return u;
+}
+
+static gfc_unit *
+flush_all_units_1 (gfc_unit *u, int min_unit)
+{
+  while (u != NULL)
+    {
+      if (u->unit_number > min_unit)
+	{
+	  gfc_unit *r = flush_all_units_1 (u->left, min_unit);
+	  if (r != NULL)
+	    return r;
+	}
+      if (u->unit_number >= min_unit)
+	{
+	  if (__gthread_mutex_trylock (&u->lock))
+	    return u;
+	  if (u->s)
+	    flush (u->s);
+	  __gthread_mutex_unlock (&u->lock);
+	}
+      u = u->right;
+    }
+  return NULL;
+}
+
+void
+flush_all_units (void)
+{
+  gfc_unit *u;
+  int min_unit = 0;
+
+  __gthread_mutex_lock (&unit_lock);
+  do
+    {
+      u = flush_all_units_1 (unit_root, min_unit);
+      if (u != NULL)
+	inc_waiting_locked (u);
+      __gthread_mutex_unlock (&unit_lock);
+      if (u == NULL)
+	return;
+
+      __gthread_mutex_lock (&u->lock);
+
+      min_unit = u->unit_number + 1;
+
+      if (u->closed == 0)
+	{
+	  flush (u->s);
+	  __gthread_mutex_lock (&unit_lock);
+	  __gthread_mutex_unlock (&u->lock);
+	  (void) predec_waiting_locked (u);
+	}
+      else
+	{
+	  __gthread_mutex_lock (&unit_lock);
+	  __gthread_mutex_unlock (&u->lock);
+	  if (predec_waiting_locked (u) == 0)
+	    free_mem (u);
+	}
+    }
+  while (1);
+}
+
+
+/* stream_at_bof()-- Returns nonzero if the stream is at the beginning
+ * of the file. */
+
+int
+stream_at_bof (stream * s)
+{
+  unix_stream *us;
+
+  if (!is_seekable (s))
+    return 0;
+
+  us = (unix_stream *) s;
+
+  return us->logical_offset == 0;
+}
+
+
+/* stream_at_eof()-- Returns nonzero if the stream is at the end
+ * of the file. */
+
+int
+stream_at_eof (stream * s)
+{
+  unix_stream *us;
+
+  if (!is_seekable (s))
+    return 0;
+
+  us = (unix_stream *) s;
+
+  return us->logical_offset == us->dirty_offset;
+}
+
+
+/* delete_file()-- Given a unit structure, delete the file associated
+ * with the unit.  Returns nonzero if something went wrong. */
+
+int
+delete_file (gfc_unit * u)
+{
+  char path[PATH_MAX + 1];
+
+  if (unpack_filename (path, u->file, u->file_len))
+    {				/* Shouldn't be possible */
+      errno = ENOENT;
+      return 1;
+    }
+
+  return unlink (path);
+}
+
+
+/* file_exists()-- Returns nonzero if the current filename exists on
+ * the system */
+
+int
+file_exists (const char *file, gfc_charlen_type file_len)
+{
+  char path[PATH_MAX + 1];
+  struct stat statbuf;
+
+  if (unpack_filename (path, file, file_len))
+    return 0;
+
+  if (stat (path, &statbuf) < 0)
+    return 0;
+
+  return 1;
+}
+
+
+
+static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
+
+/* inquire_sequential()-- Given a fortran string, determine if the
+ * file is suitable for sequential access.  Returns a C-style
+ * string. */
+
+const char *
+inquire_sequential (const char *string, int len)
+{
+  char path[PATH_MAX + 1];
+  struct stat statbuf;
+
+  if (string == NULL ||
+      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
+    return unknown;
+
+  if (S_ISREG (statbuf.st_mode) ||
+      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
+    return yes;
+
+  if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
+    return no;
+
+  return unknown;
+}
+
+
+/* inquire_direct()-- Given a fortran string, determine if the file is
+ * suitable for direct access.  Returns a C-style string. */
+
+const char *
+inquire_direct (const char *string, int len)
+{
+  char path[PATH_MAX + 1];
+  struct stat statbuf;
+
+  if (string == NULL ||
+      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
+    return unknown;
+
+  if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
+    return yes;
+
+  if (S_ISDIR (statbuf.st_mode) ||
+      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
+    return no;
+
+  return unknown;
+}
+
+
+/* inquire_formatted()-- Given a fortran string, determine if the file
+ * is suitable for formatted form.  Returns a C-style string. */
+
+const char *
+inquire_formatted (const char *string, int len)
+{
+  char path[PATH_MAX + 1];
+  struct stat statbuf;
+
+  if (string == NULL ||
+      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
+    return unknown;
+
+  if (S_ISREG (statbuf.st_mode) ||
+      S_ISBLK (statbuf.st_mode) ||
+      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
+    return yes;
+
+  if (S_ISDIR (statbuf.st_mode))
+    return no;
+
+  return unknown;
+}
+
+
+/* inquire_unformatted()-- Given a fortran string, determine if the file
+ * is suitable for unformatted form.  Returns a C-style string. */
+
+const char *
+inquire_unformatted (const char *string, int len)
+{
+  return inquire_formatted (string, len);
+}
+
+
+/* inquire_access()-- Given a fortran string, determine if the file is
+ * suitable for access. */
+
+static const char *
+inquire_access (const char *string, int len, int mode)
+{
+  char path[PATH_MAX + 1];
+
+  if (string == NULL || unpack_filename (path, string, len) ||
+      access (path, mode) < 0)
+    return no;
+
+  return yes;
+}
+
+
+/* inquire_read()-- Given a fortran string, determine if the file is
+ * suitable for READ access. */
+
+const char *
+inquire_read (const char *string, int len)
+{
+  return inquire_access (string, len, R_OK);
+}
+
+
+/* inquire_write()-- Given a fortran string, determine if the file is
+ * suitable for READ access. */
+
+const char *
+inquire_write (const char *string, int len)
+{
+  return inquire_access (string, len, W_OK);
+}
+
+
+/* inquire_readwrite()-- Given a fortran string, determine if the file is
+ * suitable for read and write access. */
+
+const char *
+inquire_readwrite (const char *string, int len)
+{
+  return inquire_access (string, len, R_OK | W_OK);
+}
+
+
+/* file_length()-- Return the file length in bytes, -1 if unknown */
+
+gfc_offset
+file_length (stream * s)
+{
+  return ((unix_stream *) s)->file_length;
+}
+
+
+/* file_position()-- Return the current position of the file */
+
+gfc_offset
+file_position (stream * s)
+{
+  return ((unix_stream *) s)->logical_offset;
+}
+
+
+/* is_seekable()-- Return nonzero if the stream is seekable, zero if
+ * it is not */
+
+int
+is_seekable (stream * s)
+{
+  /* By convention, if file_length == -1, the file is not
+     seekable.  */
+  return ((unix_stream *) s)->file_length!=-1;
+}
+
+try
+flush (stream *s)
+{
+  return fd_flush( (unix_stream *) s);
+}
+
+int
+stream_isatty (stream *s)
+{
+  return isatty (((unix_stream *) s)->fd);
+}
+
+char *
+stream_ttyname (stream *s)
+{
+#ifdef HAVE_TTYNAME
+  return ttyname (((unix_stream *) s)->fd);
+#else
+  return NULL;
+#endif
+}
+
+gfc_offset
+stream_offset (stream *s)
+{
+  return (((unix_stream *) s)->logical_offset);
+}
+
+
+/* How files are stored:  This is an operating-system specific issue,
+   and therefore belongs here.  There are three cases to consider.
+
+   Direct Access:
+      Records are written as block of bytes corresponding to the record
+      length of the file.  This goes for both formatted and unformatted
+      records.  Positioning is done explicitly for each data transfer,
+      so positioning is not much of an issue.
+
+   Sequential Formatted:
+      Records are separated by newline characters.  The newline character
+      is prohibited from appearing in a string.  If it does, this will be
+      messed up on the next read.  End of file is also the end of a record.
+
+   Sequential Unformatted:
+      In this case, we are merely copying bytes to and from main storage,
+      yet we need to keep track of varying record lengths.  We adopt
+      the solution used by f2c.  Each record contains a pair of length
+      markers:
+
+        Length of record n in bytes
+        Data of record n
+        Length of record n in bytes
+
+        Length of record n+1 in bytes
+        Data of record n+1
+        Length of record n+1 in bytes
+
+     The length is stored at the end of a record to allow backspacing to the
+     previous record.  Between data transfer statements, the file pointer
+     is left pointing to the first length of the current record.
+
+     ENDFILE records are never explicitly stored.
+
+*/
diff --git a/gcc-4.2.1/libgfortran/io/unix.h b/gcc-4.2.1/libgfortran/io/unix.h
new file mode 100644
index 000000000..25508f117
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/unix.h
@@ -0,0 +1,63 @@
+/* Copyright (C) 2002, 2003, 2004, 2005
+   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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+/* Unix stream I/O module */
+
+#define BUFFER_SIZE 8192
+
+typedef struct
+{
+  stream st;
+
+  int fd;
+  gfc_offset buffer_offset;	/* File offset of the start of the buffer */
+  gfc_offset physical_offset;	/* Current physical file offset */
+  gfc_offset logical_offset;	/* Current logical file offset */
+  gfc_offset dirty_offset;	/* Start of modified bytes in buffer */
+  gfc_offset file_length;	/* Length of the file, -1 if not seekable. */
+
+  char *buffer;
+  int len;			/* Physical length of the current buffer */
+  int active;			/* Length of valid bytes in the buffer */
+
+  int prot;
+  int ndirty;			/* Dirty bytes starting at dirty_offset */
+
+  int special_file;		/* =1 if the fd refers to a special file */
+
+  unsigned unbuffered:1;
+
+  char small_buffer[BUFFER_SIZE];
+
+}
+unix_stream;
+
+extern stream *init_error_stream (unix_stream *);
+internal_proto(init_error_stream);
diff --git a/gcc-4.2.1/libgfortran/io/write.c b/gcc-4.2.1/libgfortran/io/write.c
new file mode 100644
index 000000000..c114c9c0f
--- /dev/null
+++ b/gcc-4.2.1/libgfortran/io/write.c
@@ -0,0 +1,1898 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   Namelist output contributed by Paul Thomas
+
+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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+#include "config.h"
+#include <assert.h>
+#include <string.h>
+#include <ctype.h>
+#include <float.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include "libgfortran.h"
+#include "io.h"
+
+#define star_fill(p, n) memset(p, '*', n)
+
+
+typedef enum
+{ SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
+sign_t;
+
+
+void
+write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+  int wlen;
+  char *p;
+
+  wlen = f->u.string.length < 0 ? len : f->u.string.length;
+
+#ifdef HAVE_CRLF
+  /* If this is formatted STREAM IO convert any embedded line feed characters
+     to CR_LF on systems that use that sequence for newlines.  See F2003
+     Standard sections 10.6.3 and 9.9 for further information.  */
+  if (is_stream_io (dtp))
+    {
+      const char crlf[] = "\r\n";
+      int i, q, bytes;
+      q = bytes = 0;
+
+      /* Write out any padding if needed.  */
+      if (len < wlen)
+	{
+	  p = write_block (dtp, wlen - len);
+	  if (p == NULL)
+	    return;
+	  memset (p, ' ', wlen - len);
+	}
+
+      /* Scan the source string looking for '\n' and convert it if found.  */
+      for (i = 0; i < wlen; i++)
+	{
+	  if (source[i] == '\n')
+	    {
+	      /* Write out the previously scanned characters in the string.  */
+	      if (bytes > 0)
+		{
+		  p = write_block (dtp, bytes);
+		  if (p == NULL)
+		    return;
+		  memcpy (p, &source[q], bytes);
+		  q += bytes;
+		  bytes = 0;
+		}
+
+	      /* Write out the CR_LF sequence.  */ 
+	      q++;
+	      p = write_block (dtp, 2);
+              if (p == NULL)
+                return;
+	      memcpy (p, crlf, 2);
+	    }
+	  else
+	    bytes++;
+	}
+
+      /*  Write out any remaining bytes if no LF was found.  */
+      if (bytes > 0)
+	{
+	  p = write_block (dtp, bytes);
+	  if (p == NULL)
+	    return;
+	  memcpy (p, &source[q], bytes);
+	}
+    }
+  else
+    {
+#endif
+      p = write_block (dtp, wlen);
+      if (p == NULL)
+	return;
+
+      if (wlen < len)
+	memcpy (p, source, wlen);
+      else
+	{
+	  memset (p, ' ', wlen - len);
+	  memcpy (p + wlen - len, source, len);
+	}
+#ifdef HAVE_CRLF
+    }
+#endif
+}
+
+static GFC_INTEGER_LARGEST
+extract_int (const void *p, int len)
+{
+  GFC_INTEGER_LARGEST i = 0;
+
+  if (p == NULL)
+    return i;
+
+  switch (len)
+    {
+    case 1:
+      {
+	GFC_INTEGER_1 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+    case 2:
+      {
+	GFC_INTEGER_2 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+    case 4:
+      {
+	GFC_INTEGER_4 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+    case 8:
+      {
+	GFC_INTEGER_8 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+#ifdef HAVE_GFC_INTEGER_16
+    case 16:
+      {
+	GFC_INTEGER_16 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+#endif
+    default:
+      internal_error (NULL, "bad integer kind");
+    }
+
+  return i;
+}
+
+static GFC_UINTEGER_LARGEST
+extract_uint (const void *p, int len)
+{
+  GFC_UINTEGER_LARGEST i = 0;
+
+  if (p == NULL)
+    return i;
+
+  switch (len)
+    {
+    case 1:
+      {
+	GFC_INTEGER_1 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = (GFC_UINTEGER_1) tmp;
+      }
+      break;
+    case 2:
+      {
+	GFC_INTEGER_2 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = (GFC_UINTEGER_2) tmp;
+      }
+      break;
+    case 4:
+      {
+	GFC_INTEGER_4 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = (GFC_UINTEGER_4) tmp;
+      }
+      break;
+    case 8:
+      {
+	GFC_INTEGER_8 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = (GFC_UINTEGER_8) tmp;
+      }
+      break;
+#ifdef HAVE_GFC_INTEGER_16
+    case 16:
+      {
+	GFC_INTEGER_16 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = (GFC_UINTEGER_16) tmp;
+      }
+      break;
+#endif
+    default:
+      internal_error (NULL, "bad integer kind");
+    }
+
+  return i;
+}
+
+static GFC_REAL_LARGEST
+extract_real (const void *p, int len)
+{
+  GFC_REAL_LARGEST i = 0;
+  switch (len)
+    {
+    case 4:
+      {
+	GFC_REAL_4 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+    case 8:
+      {
+	GFC_REAL_8 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+#ifdef HAVE_GFC_REAL_10
+    case 10:
+      {
+	GFC_REAL_10 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+#endif
+#ifdef HAVE_GFC_REAL_16
+    case 16:
+      {
+	GFC_REAL_16 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+#endif
+    default:
+      internal_error (NULL, "bad real kind");
+    }
+  return i;
+}
+
+
+/* Given a flag that indicate if a value is negative or not, return a
+   sign_t that gives the sign that we need to produce.  */
+
+static sign_t
+calculate_sign (st_parameter_dt *dtp, int negative_flag)
+{
+  sign_t s = SIGN_NONE;
+
+  if (negative_flag)
+    s = SIGN_MINUS;
+  else
+    switch (dtp->u.p.sign_status)
+      {
+      case SIGN_SP:
+	s = SIGN_PLUS;
+	break;
+      case SIGN_SS:
+	s = SIGN_NONE;
+	break;
+      case SIGN_S:
+	s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
+	break;
+      }
+
+  return s;
+}
+
+
+/* Returns the value of 10**d.  */
+
+static GFC_REAL_LARGEST
+calculate_exp (int d)
+{
+  int i;
+  GFC_REAL_LARGEST r = 1.0;
+
+  for (i = 0; i< (d >= 0 ? d : -d); i++)
+    r *= 10;
+
+  r = (d >= 0) ? r : 1.0 / r;
+
+  return r;
+}
+
+
+/* Generate corresponding I/O format for FMT_G output.
+   The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
+   LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
+
+   Data Magnitude                              Equivalent Conversion
+   0< m < 0.1-0.5*10**(-d-1)                   Ew.d[Ee]
+   m = 0                                       F(w-n).(d-1), n' '
+   0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d)     F(w-n).d, n' '
+   1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1)      F(w-n).(d-1), n' '
+   10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2)  F(w-n).(d-2), n' '
+   ................                           ..........
+   10**(d-1)-0.5*10**(-1)<= m <10**d-0.5       F(w-n).0,n(' ')
+   m >= 10**d-0.5                              Ew.d[Ee]
+
+   notes: for Gw.d ,  n' ' means 4 blanks
+          for Gw.dEe, n' ' means e+2 blanks  */
+
+static fnode *
+calculate_G_format (st_parameter_dt *dtp, const fnode *f,
+		    GFC_REAL_LARGEST value, int *num_blank)
+{
+  int e = f->u.real.e;
+  int d = f->u.real.d;
+  int w = f->u.real.w;
+  fnode *newf;
+  GFC_REAL_LARGEST m, exp_d;
+  int low, high, mid;
+  int ubound, lbound;
+
+  newf = get_mem (sizeof (fnode));
+
+  /* Absolute value.  */
+  m = (value > 0.0) ? value : -value;
+
+  /* In case of the two data magnitude ranges,
+     generate E editing, Ew.d[Ee].  */
+  exp_d = calculate_exp (d);
+  if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||
+      ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))
+    {
+      newf->format = FMT_E;
+      newf->u.real.w = w;
+      newf->u.real.d = d;
+      newf->u.real.e = e;
+      *num_blank = 0;
+      return newf;
+    }
+
+  /* Use binary search to find the data magnitude range.  */
+  mid = 0;
+  low = 0;
+  high = d + 1;
+  lbound = 0;
+  ubound = d + 1;
+
+  while (low <= high)
+    {
+      GFC_REAL_LARGEST temp;
+      mid = (low + high) / 2;
+
+      /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1)  */
+      temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
+
+      if (m < temp)
+        {
+          ubound = mid;
+          if (ubound == lbound + 1)
+            break;
+          high = mid - 1;
+        }
+      else if (m > temp)
+        {
+          lbound = mid;
+          if (ubound == lbound + 1)
+            {
+              mid ++;
+              break;
+            }
+          low = mid + 1;
+        }
+      else
+        break;
+    }
+
+  /* Pad with blanks where the exponent would be.  */
+  if (e < 0)
+    *num_blank = 4;
+  else
+    *num_blank = e + 2;
+
+  /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '.  */
+  newf->format = FMT_F;
+  newf->u.real.w = f->u.real.w - *num_blank;
+
+  /* Special case.  */
+  if (m == 0.0)
+    newf->u.real.d = d - 1;
+  else
+    newf->u.real.d = - (mid - d - 1);
+
+  /* For F editing, the scale factor is ignored.  */
+  dtp->u.p.scale_factor = 0;
+  return newf;
+}
+
+
+/* Output a real number according to its format which is FMT_G free.  */
+
+static void
+output_float (st_parameter_dt *dtp, const fnode *f, GFC_REAL_LARGEST value)
+{
+#if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
+# define MIN_FIELD_WIDTH 46
+#else
+# define MIN_FIELD_WIDTH 31
+#endif
+#define STR(x) STR1(x)
+#define STR1(x) #x
+  /* This must be large enough to accurately hold any value.  */
+  char buffer[MIN_FIELD_WIDTH+1];
+  char *out;
+  char *digits;
+  int e;
+  char expchar;
+  format_token ft;
+  int w;
+  int d;
+  int edigits;
+  int ndigits;
+  /* Number of digits before the decimal point.  */
+  int nbefore;
+  /* Number of zeros after the decimal point.  */
+  int nzero;
+  /* Number of digits after the decimal point.  */
+  int nafter;
+  /* Number of zeros after the decimal point, whatever the precision.  */
+  int nzero_real;
+  int leadzero;
+  int nblanks;
+  int i;
+  sign_t sign;
+
+  ft = f->format;
+  w = f->u.real.w;
+  d = f->u.real.d;
+
+  nzero_real = -1;
+
+
+  /* We should always know the field width and precision.  */
+  if (d < 0)
+    internal_error (&dtp->common, "Unspecified precision");
+
+  /* Use sprintf to print the number in the format +D.DDDDe+ddd
+     For an N digit exponent, this gives us (MIN_FIELD_WIDTH-5)-N digits
+     after the decimal point, plus another one before the decimal point.  */
+  sign = calculate_sign (dtp, value < 0.0);
+  if (value < 0)
+    value = -value;
+
+  /* Special case when format specifies no digits after the decimal point.  */
+  if (d == 0 && ft == FMT_F)
+    {
+      if (value < 0.5)
+	value = 0.0;
+      else if (value < 1.0)
+	value = value + 0.5;
+    }
+
+  /* printf pads blanks for us on the exponent so we just need it big enough
+     to handle the largest number of exponent digits expected.  */
+  edigits=4;
+
+  if (ft == FMT_F || ft == FMT_EN
+      || ((ft == FMT_D || ft == FMT_E) && dtp->u.p.scale_factor != 0))
+    {
+      /* Always convert at full precision to avoid double rounding.  */
+      ndigits = MIN_FIELD_WIDTH - 4 - edigits;
+    }
+  else
+    {
+      /* We know the number of digits, so can let printf do the rounding
+	 for us.  */
+      if (ft == FMT_ES)
+	ndigits = d + 1;
+      else
+	ndigits = d;
+      if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
+	ndigits = MIN_FIELD_WIDTH - 4 - edigits;
+    }
+
+  /* #   The result will always contain a decimal point, even if no
+   *     digits follow it
+   *
+   * -   The converted value is to be left adjusted on the field boundary
+   *
+   * +   A sign (+ or -) always be placed before a number
+   *
+   * MIN_FIELD_WIDTH  minimum field width
+   *
+   * *   (ndigits-1) is used as the precision
+   *
+   *   e format: [-]d.ddde±dd where there is one digit before the
+   *   decimal-point character and the number of digits after it is
+   *   equal to the precision. The exponent always contains at least two
+   *   digits; if the value is zero, the exponent is 00.
+   */
+  sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*"
+	   GFC_REAL_LARGEST_FORMAT "e", ndigits - 1, value);
+
+  /* Check the resulting string has punctuation in the correct places.  */
+  if (d != 0 && (buffer[2] != '.' || buffer[ndigits + 2] != 'e'))
+      internal_error (&dtp->common, "printf is broken");
+
+  /* Read the exponent back in.  */
+  e = atoi (&buffer[ndigits + 3]) + 1;
+
+  /* Make sure zero comes out as 0.0e0.  */
+  if (value == 0.0)
+    e = 0;
+
+  /* Normalize the fractional component.  */
+  buffer[2] = buffer[1];
+  digits = &buffer[2];
+
+  /* Figure out where to place the decimal point.  */
+  switch (ft)
+    {
+    case FMT_F:
+      nbefore = e + dtp->u.p.scale_factor;
+      if (nbefore < 0)
+	{
+	  nzero = -nbefore;
+          nzero_real = nzero;
+	  if (nzero > d)
+	    nzero = d;
+	  nafter = d - nzero;
+	  nbefore = 0;
+	}
+      else
+	{
+	  nzero = 0;
+	  nafter = d;
+	}
+      expchar = 0;
+      break;
+
+    case FMT_E:
+    case FMT_D:
+      i = dtp->u.p.scale_factor;
+      if (value != 0.0)
+	e -= i;
+      if (i < 0)
+	{
+	  nbefore = 0;
+	  nzero = -i;
+	  nafter = d + i;
+	}
+      else if (i > 0)
+	{
+	  nbefore = i;
+	  nzero = 0;
+	  nafter = (d - i) + 1;
+	}
+      else /* i == 0 */
+	{
+	  nbefore = 0;
+	  nzero = 0;
+	  nafter = d;
+	}
+
+      if (ft == FMT_E)
+	expchar = 'E';
+      else
+	expchar = 'D';
+      break;
+
+    case FMT_EN:
+      /* The exponent must be a multiple of three, with 1-3 digits before
+	 the decimal point.  */
+      if (value != 0.0)
+        e--;
+      if (e >= 0)
+	nbefore = e % 3;
+      else
+	{
+	  nbefore = (-e) % 3;
+	  if (nbefore != 0)
+	    nbefore = 3 - nbefore;
+	}
+      e -= nbefore;
+      nbefore++;
+      nzero = 0;
+      nafter = d;
+      expchar = 'E';
+      break;
+
+    case FMT_ES:
+      if (value != 0.0)
+        e--;
+      nbefore = 1;
+      nzero = 0;
+      nafter = d;
+      expchar = 'E';
+      break;
+
+    default:
+      /* Should never happen.  */
+      internal_error (&dtp->common, "Unexpected format token");
+    }
+
+  /* Round the value.  */
+  if (nbefore + nafter == 0)
+    {
+      ndigits = 0;
+      if (nzero_real == d && digits[0] >= '5')
+        {
+          /* We rounded to zero but shouldn't have */
+          nzero--;
+          nafter = 1;
+          digits[0] = '1';
+          ndigits = 1;
+        }
+    }
+  else if (nbefore + nafter < ndigits)
+    {
+      ndigits = nbefore + nafter;
+      i = ndigits;
+      if (digits[i] >= '5')
+	{
+	  /* Propagate the carry.  */
+	  for (i--; i >= 0; i--)
+	    {
+	      if (digits[i] != '9')
+		{
+		  digits[i]++;
+		  break;
+		}
+	      digits[i] = '0';
+	    }
+
+	  if (i < 0)
+	    {
+	      /* The carry overflowed.  Fortunately we have some spare space
+		 at the start of the buffer.  We may discard some digits, but
+		 this is ok because we already know they are zero.  */
+	      digits--;
+	      digits[0] = '1';
+	      if (ft == FMT_F)
+		{
+		  if (nzero > 0)
+		    {
+		      nzero--;
+		      nafter++;
+		    }
+		  else
+		    nbefore++;
+		}
+	      else if (ft == FMT_EN)
+		{
+		  nbefore++;
+		  if (nbefore == 4)
+		    {
+		      nbefore = 1;
+		      e += 3;
+		    }
+		}
+	      else
+		e++;
+	    }
+	}
+    }
+
+  /* Calculate the format of the exponent field.  */
+  if (expchar)
+    {
+      edigits = 1;
+      for (i = abs (e); i >= 10; i /= 10)
+	edigits++;
+
+      if (f->u.real.e < 0)
+	{
+	  /* Width not specified.  Must be no more than 3 digits.  */
+	  if (e > 999 || e < -999)
+	    edigits = -1;
+	  else
+	    {
+	      edigits = 4;
+	      if (e > 99 || e < -99)
+		expchar = ' ';
+	    }
+	}
+      else
+	{
+	  /* Exponent width specified, check it is wide enough.  */
+	  if (edigits > f->u.real.e)
+	    edigits = -1;
+	  else
+	    edigits = f->u.real.e + 2;
+	}
+    }
+  else
+    edigits = 0;
+
+  /* Pick a field size if none was specified.  */
+  if (w <= 0)
+    w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
+
+  /* Create the ouput buffer.  */
+  out = write_block (dtp, w);
+  if (out == NULL)
+    return;
+
+  /* Zero values always output as positive, even if the value was negative
+     before rounding.  */
+  for (i = 0; i < ndigits; i++)
+    {
+      if (digits[i] != '0')
+	break;
+    }
+  if (i == ndigits)
+    sign = calculate_sign (dtp, 0);
+
+  /* Work out how much padding is needed.  */
+  nblanks = w - (nbefore + nzero + nafter + edigits + 1);
+  if (sign != SIGN_NONE)
+    nblanks--;
+
+  /* Check the value fits in the specified field width.  */
+  if (nblanks < 0 || edigits == -1)
+    {
+      star_fill (out, w);
+      return;
+    }
+
+  /* See if we have space for a zero before the decimal point.  */
+  if (nbefore == 0 && nblanks > 0)
+    {
+      leadzero = 1;
+      nblanks--;
+    }
+  else
+    leadzero = 0;
+
+  /* Pad to full field width.  */
+
+
+  if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
+    {
+      memset (out, ' ', nblanks);
+      out += nblanks;
+    }
+
+  /* Output the initial sign (if any).  */
+  if (sign == SIGN_PLUS)
+    *(out++) = '+';
+  else if (sign == SIGN_MINUS)
+    *(out++) = '-';
+
+  /* Output an optional leading zero.  */
+  if (leadzero)
+    *(out++) = '0';
+
+  /* Output the part before the decimal point, padding with zeros.  */
+  if (nbefore > 0)
+    {
+      if (nbefore > ndigits)
+	i = ndigits;
+      else
+	i = nbefore;
+
+      memcpy (out, digits, i);
+      while (i < nbefore)
+	out[i++] = '0';
+
+      digits += i;
+      ndigits -= i;
+      out += nbefore;
+    }
+  /* Output the decimal point.  */
+  *(out++) = '.';
+
+  /* Output leading zeros after the decimal point.  */
+  if (nzero > 0)
+    {
+      for (i = 0; i < nzero; i++)
+	*(out++) = '0';
+    }
+
+  /* Output digits after the decimal point, padding with zeros.  */
+  if (nafter > 0)
+    {
+      if (nafter > ndigits)
+	i = ndigits;
+      else
+	i = nafter;
+
+      memcpy (out, digits, i);
+      while (i < nafter)
+	out[i++] = '0';
+
+      digits += i;
+      ndigits -= i;
+      out += nafter;
+    }
+
+  /* Output the exponent.  */
+  if (expchar)
+    {
+      if (expchar != ' ')
+	{
+	  *(out++) = expchar;
+	  edigits--;
+	}
+#if HAVE_SNPRINTF
+      snprintf (buffer, sizeof (buffer), "%+0*d", edigits, e);
+#else
+      sprintf (buffer, "%+0*d", edigits, e);
+#endif
+      memcpy (out, buffer, edigits);
+    }
+
+  if (dtp->u.p.no_leading_blank)
+    {
+      out += edigits;
+      memset( out , ' ' , nblanks );
+      dtp->u.p.no_leading_blank = 0;
+    }
+#undef STR
+#undef STR1
+#undef MIN_FIELD_WIDTH
+}
+
+
+void
+write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
+{
+  char *p;
+  GFC_INTEGER_LARGEST n;
+
+  p = write_block (dtp, f->u.w);
+  if (p == NULL)
+    return;
+
+  memset (p, ' ', f->u.w - 1);
+  n = extract_int (source, len);
+  p[f->u.w - 1] = (n) ? 'T' : 'F';
+}
+
+/* Output a real number according to its format.  */
+
+static void
+write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+  GFC_REAL_LARGEST n;
+  int nb =0, res, save_scale_factor;
+  char * p, fin;
+  fnode *f2 = NULL;
+
+  n = extract_real (source, len);
+
+  if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
+    {
+      res = isfinite (n); 
+      if (res == 0)
+	{
+	  nb =  f->u.real.w;
+	  
+	  /* If the field width is zero, the processor must select a width 
+	     not zero.  4 is chosen to allow output of '-Inf' or '+Inf' */
+	     
+	  if (nb == 0) nb = 4;
+	  p = write_block (dtp, nb);
+          if (p == NULL)
+            return;
+	  if (nb < 3)
+	    {
+	      memset (p, '*',nb);
+	      return;
+	    }
+
+	  memset(p, ' ', nb);
+	  res = !isnan (n);
+	  if (res != 0)
+	    {
+	      if (signbit(n))
+	        {
+	        
+	          /* If the sign is negative and the width is 3, there is
+	             insufficient room to output '-Inf', so output asterisks */
+	             
+	          if (nb == 3)
+	            {
+	              memset (p, '*',nb);
+	              return;
+	            }
+	            
+	          /* The negative sign is mandatory */
+	            
+	          fin = '-';
+		}    
+	      else
+	      
+	          /* The positive sign is optional, but we output it for
+	             consistency */
+	             
+		  fin = '+';
+
+	      if (nb > 8)
+	      
+	        /* We have room, so output 'Infinity' */
+	        
+		memcpy(p + nb - 8, "Infinity", 8);
+	      else
+	      
+	        /* For the case of width equals 8, there is not enough room
+	           for the sign and 'Infinity' so we go with 'Inf' */
+	            
+		memcpy(p + nb - 3, "Inf", 3);
+	      if (nb < 9 && nb > 3)
+		p[nb - 4] = fin;  /* Put the sign in front of Inf */
+	      else if (nb > 8)
+		p[nb - 9] = fin;  /* Put the sign in front of Infinity */
+	    }
+	  else
+	    memcpy(p + nb - 3, "NaN", 3);
+	  return;
+	}
+    }
+
+  if (f->format != FMT_G)
+    output_float (dtp, f, n);
+  else
+    {
+      save_scale_factor = dtp->u.p.scale_factor;
+      f2 = calculate_G_format (dtp, f, n, &nb);
+      output_float (dtp, f2, n);
+      dtp->u.p.scale_factor = save_scale_factor;
+      if (f2 != NULL)
+        free_mem(f2);
+
+      if (nb > 0)
+        {
+	  p = write_block (dtp, nb);
+          if (p == NULL)
+            return;
+          memset (p, ' ', nb);
+        }
+    }
+}
+
+
+static void
+write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
+           const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
+{
+  GFC_UINTEGER_LARGEST n = 0;
+  int w, m, digits, nzero, nblank;
+  char *p;
+  const char *q;
+  char itoa_buf[GFC_BTOA_BUF_SIZE];
+
+  w = f->u.integer.w;
+  m = f->u.integer.m;
+
+  n = extract_uint (source, len);
+
+  /* Special case:  */
+
+  if (m == 0 && n == 0)
+    {
+      if (w == 0)
+        w = 1;
+
+      p = write_block (dtp, w);
+      if (p == NULL)
+        return;
+
+      memset (p, ' ', w);
+      goto done;
+    }
+
+  q = conv (n, itoa_buf, sizeof (itoa_buf));
+  digits = strlen (q);
+
+  /* Select a width if none was specified.  The idea here is to always
+     print something.  */
+
+  if (w == 0)
+    w = ((digits < m) ? m : digits);
+
+  p = write_block (dtp, w);
+  if (p == NULL)
+    return;
+
+  nzero = 0;
+  if (digits < m)
+    nzero = m - digits;
+
+  /* See if things will work.  */
+
+  nblank = w - (nzero + digits);
+
+  if (nblank < 0)
+    {
+      star_fill (p, w);
+      goto done;
+    }
+
+
+  if (!dtp->u.p.no_leading_blank)
+    {
+      memset (p, ' ', nblank);
+      p += nblank;
+      memset (p, '0', nzero);
+      p += nzero;
+      memcpy (p, q, digits);
+    }
+  else
+    {
+      memset (p, '0', nzero);
+      p += nzero;
+      memcpy (p, q, digits);
+      p += digits;
+      memset (p, ' ', nblank);
+      dtp->u.p.no_leading_blank = 0;
+    }
+
+ done:
+  return;
+}
+
+static void
+write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
+	       int len,
+               const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
+{
+  GFC_INTEGER_LARGEST n = 0;
+  int w, m, digits, nsign, nzero, nblank;
+  char *p;
+  const char *q;
+  sign_t sign;
+  char itoa_buf[GFC_BTOA_BUF_SIZE];
+
+  w = f->u.integer.w;
+  m = f->u.integer.m;
+
+  n = extract_int (source, len);
+
+  /* Special case:  */
+
+  if (m == 0 && n == 0)
+    {
+      if (w == 0)
+        w = 1;
+
+      p = write_block (dtp, w);
+      if (p == NULL)
+        return;
+
+      memset (p, ' ', w);
+      goto done;
+    }
+
+  sign = calculate_sign (dtp, n < 0);
+  if (n < 0)
+    n = -n;
+
+  nsign = sign == SIGN_NONE ? 0 : 1;
+  q = conv (n, itoa_buf, sizeof (itoa_buf));
+
+  digits = strlen (q);
+
+  /* Select a width if none was specified.  The idea here is to always
+     print something.  */
+
+  if (w == 0)
+    w = ((digits < m) ? m : digits) + nsign;
+
+  p = write_block (dtp, w);
+  if (p == NULL)
+    return;
+
+  nzero = 0;
+  if (digits < m)
+    nzero = m - digits;
+
+  /* See if things will work.  */
+
+  nblank = w - (nsign + nzero + digits);
+
+  if (nblank < 0)
+    {
+      star_fill (p, w);
+      goto done;
+    }
+
+  memset (p, ' ', nblank);
+  p += nblank;
+
+  switch (sign)
+    {
+    case SIGN_PLUS:
+      *p++ = '+';
+      break;
+    case SIGN_MINUS:
+      *p++ = '-';
+      break;
+    case SIGN_NONE:
+      break;
+    }
+
+  memset (p, '0', nzero);
+  p += nzero;
+
+  memcpy (p, q, digits);
+
+ done:
+  return;
+}
+
+
+/* Convert unsigned octal to ascii.  */
+
+static const char *
+otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
+{
+  char *p;
+
+  assert (len >= GFC_OTOA_BUF_SIZE);
+
+  if (n == 0)
+    return "0";
+
+  p = buffer + GFC_OTOA_BUF_SIZE - 1;
+  *p = '\0';
+
+  while (n != 0)
+    {
+      *--p = '0' + (n & 7);
+      n >>= 3;
+    }
+
+  return p;
+}
+
+
+/* Convert unsigned binary to ascii.  */
+
+static const char *
+btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
+{
+  char *p;
+
+  assert (len >= GFC_BTOA_BUF_SIZE);
+
+  if (n == 0)
+    return "0";
+
+  p = buffer + GFC_BTOA_BUF_SIZE - 1;
+  *p = '\0';
+
+  while (n != 0)
+    {
+      *--p = '0' + (n & 1);
+      n >>= 1;
+    }
+
+  return p;
+}
+
+
+void
+write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+  write_decimal (dtp, f, p, len, (void *) gfc_itoa);
+}
+
+
+void
+write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+  write_int (dtp, f, p, len, btoa);
+}
+
+
+void
+write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+  write_int (dtp, f, p, len, otoa);
+}
+
+void
+write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+  write_int (dtp, f, p, len, xtoa);
+}
+
+
+void
+write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+  write_float (dtp, f, p, len);
+}
+
+
+void
+write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+  write_float (dtp, f, p, len);
+}
+
+
+void
+write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+  write_float (dtp, f, p, len);
+}
+
+
+void
+write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+  write_float (dtp, f, p, len);
+}
+
+
+void
+write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+  write_float (dtp, f, p, len);
+}
+
+
+/* Take care of the X/TR descriptor.  */
+
+void
+write_x (st_parameter_dt *dtp, int len, int nspaces)
+{
+  char *p;
+
+  p = write_block (dtp, len);
+  if (p == NULL)
+    return;
+
+  if (nspaces > 0)
+    memset (&p[len - nspaces], ' ', nspaces);
+}
+
+
+/* List-directed writing.  */
+
+
+/* Write a single character to the output.  Returns nonzero if
+   something goes wrong.  */
+
+static int
+write_char (st_parameter_dt *dtp, char c)
+{
+  char *p;
+
+  p = write_block (dtp, 1);
+  if (p == NULL)
+    return 1;
+
+  *p = c;
+
+  return 0;
+}
+
+
+/* Write a list-directed logical value.  */
+
+static void
+write_logical (st_parameter_dt *dtp, const char *source, int length)
+{
+  write_char (dtp, extract_int (source, length) ? 'T' : 'F');
+}
+
+
+/* Write a list-directed integer value.  */
+
+static void
+write_integer (st_parameter_dt *dtp, const char *source, int length)
+{
+  char *p;
+  const char *q;
+  int digits;
+  int width;
+  char itoa_buf[GFC_ITOA_BUF_SIZE];
+
+  q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
+
+  switch (length)
+    {
+    case 1:
+      width = 4;
+      break;
+
+    case 2:
+      width = 6;
+      break;
+
+    case 4:
+      width = 11;
+      break;
+
+    case 8:
+      width = 20;
+      break;
+
+    default:
+      width = 0;
+      break;
+    }
+
+  digits = strlen (q);
+
+  if (width < digits)
+    width = digits;
+  p = write_block (dtp, width);
+  if (p == NULL)
+    return;
+  if (dtp->u.p.no_leading_blank)
+    {
+      memcpy (p, q, digits);
+      memset (p + digits, ' ', width - digits);
+    }
+  else
+    {
+      memset (p, ' ', width - digits);
+      memcpy (p + width - digits, q, digits);
+    }
+}
+
+
+/* Write a list-directed string.  We have to worry about delimiting
+   the strings if the file has been opened in that mode.  */
+
+static void
+write_character (st_parameter_dt *dtp, const char *source, int length)
+{
+  int i, extra;
+  char *p, d;
+
+  switch (dtp->u.p.current_unit->flags.delim)
+    {
+    case DELIM_APOSTROPHE:
+      d = '\'';
+      break;
+    case DELIM_QUOTE:
+      d = '"';
+      break;
+    default:
+      d = ' ';
+      break;
+    }
+
+  if (d == ' ')
+    extra = 0;
+  else
+    {
+      extra = 2;
+
+      for (i = 0; i < length; i++)
+	if (source[i] == d)
+	  extra++;
+    }
+
+  p = write_block (dtp, length + extra);
+  if (p == NULL)
+    return;
+
+  if (d == ' ')
+    memcpy (p, source, length);
+  else
+    {
+      *p++ = d;
+
+      for (i = 0; i < length; i++)
+	{
+	  *p++ = source[i];
+	  if (source[i] == d)
+	    *p++ = d;
+	}
+
+      *p = d;
+    }
+}
+
+
+/* Output a real number with default format.
+   This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
+   1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
+
+static void
+write_real (st_parameter_dt *dtp, const char *source, int length)
+{
+  fnode f ;
+  int org_scale = dtp->u.p.scale_factor;
+  f.format = FMT_G;
+  dtp->u.p.scale_factor = 1;
+  switch (length)
+    {
+    case 4:
+      f.u.real.w = 14;
+      f.u.real.d = 7;
+      f.u.real.e = 2;
+      break;
+    case 8:
+      f.u.real.w = 23;
+      f.u.real.d = 15;
+      f.u.real.e = 3;
+      break;
+    case 10:
+      f.u.real.w = 28;
+      f.u.real.d = 19;
+      f.u.real.e = 4;
+      break;
+    case 16:
+      f.u.real.w = 43;
+      f.u.real.d = 34;
+      f.u.real.e = 4;
+      break;
+    default:
+      internal_error (&dtp->common, "bad real kind");
+      break;
+    }
+  write_float (dtp, &f, source , length);
+  dtp->u.p.scale_factor = org_scale;
+}
+
+
+static void
+write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
+{
+  if (write_char (dtp, '('))
+    return;
+  write_real (dtp, source, kind);
+
+  if (write_char (dtp, ','))
+    return;
+  write_real (dtp, source + size / 2, kind);
+
+  write_char (dtp, ')');
+}
+
+
+/* Write the separator between items.  */
+
+static void
+write_separator (st_parameter_dt *dtp)
+{
+  char *p;
+
+  p = write_block (dtp, options.separator_len);
+  if (p == NULL)
+    return;
+
+  memcpy (p, options.separator, options.separator_len);
+}
+
+
+/* Write an item with list formatting.
+   TODO: handle skipping to the next record correctly, particularly
+   with strings.  */
+
+static void
+list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
+			     size_t size)
+{
+  if (dtp->u.p.current_unit == NULL)
+    return;
+
+  if (dtp->u.p.first_item)
+    {
+      dtp->u.p.first_item = 0;
+      write_char (dtp, ' ');
+    }
+  else
+    {
+      if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
+	  dtp->u.p.current_unit->flags.delim != DELIM_NONE)
+	write_separator (dtp);
+    }
+
+  switch (type)
+    {
+    case BT_INTEGER:
+      write_integer (dtp, p, kind);
+      break;
+    case BT_LOGICAL:
+      write_logical (dtp, p, kind);
+      break;
+    case BT_CHARACTER:
+      write_character (dtp, p, kind);
+      break;
+    case BT_REAL:
+      write_real (dtp, p, kind);
+      break;
+    case BT_COMPLEX:
+      write_complex (dtp, p, kind, size);
+      break;
+    default:
+      internal_error (&dtp->common, "list_formatted_write(): Bad type");
+    }
+
+  dtp->u.p.char_flag = (type == BT_CHARACTER);
+}
+
+
+void
+list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
+		      size_t size, size_t nelems)
+{
+  size_t elem;
+  char *tmp;
+
+  tmp = (char *) p;
+
+  /* Big loop over all the elements.  */
+  for (elem = 0; elem < nelems; elem++)
+    {
+      dtp->u.p.item_count++;
+      list_formatted_write_scalar (dtp, type, tmp + size*elem, kind, size);
+    }
+}
+
+/*			NAMELIST OUTPUT
+
+   nml_write_obj writes a namelist object to the output stream.  It is called
+   recursively for derived type components:
+	obj    = is the namelist_info for the current object.
+	offset = the offset relative to the address held by the object for
+		 derived type arrays.
+	base   = is the namelist_info of the derived type, when obj is a
+		 component.
+	base_name = the full name for a derived type, including qualifiers
+		    if any.
+   The returned value is a pointer to the object beyond the last one
+   accessed, including nested derived types.  Notice that the namelist is
+   a linear linked list of objects, including derived types and their
+   components.  A tree, of sorts, is implied by the compound names of
+   the derived type components and this is how this function recurses through
+   the list.  */
+
+/* A generous estimate of the number of characters needed to print
+   repeat counts and indices, including commas, asterices and brackets.  */
+
+#define NML_DIGITS 20
+
+static namelist_info *
+nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
+	       namelist_info * base, char * base_name)
+{
+  int rep_ctr;
+  int num;
+  int nml_carry;
+  index_type len;
+  index_type obj_size;
+  index_type nelem;
+  index_type dim_i;
+  index_type clen;
+  index_type elem_ctr;
+  index_type obj_name_len;
+  void * p ;
+  char cup;
+  char * obj_name;
+  char * ext_name;
+  char rep_buff[NML_DIGITS];
+  namelist_info * cmp;
+  namelist_info * retval = obj->next;
+
+  /* Write namelist variable names in upper case. If a derived type,
+     nothing is output.  If a component, base and base_name are set.  */
+
+  if (obj->type != GFC_DTYPE_DERIVED)
+    {
+#ifdef HAVE_CRLF
+      write_character (dtp, "\r\n ", 3);
+#else
+      write_character (dtp, "\n ", 2);
+#endif
+      len = 0;
+      if (base)
+	{
+	  len =strlen (base->var_name);
+	  for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
+            {
+	      cup = toupper (base_name[dim_i]);
+	      write_character (dtp, &cup, 1);
+            }
+	}
+      for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
+	{
+	  cup = toupper (obj->var_name[dim_i]);
+	  write_character (dtp, &cup, 1);
+	}
+      write_character (dtp, "=", 1);
+    }
+
+  /* Counts the number of data output on a line, including names.  */
+
+  num = 1;
+
+  len = obj->len;
+
+  switch (obj->type)
+    {
+
+    case GFC_DTYPE_REAL:
+      obj_size = size_from_real_kind (len);
+      break;
+
+    case GFC_DTYPE_COMPLEX:
+      obj_size = size_from_complex_kind (len);
+      break;
+
+    case GFC_DTYPE_CHARACTER:
+      obj_size = obj->string_length;
+      break;
+
+    default:
+      obj_size = len;      
+    }
+
+  if (obj->var_rank)
+    obj_size = obj->size;
+
+  /* Set the index vector and count the number of elements.  */
+
+  nelem = 1;
+  for (dim_i=0; dim_i < obj->var_rank; dim_i++)
+    {
+      obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
+      nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
+    }
+
+  /* Main loop to output the data held in the object.  */
+
+  rep_ctr = 1;
+  for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
+    {
+
+      /* Build the pointer to the data value.  The offset is passed by
+	 recursive calls to this function for arrays of derived types.
+	 Is NULL otherwise.  */
+
+      p = (void *)(obj->mem_pos + elem_ctr * obj_size);
+      p += offset;
+
+      /* Check for repeat counts of intrinsic types.  */
+
+      if ((elem_ctr < (nelem - 1)) &&
+	  (obj->type != GFC_DTYPE_DERIVED) &&
+	  !memcmp (p, (void*)(p + obj_size ), obj_size ))
+	{
+	  rep_ctr++;
+	}
+
+      /* Execute a repeated output.  Note the flag no_leading_blank that
+	 is used in the functions used to output the intrinsic types.  */
+
+      else
+	{
+	  if (rep_ctr > 1)
+	    {
+	      st_sprintf(rep_buff, " %d*", rep_ctr);
+	      write_character (dtp, rep_buff, strlen (rep_buff));
+	      dtp->u.p.no_leading_blank = 1;
+	    }
+	  num++;
+
+	  /* Output the data, if an intrinsic type, or recurse into this
+	     routine to treat derived types.  */
+
+	  switch (obj->type)
+	    {
+
+	    case GFC_DTYPE_INTEGER:
+	      write_integer (dtp, p, len);
+              break;
+
+	    case GFC_DTYPE_LOGICAL:
+	      write_logical (dtp, p, len);
+              break;
+
+	    case GFC_DTYPE_CHARACTER:
+	      if (dtp->u.p.nml_delim)
+		write_character (dtp, &dtp->u.p.nml_delim, 1);
+	      write_character (dtp, p, obj->string_length);
+	      if (dtp->u.p.nml_delim)
+		write_character (dtp, &dtp->u.p.nml_delim, 1);
+              break;
+
+	    case GFC_DTYPE_REAL:
+	      write_real (dtp, p, len);
+              break;
+
+	    case GFC_DTYPE_COMPLEX:
+	      dtp->u.p.no_leading_blank = 0;
+	      num++;
+              write_complex (dtp, p, len, obj_size);
+              break;
+
+	    case GFC_DTYPE_DERIVED:
+
+	      /* To treat a derived type, we need to build two strings:
+		 ext_name = the name, including qualifiers that prepends
+			    component names in the output - passed to
+			    nml_write_obj.
+		 obj_name = the derived type name with no qualifiers but %
+			    appended.  This is used to identify the
+			    components.  */
+
+	      /* First ext_name => get length of all possible components  */
+
+	      ext_name = (char*)get_mem ( (base_name ? strlen (base_name) : 0)
+					+ (base ? strlen (base->var_name) : 0)
+					+ strlen (obj->var_name)
+					+ obj->var_rank * NML_DIGITS
+					+ 1);
+
+	      strcpy(ext_name, base_name ? base_name : "");
+	      clen = base ? strlen (base->var_name) : 0;
+	      strcat (ext_name, obj->var_name + clen);
+
+	      /* Append the qualifier.  */
+
+	      for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
+		{
+		  strcat (ext_name, dim_i ? "" : "(");
+		  clen = strlen (ext_name);
+		  st_sprintf (ext_name + clen, "%d", (int) obj->ls[dim_i].idx);
+		  strcat (ext_name, (dim_i == obj->var_rank - 1) ? ")" : ",");
+		}
+
+	      /* Now obj_name.  */
+
+	      obj_name_len = strlen (obj->var_name) + 1;
+	      obj_name = get_mem (obj_name_len+1);
+	      strcpy (obj_name, obj->var_name);
+	      strcat (obj_name, "%");
+
+	      /* Now loop over the components. Update the component pointer
+		 with the return value from nml_write_obj => this loop jumps
+		 past nested derived types.  */
+
+	      for (cmp = obj->next;
+		   cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
+		   cmp = retval)
+		{
+		  retval = nml_write_obj (dtp, cmp,
+					  (index_type)(p - obj->mem_pos),
+					  obj, ext_name);
+		}
+
+	      free_mem (obj_name);
+	      free_mem (ext_name);
+	      goto obj_loop;
+
+            default:
+	      internal_error (&dtp->common, "Bad type for namelist write");
+            }
+
+	  /* Reset the leading blank suppression, write a comma and, if 5
+	     values have been output, write a newline and advance to column
+	     2. Reset the repeat counter.  */
+
+	  dtp->u.p.no_leading_blank = 0;
+	  write_character (dtp, ",", 1);
+	  if (num > 5)
+	    {
+	      num = 0;
+#ifdef HAVE_CRLF
+	      write_character (dtp, "\r\n ", 3);
+#else
+	      write_character (dtp, "\n ", 2);
+#endif
+	    }
+	  rep_ctr = 1;
+	}
+
+    /* Cycle through and increment the index vector.  */
+
+obj_loop:
+
+    nml_carry = 1;
+    for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
+      {
+	obj->ls[dim_i].idx += nml_carry ;
+	nml_carry = 0;
+	if (obj->ls[dim_i].idx  > (ssize_t)obj->dim[dim_i].ubound)
+	  {
+	    obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
+	    nml_carry = 1;
+	  }
+       }
+    }
+
+  /* Return a pointer beyond the furthest object accessed.  */
+
+  return retval;
+}
+
+/* This is the entry function for namelist writes.  It outputs the name
+   of the namelist and iterates through the namelist by calls to
+   nml_write_obj.  The call below has dummys in the arguments used in
+   the treatment of derived types.  */
+
+void
+namelist_write (st_parameter_dt *dtp)
+{
+  namelist_info * t1, *t2, *dummy = NULL;
+  index_type i;
+  index_type dummy_offset = 0;
+  char c;
+  char * dummy_name = NULL;
+  unit_delim tmp_delim;
+
+  /* Set the delimiter for namelist output.  */
+
+  tmp_delim = dtp->u.p.current_unit->flags.delim;
+  dtp->u.p.current_unit->flags.delim = DELIM_NONE;
+  switch (tmp_delim)
+    {
+    case (DELIM_QUOTE):
+      dtp->u.p.nml_delim = '"';
+      break;
+
+    case (DELIM_APOSTROPHE):
+      dtp->u.p.nml_delim = '\'';
+      break;
+
+    default:
+      dtp->u.p.nml_delim = '\0';
+      break;
+    }
+
+  write_character (dtp, "&", 1);
+
+  /* Write namelist name in upper case - f95 std.  */
+
+  for (i = 0 ;i < dtp->namelist_name_len ;i++ )
+    {
+      c = toupper (dtp->namelist_name[i]);
+      write_character (dtp, &c ,1);
+    }
+
+  if (dtp->u.p.ionml != NULL)
+    {
+      t1 = dtp->u.p.ionml;
+      while (t1 != NULL)
+	{
+	  t2 = t1;
+	  t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
+	}
+    }
+#ifdef HAVE_CRLF
+  write_character (dtp, "  /\r\n", 5);
+#else
+  write_character (dtp, "  /\n", 4);
+#endif
+
+  /* Recover the original delimiter.  */
+
+  dtp->u.p.current_unit->flags.delim = tmp_delim;
+}
+
+#undef NML_DIGITS