Add gcc-4.6. Synced to @180989

Change-Id: Ie3676586e1d8e3c8cd9f07d022f450d05fa08439
svn://gcc.gnu.org/svn/gcc/branches/google/gcc-4_6-mobile

21 files changed, 19515 insertions, 0 deletions

diff --git a/gcc-4.6/libgfortran/io/close.c b/gcc-4.6/libgfortran/io/close.c
new file mode 100644
index 000000000..1a4d7d16e
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/close.c
@@ -0,0 +1,102 @@
+/* Copyright (C) 2002, 2003, 2005, 2007, 2009 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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "io.h"
+#include "unix.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, LIBERROR_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.6/libgfortran/io/fbuf.c b/gcc-4.6/libgfortran/io/fbuf.c
new file mode 100644
index 000000000..82b3f6ba6
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/fbuf.c
@@ -0,0 +1,270 @@
+/* Copyright (C) 2008, 2009, 2010 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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+
+#include "io.h"
+#include "fbuf.h"
+#include "unix.h"
+#include <string.h>
+#include <stdlib.h>
+
+
+//#define FBUF_DEBUG
+
+
+void
+fbuf_init (gfc_unit * u, int len)
+{
+  if (len == 0)
+    len = 512;			/* Default size.  */
+
+  u->fbuf = get_mem (sizeof (struct fbuf));
+  u->fbuf->buf = get_mem (len);
+  u->fbuf->len = len;
+  u->fbuf->act = u->fbuf->pos = 0;
+}
+
+
+void
+fbuf_destroy (gfc_unit * u)
+{
+  if (u->fbuf == NULL)
+    return;
+  if (u->fbuf->buf)
+    free (u->fbuf->buf);
+  free (u->fbuf);
+  u->fbuf = NULL;
+}
+
+
+static void
+#ifdef FBUF_DEBUG
+fbuf_debug (gfc_unit * u, const char * format, ...)
+{
+  va_list args;
+  va_start(args, format);
+  vfprintf(stderr, format, args);
+  va_end(args);
+  fprintf (stderr, "fbuf_debug pos: %d, act: %d, buf: ''", 
+           u->fbuf->pos, u->fbuf->act);
+  for (int ii = 0; ii < u->fbuf->act; ii++)
+    {
+      putc (u->fbuf->buf[ii], stderr);
+    }
+  fprintf (stderr, "''\n");
+}
+#else
+fbuf_debug (gfc_unit * u __attribute__ ((unused)),
+            const char * format __attribute__ ((unused)),
+            ...) {}
+#endif
+
+  
+
+/* You should probably call this before doing a physical seek on the
+   underlying device.  Returns how much the physical position was
+   modified.  */
+
+int
+fbuf_reset (gfc_unit * u)
+{
+  int seekval = 0;
+
+  if (!u->fbuf)
+    return 0;
+
+  fbuf_debug (u, "fbuf_reset: ");
+  fbuf_flush (u, u->mode);
+  /* If we read past the current position, seek the underlying device
+     back.  */
+  if (u->mode == READING && u->fbuf->act > u->fbuf->pos)
+    {
+      seekval = - (u->fbuf->act - u->fbuf->pos);
+      fbuf_debug (u, "fbuf_reset seekval %d, ", seekval);
+    }
+  u->fbuf->act = u->fbuf->pos = 0;
+  return seekval;
+}
+
+
+/* Return a pointer to the current position in the buffer, and increase
+   the pointer by len. Makes sure that the buffer is big enough, 
+   reallocating if necessary.  */
+
+char *
+fbuf_alloc (gfc_unit * u, int len)
+{
+  int newlen;
+  char *dest;
+  fbuf_debug (u, "fbuf_alloc len %d, ", len);
+  if (u->fbuf->pos + len > u->fbuf->len)
+    {
+      /* Round up to nearest multiple of the current buffer length.  */
+      newlen = ((u->fbuf->pos + len) / u->fbuf->len + 1) * u->fbuf->len;
+      dest = realloc (u->fbuf->buf, newlen);
+      if (dest == NULL)
+	return NULL;
+      u->fbuf->buf = dest;
+      u->fbuf->len = newlen;
+    }
+
+  dest = u->fbuf->buf + u->fbuf->pos;
+  u->fbuf->pos += len;
+  if (u->fbuf->pos > u->fbuf->act)
+    u->fbuf->act = u->fbuf->pos;
+  return dest;
+}
+
+
+/* mode argument is WRITING for write mode and READING for read
+   mode. Return value is 0 for success, -1 on failure.  */
+
+int
+fbuf_flush (gfc_unit * u, unit_mode mode)
+{
+  int nwritten;
+
+  if (!u->fbuf)
+    return 0;
+
+  fbuf_debug (u, "fbuf_flush with mode %d: ", mode);
+
+  if (mode == WRITING)
+    {
+      if (u->fbuf->pos > 0)
+	{
+	  nwritten = swrite (u->s, u->fbuf->buf, u->fbuf->pos);
+	  if (nwritten < 0)
+	    return -1;
+	}
+    }
+  /* Salvage remaining bytes for both reading and writing. This
+     happens with the combination of advance='no' and T edit
+     descriptors leaving the final position somewhere not at the end
+     of the record. For reading, this also happens if we sread() past
+     the record boundary.  */ 
+  if (u->fbuf->act > u->fbuf->pos && u->fbuf->pos > 0)
+    memmove (u->fbuf->buf, u->fbuf->buf + u->fbuf->pos, 
+             u->fbuf->act - u->fbuf->pos);
+
+  u->fbuf->act -= u->fbuf->pos;
+  u->fbuf->pos = 0;
+
+  return 0;
+}
+
+
+int
+fbuf_seek (gfc_unit * u, int off, int whence)
+{
+  if (!u->fbuf)
+    return -1;
+
+  switch (whence)
+    {
+    case SEEK_SET:
+      break;
+    case SEEK_CUR:
+      off += u->fbuf->pos;
+      break;
+    case SEEK_END:
+      off += u->fbuf->act;
+      break;
+    default:
+      return -1;
+    }
+
+  fbuf_debug (u, "fbuf_seek, off %d ", off);
+  /* The start of the buffer is always equal to the left tab
+     limit. Moving to the left past the buffer is illegal in C and
+     would also imply moving past the left tab limit, which is never
+     allowed in Fortran. Similarly, seeking past the end of the buffer
+     is not possible, in that case the user must make sure to allocate
+     space with fbuf_alloc().  So return error if that is
+     attempted.  */
+  if (off < 0 || off > u->fbuf->act)
+    return -1;
+  u->fbuf->pos = off;
+  return off;
+}
+
+
+/* Fill the buffer with bytes for reading.  Returns a pointer to start
+   reading from. If we hit EOF, returns a short read count. If any
+   other error occurs, return NULL.  After reading, the caller is
+   expected to call fbuf_seek to update the position with the number
+   of bytes actually processed. */
+
+char *
+fbuf_read (gfc_unit * u, int * len)
+{
+  char *ptr;
+  int oldact, oldpos;
+  int readlen = 0;
+
+  fbuf_debug (u, "fbuf_read, len %d: ", *len);
+  oldact = u->fbuf->act;
+  oldpos = u->fbuf->pos;
+  ptr = fbuf_alloc (u, *len);
+  u->fbuf->pos = oldpos;
+  if (oldpos + *len > oldact)
+    {
+      fbuf_debug (u, "reading %d bytes starting at %d ", 
+                  oldpos + *len - oldact, oldact);
+      readlen = sread (u->s, u->fbuf->buf + oldact, oldpos + *len - oldact);
+      if (readlen < 0)
+	return NULL;
+      *len = oldact - oldpos + readlen;
+    }
+  u->fbuf->act = oldact + readlen;
+  fbuf_debug (u, "fbuf_read done: ");
+  return ptr;
+}
+
+
+/* When the fbuf_getc() inline function runs out of buffer space, it
+   calls this function to fill the buffer with bytes for
+   reading. Never call this function directly.  */
+
+int
+fbuf_getc_refill (gfc_unit * u)
+{
+  int nread;
+  char *p;
+
+  fbuf_debug (u, "fbuf_getc_refill ");
+
+  /* Read 80 bytes (average line length?).  This is a compromise
+     between not needing to call the read() syscall all the time and
+     not having to memmove unnecessary stuff when switching to the
+     next record.  */
+  nread = 80;
+
+  p = fbuf_read (u, &nread);
+
+  if (p && nread > 0)
+    return (unsigned char) u->fbuf->buf[u->fbuf->pos++];
+  else
+    return EOF;
+}
diff --git a/gcc-4.6/libgfortran/io/fbuf.h b/gcc-4.6/libgfortran/io/fbuf.h
new file mode 100644
index 000000000..3a2883bc5
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/fbuf.h
@@ -0,0 +1,87 @@
+/* Copyright (C) 2009
+   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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef GFOR_FBUF_H
+#define GFOR_FBUF_H
+
+#include "io.h"
+
+
+/* Formatting buffer. This is a temporary scratch buffer used by
+   formatted read and writes.  After every formatted I/O statement,
+   this buffer is flushed. This buffer is needed since not all devices
+   are seekable, and T or TL edit descriptors require moving backwards
+   in the record.  However, advance='no' complicates the situation, so
+   the buffer must only be partially flushed from the end of the last
+   flush until the current position in the record. */
+
+struct fbuf
+{
+  char *buf;			/* Start of buffer.  */
+  int len;			/* Length of buffer.  */
+  int act;			/* Active bytes in buffer.  */
+  int pos;			/* Current position in buffer.  */
+};
+
+extern void fbuf_init (gfc_unit *, int);
+internal_proto(fbuf_init);
+
+extern void fbuf_destroy (gfc_unit *);
+internal_proto(fbuf_destroy);
+
+extern int fbuf_reset (gfc_unit *);
+internal_proto(fbuf_reset);
+
+extern char * fbuf_alloc (gfc_unit *, int);
+internal_proto(fbuf_alloc);
+
+extern int fbuf_flush (gfc_unit *, unit_mode);
+internal_proto(fbuf_flush);
+
+extern int fbuf_seek (gfc_unit *, int, int);
+internal_proto(fbuf_seek);
+
+extern char * fbuf_read (gfc_unit *, int *);
+internal_proto(fbuf_read);
+
+/* Never call this function, only use fbuf_getc().  */
+extern int fbuf_getc_refill (gfc_unit *);
+internal_proto(fbuf_getc_refill);
+
+static inline int
+fbuf_getc (gfc_unit * u)
+{
+  if (u->fbuf->pos < u->fbuf->act)
+    return (unsigned char) u->fbuf->buf[u->fbuf->pos++];
+  return fbuf_getc_refill (u);
+}
+
+static inline char *
+fbuf_getptr (gfc_unit * u)
+{
+  return (char*) (u->fbuf->buf + u->fbuf->pos);
+}
+
+#endif
diff --git a/gcc-4.6/libgfortran/io/file_pos.c b/gcc-4.6/libgfortran/io/file_pos.c
new file mode 100644
index 000000000..b034f3825
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/file_pos.c
@@ -0,0 +1,463 @@
+/* Copyright (C) 2002-2003, 2005, 2006, 2007, 2009, 2010
+   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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "io.h"
+#include "fbuf.h"
+#include "unix.h"
+#include <string.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.  */
+
+static const int READ_CHUNK = 4096;
+
+static void
+formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
+{
+  gfc_offset base;
+  char p[READ_CHUNK];
+  ssize_t n;
+
+  base = stell (u->s) - 1;
+
+  do
+    {
+      n = (base < READ_CHUNK) ? base : READ_CHUNK;
+      base -= n;
+      if (sseek (u->s, base, SEEK_SET) < 0)
+        goto io_error;
+      if (sread (u->s, p, n) != n)
+	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.  */
+
+      while (n > 0)
+	{
+          n--;
+	  if (p[n] == '\n')
+	    {
+	      base += n + 1;
+	      goto done;
+	    }
+	}
+
+    }
+  while (base != 0);
+
+  /* base is the new pointer.  Seek to it exactly.  */
+ done:
+  if (sseek (u->s, base, SEEK_SET) < 0)
+    goto io_error;
+  u->last_record--;
+  u->endfile = NO_ENDFILE;
+
+  return;
+
+ io_error:
+  generate_error (&fpp->common, LIBERROR_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, slen;
+  GFC_INTEGER_4 m4;
+  GFC_INTEGER_8 m8;
+  ssize_t length;
+  int continued;
+  char p[sizeof (GFC_INTEGER_8)];
+
+  if (compile_options.record_marker == 0)
+    length = sizeof (GFC_INTEGER_4);
+  else
+    length = compile_options.record_marker;
+
+  do
+    {
+      slen = - (gfc_offset) length;
+      if (sseek (u->s, slen, SEEK_CUR) < 0)
+        goto io_error;
+      if (sread (u->s, p, length) != length)
+        goto io_error;
+
+      /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
+      if (likely (u->flags.convert == GFC_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 (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
+	goto io_error;
+    } while (continued);
+
+  u->last_record--;
+  return;
+
+ io_error:
+  generate_error (&fpp->common, LIBERROR_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, LIBERROR_BAD_UNIT, NULL);
+      goto done;
+    }
+
+  /* Direct access is prohibited, and so is unformatted stream access.  */
+
+
+  if (u->flags.access == ACCESS_DIRECT)
+    {
+      generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+		      "Cannot BACKSPACE a file opened for DIRECT access");
+      goto done;
+    }
+
+  if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
+    {
+      generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+                      "Cannot BACKSPACE an unformatted stream file");
+      goto done;
+    }
+
+  /* Make sure format buffer is flushed and reset.  */
+  if (u->flags.form == FORM_FORMATTED)
+    {
+      int pos = fbuf_reset (u);
+      if (pos != 0)
+        sseek (u->s, pos, SEEK_CUR);
+    }
+
+  
+  /* Check for special cases involving the ENDFILE record first.  */
+
+  if (u->endfile == AFTER_ENDFILE)
+    {
+      u->endfile = AT_ENDFILE;
+      u->flags.position = POSITION_APPEND;
+      sflush (u->s);
+    }
+  else
+    {
+      if (stell (u->s) == 0)
+	{
+	  u->flags.position = POSITION_REWIND;
+	  goto done;		/* Common special case */
+	}
+
+      if (u->mode == WRITING)
+	{
+	  /* If there are previously written bytes from a write with
+	     ADVANCE="no", add a record marker before performing the
+	     BACKSPACE.  */
+
+	  if (u->previous_nonadvancing_write)
+	    finish_last_advance_record (u);
+
+	  u->previous_nonadvancing_write = 0;
+
+	  unit_truncate (u, stell (u->s), &fpp->common);
+	  u->mode = READING;
+        }
+
+      if (u->flags.form == FORM_FORMATTED)
+	formatted_backspace (fpp, u);
+      else
+	unformatted_backspace (fpp, u);
+
+      u->flags.position = POSITION_UNSPECIFIED;
+      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->flags.access == ACCESS_DIRECT)
+	{
+	  generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+			  "Cannot perform ENDFILE on a file opened "
+			  "for DIRECT access");
+	  goto done;
+	}
+
+      if (u->flags.access == ACCESS_SEQUENTIAL
+      	  && u->endfile == AFTER_ENDFILE)
+	{
+	  generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+			  "Cannot perform ENDFILE on a file already "
+			  "positioned after the EOF marker");
+	  goto done;
+	}
+
+      /* If there are previously written bytes from a write with ADVANCE="no",
+	 add a record marker before performing the ENDFILE.  */
+
+      if (u->previous_nonadvancing_write)
+	finish_last_advance_record (u);
+
+      u->previous_nonadvancing_write = 0;
+
+      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);
+	}
+
+      unit_truncate (u, stell (u->s), &fpp->common);
+      u->endfile = AFTER_ENDFILE;
+      if (0 == stell (u->s))
+        u->flags.position = POSITION_REWIND;
+    }
+  else
+    {
+      if (fpp->common.unit < 0)
+	{
+	  generate_error (&fpp->common, LIBERROR_BAD_OPTION,
+			  "Bad unit number in statement");
+	  return;
+	}
+
+      u = find_or_create_unit (fpp->common.unit);
+      if (u->s == NULL)
+	{
+	  /* Open the unit with some default flags.  */
+	  st_parameter_open opp;
+	  unit_flags u_flags;
+
+	  memset (&u_flags, '\0', sizeof (u_flags));
+	  u_flags.access = ACCESS_SEQUENTIAL;
+	  u_flags.action = ACTION_READWRITE;
+
+	  /* Is it unformatted?  */
+	  if (!(fpp->common.flags & (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.decimal = DECIMAL_UNSPECIFIED;
+	  u_flags.encoding = ENCODING_UNSPECIFIED;
+	  u_flags.async = ASYNC_UNSPECIFIED;
+	  u_flags.round = ROUND_UNSPECIFIED;
+	  u_flags.sign = SIGN_UNSPECIFIED;
+	  u_flags.status = STATUS_UNKNOWN;
+	  u_flags.convert = GFC_CONVERT_NATIVE;
+
+	  opp.common = fpp->common;
+	  opp.common.flags &= IOPARM_COMMON_MASK;
+	  u = new_unit (&opp, u, &u_flags);
+	  if (u == NULL)
+	    return;
+	  u->endfile = AFTER_ENDFILE;
+	}
+    }
+
+  done:
+    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, LIBERROR_BAD_OPTION,
+			"Cannot REWIND a file opened for DIRECT access");
+      else
+	{
+	  /* If there are previously written bytes from a write with ADVANCE="no",
+	     add a record marker before performing the ENDFILE.  */
+
+	  if (u->previous_nonadvancing_write)
+	    finish_last_advance_record (u);
+
+	  u->previous_nonadvancing_write = 0;
+
+	  fbuf_reset (u);
+
+	  u->last_record = 0;
+
+	  if (sseek (u->s, 0, SEEK_SET) < 0)
+	    generate_error (&fpp->common, LIBERROR_OS, NULL);
+
+	  /* Handle special files like /dev/null differently.  */
+	  if (!is_special (u->s))
+	    {
+	      /* We are rewinding so we are not at the end.  */
+	      u->endfile = NO_ENDFILE;
+	    }
+	  else
+	    {
+	      /* Set this for compatibilty with g77 for /dev/null.  */
+	      if (file_length (u->s) == 0  && stell (u->s) == 0)
+		u->endfile = AT_ENDFILE;
+	      /* Future refinements on special files can go here.  */
+	    }
+
+	  u->current_record = 0;
+	  u->strm_pos = 1;
+	  u->read_bad = 0;
+	}
+      /* 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)
+    {
+      /* Make sure format buffer is flushed.  */
+      if (u->flags.form == FORM_FORMATTED)
+        fbuf_flush (u, u->mode);
+
+      sflush (u->s);
+      unlock_unit (u);
+    }
+  else
+    /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */ 
+    generate_error (&fpp->common, LIBERROR_BAD_OPTION,
+			"Specified UNIT in FLUSH is not connected");
+
+  library_end ();
+}
diff --git a/gcc-4.6/libgfortran/io/format.c b/gcc-4.6/libgfortran/io/format.c
new file mode 100644
index 000000000..d540fc47e
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/format.c
@@ -0,0 +1,1400 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   F2003 I/O support contributed by Jerry DeLisle
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* format.c-- parse a FORMAT string into a binary format suitable for
+ * interpretation during I/O statements */
+
+#include "io.h"
+#include "format.h"
+#include <ctype.h>
+#include <string.h>
+#include <stdbool.h>
+#include <stdlib.h>
+
+
+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 '%c' in format\n",
+  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",
+  zero_width[] = "Zero width in format descriptor";
+
+/* The following routines support caching format data from parsed format strings
+   into a hash table.  This avoids repeatedly parsing duplicate format strings
+   or format strings in I/O statements that are repeated in loops.  */
+
+
+/* Traverse the table and free all data.  */
+
+void
+free_format_hash_table (gfc_unit *u)
+{
+  size_t i;
+
+  /* free_format_data handles any NULL pointers.  */
+  for (i = 0; i < FORMAT_HASH_SIZE; i++)
+    {
+      if (u->format_hash_table[i].hashed_fmt != NULL)
+	{
+	  free_format_data (u->format_hash_table[i].hashed_fmt);
+	  free (u->format_hash_table[i].key);
+	}
+      u->format_hash_table[i].key = NULL;
+      u->format_hash_table[i].key_len = 0;      
+      u->format_hash_table[i].hashed_fmt = NULL;
+    }
+}
+
+/* Traverse the format_data structure and reset the fnode counters.  */
+
+static void
+reset_node (fnode *fn)
+{
+  fnode *f;
+
+  fn->count = 0;
+  fn->current = NULL;
+  
+  if (fn->format != FMT_LPAREN)
+    return;
+
+  for (f = fn->u.child; f; f = f->next)
+    {
+      if (f->format == FMT_RPAREN)
+	break;
+      reset_node (f);
+    }
+}
+
+static void
+reset_fnode_counters (st_parameter_dt *dtp)
+{
+  fnode *f;
+  format_data *fmt;
+
+  fmt = dtp->u.p.fmt;
+
+  /* Clear this pointer at the head so things start at the right place.  */
+  fmt->array.array[0].current = NULL;
+
+  for (f = fmt->array.array[0].u.child; f; f = f->next)
+    reset_node (f);
+}
+
+
+/* A simple hashing function to generate an index into the hash table.  */
+
+static inline
+uint32_t format_hash (st_parameter_dt *dtp)
+{
+  char *key;
+  gfc_charlen_type key_len;
+  uint32_t hash = 0;
+  gfc_charlen_type i;
+
+  /* Hash the format string. Super simple, but what the heck!  */
+  key = dtp->format;
+  key_len = dtp->format_len;
+  for (i = 0; i < key_len; i++)
+    hash ^= key[i];
+  hash &= (FORMAT_HASH_SIZE - 1);
+  return hash;
+}
+
+
+static void
+save_parsed_format (st_parameter_dt *dtp)
+{
+  uint32_t hash;
+  gfc_unit *u;
+
+  hash = format_hash (dtp);
+  u = dtp->u.p.current_unit;
+
+  /* Index into the hash table.  We are simply replacing whatever is there
+     relying on probability.  */
+  if (u->format_hash_table[hash].hashed_fmt != NULL)
+    free_format_data (u->format_hash_table[hash].hashed_fmt);
+  u->format_hash_table[hash].hashed_fmt = NULL;
+
+  if (u->format_hash_table[hash].key != NULL)
+    free (u->format_hash_table[hash].key);
+  u->format_hash_table[hash].key = get_mem (dtp->format_len);
+  memcpy (u->format_hash_table[hash].key, dtp->format, dtp->format_len);
+
+  u->format_hash_table[hash].key_len = dtp->format_len;
+  u->format_hash_table[hash].hashed_fmt = dtp->u.p.fmt;
+}
+
+
+static format_data *
+find_parsed_format (st_parameter_dt *dtp)
+{
+  uint32_t hash;
+  gfc_unit *u;
+
+  hash = format_hash (dtp);
+  u = dtp->u.p.current_unit;
+
+  if (u->format_hash_table[hash].key != NULL)
+    {
+      /* See if it matches.  */
+      if (u->format_hash_table[hash].key_len == dtp->format_len)
+	{
+	  /* So far so good.  */
+	  if (strncmp (u->format_hash_table[hash].key,
+	      dtp->format, dtp->format_len) == 0)
+	    return u->format_hash_table[hash].hashed_fmt;
+	}
+    }
+  return NULL;
+}
+
+
+/* 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++);
+      fmt->error_element = c;
+    }
+  while ((c == ' ' || c == '\t') && !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 (format_data *fmt)
+{
+  fnode_array *fa, *fa_next;
+
+
+  if (fmt == NULL)
+    return;
+
+  for (fa = fmt->array.next; fa; fa = fa_next)
+    {
+      fa_next = fa->next;
+      free (fa);
+    }
+
+  free (fmt);
+  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 '*':
+       token = FMT_STAR;
+       break;
+
+    case '(':
+      token = FMT_LPAREN;
+      break;
+
+    case ')':
+      token = FMT_RPAREN;
+      break;
+
+    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 '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':
+      switch (next_char (fmt, 0))
+	{
+	case 'P':
+	  token = FMT_DP;
+	  break;
+	case 'C':
+	  token = FMT_DC;
+	  break;
+	default:
+	  token = FMT_D;
+	  unget_char (fmt);
+	  break;
+	}
+      break;
+
+    case 'R':
+      switch (next_char (fmt, 0))
+	{
+	case 'C':
+	  token = FMT_RC;
+	  break;
+	case 'D':
+	  token = FMT_RD;
+	  break;
+	case 'N':
+	  token = FMT_RN;
+	  break;
+	case 'P':
+	  token = FMT_RP;
+	  break;
+	case 'U':
+	  token = FMT_RU;
+	  break;
+	case 'Z':
+	  token = FMT_RZ;
+	  break;
+	default:
+	  unget_char (fmt);
+	  token = FMT_UNKNOWN;
+	  break;
+	}
+      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, bool *save_ok, bool *seen_dd)
+{
+  fnode *head, *tail;
+  format_token t, u, t2;
+  int repeat;
+  format_data *fmt = dtp->u.p.fmt;
+  bool saveit, seen_data_desc = false;
+
+  head = tail = NULL;
+  saveit = *save_ok;
+
+  /* Get the next format item */
+ format_item:
+  t = format_lex (fmt);
+ format_item_1:
+  switch (t)
+    {
+    case FMT_STAR:
+      t = format_lex (fmt);
+      if (t != FMT_LPAREN)
+	{
+	  fmt->error = "Left parenthesis required after '*'";
+	  goto finished;
+	}
+      get_fnode (fmt, &head, &tail, FMT_LPAREN);
+      tail->repeat = -2;  /* Signifies unlimited format.  */
+      tail->u.child = parse_format_list (dtp, &saveit, &seen_data_desc);
+      if (fmt->error != NULL)
+	goto finished;
+      if (!seen_data_desc)
+	{
+	  fmt->error = "'*' requires at least one associated data descriptor";
+	  goto finished;
+	}
+      goto between_desc;
+
+    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, &saveit, &seen_data_desc);
+	  *seen_dd = seen_data_desc;
+	  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, &saveit, &seen_data_desc);
+      *seen_dd = seen_data_desc;
+      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;
+	}
+
+      if (t != FMT_COMMA && t != FMT_RPAREN && t != FMT_SLASH
+	  && t != FMT_POSINT)
+	{
+	  fmt->error = "Comma required after P descriptor";
+	  goto finished;
+	}
+
+      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:
+      /* TODO: Find out why it is necessary to turn off format caching.  */
+      saveit = false;
+      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_RC:
+    case FMT_RD:
+    case FMT_RN:
+    case FMT_RP:
+    case FMT_RU:
+    case FMT_RZ:
+      notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: Round "
+		  "descriptor not allowed");
+      get_fnode (fmt, &head, &tail, t);
+      tail->repeat = 1;
+      goto between_desc;
+
+    case FMT_DC:
+    case FMT_DP:
+      notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: DC or DP "
+		  "descriptor not allowed");
+    /* Fall through.  */
+    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;
+      *seen_dd = true;
+      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_L:
+      t = format_lex (fmt);
+      if (t != FMT_POSINT)
+	{
+	  if (notification_std(GFC_STD_GNU) == NOTIFICATION_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_ZERO)
+	{
+	  fmt->error = zero_width;
+	  goto finished;
+	}
+
+      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_G && u == FMT_ZERO)
+	{
+	  if (notification_std (GFC_STD_F2008) == NOTIFICATION_ERROR
+	      || dtp->u.p.mode == READING)
+	    {
+	      fmt->error = zero_width;
+	      goto finished;
+	    }
+	  tail->u.real.w = 0;
+	  u = format_lex (fmt);
+	  if (u != FMT_PERIOD)
+	    {
+	      fmt->saved_token = u;
+	      break;
+	    }
+
+	  u = format_lex (fmt);
+	  if (u != FMT_POSINT)
+	    {
+	      fmt->error = posint_required;
+	      goto finished;
+	    }
+	  tail->u.real.d = fmt->value;
+	  break;
+	}
+      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;
+	  tail->u.real.e = -1;
+	  break;
+	}
+
+      t = format_lex (fmt);
+      if (t != FMT_ZERO && t != FMT_POSINT)
+	{
+	  fmt->error = nonneg_required;
+	  goto finished;
+	}
+
+      tail->u.real.d = fmt->value;
+      tail->u.real.e = -1;
+
+      if (t2 == FMT_D || t2 == FMT_F)
+	break;
+
+
+      /* 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:
+    case FMT_COLON:
+      get_fnode (fmt, &head, &tail, t);
+      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:
+
+  *save_ok = saveit;
+  
+  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;
+
+  if (message == unexpected_element)
+    sprintf (buffer, message, fmt->error_element);
+  else
+    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, LIBERROR_FORMAT, buffer);
+}
+
+
+/* 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;
+}
+
+/* parse_format()-- Parse a format string.  */
+
+void
+parse_format (st_parameter_dt *dtp)
+{
+  format_data *fmt;
+  bool format_cache_ok, seen_data_desc = false;
+
+  /* Don't cache for internal units and set an arbitrary limit on the size of
+     format strings we will cache.  (Avoids memory issues.)  */
+  format_cache_ok = !is_internal_unit (dtp);
+
+  /* Lookup format string to see if it has already been parsed.  */
+  if (format_cache_ok)
+    {
+      dtp->u.p.fmt = find_parsed_format (dtp);
+
+      if (dtp->u.p.fmt != NULL)
+	{
+	  dtp->u.p.fmt->reversion_ok = 0;
+	  dtp->u.p.fmt->saved_token = FMT_NONE;
+	  dtp->u.p.fmt->saved_format = NULL;
+	  reset_fnode_counters (dtp);
+	  return;
+	}
+    }
+
+  /* Not found so proceed as follows.  */
+
+  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, &format_cache_ok,
+						     &seen_data_desc);
+  else
+    fmt->error = "Missing initial left parenthesis in format";
+
+  if (fmt->error)
+    {
+      format_error (dtp, NULL, fmt->error);
+      free_format_hash_table (dtp->u.p.current_unit);
+      return;
+    }
+
+  if (format_cache_ok)
+    save_parsed_format (dtp);
+  else
+    dtp->u.p.format_not_saved = 1;
+}
+
+
+/* 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 with unlimited format.  */
+
+  if (f->repeat == -2)  /* -2 signifies unlimited.  */
+  for (;;)
+    {
+      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;
+	}
+    }
+
+  /* Deal with a parenthesis node with specific repeat count.  */
+  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 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.6/libgfortran/io/format.h b/gcc-4.6/libgfortran/io/format.h
new file mode 100644
index 000000000..87d86419b
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/format.h
@@ -0,0 +1,145 @@
+/* Copyright (C) 2009, 2010
+   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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef GFOR_FORMAT_H
+#define GFOR_FORMAT_H
+
+#include "io.h"
+
+
+/* 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, FMT_DC,
+  FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
+}
+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.  */
+
+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;
+
+};
+
+
+/* A storage structures for format node data.  */
+
+#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;
+  char error_element;
+  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;
+
+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 (struct format_data *);
+internal_proto(free_format_data);
+
+extern void free_format_hash_table (gfc_unit *);
+internal_proto(free_format_hash_table);
+
+extern void init_format_hash (st_parameter_dt *);
+internal_proto(init_format_hash);
+
+extern void free_format_hash (st_parameter_dt *);
+internal_proto(free_format_hash);
+
+#endif
diff --git a/gcc-4.6/libgfortran/io/inquire.c b/gcc-4.6/libgfortran/io/inquire.c
new file mode 100644
index 000000000..252f29f0a
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/inquire.c
@@ -0,0 +1,705 @@
+/* Copyright (C) 2002, 2003, 2005, 2007, 2009, 2010, 2011
+   Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* Implement the non-IOLENGTH variant of the INQUIRY statement */
+
+#include "io.h"
+#include "unix.h"
+#include <string.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
+		     && iqp->common.unit <= GFC_INTEGER_4_HUGE);
+
+      if ((cf & IOPARM_INQUIRE_HAS_FILE) == 0)
+	{
+	  if (!(*iqp->exist))
+	    *iqp->common.iostat = LIBERROR_BAD_UNIT;
+	  *iqp->exist = *iqp->exist
+			&& (*iqp->common.iostat != LIBERROR_BAD_UNIT);
+	}
+    }
+
+  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)
+    {
+#if defined(HAVE_TTYNAME_R) || defined(HAVE_TTYNAME)
+      if (u->unit_number == options.stdin_unit
+	  || u->unit_number == options.stdout_unit
+	  || u->unit_number == options.stderr_unit)
+	{
+	  int err = stream_ttyname (u->s, iqp->name, iqp->name_len);
+	  if (err == 0)
+	    {
+	      gfc_charlen_type tmplen = strlen (iqp->name);
+	      if (iqp->name_len > tmplen)
+		memset (&iqp->name[tmplen], ' ', iqp->name_len - tmplen);
+	    }
+	  else /* If ttyname does not work, go with the default.  */
+	    fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
+	}
+      else
+	fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
+#elif defined __MINGW32__
+      if (u->unit_number == options.stdin_unit)
+	fstrcpy (iqp->name, iqp->name_len, "CONIN$", sizeof("CONIN$"));
+      else if (u->unit_number == options.stdout_unit)
+	fstrcpy (iqp->name, iqp->name_len, "CONOUT$", sizeof("CONOUT$"));
+      else if (u->unit_number == options.stderr_unit)
+	fstrcpy (iqp->name, iqp->name_len, "CONERR$", sizeof("CONERR$"));
+      else
+	fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
+#else
+    fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
+#endif
+    }
+
+  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
+	switch (u->flags.access)
+	  {
+	  case ACCESS_DIRECT:
+	  case ACCESS_STREAM:
+	    p = "NO";
+	    break;
+	  case ACCESS_SEQUENTIAL:
+	    p = "YES";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad access");
+	  }
+
+      cf_strcpy (iqp->sequential, iqp->sequential_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
+    {
+      if (u == NULL)
+	p = inquire_direct (NULL, 0);
+      else
+	switch (u->flags.access)
+	  {
+	  case ACCESS_SEQUENTIAL:
+	  case ACCESS_STREAM:
+	    p = "NO";
+	    break;
+	  case ACCESS_DIRECT:
+	    p = "YES";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad access");
+	  }
+
+      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)
+    {
+      if (u == NULL)
+	p = inquire_formatted (NULL, 0);
+      else
+	switch (u->flags.form)
+	  {
+	  case FORM_FORMATTED:
+	    p = "YES";
+	    break;
+	  case FORM_UNFORMATTED:
+	    p = "NO";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad form");
+	  }
+
+      cf_strcpy (iqp->formatted, iqp->formatted_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
+    {
+      if (u == NULL)
+	p = inquire_unformatted (NULL, 0);
+      else
+	switch (u->flags.form)
+	  {
+	  case FORM_FORMATTED:
+	    p = "NO";
+	    break;
+	  case FORM_UNFORMATTED:
+	    p = "YES";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad form");
+	  }
+
+      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)
+    {
+      /* This only makes sense in the context of DIRECT access.  */
+      if (u != NULL && u->flags.access == ACCESS_DIRECT)
+	*iqp->nextrec = u->last_record + 1;
+      else
+	*iqp->nextrec = 0;
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
+    {
+      if (u == NULL || u->flags.form != FORM_FORMATTED)
+	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_PAD) != 0)
+    {
+      if (u == NULL || u->flags.form != FORM_FORMATTED)
+	p = undefined;
+      else
+	switch (u->flags.pad)
+	  {
+	  case PAD_YES:
+	    p = "YES";
+	    break;
+	  case PAD_NO:
+	    p = "NO";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
+	  }
+
+      cf_strcpy (iqp->pad, iqp->pad_len, p);
+    }
+
+  if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
+    {
+      GFC_INTEGER_4 cf2 = iqp->flags2;
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
+	*iqp->pending = 0;
+  
+      if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
+        *iqp->id = 0;
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
+	{
+	  if (u == NULL || u->flags.form != FORM_FORMATTED)
+	    p = undefined;
+          else
+	    switch (u->flags.encoding)
+	      {
+	      case ENCODING_DEFAULT:
+		p = "UNKNOWN";
+		break;
+	      case ENCODING_UTF8:
+		p = "UTF-8";
+		break;
+	      default:
+		internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
+	      }
+
+	  cf_strcpy (iqp->encoding, iqp->encoding_len, p);
+	}
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
+	{
+	  if (u == NULL || u->flags.form != FORM_FORMATTED)
+	    p = undefined;
+	  else
+	    switch (u->flags.decimal)
+	      {
+	      case DECIMAL_POINT:
+		p = "POINT";
+		break;
+	      case DECIMAL_COMMA:
+		p = "COMMA";
+		break;
+	      default:
+		internal_error (&iqp->common, "inquire_via_unit(): Bad comma");
+	      }
+
+	  cf_strcpy (iqp->decimal, iqp->decimal_len, p);
+	}
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0)
+	{
+	  if (u == NULL)
+	    p = undefined;
+	  else
+	    switch (u->flags.async)
+	    {
+	      case ASYNC_YES:
+		p = "YES";
+		break;
+	      case ASYNC_NO:
+		p = "NO";
+		break;
+	      default:
+		internal_error (&iqp->common, "inquire_via_unit(): Bad async");
+	    }
+
+	  cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
+	}
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
+	{
+	  if (u == NULL)
+	    p = undefined;
+	  else
+	    switch (u->flags.sign)
+	    {
+	      case SIGN_PROCDEFINED:
+		p = "PROCESSOR_DEFINED";
+		break;
+	      case SIGN_SUPPRESS:
+		p = "SUPPRESS";
+		break;
+	      case SIGN_PLUS:
+		p = "PLUS";
+		break;
+	      default:
+		internal_error (&iqp->common, "inquire_via_unit(): Bad sign");
+	    }
+
+	  cf_strcpy (iqp->sign, iqp->sign_len, p);
+	}
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0)
+	{
+	  if (u == NULL)
+	    p = undefined;
+	  else
+	    switch (u->flags.round)
+	    {
+	      case ROUND_UP:
+		p = "UP";
+		break;
+	      case ROUND_DOWN:
+		p = "DOWN";
+		break;
+	      case ROUND_ZERO:
+		p = "ZERO";
+		break;
+	      case ROUND_NEAREST:
+		p = "NEAREST";
+		break;
+	      case ROUND_COMPATIBLE:
+		p = "COMPATIBLE";
+		break;
+	      case ROUND_PROCDEFINED:
+		p = "PROCESSOR_DEFINED";
+		break;
+	      default:
+		internal_error (&iqp->common, "inquire_via_unit(): Bad round");
+	    }
+
+	  cf_strcpy (iqp->round, iqp->round_len, p);
+	}
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0)
+	{
+	  if (u == NULL)
+	    *iqp->size = -1;
+	  else
+	    *iqp->size = file_size (u->file, (gfc_charlen_type) u->file_len);
+	}
+    }
+
+  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)
+	  {
+	    /*  big_endian is 0 for little-endian, 1 for big-endian.  */
+	  case GFC_CONVERT_NATIVE:
+	    p = big_endian ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
+	    break;
+
+	  case GFC_CONVERT_SWAP:
+	    p = big_endian ? "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 = "UNKNOWN";
+      cf_strcpy (iqp->sequential, iqp->sequential_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
+    {
+      p = "UNKNOWN";
+      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 = "UNKNOWN";
+      cf_strcpy (iqp->formatted, iqp->formatted_len, p);
+    }
+
+  if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
+    {
+      p = "UNKNOWN";
+      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_PAD) != 0)
+    cf_strcpy (iqp->pad, iqp->pad_len, undefined);
+
+  if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
+    {
+      GFC_INTEGER_4 cf2 = iqp->flags2;
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
+	cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
+  
+      if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
+	cf_strcpy (iqp->delim, iqp->delim_len, undefined);
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
+	cf_strcpy (iqp->decimal, iqp->decimal_len, undefined);
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
+	cf_strcpy (iqp->delim, iqp->delim_len, undefined);
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0)
+	cf_strcpy (iqp->pad, iqp->pad_len, undefined);
+  
+      if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
+	cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
+
+      if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0)
+	*iqp->size = file_size (iqp->file, iqp->file_len);
+    }
+
+  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);
+    }
+}
+
+
+/* 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.6/libgfortran/io/intrinsics.c b/gcc-4.6/libgfortran/io/intrinsics.c
new file mode 100644
index 000000000..f48bd7774
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/intrinsics.c
@@ -0,0 +1,400 @@
+/* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH 
+   FTELL, TTYNAM and ISATTY intrinsics.
+   Copyright (C) 2005, 2007, 2009, 2010, 2011 Free Software
+   Foundation, Inc.
+
+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 3 of the License, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "io.h"
+#include "fbuf.h"
+#include "unix.h"
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#include <string.h>
+
+static const int five = 5;
+static const int six = 6;
+
+extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type);
+export_proto_np(PREFIX(fgetc));
+
+int
+PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
+{
+  int ret;
+  gfc_unit * u = find_unit (*unit);
+
+  if (u == NULL)
+    return -1;
+
+  fbuf_reset (u);
+  if (u->mode == WRITING)
+    {
+      sflush (u->s);
+      u->mode = READING;
+    }
+
+  memset (c, ' ', c_len);
+  ret = sread (u->s, c, 1);
+  unlock_unit (u);
+
+  if (ret < 0)
+    return ret;
+
+  if (ret != 1)
+    return -1;
+  else
+    return 0;
+}
+
+
+#define FGETC_SUB(kind) \
+  extern void fgetc_i ## kind ## _sub \
+    (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
+  export_proto(fgetc_i ## kind ## _sub); \
+  void fgetc_i ## kind ## _sub \
+  (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
+    { if (st != NULL) \
+        *st = PREFIX(fgetc) (unit, c, c_len); \
+      else \
+        PREFIX(fgetc) (unit, c, c_len); }
+
+FGETC_SUB(1)
+FGETC_SUB(2)
+FGETC_SUB(4)
+FGETC_SUB(8)
+
+
+extern int PREFIX(fget) (char *, gfc_charlen_type);
+export_proto_np(PREFIX(fget));
+
+int
+PREFIX(fget) (char * c, gfc_charlen_type c_len)
+{
+  return PREFIX(fgetc) (&five, c, c_len);
+}
+
+
+#define FGET_SUB(kind) \
+  extern void fget_i ## kind ## _sub \
+    (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
+  export_proto(fget_i ## kind ## _sub); \
+  void fget_i ## kind ## _sub \
+  (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
+    { if (st != NULL) \
+        *st = PREFIX(fgetc) (&five, c, c_len); \
+      else \
+        PREFIX(fgetc) (&five, c, c_len); }
+
+FGET_SUB(1)
+FGET_SUB(2)
+FGET_SUB(4)
+FGET_SUB(8)
+
+
+
+extern int PREFIX(fputc) (const int *, char *, gfc_charlen_type);
+export_proto_np(PREFIX(fputc));
+
+int
+PREFIX(fputc) (const int * unit, char * c,
+	       gfc_charlen_type c_len __attribute__((unused)))
+{
+  ssize_t s;
+  gfc_unit * u = find_unit (*unit);
+
+  if (u == NULL)
+    return -1;
+
+  fbuf_reset (u);
+  if (u->mode == READING)
+    {
+      sflush (u->s);
+      u->mode = WRITING;
+    }
+
+  s = swrite (u->s, c, 1);
+  unlock_unit (u);
+  if (s < 0)
+    return -1;
+  return 0;
+}
+
+
+#define FPUTC_SUB(kind) \
+  extern void fputc_i ## kind ## _sub \
+    (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
+  export_proto(fputc_i ## kind ## _sub); \
+  void fputc_i ## kind ## _sub \
+  (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
+    { if (st != NULL) \
+        *st = PREFIX(fputc) (unit, c, c_len); \
+      else \
+        PREFIX(fputc) (unit, c, c_len); }
+
+FPUTC_SUB(1)
+FPUTC_SUB(2)
+FPUTC_SUB(4)
+FPUTC_SUB(8)
+
+
+extern int PREFIX(fput) (char *, gfc_charlen_type);
+export_proto_np(PREFIX(fput));
+
+int
+PREFIX(fput) (char * c, gfc_charlen_type c_len)
+{
+  return PREFIX(fputc) (&six, c, c_len);
+}
+
+
+#define FPUT_SUB(kind) \
+  extern void fput_i ## kind ## _sub \
+    (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
+  export_proto(fput_i ## kind ## _sub); \
+  void fput_i ## kind ## _sub \
+  (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
+    { if (st != NULL) \
+        *st = PREFIX(fputc) (&six, c, c_len); \
+      else \
+        PREFIX(fputc) (&six, c, c_len); }
+
+FPUT_SUB(1)
+FPUT_SUB(2)
+FPUT_SUB(4)
+FPUT_SUB(8)
+
+
+/* SUBROUTINE FLUSH(UNIT)
+   INTEGER, INTENT(IN), OPTIONAL :: UNIT  */
+
+extern void flush_i4 (GFC_INTEGER_4 *);
+export_proto(flush_i4);
+
+void
+flush_i4 (GFC_INTEGER_4 *unit)
+{
+  gfc_unit *us;
+
+  /* flush all streams */
+  if (unit == NULL)
+    flush_all_units ();
+  else
+    {
+      us = find_unit (*unit);
+      if (us != NULL)
+	{
+	  sflush (us->s);
+	  unlock_unit (us);
+	}
+    }
+}
+
+
+extern void flush_i8 (GFC_INTEGER_8 *);
+export_proto(flush_i8);
+
+void
+flush_i8 (GFC_INTEGER_8 *unit)
+{
+  gfc_unit *us;
+
+  /* flush all streams */
+  if (unit == NULL)
+    flush_all_units ();
+  else
+    {
+      us = find_unit (*unit);
+      if (us != NULL)
+	{
+	  sflush (us->s);
+	  unlock_unit (us);
+	}
+    }
+}
+
+/* FSEEK intrinsic */
+
+extern void fseek_sub (int *, GFC_IO_INT *, int *, int *);
+export_proto(fseek_sub);
+
+void
+fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
+{
+  gfc_unit * u = find_unit (*unit);
+  ssize_t result = -1;
+
+  if (u != NULL && is_seekable(u->s))
+    {
+      result = sseek(u->s, *offset, *whence);
+
+      unlock_unit (u);
+    }
+
+  if (status)
+    *status = (result < 0 ? -1 : 0);
+}
+
+
+
+/* FTELL intrinsic */
+
+static gfc_offset
+gf_ftell (int unit)
+{
+  gfc_unit * u = find_unit (unit);
+  if (u == NULL)
+    return -1;
+  int pos = fbuf_reset (u);
+  if (pos != 0)
+    sseek (u->s, pos, SEEK_CUR);
+  gfc_offset ret = stell (u->s);
+  unlock_unit (u);
+  return ret;
+}
+
+extern size_t PREFIX(ftell) (int *);
+export_proto_np(PREFIX(ftell));
+
+size_t
+PREFIX(ftell) (int * unit)
+{
+  return gf_ftell (*unit);
+}
+
+#define FTELL_SUB(kind) \
+  extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
+  export_proto(ftell_i ## kind ## _sub); \
+  void \
+  ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
+  { \
+    *offset = gf_ftell (*unit);			\
+  }
+
+FTELL_SUB(1)
+FTELL_SUB(2)
+FTELL_SUB(4)
+FTELL_SUB(8)
+
+
+
+/* LOGICAL FUNCTION ISATTY(UNIT)
+   INTEGER, INTENT(IN) :: UNIT */
+
+extern GFC_LOGICAL_4 isatty_l4 (int *);
+export_proto(isatty_l4);
+
+GFC_LOGICAL_4
+isatty_l4 (int *unit)
+{
+  gfc_unit *u;
+  GFC_LOGICAL_4 ret = 0;
+
+  u = find_unit (*unit);
+  if (u != NULL)
+    {
+      ret = (GFC_LOGICAL_4) stream_isatty (u->s);
+      unlock_unit (u);
+    }
+  return ret;
+}
+
+
+extern GFC_LOGICAL_8 isatty_l8 (int *);
+export_proto(isatty_l8);
+
+GFC_LOGICAL_8
+isatty_l8 (int *unit)
+{
+  gfc_unit *u;
+  GFC_LOGICAL_8 ret = 0;
+
+  u = find_unit (*unit);
+  if (u != NULL)
+    {
+      ret = (GFC_LOGICAL_8) stream_isatty (u->s);
+      unlock_unit (u);
+    }
+  return ret;
+}
+
+
+/* SUBROUTINE TTYNAM(UNIT,NAME)
+   INTEGER,SCALAR,INTENT(IN) :: UNIT
+   CHARACTER,SCALAR,INTENT(OUT) :: NAME */
+
+extern void ttynam_sub (int *, char *, gfc_charlen_type);
+export_proto(ttynam_sub);
+
+void
+ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
+{
+  gfc_unit *u;
+  int nlen;
+  int err = 1;
+
+  u = find_unit (*unit);
+  if (u != NULL)
+    {
+      err = stream_ttyname (u->s, name, name_len);
+      if (err == 0)
+	{
+	  nlen = strlen (name);
+	  memset (&name[nlen], ' ', name_len - nlen);
+	}
+
+      unlock_unit (u);
+    }
+  if (err != 0)
+    memset (name, ' ', name_len);
+}
+
+
+extern void ttynam (char **, gfc_charlen_type *, int);
+export_proto(ttynam);
+
+void
+ttynam (char ** name, gfc_charlen_type * name_len, int unit)
+{
+  gfc_unit *u;
+
+  u = find_unit (unit);
+  if (u != NULL)
+    {
+      *name = get_mem (TTY_NAME_MAX);
+      int err = stream_ttyname (u->s, *name, TTY_NAME_MAX);
+      if (err == 0)
+	{
+	  *name_len = strlen (*name);
+	  unlock_unit (u);
+	  return;
+	}
+      free (*name);
+      unlock_unit (u);
+    }
+
+  *name_len = 0;
+  *name = NULL;
+}
diff --git a/gcc-4.6/libgfortran/io/io.h b/gcc-4.6/libgfortran/io/io.h
new file mode 100644
index 000000000..ebe7f7cc1
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/io.h
@@ -0,0 +1,809 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   F2003 I/O support contributed by Jerry DeLisle
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef GFOR_IO_H
+#define GFOR_IO_H
+
+/* IO library include.  */
+
+#include "libgfortran.h"
+
+#include <gthr.h>
+
+/* Forward declarations.  */
+struct st_parameter_dt;
+typedef struct stream stream;
+struct fbuf;
+struct format_data;
+typedef struct fnode fnode;
+struct gfc_unit;
+
+
+/* Macros for testing what kinds of I/O we are doing.  */
+
+#define is_array_io(dtp) ((dtp)->internal_unit_desc)
+
+#define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal)
+
+#define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM)
+
+#define is_char4_unit(dtp) ((dtp)->u.p.unit_is_internal && (dtp)->common.unit)
+
+/* 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;
+
+/* A stucture to build a hash table for format data.  */
+
+#define FORMAT_HASH_SIZE 16
+
+typedef struct format_hash_entry
+{
+  char *key;
+  gfc_charlen_type key_len;
+  struct format_data *hashed_fmt;
+}
+format_hash_entry;
+
+/* 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.  */
+  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
+{ DECIMAL_POINT, DECIMAL_COMMA, DECIMAL_UNSPECIFIED }
+unit_decimal;
+
+typedef enum
+{ ENCODING_UTF8, ENCODING_DEFAULT, ENCODING_UNSPECIFIED }
+unit_encoding;
+
+typedef enum
+{ ROUND_UP, ROUND_DOWN, ROUND_ZERO, ROUND_NEAREST, ROUND_COMPATIBLE,
+  ROUND_PROCDEFINED, ROUND_UNSPECIFIED }
+unit_round;
+
+/* NOTE: unit_sign must correspond with the sign_status enumerator in
+   st_parameter_dt to not break the ABI.  */
+typedef enum
+{ SIGN_PROCDEFINED, SIGN_SUPPRESS, SIGN_PLUS, SIGN_UNSPECIFIED }
+unit_sign;
+
+typedef enum
+{ ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED }
+unit_advance;
+
+typedef enum
+{READING, WRITING}
+unit_mode;
+
+typedef enum
+{ ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED }
+unit_async;
+
+typedef enum
+{ SIGN_S, SIGN_SS, SIGN_SP }
+unit_sign_s;
+
+#define CHARACTER1(name) \
+	      char * name; \
+	      gfc_charlen_type name ## _len
+#define CHARACTER2(name) \
+	      gfc_charlen_type name ## _len; \
+	      char * name
+
+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);
+  CHARACTER2 (decimal);
+  CHARACTER1 (encoding);
+  CHARACTER2 (round);
+  CHARACTER1 (sign);
+  CHARACTER2 (asynchronous);
+  GFC_INTEGER_4 *newunit;
+}
+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)
+#define IOPARM_INQUIRE_HAS_FLAGS2	(1 << 31)
+
+#define IOPARM_INQUIRE_HAS_ASYNCHRONOUS	(1 << 0)
+#define IOPARM_INQUIRE_HAS_DECIMAL	(1 << 1)
+#define IOPARM_INQUIRE_HAS_ENCODING	(1 << 2)
+#define IOPARM_INQUIRE_HAS_ROUND	(1 << 3)
+#define IOPARM_INQUIRE_HAS_SIGN		(1 << 4)
+#define IOPARM_INQUIRE_HAS_PENDING	(1 << 5)
+#define IOPARM_INQUIRE_HAS_SIZE		(1 << 6)
+#define IOPARM_INQUIRE_HAS_ID		(1 << 7)
+
+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);
+  GFC_INTEGER_4 flags2;
+  CHARACTER1 (asynchronous);
+  CHARACTER2 (decimal);
+  CHARACTER1 (encoding);
+  CHARACTER2 (round);
+  CHARACTER1 (sign);
+  GFC_INTEGER_4 *pending;
+  GFC_IO_INT *size;
+  GFC_INTEGER_4 *id;
+}
+st_parameter_inquire;
+
+
+#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)
+#define IOPARM_DT_HAS_ID			(1 << 16)
+#define IOPARM_DT_HAS_POS			(1 << 17)
+#define IOPARM_DT_HAS_ASYNCHRONOUS		(1 << 18)
+#define IOPARM_DT_HAS_BLANK			(1 << 19)
+#define IOPARM_DT_HAS_DECIMAL			(1 << 20)
+#define IOPARM_DT_HAS_DELIM			(1 << 21)
+#define IOPARM_DT_HAS_PAD			(1 << 22)
+#define IOPARM_DT_HAS_ROUND			(1 << 23)
+#define IOPARM_DT_HAS_SIGN			(1 << 24)
+#define IOPARM_DT_HAS_F2003                     (1 << 25)
+/* Internal use bit.  */
+#define IOPARM_DT_IONML_SET			(1 << 31)
+
+
+typedef struct st_parameter_dt
+{
+  st_parameter_common common;
+  GFC_IO_INT rec;
+  GFC_IO_INT *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;
+	  unit_sign 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;
+	  /* Used for g0 floating point output.  */
+	  unsigned g0_no_blanks : 1;
+	  /* Used to signal use of free_format_data.  */
+	  unsigned format_not_saved : 1;
+	  /* 14 unused bits.  */
+
+	  /* Used for ungetc() style functionality. Possible values
+	     are an unsigned char, EOF, or EOF - 1 used to mark the
+	     field as not valid.  */
+	  int 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;
+	  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_IO_INT 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;
+  GFC_INTEGER_4 *id;
+  GFC_IO_INT pos;
+  CHARACTER1 (asynchronous);
+  CHARACTER2 (blank);
+  CHARACTER1 (decimal);
+  CHARACTER2 (delim);
+  CHARACTER1 (pad);
+  CHARACTER2 (round);
+  CHARACTER1 (sign);
+}
+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];
+
+#define IOPARM_WAIT_HAS_ID		(1 << 7)
+
+typedef struct
+{
+  st_parameter_common common;
+  CHARACTER1 (id);
+}
+st_parameter_wait;
+
+
+#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_decimal decimal;
+  unit_encoding encoding;
+  unit_round round;
+  unit_sign sign;
+  unit_async async;
+}
+unit_flags;
+
+
+typedef struct gfc_unit
+{
+  int unit_number;
+  stream *s;
+  
+  /* Treap links.  */
+  struct gfc_unit *left, *right;
+  int priority;
+
+  int read_bad, current_record, saved_pos, previous_nonadvancing_write;
+
+  enum
+  { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
+  endfile;
+
+  unit_mode mode;
+  unit_flags flags;
+  unit_pad pad_status;
+  unit_decimal decimal_status;
+  unit_delim delim_status;
+  unit_round round_status;
+
+  /* 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;
+
+  /* The format hash table.  */
+  struct format_hash_entry format_hash_table[FORMAT_HASH_SIZE];
+  
+  /* Formatting buffer.  */
+  struct fbuf *fbuf;
+}
+gfc_unit;
+
+
+/* unit.c */
+
+/* Maximum file offset, computed at library initialization time.  */
+extern gfc_offset max_offset;
+internal_proto(max_offset);
+
+/* Unit number to be assigned when NEWUNIT is used in an OPEN statement.  */
+extern GFC_INTEGER_4 next_available_newunit;
+internal_proto(next_available_newunit);
+
+/* 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 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);
+
+extern void update_position (gfc_unit *);
+internal_proto(update_position);
+
+extern void finish_last_advance_record (gfc_unit *u);
+internal_proto (finish_last_advance_record);
+
+extern int unit_truncate (gfc_unit *, gfc_offset, st_parameter_common *);
+internal_proto (unit_truncate);
+
+extern GFC_INTEGER_4 get_unique_unit_number (st_parameter_open *);
+internal_proto(get_unique_unit_number);
+
+/* open.c */
+
+extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
+internal_proto(new_unit);
+
+
+/* transfer.c */
+
+#define SCRATCH_SIZE 300
+
+extern const char *type_name (bt);
+internal_proto(type_name);
+
+extern void * read_block_form (st_parameter_dt *, int *);
+internal_proto(read_block_form);
+
+extern void * read_block_form4 (st_parameter_dt *, int *);
+internal_proto(read_block_form4);
+
+extern void *write_block (st_parameter_dt *, int);
+internal_proto(write_block);
+
+extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *,
+				     int*);
+internal_proto(next_array_record);
+
+extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *,
+				  gfc_offset *);
+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);
+
+extern void st_wait (st_parameter_wait *);
+export_proto(st_wait);
+
+extern void hit_eof (st_parameter_dt *);
+internal_proto(hit_eof);
+
+/* 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_a_char4 (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_a_char4 (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_a_char4);
+
+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_real (st_parameter_dt *, const char *, int);
+internal_proto(write_real);
+
+extern void write_real_g0 (st_parameter_dt *, const char *, int, int);
+internal_proto(write_real_g0);
+
+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);
+
+/* 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
+
diff --git a/gcc-4.6/libgfortran/io/list_read.c b/gcc-4.6/libgfortran/io/list_read.c
new file mode 100644
index 000000000..9d92f771c
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/list_read.c
@@ -0,0 +1,3085 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011
+   Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   Namelist input contributed by Paul Thomas
+   F2003 I/O support contributed by Jerry DeLisle
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+
+#include "io.h"
+#include "fbuf.h"
+#include "unix.h"
+#include <string.h>
+#include <stdlib.h>
+#include <ctype.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': case ';'
+
+/* This macro assumes that we're operating on a variable.  */
+
+#define is_separator(c) (c == '/' ||  c == ',' || c == '\n' || c == ' ' \
+                         || c == '\t' || c == '\r' || c == ';')
+
+/* Maximum repeat count.  Less than ten times the maximum signed int32.  */
+
+#define MAX_REPEAT 200000000
+
+#ifndef HAVE_SNPRINTF
+# undef snprintf
+# define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
+#endif
+
+/* 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)
+    {
+      dtp->u.p.saved_string = get_mem (SCRATCH_SIZE);
+      // memset below should be commented out.
+      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 = realloc (dtp->u.p.saved_string, dtp->u.p.saved_length);
+      if (new == NULL)
+	generate_error (&dtp->common, LIBERROR_OS, NULL);
+      dtp->u.p.saved_string = new;
+      
+      // Also this should not be necessary.
+      memset (new + dtp->u.p.saved_used, 0, 
+	      dtp->u.p.saved_length - dtp->u.p.saved_used);
+
+    }
+
+  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;
+
+  free (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)
+{
+  dtp->u.p.item_count = 0;
+  dtp->u.p.line_buffer_enabled = 0;
+
+  if (dtp->u.p.line_buffer == NULL)
+    return;
+
+  free (dtp->u.p.line_buffer);
+  dtp->u.p.line_buffer = NULL;
+}
+
+
+static int
+next_char (st_parameter_dt *dtp)
+{
+  ssize_t length;
+  gfc_offset record;
+  int c;
+
+  if (dtp->u.p.last_char != EOF - 1)
+    {
+      dtp->u.p.at_eol = 0;
+      c = dtp->u.p.last_char;
+      dtp->u.p.last_char = EOF - 1;
+      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)
+	return EOF;
+
+      /* Check for "end-of-record" condition.  */
+      if (dtp->u.p.current_unit->bytes_left == 0)
+	{
+	  int finished;
+
+	  c = '\n';
+	  record = next_array_record (dtp, dtp->u.p.current_unit->ls,
+				      &finished);
+
+	  /* Check for "end-of-file" condition.  */      
+	  if (finished)
+	    {
+	      dtp->u.p.at_eof = 1;
+	      goto done;
+	    }
+
+	  record *= dtp->u.p.current_unit->recl;
+	  if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
+	    return EOF;
+
+	  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.  */
+
+  if (is_internal_unit (dtp))
+    {
+      char cc;
+      length = sread (dtp->u.p.current_unit->s, &cc, 1);
+      c = cc;
+      if (length < 0)
+	{
+	  generate_error (&dtp->common, LIBERROR_OS, NULL);
+	  return '\0';
+	}
+  
+      if (is_array_io (dtp))
+	{
+	  /* Check whether we hit EOF.  */ 
+	  if (length == 0)
+	    {
+	      generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
+	      return '\0';
+	    } 
+	  dtp->u.p.current_unit->bytes_left--;
+	}
+      else
+	{
+	  if (dtp->u.p.at_eof) 
+	    return EOF;
+	  if (length == 0)
+	    {
+	      c = '\n';
+	      dtp->u.p.at_eof = 1;
+	    }
+	}
+    }
+  else
+    {
+      c = fbuf_getc (dtp->u.p.current_unit);
+      if (c != EOF && is_stream_io (dtp))
+	dtp->u.p.current_unit->strm_pos++;
+    }
+done:
+  dtp->u.p.at_eol = (c == '\n' || c == '\r' || c == EOF);
+  return c;
+}
+
+
+/* Push a character back onto the input.  */
+
+static void
+unget_char (st_parameter_dt *dtp, int 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 int
+eat_spaces (st_parameter_dt *dtp)
+{
+  int c;
+
+  do
+    c = next_char (dtp);
+  while (c != EOF && (c == ' ' || c == '\t'));
+
+  unget_char (dtp, c);
+  return c;
+}
+
+
+/* This function reads characters through to the end of the current
+   line and just ignores them.  Returns 0 for success and LIBERROR_END
+   if it hit EOF.  */
+
+static int
+eat_line (st_parameter_dt *dtp)
+{
+  int c;
+
+  do
+    c = next_char (dtp);
+  while (c != EOF && c != '\n');
+  if (c == EOF)
+    return LIBERROR_END;
+  return 0;
+}
+
+
+/* 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. 
+
+   Returns 0 for success, and non-zero error code otherwise.  */
+
+static int
+eat_separator (st_parameter_dt *dtp)
+{
+  int c, n;
+  int err = 0;
+
+  eat_spaces (dtp);
+  dtp->u.p.comma_flag = 0;
+
+  if ((c = next_char (dtp)) == EOF)
+    return LIBERROR_END;
+  switch (c)
+    {
+    case ',':
+      if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+	{
+	  unget_char (dtp, c);
+	  break;
+	}
+      /* Fall through.  */
+    case ';':
+      dtp->u.p.comma_flag = 1;
+      eat_spaces (dtp);
+      break;
+
+    case '/':
+      dtp->u.p.input_complete = 1;
+      break;
+
+    case '\r':
+      dtp->u.p.at_eol = 1;
+      if ((n = next_char(dtp)) == EOF)
+	return LIBERROR_END;
+      if (n != '\n')
+	{
+	  unget_char (dtp, n);
+	  break;
+	}
+    /* Fall through.  */
+    case '\n':
+      dtp->u.p.at_eol = 1;
+      if (dtp->u.p.namelist_mode)
+	{
+	  do
+	    {
+	      if ((c = next_char (dtp)) == EOF)
+		  return LIBERROR_END;
+	      if (c == '!')
+		{
+		  err = eat_line (dtp);
+		  if (err)
+		    return err;
+		  if ((c = next_char (dtp)) == EOF)
+		    return LIBERROR_END;
+		  if (c == '!')
+		    {
+		      err = eat_line (dtp);
+		      if (err)
+			return err;
+		      if ((c = next_char (dtp)) == EOF)
+			return LIBERROR_END;
+		    }
+		}
+	    }
+	  while (c == '\n' || c == '\r' || c == ' ' || c == '\t');
+	  unget_char (dtp, c);
+	}
+      break;
+
+    case '!':
+      if (dtp->u.p.namelist_mode)
+	{			/* Eat a namelist comment.  */
+	  err = eat_line (dtp);
+	  if (err)
+	    return err;
+
+	  break;
+	}
+
+      /* Fall Through...  */
+
+    default:
+      unget_char (dtp, c);
+      break;
+    }
+  return err;
+}
+
+
+/* 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.  Return 0 on success, error code
+   on failure.  */
+
+static int
+finish_separator (st_parameter_dt *dtp)
+{
+  int c;
+  int err;
+
+ restart:
+  eat_spaces (dtp);
+
+  if ((c = next_char (dtp)) == EOF)
+    return LIBERROR_END;
+  switch (c)
+    {
+    case ',':
+      if (dtp->u.p.comma_flag)
+	unget_char (dtp, c);
+      else
+	{
+	  if ((c = eat_spaces (dtp)) == EOF)
+	    return LIBERROR_END;
+	  if (c == '\n' || c == '\r')
+	    goto restart;
+	}
+
+      break;
+
+    case '/':
+      dtp->u.p.input_complete = 1;
+      if (!dtp->u.p.namelist_mode)
+	return err;
+      break;
+
+    case '\n':
+    case '\r':
+      goto restart;
+
+    case '!':
+      if (dtp->u.p.namelist_mode)
+	{
+	  err = eat_line (dtp);
+	  if (err)
+	    return err;
+	  goto restart;
+	}
+
+    default:
+      unget_char (dtp, c);
+      break;
+    }
+  return err;
+}
+
+
+/* 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)
+	{
+	  sprintf (message, "Zero repeat count in item %d of list input",
+		   dtp->u.p.item_count);
+
+	  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+	  m = 1;
+	}
+    }
+
+  free_saved (dtp);
+  return m;
+
+ overflow:
+  if (length == -1)
+    sprintf (message, "Repeat count overflow in item %d of list input",
+	     dtp->u.p.item_count);
+  else
+    sprintf (message, "Integer overflow while reading item %d",
+	     dtp->u.p.item_count);
+
+  free_saved (dtp);
+  generate_error (&dtp->common, LIBERROR_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 message[100];
+  int c, repeat;
+
+  if ((c = next_char (dtp)) == EOF)
+    goto bad_repeat;
+  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)
+	    {
+	      sprintf (message,
+		       "Repeat count overflow in item %d of list input",
+		       dtp->u.p.item_count);
+
+	      generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+	      return 1;
+	    }
+
+	  break;
+
+	case '*':
+	  if (repeat == 0)
+	    {
+	      sprintf (message,
+		       "Zero repeat count in item %d of list input",
+		       dtp->u.p.item_count);
+
+	      generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+	      return 1;
+	    }
+
+	  goto done;
+
+	default:
+	  goto bad_repeat;
+	}
+    }
+
+ done:
+  dtp->u.p.repeat_count = repeat;
+  return 0;
+
+ bad_repeat:
+
+  free_saved (dtp);
+  if (c == EOF)
+    {
+      hit_eof (dtp);
+      return 1;
+    }
+  else
+    eat_line (dtp);
+  sprintf (message, "Bad repeat count in item %d of list input",
+	   dtp->u.p.item_count);
+  generate_error (&dtp->common, LIBERROR_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 message[100];
+  int c, 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) && c != EOF)
+	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) && c != EOF)
+	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:
+      /* Save the character in case it is the beginning
+	 of the next object name. */
+      unget_char (dtp, c);
+      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 (c != EOF && !is_separator (c));
+
+  unget_char (dtp, c);
+  eat_separator (dtp);
+  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;
+
+  free_saved (dtp);
+  if (c == EOF)
+    {
+      hit_eof (dtp);
+      return;
+    }
+  else if (c != '\n')
+    eat_line (dtp);
+  sprintf (message, "Bad logical value while reading item %d",
+	      dtp->u.p.item_count);
+  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+  return;
+
+ logical_done:
+
+  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 message[100];
+  int c, negative;
+
+  negative = 0;
+
+  c = next_char (dtp);
+  switch (c)
+    {
+    case '-':
+      negative = 1;
+      /* Fall through...  */
+
+    case '+':
+      if ((c = next_char (dtp)) == EOF)
+	goto bad_integer;
+      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.  */
+	case EOF:
+	  goto done;
+
+	default:
+	  goto bad_integer;
+	}
+    }
+
+ repeat:
+  if (convert_integer (dtp, -1, 0))
+    return;
+
+  /* Get the real integer.  */
+
+  if ((c = next_char (dtp)) == EOF)
+    goto bad_integer;
+  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;
+
+  free_saved (dtp);  
+  if (c == EOF)
+    {
+      hit_eof (dtp);
+      return;
+    }
+  else if (c != '\n')
+    eat_line (dtp);
+  sprintf (message, "Bad integer for item %d in list input",
+	      dtp->u.p.item_count);
+  generate_error (&dtp->common, LIBERROR_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 quote, message[100];
+  int c;
+
+  quote = ' ';			/* Space means no quote character.  */
+
+  if ((c = next_char (dtp)) == EOF)
+    goto eof;
+  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 (;;)
+    {
+      if ((c = next_char (dtp)) == EOF)
+	goto eof;
+      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.  */
+
+  if ((c = next_char (dtp)) == EOF)
+    goto eof;
+  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 (;;)
+    {
+      if ((c = next_char (dtp)) == EOF)
+	goto done_eof;
+      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.  */
+
+	  if ((c = next_char (dtp)) == EOF)
+	    goto eof;
+	  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);
+ done_eof:
+  if (is_separator (c) || c == '!' || c == EOF)
+    {
+      unget_char (dtp, c);
+      eat_separator (dtp);
+      dtp->u.p.saved_type = BT_CHARACTER;
+      free_line (dtp);
+    }
+  else
+    {
+      free_saved (dtp);
+      sprintf (message, "Invalid string input in item %d",
+		  dtp->u.p.item_count);
+      generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+    }
+  return;
+
+ eof:
+  free_saved (dtp);
+  hit_eof (dtp);
+}
+
+
+/* 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 message[100];
+  int c, m, seen_dp;
+
+  if ((c = next_char (dtp)) == EOF)
+    goto bad;
+    
+  if (c == '-' || c == '+')
+    {
+      push_char (dtp, c);
+      if ((c = next_char (dtp)) == EOF)
+	goto bad;
+    }
+
+  if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+    c = '.';
+  
+  if (!isdigit (c) && c != '.')
+    {
+      if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
+	goto inf_nan;
+      else
+	goto bad;
+    }
+
+  push_char (dtp, c);
+
+  seen_dp = (c == '.') ? 1 : 0;
+
+  for (;;)
+    {
+      if ((c = next_char (dtp)) == EOF)
+	goto bad;
+      if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+	c = '.';
+      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);
+	  if ((c = next_char (dtp)) == EOF)
+	    goto bad;
+	  goto exp2;
+
+	CASE_SEPARATORS:
+	  goto done;
+
+	default:
+	  goto done;
+	}
+    }
+
+ exp1:
+  if ((c = next_char (dtp)) == EOF)
+    goto bad;
+  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 (;;)
+    {
+      if ((c = next_char (dtp)) == EOF)
+	goto bad;
+      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;
+
+ inf_nan:
+  /* Match INF and Infinity.  */
+  if ((c == 'i' || c == 'I')
+      && ((c = next_char (dtp)) == 'n' || c == 'N')
+      && ((c = next_char (dtp)) == 'f' || c == 'F'))
+    {
+	c = next_char (dtp);
+	if ((c != 'i' && c != 'I')
+	    || ((c == 'i' || c == 'I')
+		&& ((c = next_char (dtp)) == 'n' || c == 'N')
+		&& ((c = next_char (dtp)) == 'i' || c == 'I')
+		&& ((c = next_char (dtp)) == 't' || c == 'T')
+		&& ((c = next_char (dtp)) == 'y' || c == 'Y')
+		&& (c = next_char (dtp))))
+	  {
+	     if (is_separator (c))
+	       unget_char (dtp, c);
+	     push_char (dtp, 'i');
+	     push_char (dtp, 'n');
+	     push_char (dtp, 'f');
+	     goto done;
+	  }
+    } /* Match NaN.  */
+  else if (((c = next_char (dtp)) == 'a' || c == 'A')
+	   && ((c = next_char (dtp)) == 'n' || c == 'N')
+	   && (c = next_char (dtp)))
+    {
+      if (is_separator (c))
+	unget_char (dtp, c);
+      push_char (dtp, 'n');
+      push_char (dtp, 'a');
+      push_char (dtp, 'n');
+      
+      /* Match "NAN(alphanum)".  */
+      if (c == '(')
+	{
+	  for ( ; c != ')'; c = next_char (dtp))
+	    if (is_separator (c))
+	      goto bad;
+
+	  c = next_char (dtp);
+	  if (is_separator (c))
+	    unget_char (dtp, c);
+	}
+      goto done;
+    }
+
+ bad:
+
+  if (nml_bad_return (dtp, c))
+    return 0;
+
+  free_saved (dtp);
+  if (c == EOF)
+    {
+      hit_eof (dtp);
+      return 1;
+    }
+  else if (c != '\n')
+    eat_line (dtp);
+  sprintf (message, "Bad floating point number for item %d",
+	      dtp->u.p.item_count);
+  generate_error (&dtp->common, LIBERROR_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, void * dest, int kind, size_t size)
+{
+  char message[100];
+  int 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;
+    }
+
+eol_1:
+  eat_spaces (dtp);
+  c = next_char (dtp);
+  if (c == '\n' || c== '\r')
+    goto eol_1;
+  else
+    unget_char (dtp, c);
+
+  if (parse_real (dtp, dest, kind))
+    return;
+
+eol_2:
+  eat_spaces (dtp);
+  c = next_char (dtp);
+  if (c == '\n' || c== '\r')
+    goto eol_2;
+  else
+    unget_char (dtp, c);
+
+  if (next_char (dtp)
+      !=  (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';'))
+    goto bad_complex;
+
+eol_3:
+  eat_spaces (dtp);
+  c = next_char (dtp);
+  if (c == '\n' || c== '\r')
+    goto eol_3;
+  else
+    unget_char (dtp, c);
+
+  if (parse_real (dtp, dest + size / 2, kind))
+    return;
+    
+eol_4:
+  eat_spaces (dtp);
+  c = next_char (dtp);
+  if (c == '\n' || c== '\r')
+    goto eol_4;
+  else
+    unget_char (dtp, c);
+
+  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;
+
+  free_saved (dtp);
+  if (c == EOF)
+    {
+      hit_eof (dtp);
+      return;
+    }
+  else if (c != '\n')   
+    eat_line (dtp);
+  sprintf (message, "Bad complex value in item %d of list input",
+	      dtp->u.p.item_count);
+  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+}
+
+
+/* Parse a real number with a possible repeat count.  */
+
+static void
+read_real (st_parameter_dt *dtp, void * dest, int length)
+{
+  char message[100];
+  int c;
+  int seen_dp;
+  int is_inf;
+
+  seen_dp = 0;
+
+  c = next_char (dtp);
+  if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+    c = '.';
+  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;
+
+    case 'i':
+    case 'I':
+    case 'n':
+    case 'N':
+      goto inf_nan;
+
+    default:
+      goto bad_real;
+    }
+
+  /* Get the digit string that might be a repeat count.  */
+
+  for (;;)
+    {
+      c = next_char (dtp);
+      if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+	c = '.';
+      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' && c != ';')
+	    unget_char (dtp, c);
+	  goto done;
+
+	default:
+	  goto bad_real;
+	}
+    }
+
+ got_repeat:
+  if (convert_integer (dtp, -1, 0))
+    return;
+
+  /* Now get the number itself.  */
+
+  if ((c = next_char (dtp)) == EOF)
+    goto bad_real;
+  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);
+      if ((c = next_char (dtp)) == EOF)
+	goto bad_real;
+    }
+
+  if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+    c = '.';
+
+  if (!isdigit (c) && c != '.')
+    {
+      if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
+	goto inf_nan;
+      else
+	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);
+      if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+	c = '.';
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (dtp, c);
+	  break;
+
+	CASE_SEPARATORS:
+	case EOF:
+	  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');
+
+  if ((c = next_char (dtp)) == EOF)
+    goto bad_real;
+  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:
+	case EOF:
+	  goto done;
+
+	default:
+	  goto bad_real;
+	}
+    }
+
+ done:
+  unget_char (dtp, c);
+  eat_separator (dtp);
+  push_char (dtp, '\0');
+  if (convert_real (dtp, dest, dtp->u.p.saved_string, length))
+    return;
+
+  free_saved (dtp);
+  dtp->u.p.saved_type = BT_REAL;
+  return;
+
+ inf_nan:
+  l_push_char (dtp, c);
+  is_inf = 0;
+
+  /* Match INF and Infinity.  */
+  if (c == 'i' || c == 'I')
+    {
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+      if (c != 'n' && c != 'N')
+	goto unwind;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+      if (c != 'f' && c != 'F')
+	goto unwind;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+      if (!is_separator (c))
+	{
+	  if (c != 'i' && c != 'I')
+	    goto unwind;
+	  c = next_char (dtp);
+	  l_push_char (dtp, c);
+	  if (c != 'n' && c != 'N')
+	    goto unwind;
+	  c = next_char (dtp);
+	  l_push_char (dtp, c);
+	  if (c != 'i' && c != 'I')
+	    goto unwind;
+	  c = next_char (dtp);
+	  l_push_char (dtp, c);
+	  if (c != 't' && c != 'T')
+	    goto unwind;
+	  c = next_char (dtp);
+	  l_push_char (dtp, c);
+	  if (c != 'y' && c != 'Y')
+	    goto unwind;
+	  c = next_char (dtp);
+	  l_push_char (dtp, c);
+	}
+	is_inf = 1;
+    } /* Match NaN.  */
+  else
+    {
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+      if (c != 'a' && c != 'A')
+	goto unwind;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+      if (c != 'n' && c != 'N')
+	goto unwind;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+
+      /* Match NAN(alphanum).  */
+      if (c == '(')
+	{
+	  for (c = next_char (dtp); c != ')'; c = next_char (dtp))
+	    if (is_separator (c))
+	      goto unwind;
+	    else
+	      l_push_char (dtp, c);
+
+	  l_push_char (dtp, ')');
+	  c = next_char (dtp);
+	  l_push_char (dtp, c);
+	}
+    }
+
+  if (!is_separator (c))
+    goto unwind;
+
+  if (dtp->u.p.namelist_mode)
+    {	
+      if (c == ' ' || c =='\n' || c == '\r')
+	{
+	  do
+	    {
+	      if ((c = next_char (dtp)) == EOF)
+		goto bad_real;
+	    }
+	  while (c == ' ' || c =='\n' || c == '\r');
+
+	  l_push_char (dtp, c);
+
+	  if (c == '=')
+	    goto unwind;
+	}
+    }
+
+  if (is_inf)
+    {
+      push_char (dtp, 'i');
+      push_char (dtp, 'n');
+      push_char (dtp, 'f');
+    }
+  else
+    {
+      push_char (dtp, 'n');
+      push_char (dtp, 'a');
+      push_char (dtp, 'n');
+    }
+
+  free_line (dtp);
+  goto done;
+
+ unwind:
+  if (dtp->u.p.namelist_mode)
+    {
+      dtp->u.p.nml_read_error = 1;
+      dtp->u.p.line_buffer_enabled = 1;
+      dtp->u.p.item_count = 0;
+      return;
+    }
+
+ bad_real:
+
+  if (nml_bad_return (dtp, c))
+    return;
+
+  free_saved (dtp);
+  if (c == EOF)
+    {
+      hit_eof (dtp);
+      return;
+    }
+  else if (c != '\n')
+    eat_line (dtp);
+
+  sprintf (message, "Bad real number in item %d of list input",
+	      dtp->u.p.item_count);
+  generate_error (&dtp->common, LIBERROR_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_UNKNOWN && dtp->u.p.saved_type != type)
+    {
+      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, LIBERROR_READ_VALUE, message);
+      return 1;
+    }
+
+  if (dtp->u.p.saved_type == BT_UNKNOWN || dtp->u.p.saved_type == BT_CHARACTER)
+    return 0;
+
+  if (dtp->u.p.saved_length != len)
+    {
+      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, LIBERROR_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 int
+list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
+			    int kind, size_t size)
+{
+  gfc_char4_t *q;
+  int c, i, m;
+  int err = 0;
+
+  dtp->u.p.namelist_mode = 0;
+
+  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;
+      
+      if ((c = eat_spaces (dtp)) == EOF)
+	{
+	  err = LIBERROR_END;
+	  goto cleanup;
+	}
+      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.repeat_count > 0)
+	{
+	  if (check_type (dtp, type, kind))
+	    return err;
+	  goto set_value;
+	}
+	
+      if (dtp->u.p.input_complete)
+	goto cleanup;
+
+      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_UNKNOWN;
+      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, p, kind);
+      /* Copy value back to temporary if needed.  */
+      if (dtp->u.p.repeat_count > 0)
+	memcpy (dtp->u.p.value, p, kind);
+      break;
+    case BT_COMPLEX:
+      read_complex (dtp, p, kind, size);
+      /* Copy value back to temporary if needed.  */
+      if (dtp->u.p.repeat_count > 0)
+	memcpy (dtp->u.p.value, p, 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_UNKNOWN)
+    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_REAL:
+      if (dtp->u.p.repeat_count > 0)
+	memcpy (p, dtp->u.p.value, size);
+      break;
+
+    case BT_INTEGER:
+    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;
+	  if (kind == 1)
+	    memcpy (p, dtp->u.p.saved_string, m);
+	  else
+	    {
+	      q = (gfc_char4_t *) p;
+	      for (i = 0; i < m; i++)
+		q[i] = (unsigned char) dtp->u.p.saved_string[i];
+	    }
+	}
+      else
+	/* Just delimiters encountered, nothing to copy but SPACE.  */
+        m = 0;
+
+      if (m < (int) size)
+	{
+	  if (kind == 1)
+	    memset (((char *) p) + m, ' ', size - m);
+	  else
+	    {
+	      q = (gfc_char4_t *) p;
+	      for (i = m; i < (int) size; i++)
+		q[i] = (unsigned char) ' ';
+	    }
+	}
+      break;
+
+    case BT_UNKNOWN:
+      break;
+
+    default:
+      internal_error (&dtp->common, "Bad type for list read");
+    }
+
+  if (--dtp->u.p.repeat_count <= 0)
+    free_saved (dtp);
+
+cleanup:
+  if (err == LIBERROR_END)
+    hit_eof (dtp);
+  return err;
+}
+
+
+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;
+  size_t stride = type == BT_CHARACTER ?
+		  size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
+  int err;
+
+  tmp = (char *) p;
+
+  /* Big loop over all the elements.  */
+  for (elem = 0; elem < nelems; elem++)
+    {
+      dtp->u.p.item_count++;
+      err = list_formatted_read_scalar (dtp, type, tmp + stride*elem, 
+					kind, size);
+      if (err)
+	break;
+    }
+}
+
+
+/* Finish a list read.  */
+
+void
+finish_list_read (st_parameter_dt *dtp)
+{
+  int err;
+
+  free_saved (dtp);
+
+  fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+
+  if (dtp->u.p.at_eol)
+    {
+      dtp->u.p.at_eol = 0;
+      return;
+    }
+
+  err = eat_line (dtp);
+  if (err == LIBERROR_END)
+    hit_eof (dtp);
+}
+
+/*			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 *, size_t)
+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 *, size_t,
+			       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 *parsed_rank)
+{
+  int dim;
+  int indx;
+  int neg;
+  int null_flag;
+  int is_array_section, is_char;
+  int c;
+
+  is_char = 0;
+  is_array_section = 0;
+  dtp->u.p.expanded_read = 0;
+
+  /* See if this is a character substring qualifier we are looking for.  */
+  if (rank == -1)
+    {
+      rank = 1;
+      is_char = 1;
+    }
+
+  /* The next character in the stream should be the '('.  */
+
+  if ((c = next_char (dtp)) == EOF)
+    return FAILURE;
+
+  /* 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.  */
+	  if ((c = next_char (dtp)) == EOF)
+	    return FAILURE;
+	  switch (c)
+	    {
+	    case '-':
+	      neg = 1;
+	      break;
+
+	    case '+':
+	      break;
+
+	    default:
+	      unget_char (dtp, c);
+	      break;
+	    }
+
+	  /* Process characters up to the next ':' , ',' or ')'.  */
+	  for (;;)
+	    {
+	      if ((c = next_char (dtp)) == EOF)
+		return FAILURE;
+
+	      switch (c)
+		{
+		case ':':
+                  is_array_section = 1;
+		  break;
+
+		case ',': case ')':
+		  if ((c==',' && dim == rank -1)
+		      || (c==')' && dim < rank -1))
+		    {
+		      if (is_char)
+		        sprintf (parse_err_msg, "Bad substring qualifier");
+		      else
+			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);
+		  if ((c = next_char (dtp) == EOF))
+		    return FAILURE;
+		  break;
+
+		default:
+		  if (is_char)
+		    sprintf (parse_err_msg,
+			     "Bad character in substring qualifier");
+		  else
+		    sprintf (parse_err_msg, "Bad character in index");
+		  goto err_ret;
+		}
+
+	      if ((c == ',' || c == ')') && indx == 0
+		  && dtp->u.p.saved_string == 0)
+		{
+		  if (is_char)
+		    sprintf (parse_err_msg, "Null substring qualifier");
+		  else
+		    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))
+		{
+		  if (is_char)
+		    sprintf (parse_err_msg, "Bad substring qualifier");
+		  else
+		    sprintf (parse_err_msg, "Bad index triplet");
+		  goto err_ret;
+		}
+
+	      if (is_char && !is_array_section)
+		{
+		  sprintf (parse_err_msg,
+			   "Missing colon in substring qualifier");
+		  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))
+		{
+		  if (is_char)
+		    sprintf (parse_err_msg, "Bad integer substring qualifier");
+		  else
+		    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)
+		      || !dtp->u.p.ionml->touched
+		      || dtp->u.p.ionml->type == BT_DERIVED)
+		    ls[dim].end = ls[dim].start;
+		  else
+		    dtp->u.p.expanded_read = 1;
+		}
+
+	      /* Check for non-zero rank.  */
+	      if (is_array_section == 1 && ls[dim].start != ls[dim].end)
+		*parsed_rank = 1;
+
+	      break;
+	    }
+	}
+
+      if (is_array_section == 1 && dtp->u.p.expanded_read == 1)
+	{
+	  int i;
+	  dtp->u.p.expanded_read = 0;
+	  for (i = 0; i < dim; i++)
+	    ls[i].end = ls[i].start;
+	}
+
+      /* Check the values of the triplet indices.  */
+      if ((ls[dim].start > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
+	   || (ls[dim].start < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim]))
+	   || (ls[dim].end > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
+	   || (ls[dim].end < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim])))
+	{
+	  if (is_char)
+	    sprintf (parse_err_msg, "Substring out of range");
+	  else
+	    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))
+	{
+	  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);
+  memcpy (ext_name, nl->var_name, len-1);
+  memcpy (ext_name + len - 1, "%", 2);
+  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 = GFC_DESCRIPTOR_UBOUND(nl,dim);
+	      nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
+	      nl->ls[dim].idx = nl->ls[dim].start;
+	    }
+	}
+      else
+	break;
+    }
+  free (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;
+  int c;
+
+  dtp->u.p.nml_read_error = 0;
+  for (i = 0; i < len; i++)
+    {
+      c = next_char (dtp);
+      if (c == EOF || (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;
+#ifdef HAVE_CRLF
+  static const index_type endlen = 3;
+  static const char endl[] = "\r\n";
+  static const char nmlend[] = "&end\r\n";
+#else
+  static const index_type endlen = 2;
+  static const char endl[] = "\n";
+  static const char nmlend[] = "&end\n";
+#endif
+
+  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;
+	  p = write_block (dtp, len + endlen);
+          if (!p)
+            goto query_return;
+	  memcpy (p, "&", 1);
+	  memcpy ((char*)(p + 1), dtp->namelist_name, len);
+	  memcpy ((char*)(p + len + 1), &endl, endlen - 1);
+	  for (nl = dtp->u.p.ionml; nl; nl = nl->next)
+	    {
+	      /* " var_name\n"  */
+
+	      len = strlen (nl->var_name);
+              p = write_block (dtp, len + endlen);
+	      if (!p)
+		goto query_return;
+	      memcpy (p, " ", 1);
+	      memcpy ((char*)(p + 1), nl->var_name, len);
+	      memcpy ((char*)(p + len + 1), &endl, endlen - 1);
+	    }
+
+	  /* "&end\n"  */
+
+          p = write_block (dtp, endlen + 3);
+	    goto query_return;
+          memcpy (p, &nmlend, endlen + 3);
+	}
+
+      /* Flush the stream to force immediate output.  */
+
+      fbuf_flush (dtp->u.p.current_unit, WRITING);
+      sflush (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,
+	      size_t nml_err_msg_size, 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;
+  size_t 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 BT_INTEGER:
+    case BT_LOGICAL:
+      dlen = len;
+      break;
+
+    case BT_REAL:
+      dlen = size_from_real_kind (len);
+      break;
+
+    case BT_COMPLEX:
+      dlen = size_from_complex_kind (len);
+      break;
+
+    case BT_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
+				 - GFC_DESCRIPTOR_LBOUND(nl,dim))
+			* GFC_DESCRIPTOR_STRIDE(nl,dim) * 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;
+
+	  dtp->u.p.saved_type = BT_UNKNOWN;
+	  free_saved (dtp);
+
+          switch (nl->type)
+	  {
+	  case BT_INTEGER:
+	      read_integer (dtp, len);
+              break;
+
+	  case BT_LOGICAL:
+	      read_logical (dtp, len);
+              break;
+
+	  case BT_CHARACTER:
+	      read_character (dtp, len);
+              break;
+
+	  case BT_REAL:
+	    /* Need to copy data back from the real location to the temp in order
+	       to handle nml reads into arrays.  */
+	    read_real (dtp, pdata, len);
+	    memcpy (dtp->u.p.value, pdata, dlen);
+	    break;
+
+	  case BT_COMPLEX:
+	    /* Same as for REAL, copy back to temp.  */
+	    read_complex (dtp, pdata, len, dlen);
+	    memcpy (dtp->u.p.value, pdata, dlen);
+	    break;
+
+	  case BT_DERIVED:
+	    obj_name_len = strlen (nl->var_name) + 1;
+	    obj_name = get_mem (obj_name_len+1);
+	    memcpy (obj_name, nl->var_name, obj_name_len-1);
+	    memcpy (obj_name + obj_name_len - 1, "%", 2);
+
+	    /* 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, nml_err_msg_size,
+				  clow, chigh) == FAILURE)
+		  {
+		    free (obj_name);
+		    return FAILURE;
+		  }
+
+		if (dtp->u.p.input_complete)
+		  {
+		    free (obj_name);
+		    return SUCCESS;
+		  }
+	      }
+
+	    free (obj_name);
+	    goto incr_idx;
+
+          default:
+	    snprintf (nml_err_msg, nml_err_msg_size,
+		      "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 == BT_UNKNOWN)
+	{
+	  dtp->u.p.expanded_read = 0;
+	  goto incr_idx;
+	}
+
+      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:
+	  if (dlen < dtp->u.p.saved_used)
+	    {
+	      if (compile_options.bounds_check)
+		{
+		  snprintf (nml_err_msg, nml_err_msg_size,
+			    "Namelist object '%s' truncated on read.",
+			    nl->var_name);
+		  generate_warning (&dtp->common, nml_err_msg);
+		}
+	      m = dlen;
+	    }
+	  else
+	    m = 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)
+    {
+      snprintf (nml_err_msg, nml_err_msg_size,
+		"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, size_t nml_err_msg_size)
+{
+  int c;
+  namelist_info * nl;
+  namelist_info * first_nl = NULL;
+  namelist_info * root_nl = NULL;
+  int dim, parsed_rank;
+  int component_flag, qualifier_flag;
+  index_type clow, chigh;
+  int non_zero_rank_count;
+
+  /* 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;
+
+  if ((c = next_char (dtp)) == EOF)
+    return FAILURE;
+  switch (c)
+    {
+    case '=':
+      if ((c = next_char (dtp)) == EOF)
+	return FAILURE;
+      if (c != '?')
+	{
+	  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)
+	{
+	  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 flags that are set for
+     derived type components.  */
+
+  nml_untouch_nodes (dtp);
+  component_flag = 0;
+  qualifier_flag = 0;
+  non_zero_rank_count = 0;
+
+  /* Get the object name - should '!' and '\n' be permitted separators?  */
+
+get_name:
+
+  free_saved (dtp);
+
+  do
+    {
+      if (!is_separator (c))
+	push_char (dtp, tolower(c));
+      if ((c = next_char (dtp)) == EOF)
+	return FAILURE;
+    } 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)
+	snprintf (nml_err_msg, nml_err_msg_size,
+		  "Bad data for namelist object %s", (*pprev_nl)->var_name);
+
+      else
+	snprintf (nml_err_msg, nml_err_msg_size,
+		  "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 = GFC_DESCRIPTOR_UBOUND(nl,dim);
+      nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
+      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)
+    {
+      parsed_rank = 0;
+      if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
+			       nml_err_msg, &parsed_rank) == FAILURE)
+	{
+	  char *nml_err_msg_end = strchr (nml_err_msg, '\0');
+	  snprintf (nml_err_msg_end,
+		    nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
+		    " for namelist variable %s", nl->var_name);
+	  goto nml_err_ret;
+	}
+      if (parsed_rank > 0)
+	non_zero_rank_count++;
+
+      qualifier_flag = 1;
+
+      if ((c = next_char (dtp)) == EOF)
+	return FAILURE;
+      unget_char (dtp, c);
+    }
+  else if (nl->var_rank > 0)
+    non_zero_rank_count++;
+
+  /* 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 != BT_DERIVED)
+	{
+	  snprintf (nml_err_msg, nml_err_msg_size,
+		    "Attempt to get derived component for %s", nl->var_name);
+	  goto nml_err_ret;
+	}
+
+      if (*pprev_nl == NULL || !component_flag)
+	first_nl = nl;
+
+      root_nl = nl;
+
+      component_flag = 1;
+      if ((c = next_char (dtp)) == EOF)
+	return FAILURE;
+      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 == BT_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, nml_err_msg, &parsed_rank)
+	  == FAILURE)
+	{
+	  char *nml_err_msg_end = strchr (nml_err_msg, '\0');
+	  snprintf (nml_err_msg_end,
+		    nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
+		    " for namelist variable %s", nl->var_name);
+	  goto nml_err_ret;
+	}
+
+      clow = ind[0].start;
+      chigh = ind[0].end;
+
+      if (ind[0].step != 1)
+	{
+	  snprintf (nml_err_msg, nml_err_msg_size,
+		    "Step not allowed in substring qualifier"
+		    " for namelist object %s", nl->var_name);
+	  goto nml_err_ret;
+	}
+
+      if ((c = next_char (dtp)) == EOF)
+	return FAILURE;
+      unget_char (dtp, c);
+    }
+
+  /* Make sure no extraneous qualifiers are there.  */
+
+  if (c == '(')
+    {
+      snprintf (nml_err_msg, nml_err_msg_size,
+		"Qualifier for a scalar or non-character namelist object %s",
+		nl->var_name);
+      goto nml_err_ret;
+    }
+
+  /* Make sure there is no more than one non-zero rank object.  */
+  if (non_zero_rank_count > 1)
+    {
+      snprintf (nml_err_msg, nml_err_msg_size,
+		"Multiple sub-objects with non-zero rank in namelist object %s",
+		nl->var_name);
+      non_zero_rank_count = 0;
+      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;
+
+  if ((c = next_char (dtp)) == EOF)
+    return FAILURE;
+
+  if (c != '=')
+    {
+      snprintf (nml_err_msg, nml_err_msg_size,
+		"Equal sign must follow namelist object name %s",
+		nl->var_name);
+      goto nml_err_ret;
+    }
+  /* 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 == BT_DERIVED)
+    nml_touch_nodes (nl);
+
+  if (first_nl)
+    {
+      if (first_nl->var_rank == 0)
+	{
+	  if (component_flag && qualifier_flag)
+	    nl = first_nl;
+	}
+      else
+	nl = first_nl;
+    }
+
+  if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
+		    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)
+{
+  int c;
+  char nml_err_msg[200];
+
+  /* Initialize the error string buffer just in case we get an unexpected fail
+     somewhere and end up at nml_err_ret.  */
+  strcpy (nml_err_msg, "Internal namelist read error");
+
+  /* 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;
+
+  /* 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:
+  c = next_char (dtp);
+  switch (c)
+    {
+    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, '?');
+
+    case EOF:
+      return;
+
+    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;
+
+  /* A trailing space is required, we give a little lattitude here, 10.9.1.  */ 
+  c = next_char (dtp);
+  if (!is_separator(c) && c != '!')
+    {
+      unget_char (dtp, c);
+      goto find_nml_name;
+    }
+
+  unget_char (dtp, c);
+  eat_separator (dtp);
+
+  /* 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, sizeof nml_err_msg)
+			    == FAILURE)
+	{
+	  if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
+	    goto nml_err_ret;
+	  generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
+        }
+
+      /* Reset the previous namelist pointer if we know we are not going
+	 to be doing multiple reads within a single namelist object.  */
+      if (prev_nl && prev_nl->var_rank == 0)
+	prev_nl = NULL;
+    }
+
+  free_saved (dtp);
+  free_line (dtp);
+  return;
+
+
+nml_err_ret:
+
+  /* All namelist error calls return from here */
+  free_saved (dtp);
+  free_line (dtp);
+  generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
+  return;
+}
diff --git a/gcc-4.6/libgfortran/io/lock.c b/gcc-4.6/libgfortran/io/lock.c
new file mode 100644
index 000000000..9e7e9513e
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/lock.c
@@ -0,0 +1,67 @@
+/* Thread/recursion locking
+   Copyright 2002, 2003, 2004, 2005, 2007, 2009, 2010 
+   Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org> and Andy Vaught
+
+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 3 of the License, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "io.h"
+#include <string.h>
+#include <stdlib.h>
+
+/* library_start()-- Called with a library call is entered.  */
+
+void
+library_start (st_parameter_common *cmp)
+{
+  if ((cmp->flags & IOPARM_LIBRETURN_ERROR) != 0)
+    return;
+
+  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 (t2->var_name);
+	  if (t2->var_rank)
+	    {
+	     free (t2->dim);
+	     free (t2->ls);
+	    }
+	  free (t2);
+	}
+    }
+  dtp->u.p.ionml = NULL;
+}
diff --git a/gcc-4.6/libgfortran/io/open.c b/gcc-4.6/libgfortran/io/open.c
new file mode 100644
index 000000000..d7448c007
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/open.c
@@ -0,0 +1,866 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010
+   Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   F2003 I/O support contributed by Jerry DeLisle
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "io.h"
+#include "fbuf.h"
+#include "unix.h"
+#include <unistd.h>
+#include <string.h>
+#include <errno.h>
+#include <stdlib.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 decimal_opt[] =
+{
+  { "point", DECIMAL_POINT},
+  { "comma", DECIMAL_COMMA},
+  { NULL, 0}
+};
+
+static const st_option encoding_opt[] =
+{
+  { "utf-8", ENCODING_UTF8},
+  { "default", ENCODING_DEFAULT},
+  { NULL, 0}
+};
+
+static const st_option round_opt[] =
+{
+  { "up", ROUND_UP},
+  { "down", ROUND_DOWN},
+  { "zero", ROUND_ZERO},
+  { "nearest", ROUND_NEAREST},
+  { "compatible", ROUND_COMPATIBLE},
+  { "processor_defined", ROUND_PROCDEFINED},
+  { NULL, 0}
+};
+
+static const st_option sign_opt[] =
+{
+  { "plus", SIGN_PLUS},
+  { "suppress", SIGN_SUPPRESS},
+  { "processor_defined", SIGN_PROCDEFINED},
+  { NULL, 0}
+};
+
+static const st_option convert_opt[] =
+{
+  { "native", GFC_CONVERT_NATIVE},
+  { "swap", GFC_CONVERT_SWAP},
+  { "big_endian", GFC_CONVERT_BIG},
+  { "little_endian", GFC_CONVERT_LITTLE},
+  { NULL, 0}
+};
+
+static const st_option async_opt[] =
+{
+  { "yes", ASYNC_YES},
+  { "no", ASYNC_NO},
+  { 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.  */
+
+static void
+test_endfile (gfc_unit * u)
+{
+  if (u->endfile == NO_ENDFILE && file_length (u->s) == stell (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, LIBERROR_BAD_OPTION,
+		    "Cannot change STATUS parameter in OPEN statement");
+
+  if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
+    generate_error (&opp->common, LIBERROR_BAD_OPTION,
+		    "Cannot change ACCESS parameter in OPEN statement");
+
+  if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
+    generate_error (&opp->common, LIBERROR_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, LIBERROR_BAD_OPTION,
+		    "Cannot change RECL parameter in OPEN statement");
+
+  if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
+    generate_error (&opp->common, LIBERROR_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, LIBERROR_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, LIBERROR_OPTION_CONFLICT,
+			"DELIM parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->blank != BLANK_UNSPECIFIED)
+	generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+			"BLANK parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->pad != PAD_UNSPECIFIED)
+	generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+			"PAD parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->decimal != DECIMAL_UNSPECIFIED)
+	generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+			"DECIMAL parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->encoding != ENCODING_UNSPECIFIED)
+	generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+			"ENCODING parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->round != ROUND_UNSPECIFIED)
+	generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+			"ROUND parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->sign != SIGN_UNSPECIFIED)
+	generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+			"SIGN 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;
+      if (flags->decimal != DECIMAL_UNSPECIFIED)
+	u->flags.decimal = flags->decimal;
+      if (flags->encoding != ENCODING_UNSPECIFIED)
+	u->flags.encoding = flags->encoding;
+      if (flags->async != ASYNC_UNSPECIFIED)
+	u->flags.async = flags->async;
+      if (flags->round != ROUND_UNSPECIFIED)
+	u->flags.round = flags->round;
+      if (flags->sign != SIGN_UNSPECIFIED)
+	u->flags.sign = flags->sign;
+    }
+
+  /* Reposition the file if necessary.  */
+
+  switch (flags->position)
+    {
+    case POSITION_UNSPECIFIED:
+    case POSITION_ASIS:
+      break;
+
+    case POSITION_REWIND:
+      if (sseek (u->s, 0, SEEK_SET) != 0)
+	goto seek_error;
+
+      u->current_record = 0;
+      u->last_record = 0;
+
+      test_endfile (u);
+      break;
+
+    case POSITION_APPEND:
+      if (sseek (u->s, 0, SEEK_END) < 0)
+	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, LIBERROR_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->async == ASYNC_UNSPECIFIED)
+    flags->async = ASYNC_NO;
+
+  if (flags->status == STATUS_UNSPECIFIED)
+    flags->status = STATUS_UNKNOWN;
+
+  /* Checks.  */
+
+  if (flags->delim == DELIM_UNSPECIFIED)
+    flags->delim = DELIM_NONE;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (&opp->common, LIBERROR_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, LIBERROR_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, LIBERROR_OPTION_CONFLICT,
+			  "PAD parameter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto fail;
+	}
+    }
+
+  if (flags->decimal == DECIMAL_UNSPECIFIED)
+    flags->decimal = DECIMAL_POINT;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+			  "DECIMAL parameter conflicts with UNFORMATTED form "
+			  "in OPEN statement");
+	  goto fail;
+	}
+    }
+
+  if (flags->encoding == ENCODING_UNSPECIFIED)
+    flags->encoding = ENCODING_DEFAULT;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+			  "ENCODING parameter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto fail;
+	}
+    }
+
+  /* NB: the value for ROUND when it's not specified by the user does not
+         have to be PROCESSOR_DEFINED; the standard says that it is
+	 processor dependent, and requires that it is one of the
+	 possible value (see F2003, 9.4.5.13).  */
+  if (flags->round == ROUND_UNSPECIFIED)
+    flags->round = ROUND_PROCDEFINED;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+			  "ROUND parameter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto fail;
+	}
+    }
+
+  if (flags->sign == SIGN_UNSPECIFIED)
+    flags->sign = SIGN_PROCDEFINED;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+			  "SIGN parameter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto fail;
+	}
+    }
+
+  if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
+   {
+     generate_error (&opp->common, LIBERROR_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->access == ACCESS_DIRECT
+      && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
+    {
+      generate_error (&opp->common, LIBERROR_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, LIBERROR_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, LIBERROR_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;
+#ifdef HAVE_SNPRINTF
+      opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d", 
+			       (int) opp->common.unit);
+#else
+      opp->file_len = sprintf(opp->file, "fort.%d", (int) opp->common.unit);
+#endif
+      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, LIBERROR_ALREADY_OPEN, NULL);
+      goto cleanup;
+    }
+
+  if (u2 != NULL)
+    unlock_unit (u2);
+
+  /* Open file.  */
+
+  s = open_external (opp, flags);
+  if (s == NULL)
+    {
+      char *path, *msg;
+      path = (char *) gfc_alloca (opp->file_len + 1);
+      msg = (char *) gfc_alloca (opp->file_len + 51);
+      unpack_filename (path, opp->file, opp->file_len);
+
+      switch (errno)
+	{
+	case ENOENT: 
+	  sprintf (msg, "File '%s' does not exist", path);
+	  break;
+
+	case EEXIST:
+	  sprintf (msg, "File '%s' already exists", path);
+	  break;
+
+	case EACCES:
+	  sprintf (msg, "Permission denied trying to open file '%s'", path);
+	  break;
+
+	case EISDIR:
+	  sprintf (msg, "'%s' is a directory", path);
+	  break;
+
+	default:
+	  msg = NULL;
+	}
+
+      generate_error (&opp->common, LIBERROR_OS, msg);
+      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;
+  u->saved_pos = 0;
+
+  if (flags->position == POSITION_APPEND)
+    {
+      if (file_size (opp->file, opp->file_len) > 0 && sseek (u->s, 0, SEEK_END) < 0)
+	generate_error (&opp->common, LIBERROR_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->bytes_left = 1;
+      u->strm_pos = stell (u->s) + 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 at 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 (opp->file);
+    
+  if (flags->form == FORM_FORMATTED)
+    {
+      if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
+        fbuf_init (u, u->recl);
+      else
+        fbuf_init (u, 0);
+    }
+  else
+    u->fbuf = NULL;
+
+    
+    
+  return u;
+
+ cleanup:
+
+  /* Free memory associated with a temporary filename.  */
+
+  if (flags->status == STATUS_SCRATCH && opp->file != NULL)
+    free (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) == -1)
+	{
+	  unlock_unit (u);
+	  generate_error (&opp->common, LIBERROR_OS,
+			  "Error closing file in OPEN statement");
+	  return;
+	}
+
+      u->s = NULL;
+      if (u->file)
+	free (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.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
+    find_option (&opp->common, opp->decimal, opp->decimal_len,
+		 decimal_opt, "Bad DECIMAL parameter in OPEN statement");
+
+  flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
+    find_option (&opp->common, opp->encoding, opp->encoding_len,
+		 encoding_opt, "Bad ENCODING parameter in OPEN statement");
+
+  flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
+    find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
+		 async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
+
+  flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
+    find_option (&opp->common, opp->round, opp->round_len,
+		 round_opt, "Bad ROUND parameter in OPEN statement");
+
+  flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
+    find_option (&opp->common, opp->sign, opp->sign_len,
+		 sign_opt, "Bad SIGN 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 == GFC_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 big_endian, which is 0 on little-endian machines
+     and 1 on big-endian machines.  */
+  switch (conv)
+    {
+    case GFC_CONVERT_NATIVE:
+    case GFC_CONVERT_SWAP:
+      break;
+      
+    case GFC_CONVERT_BIG:
+      conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
+      break;
+      
+    case GFC_CONVERT_LITTLE:
+      conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
+      break;
+      
+    default:
+      internal_error (&opp->common, "Illegal value for CONVERT");
+      break;
+    }
+
+  flags.convert = conv;
+
+  if (!(opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT) && opp->common.unit < 0)
+    generate_error (&opp->common, LIBERROR_BAD_OPTION,
+		    "Bad unit number in OPEN statement");
+
+  if (flags.position != POSITION_UNSPECIFIED
+      && flags.access == ACCESS_DIRECT)
+    generate_error (&opp->common, LIBERROR_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, LIBERROR_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)
+    {
+      if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
+	{
+	  *opp->newunit = get_unique_unit_number(opp);
+	  opp->common.unit = *opp->newunit;
+	}
+
+      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.6/libgfortran/io/read.c b/gcc-4.6/libgfortran/io/read.c
new file mode 100644
index 000000000..4eda4a2f8
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/read.c
@@ -0,0 +1,1179 @@
+/* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009, 2010
+   Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   F2003 I/O support contributed by Jerry DeLisle
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
+#include <string.h>
+#include <errno.h>
+#include <ctype.h>
+#include <stdlib.h>
+#include <assert.h>
+
+typedef unsigned char uchar;
+
+/* 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
+/* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
+    case 10:
+    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;
+#if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
+  int n;
+#endif
+
+  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.  Note: many architectures
+   (e.g. IA-64, HP-PA) require that the storage pointed to by the dest
+   argument is properly aligned for the type in question.  */
+
+int
+convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
+{
+  errno = 0;
+
+  switch (length)
+    {
+    case 4:
+      *((GFC_REAL_4*) dest) =
+#if defined(HAVE_STRTOF)
+	gfc_strtof (buffer, NULL);
+#else
+	(GFC_REAL_4) gfc_strtod (buffer, NULL);
+#endif
+      break;
+
+    case 8:
+      *((GFC_REAL_8*) dest) = gfc_strtod (buffer, NULL);
+      break;
+
+#if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
+    case 10:
+      *((GFC_REAL_10*) dest) = gfc_strtold (buffer, NULL);
+      break;
+#endif
+
+#if defined(HAVE_GFC_REAL_16)
+# if defined(GFC_REAL_16_IS_FLOAT128)
+    case 16:
+      *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, NULL);
+      break;
+# elif defined(HAVE_STRTOLD)
+    case 16:
+      *((GFC_REAL_16*) dest) = gfc_strtold (buffer, NULL);
+      break;
+# endif
+#endif
+
+    default:
+      internal_error (&dtp->common, "Unsupported real kind during IO");
+    }
+
+  if (errno == EINVAL)
+    {
+      generate_error (&dtp->common, LIBERROR_READ_VALUE,
+		      "Error during floating point read");
+      next_record (dtp, 1);
+      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_form (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, LIBERROR_READ_VALUE,
+		      "Bad value on logical read");
+      next_record (dtp, 1);
+      break;
+    }
+}
+
+
+static gfc_char4_t
+read_utf8 (st_parameter_dt *dtp, int *nbytes) 
+{
+  static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
+  static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
+  int i, nb, nread;
+  gfc_char4_t c;
+  char *s;
+
+  *nbytes = 1;
+
+  s = read_block_form (dtp, nbytes);
+  if (s == NULL)
+    return 0;
+
+  /* If this is a short read, just return.  */
+  if (*nbytes == 0)
+    return 0;
+
+  c = (uchar) s[0];
+  if (c < 0x80)
+    return c;
+
+  /* The number of leading 1-bits in the first byte indicates how many
+     bytes follow.  */
+  for (nb = 2; nb < 7; nb++)
+    if ((c & ~masks[nb-1]) == patns[nb-1])
+      goto found;
+  goto invalid;
+	
+ found:
+  c = (c & masks[nb-1]);
+  nread = nb - 1;
+
+  s = read_block_form (dtp, &nread);
+  if (s == NULL)
+    return 0;
+  /* Decode the bytes read.  */
+  for (i = 1; i < nb; i++)
+    {
+      gfc_char4_t n = *s++;
+
+      if ((n & 0xC0) != 0x80)
+	goto invalid;
+
+      c = ((c << 6) + (n & 0x3F));
+    }
+
+  /* Make sure the shortest possible encoding was used.  */
+  if (c <=      0x7F && nb > 1) goto invalid;
+  if (c <=     0x7FF && nb > 2) goto invalid;
+  if (c <=    0xFFFF && nb > 3) goto invalid;
+  if (c <=  0x1FFFFF && nb > 4) goto invalid;
+  if (c <= 0x3FFFFFF && nb > 5) goto invalid;
+
+  /* Make sure the character is valid.  */
+  if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF))
+    goto invalid;
+
+  return c;
+      
+ invalid:
+  generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
+  return (gfc_char4_t) '?';
+}
+
+
+static void
+read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width)
+{
+  gfc_char4_t c;
+  char *dest;
+  int nbytes;
+  int i, j;
+
+  len = (width < len) ? len : width;
+
+  dest = (char *) p;
+
+  /* Proceed with decoding one character at a time.  */
+  for (j = 0; j < len; j++, dest++)
+    {
+      c = read_utf8 (dtp, &nbytes);
+
+      /* Check for a short read and if so, break out.  */
+      if (nbytes == 0)
+	break;
+
+      *dest = c > 255 ? '?' : (uchar) c;
+    }
+
+  /* If there was a short read, pad the remaining characters.  */
+  for (i = j; i < len; i++)
+    *dest++ = ' ';
+  return;
+}
+
+static void
+read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width)
+{
+  char *s;
+  int m, n;
+
+  s = read_block_form (dtp, &width);
+  
+  if (s == NULL)
+    return;
+  if (width > len)
+     s += (width - len);
+
+  m = (width > len) ? len : width;
+  memcpy (p, s, m);
+
+  n = len - width;
+  if (n > 0)
+    memset (p + m, ' ', n);
+}
+
+
+static void
+read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
+{
+  gfc_char4_t *dest;
+  int nbytes;
+  int i, j;
+
+  len = (width < len) ? len : width;
+
+  dest = (gfc_char4_t *) p;
+
+  /* Proceed with decoding one character at a time.  */
+  for (j = 0; j < len; j++, dest++)
+    {
+      *dest = read_utf8 (dtp, &nbytes);
+
+      /* Check for a short read and if so, break out.  */
+      if (nbytes == 0)
+	break;
+    }
+
+  /* If there was a short read, pad the remaining characters.  */
+  for (i = j; i < len; i++)
+    *dest++ = (gfc_char4_t) ' ';
+  return;
+}
+
+
+static void
+read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
+{
+  int m, n;
+  gfc_char4_t *dest;
+
+  if (is_char4_unit(dtp))
+    {
+      gfc_char4_t *s4;
+
+      s4 = (gfc_char4_t *) read_block_form4 (dtp, &width);
+
+      if (s4 == NULL)
+	return;
+      if (width > len)
+	 s4 += (width - len);
+
+      m = ((int) width > len) ? len : (int) width;
+
+      dest = (gfc_char4_t *) p;
+
+      for (n = 0; n < m; n++)
+	*dest++ = *s4++;
+
+      for (n = 0; n < len - (int) width; n++)
+	*dest++ = (gfc_char4_t) ' ';
+    }
+  else
+    {
+      char *s;
+
+      s = read_block_form (dtp, &width);
+
+      if (s == NULL)
+	return;
+      if (width > len)
+	 s += (width - len);
+
+      m = ((int) width > len) ? len : (int) width;
+
+      dest = (gfc_char4_t *) p;
+
+      for (n = 0; n < m; n++, dest++, s++)
+	*dest = (unsigned char ) *s;
+
+      for (n = 0; n < len - (int) width; n++, dest++)
+	*dest = (unsigned char) ' ';
+    }
+}
+
+
+/* read_a()-- Read a character record into a KIND=1 character destination,
+   processing UTF-8 encoding if necessary.  */
+
+void
+read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
+{
+  int wi;
+  int w;
+
+  wi = f->u.w;
+  if (wi == -1) /* '(A)' edit descriptor  */
+    wi = length;
+  w = wi;
+
+  /* Read in w characters, treating comma as not a separator.  */
+  dtp->u.p.sf_read_comma = 0;
+
+  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+    read_utf8_char1 (dtp, p, length, w);
+  else
+    read_default_char1 (dtp, p, length, w);
+
+  dtp->u.p.sf_read_comma =
+    dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
+}
+
+
+/* read_a_char4()-- Read a character record into a KIND=4 character destination,
+   processing UTF-8 encoding if necessary.  */
+
+void
+read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
+{
+  int w;
+
+  w = f->u.w;
+  if (w == -1) /* '(A)' edit descriptor  */
+    w = length;
+
+  /* Read in w characters, treating comma as not a separator.  */
+  dtp->u.p.sf_read_comma = 0;
+
+  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+    read_utf8_char4 (dtp, p, length, w);
+  else
+    read_default_char4 (dtp, p, length, w);
+  
+  dtp->u.p.sf_read_comma =
+    dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
+}
+
+/* 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_form (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 && compile_options.range_check == 1)
+	goto overflow;
+
+      c -= '0';
+      value = 10 * value;
+
+      if (value > maxv - c && compile_options.range_check == 1)
+	goto overflow;
+      value += c;
+    }
+
+  v = value;
+  if (negative)
+    v = -v;
+
+  set_integer (dest, v, length);
+  return;
+
+ bad:
+  generate_error (&dtp->common, LIBERROR_READ_VALUE,
+		  "Bad value during integer read");
+  next_record (dtp, 1);
+  return;
+
+ overflow:
+  generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
+		  "Value overflowed during integer read");
+  next_record (dtp, 1);
+
+}
+
+
+/* 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_form (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, LIBERROR_READ_VALUE,
+		  "Bad value during integer read");
+  next_record (dtp, 1);
+  return;
+
+ overflow:
+  generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
+		  "Value overflowed during integer read");
+  next_record (dtp, 1);
+
+}
+
+
+/* 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;
+  const char *p;
+  char *buffer;
+  char *out;
+  int seen_int_digit; /* Seen a digit before the decimal point?  */
+  int seen_dec_digit; /* Seen a digit after the decimal point?  */
+
+  seen_dp = 0;
+  seen_int_digit = 0;
+  seen_dec_digit = 0;
+  exponent_sign = 1;
+  exponent = 0;
+  w = f->u.w;
+
+  /* Read in the next block.  */
+  p = read_block_form (dtp, &w);
+  if (p == NULL)
+    return;
+  p = eat_leading_spaces (&w, (char*) p);
+  if (w == 0)
+    goto zero;
+
+  /* In this buffer we're going to re-format the number cleanly to be parsed
+     by convert_real in the end; this assures we're using strtod from the
+     C library for parsing and thus probably get the best accuracy possible.
+     This process may add a '+0.0' in front of the number as well as change the
+     exponent because of an implicit decimal point or the like.  Thus allocating
+     strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
+     original buffer had should be enough.  */
+  buffer = gfc_alloca (w + 11);
+  out = buffer;
+
+  /* Optional sign */
+  if (*p == '-' || *p == '+')
+    {
+      if (*p == '-')
+	*(out++) = '-';
+      ++p;
+      --w;
+    }
+
+  p = eat_leading_spaces (&w, (char*) p);
+  if (w == 0)
+    goto zero;
+
+  /* Check for Infinity or NaN.  */    
+  if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
+    {
+      int seen_paren = 0;
+      char *save = out;
+
+      /* Scan through the buffer keeping track of spaces and parenthesis. We
+	 null terminate the string as soon as we see a left paren or if we are
+	 BLANK_NULL mode.  Leading spaces have already been skipped above,
+	 trailing spaces are ignored by converting to '\0'. A space
+	 between "NaN" and the optional perenthesis is not permitted.  */
+      while (w > 0)
+	{
+	  *out = tolower (*p);
+	  switch (*p)
+	    {
+	    case ' ':
+	      if (dtp->u.p.blank_status == BLANK_ZERO)
+		{
+		  *out = '0';
+		  break;
+		}
+	      *out = '\0';
+	      if (seen_paren == 1)
+	        goto bad_float;
+	      break;
+	    case '(':
+	      seen_paren++;
+	      *out = '\0';
+	      break;
+	    case ')':
+	      if (seen_paren++ != 1)
+		goto bad_float;
+	      break;
+	    default:
+	      if (!isalnum (*out))
+		goto bad_float;
+	    }
+	  --w;
+	  ++p;
+	  ++out;
+	}
+	 
+      *out = '\0';
+      
+      if (seen_paren != 0 && seen_paren != 2)
+	goto bad_float;
+
+      if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
+	{
+	   if (seen_paren)
+	     goto bad_float;
+	}
+      else if (strcmp (save, "nan") != 0)
+	goto bad_float;
+
+      convert_real (dtp, dest, buffer, length);
+      return;
+    }
+
+  /* Process the mantissa string.  */
+  while (w > 0)
+    {
+      switch (*p)
+	{
+	case ',':
+	  if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
+	    goto bad_float;
+	  /* Fall through.  */
+	case '.':
+	  if (seen_dp)
+	    goto bad_float;
+	  if (!seen_int_digit)
+	    *(out++) = '0';
+	  *(out++) = '.';
+	  seen_dp = 1;
+	  break;
+
+	case ' ':
+	  if (dtp->u.p.blank_status == BLANK_ZERO)
+	    {
+	      *(out++) = '0';
+	      goto found_digit;
+	    }
+	  else if (dtp->u.p.blank_status == BLANK_NULL)
+	    break;
+	  else
+	    /* TODO: Should we check instead that there are only trailing
+	       blanks here, as is done below for exponents?  */
+	    goto done;
+	  /* Fall through.  */
+	case '0':
+	case '1':
+	case '2':
+	case '3':
+	case '4':
+	case '5':
+	case '6':
+	case '7':
+	case '8':
+	case '9':
+	  *(out++) = *p;
+found_digit:
+	  if (!seen_dp)
+	    seen_int_digit = 1;
+	  else
+	    seen_dec_digit = 1;
+	  break;
+
+	case '-':
+	case '+':
+	  goto exponent;
+
+	case 'e':
+	case 'E':
+	case 'd':
+	case 'D':
+	  ++p;
+	  --w;
+	  goto exponent;
+
+	default:
+	  goto bad_float;
+	}
+
+      ++p;
+      --w;
+    }
+  
+  /* No exponent has been seen, so we use the current scale factor.  */
+  exponent = - dtp->u.p.scale_factor;
+  goto done;
+
+  /* At this point the start of an exponent has been found.  */
+exponent:
+  p = eat_leading_spaces (&w, (char*) p);
+  if (*p == '-' || *p == '+')
+    {
+      if (*p == '-')
+	exponent_sign = -1;
+      ++p;
+      --w;
+    }
+
+  /* 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.  */
+
+  if (w == 0)
+    goto bad_float;
+
+  if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
+    {
+      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)
+		exponent *= 10;
+	      else
+		assert (dtp->u.p.blank_status == BLANK_NULL);
+	    }
+	  else if (!isdigit (*p))
+	    goto bad_float;
+	  else
+	    {
+	      exponent *= 10;
+	      exponent += *p - '0';
+	    }
+
+	  ++p;
+	  --w;
+	}
+    }
+
+  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;
+
+  /* Output a trailing '0' after decimal point if not yet found.  */
+  if (seen_dp && !seen_dec_digit)
+    *(out++) = '0';
+
+  /* Print out the exponent to finish the reformatted number.  Maximum 4
+     digits for the exponent.  */
+  if (exponent != 0)
+    {
+      int dig;
+
+      *(out++) = 'e';
+      if (exponent < 0)
+	{
+	  *(out++) = '-';
+	  exponent = - exponent;
+	}
+
+      assert (exponent < 10000);
+      for (dig = 3; dig >= 0; --dig)
+	{
+	  out[dig] = (char) ('0' + exponent % 10);
+	  exponent /= 10;
+	}
+      out += 4;
+    }
+  *(out++) = '\0';
+
+  /* Do the actual conversion.  */
+  convert_real (dtp, dest, buffer, length);
+
+  return;
+
+  /* The value read is zero.  */
+zero:
+  switch (length)
+    {
+      case 4:
+	*((GFC_REAL_4 *) dest) = 0.0;
+	break;
+
+      case 8:
+	*((GFC_REAL_8 *) dest) = 0.0;
+	break;
+
+#ifdef HAVE_GFC_REAL_10
+      case 10:
+	*((GFC_REAL_10 *) dest) = 0.0;
+	break;
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+      case 16:
+	*((GFC_REAL_16 *) dest) = 0.0;
+	break;
+#endif
+
+      default:
+	internal_error (&dtp->common, "Unsupported real kind during IO");
+    }
+  return;
+
+bad_float:
+  generate_error (&dtp->common, LIBERROR_READ_VALUE,
+		  "Bad value during floating point read");
+  next_record (dtp, 1);
+  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)
+{
+  int length, q, q2;
+
+  if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
+       && dtp->u.p.current_unit->bytes_left < n)
+    n = dtp->u.p.current_unit->bytes_left;
+    
+  if (n == 0)
+    return;
+
+  length = n;
+
+  if (is_internal_unit (dtp))
+    {
+      mem_alloc_r (dtp->u.p.current_unit->s, &length);
+      if (unlikely (length < n))
+	n = length;
+      goto done;
+    }
+
+  if (dtp->u.p.sf_seen_eor)
+    return;
+
+  n = 0;
+  while (n < length)
+    {
+      q = fbuf_getc (dtp->u.p.current_unit);
+      if (q == EOF)
+	break;
+      else if (q == '\n' || q == '\r')
+	{
+	  /* Unexpected end of line. Set the position.  */
+	  dtp->u.p.sf_seen_eor = 1;
+
+	  /* 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;
+	    
+	  /* If we encounter a CR, it might be a CRLF.  */
+	  if (q == '\r') /* Probably a CRLF */
+	    {
+	      /* See if there is an LF.  */
+	      q2 = fbuf_getc (dtp->u.p.current_unit);
+	      if (q2 == '\n')
+		dtp->u.p.sf_seen_eor = 2;
+	      else if (q2 != EOF) /* Oops, seek back.  */
+		fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
+	    }
+	  goto done;
+	}
+      n++;
+    } 
+
+ done:
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used += (GFC_IO_INT) n;
+  dtp->u.p.current_unit->bytes_left -= n;
+  dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
+}
+
diff --git a/gcc-4.6/libgfortran/io/size_from_kind.c b/gcc-4.6/libgfortran/io/size_from_kind.c
new file mode 100644
index 000000000..d467df015
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/size_from_kind.c
@@ -0,0 +1,83 @@
+/* Copyright (C) 2005, 2007, 2009 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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* This file contains utility functions for determining the size of a
+   variable given its kind. */
+
+#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.6/libgfortran/io/transfer.c b/gcc-4.6/libgfortran/io/transfer.c
new file mode 100644
index 000000000..15f90e767
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/transfer.c
@@ -0,0 +1,3745 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+   Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   Namelist transfer functions contributed by Paul Thomas
+   F2003 I/O support contributed by Jerry DeLisle
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+
+/* transfer.c -- Top level handling of data transfer statements.  */
+
+#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
+#include <string.h>
+#include <assert.h>
+#include <stdlib.h>
+#include <errno.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. For READ (and for backwards compatibily: for WRITE), one has
+
+      transfer_integer
+      transfer_logical
+      transfer_character
+      transfer_character_wide
+      transfer_real
+      transfer_complex
+      transfer_real128
+      transfer_complex128
+   
+    and for WRITE
+
+      transfer_integer_write
+      transfer_logical_write
+      transfer_character_write
+      transfer_character_wide_write
+      transfer_real_write
+      transfer_complex_write
+      transfer_real128_write
+      transfer_complex128_write
+
+    These subroutines do not return status. The *128 functions
+    are in the file transfer128.c.
+
+    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_integer_write (st_parameter_dt *, void *, int);
+export_proto(transfer_integer_write);
+
+extern void transfer_real (st_parameter_dt *, void *, int);
+export_proto(transfer_real);
+
+extern void transfer_real_write (st_parameter_dt *, void *, int);
+export_proto(transfer_real_write);
+
+extern void transfer_logical (st_parameter_dt *, void *, int);
+export_proto(transfer_logical);
+
+extern void transfer_logical_write (st_parameter_dt *, void *, int);
+export_proto(transfer_logical_write);
+
+extern void transfer_character (st_parameter_dt *, void *, int);
+export_proto(transfer_character);
+
+extern void transfer_character_write (st_parameter_dt *, void *, int);
+export_proto(transfer_character_write);
+
+extern void transfer_character_wide (st_parameter_dt *, void *, int, int);
+export_proto(transfer_character_wide);
+
+extern void transfer_character_wide_write (st_parameter_dt *,
+					   void *, int, int);
+export_proto(transfer_character_wide_write);
+
+extern void transfer_complex (st_parameter_dt *, void *, int);
+export_proto(transfer_complex);
+
+extern void transfer_complex_write (st_parameter_dt *, void *, int);
+export_proto(transfer_complex_write);
+
+extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
+			    gfc_charlen_type);
+export_proto(transfer_array);
+
+extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int,
+			    gfc_charlen_type);
+export_proto(transfer_array_write);
+
+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}
+};
+
+
+static const st_option decimal_opt[] = {
+  {"point", DECIMAL_POINT},
+  {"comma", DECIMAL_COMMA},
+  {NULL, 0}
+};
+
+static const st_option round_opt[] = {
+  {"up", ROUND_UP},
+  {"down", ROUND_DOWN},
+  {"zero", ROUND_ZERO},
+  {"nearest", ROUND_NEAREST},
+  {"compatible", ROUND_COMPATIBLE},
+  {"processor_defined", ROUND_PROCDEFINED},
+  {NULL, 0}
+};
+
+
+static const st_option sign_opt[] = {
+  {"plus", SIGN_SP},
+  {"suppress", SIGN_SS},
+  {"processor_defined", SIGN_S},
+  {NULL, 0}
+};
+
+static const st_option blank_opt[] = {
+  {"null", BLANK_NULL},
+  {"zero", BLANK_ZERO},
+  {NULL, 0}
+};
+
+static const st_option delim_opt[] = {
+  {"apostrophe", DELIM_APOSTROPHE},
+  {"quote", DELIM_QUOTE},
+  {"none", DELIM_NONE},
+  {NULL, 0}
+};
+
+static const st_option pad_opt[] = {
+  {"yes", PAD_YES},
+  {"no", PAD_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.  */
+
+/* Read sequential file - internal unit  */
+
+static char *
+read_sf_internal (st_parameter_dt *dtp, int * length)
+{
+  static char *empty_string[0];
+  char *base;
+  int lorig;
+
+  /* Zero size array gives internal unit len of 0.  Nothing to read. */
+  if (dtp->internal_unit_len == 0
+      && dtp->u.p.current_unit->pad_status == PAD_NO)
+    hit_eof (dtp);
+
+  /* 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;
+      /* Just return something that isn't a NULL pointer, otherwise the
+         caller thinks an error occured.  */
+      return (char*) empty_string;
+    }
+
+  lorig = *length;
+  if (is_char4_unit(dtp))
+    {
+      int i;
+      gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s,
+			length);
+      base = fbuf_alloc (dtp->u.p.current_unit, lorig);
+      for (i = 0; i < *length; i++, p++)
+	base[i] = *p > 255 ? '?' : (unsigned char) *p;
+    }
+  else
+    base = mem_alloc_r (dtp->u.p.current_unit->s, length);
+
+  if (unlikely (lorig > *length))
+    {
+      hit_eof (dtp);
+      return NULL;
+    }
+
+  dtp->u.p.current_unit->bytes_left -= *length;
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used += (GFC_IO_INT) *length;
+
+  return base;
+
+}
+
+/* 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.  */
+
+/* Read sequential file - external unit */
+
+static char *
+read_sf (st_parameter_dt *dtp, int * length)
+{
+  static char *empty_string[0];
+  int q, q2;
+  int n, lorig, seen_comma;
+
+  /* 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;
+      /* Just return something that isn't a NULL pointer, otherwise the
+         caller thinks an error occured.  */
+      return (char*) empty_string;
+    }
+
+  n = seen_comma = 0;
+
+  /* Read data into format buffer and scan through it.  */
+  lorig = *length;
+
+  while (n < *length)
+    {
+      q = fbuf_getc (dtp->u.p.current_unit);
+      if (q == EOF)
+	break;
+      else if (q == '\n' || q == '\r')
+	{
+	  /* Unexpected end of line. Set the position.  */
+	  dtp->u.p.sf_seen_eor = 1;
+
+	  /* 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;
+	    
+	  /* If we encounter a CR, it might be a CRLF.  */
+	  if (q == '\r') /* Probably a CRLF */
+	    {
+	      /* See if there is an LF.  */
+	      q2 = fbuf_getc (dtp->u.p.current_unit);
+	      if (q2 == '\n')
+		dtp->u.p.sf_seen_eor = 2;
+	      else if (q2 != EOF) /* Oops, seek back.  */
+		fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
+	    }
+
+	  /* 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->pad_status == PAD_NO)
+	    {
+	      generate_error (&dtp->common, LIBERROR_EOR, NULL);
+	      return NULL;
+	    }
+
+	  *length = n;
+	  goto done;
+	}
+      /*  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  */
+      else if (q == ',')
+	if (dtp->u.p.sf_read_comma == 1)
+	  {
+            seen_comma = 1;
+	    notify_std (&dtp->common, GFC_STD_GNU,
+			"Comma in formatted numeric read.");
+	    break;
+	  }
+      n++;
+    }
+
+  *length = n;
+
+  /* A short read implies we hit EOF, unless we hit EOR, a comma, or
+     some other stuff. Set the relevant flags.  */
+  if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma)
+    {
+      if (n > 0)
+        {
+	  if (dtp->u.p.advance_status == ADVANCE_NO)
+	    {
+	      if (dtp->u.p.current_unit->pad_status == PAD_NO)
+	        {
+		  hit_eof (dtp);
+		  return NULL;
+		}
+	      else
+		dtp->u.p.eor_condition = 1;
+	    }
+	  else
+	    dtp->u.p.at_eof = 1;
+	}
+      else if (dtp->u.p.advance_status == ADVANCE_NO
+	       || dtp->u.p.current_unit->pad_status == PAD_NO
+	       || dtp->u.p.current_unit->bytes_left
+		    == dtp->u.p.current_unit->recl)
+	{
+	  hit_eof (dtp);
+	  return NULL;
+	}
+    }
+
+ done:
+
+  dtp->u.p.current_unit->bytes_left -= n;
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used += (GFC_IO_INT) n;
+
+  /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
+     fbuf_getc might reallocate the buffer.  So return current pointer
+     minus all the advances, which is n plus up to two characters
+     of newline or comma.  */
+  return fbuf_getptr (dtp->u.p.current_unit)
+	 - n - dtp->u.p.sf_seen_eor - seen_comma;
+}
+
+
+/* Function for reading the next couple of bytes from the current
+   file, advancing the current position. We return FAILURE on end of record or
+   end of file. This function is only for formatted I/O, unformatted uses
+   read_block_direct.
+
+   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_form (st_parameter_dt *dtp, int * nbytes)
+{
+  char *source;
+  int norig;
+
+  if (!is_stream_io (dtp))
+    {
+      if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
+	{
+	  /* 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 (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO)
+		  && !is_internal_unit (dtp))
+		{
+		  /* Not enough data left.  */
+		  generate_error (&dtp->common, LIBERROR_EOR, NULL);
+		  return NULL;
+		}
+	    }
+
+	  if (unlikely (dtp->u.p.current_unit->bytes_left == 0
+	      && !is_internal_unit(dtp)))
+	    {
+	      hit_eof (dtp);
+	      return NULL;
+	    }
+
+	  *nbytes = 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))
+    {
+      if (is_internal_unit (dtp))
+	source = read_sf_internal (dtp, nbytes);
+      else
+	source = read_sf (dtp, nbytes);
+
+      dtp->u.p.current_unit->strm_pos +=
+	(gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
+      return source;
+    }
+
+  /* If we reach here, we can assume it's direct access.  */
+
+  dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
+
+  norig = *nbytes;
+  source = fbuf_read (dtp->u.p.current_unit, nbytes);
+  fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR);
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
+
+  if (norig != *nbytes)
+    {
+      /* Short read, this shouldn't happen.  */
+      if (!dtp->u.p.current_unit->pad_status == PAD_YES)
+	{
+	  generate_error (&dtp->common, LIBERROR_EOR, NULL);
+	  source = NULL;
+	}
+    }
+
+  dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes;
+
+  return source;
+}
+
+
+/* Read a block from a character(kind=4) internal unit, to be transferred into
+   a character(kind=4) variable.  Note: Portions of this code borrowed from
+   read_sf_internal.  */
+void *
+read_block_form4 (st_parameter_dt *dtp, int * nbytes)
+{
+  static gfc_char4_t *empty_string[0];
+  gfc_char4_t *source;
+  int lorig;
+
+  if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
+    *nbytes = dtp->u.p.current_unit->bytes_left;
+
+  /* Zero size array gives internal unit len of 0.  Nothing to read. */
+  if (dtp->internal_unit_len == 0
+      && dtp->u.p.current_unit->pad_status == PAD_NO)
+    hit_eof (dtp);
+
+  /* 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)
+    {
+      *nbytes = 0;
+      /* Just return something that isn't a NULL pointer, otherwise the
+         caller thinks an error occured.  */
+      return empty_string;
+    }
+
+  lorig = *nbytes;
+  source = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, nbytes);
+
+  if (unlikely (lorig > *nbytes))
+    {
+      hit_eof (dtp);
+      return NULL;
+    }
+
+  dtp->u.p.current_unit->bytes_left -= *nbytes;
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
+
+  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)
+{
+  ssize_t to_read_record;
+  ssize_t have_read_record;
+  ssize_t to_read_subrecord;
+  ssize_t have_read_subrecord;
+  int short_record;
+
+  if (is_stream_io (dtp))
+    {
+      have_read_record = sread (dtp->u.p.current_unit->s, buf, 
+				nbytes);
+      if (unlikely (have_read_record < 0))
+	{
+	  generate_error (&dtp->common, LIBERROR_OS, NULL);
+	  return;
+	}
+
+      dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record; 
+
+      if (unlikely ((ssize_t) nbytes != have_read_record))
+	{
+	  /* Short read,  e.g. if we hit EOF.  For stream files,
+	   we have to set the end-of-file condition.  */
+          hit_eof (dtp);
+	}
+      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 = 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;
+
+      to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record);
+      if (unlikely (to_read_record < 0))
+	{
+	  generate_error (&dtp->common, LIBERROR_OS, NULL);
+	  return;
+	}
+
+      if (to_read_record != (ssize_t) nbytes)  
+	{
+	  /* Short read, e.g. if we hit EOF.  Apparently, we read
+	   more than was written to the last record.  */
+	  return;
+	}
+
+      if (unlikely (short_record))
+	{
+	  generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
+	}
+      return;
+    }
+
+  /* Unformatted sequential.  We loop over the subrecords, reading
+     until the request has been fulfilled or the record has run out
+     of continuation subrecords.  */
+
+  /* Check whether we exceed the total record length.  */
+
+  if (dtp->u.p.current_unit->flags.has_recl
+      && ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left))
+    {
+      to_read_record = 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 = 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 = sread (dtp->u.p.current_unit->s, 
+				   buf + have_read_record, to_read_subrecord);
+      if (unlikely (have_read_subrecord) < 0)
+	{
+	  generate_error (&dtp->common, LIBERROR_OS, NULL);
+	  return;
+	}
+
+      have_read_record += have_read_subrecord;
+
+      if (unlikely (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.  */
+
+	  generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL);
+	  return;
+	}
+
+      if (to_read_record > 0)
+	{
+	  if (likely (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, LIBERROR_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 (unlikely (short_record))
+    {
+      generate_error (&dtp->common, LIBERROR_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 (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 (likely ((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, LIBERROR_EOR, NULL);
+	      return NULL;
+	    }
+	}
+
+      dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
+    }
+
+  if (is_internal_unit (dtp))
+    {
+      if (dtp->common.unit) /* char4 internel unit.  */
+	{
+	  gfc_char4_t *dest4;
+	  dest4 = mem_alloc_w4 (dtp->u.p.current_unit->s, &length);
+	  if (dest4 == NULL)
+	  {
+            generate_error (&dtp->common, LIBERROR_END, NULL);
+            return NULL;
+	  }
+	  return dest4;
+	}
+      else
+	dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
+
+      if (dest == NULL)
+	{
+          generate_error (&dtp->common, LIBERROR_END, NULL);
+          return NULL;
+	}
+
+      if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
+	generate_error (&dtp->common, LIBERROR_END, NULL);
+    }
+  else
+    {
+      dest = fbuf_alloc (dtp->u.p.current_unit, length);
+      if (dest == NULL)
+	{
+	  generate_error (&dtp->common, LIBERROR_OS, NULL);
+	  return NULL;
+	}
+    }
+    
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    dtp->u.p.size_used += (GFC_IO_INT) 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)
+{
+
+  ssize_t have_written;
+  ssize_t to_write_subrecord;
+  int short_record;
+
+  /* Stream I/O.  */
+
+  if (is_stream_io (dtp))
+    {
+      have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
+      if (unlikely (have_written < 0))
+	{
+	  generate_error (&dtp->common, LIBERROR_OS, NULL);
+	  return FAILURE;
+	}
+
+      dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; 
+
+      return SUCCESS;
+    }
+
+  /* Unformatted direct access.  */
+
+  if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+    {
+      if (unlikely (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes))
+	{
+	  generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL);
+	  return FAILURE;
+	}
+
+      if (buf == NULL && nbytes == 0)
+	return SUCCESS;
+
+      have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); 
+      if (unlikely (have_written < 0))
+	{
+	  generate_error (&dtp->common, LIBERROR_OS, NULL);
+	  return FAILURE;
+	}
+
+      dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
+      dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written;
+
+      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;
+
+      to_write_subrecord = swrite (dtp->u.p.current_unit->s, 
+				   buf + have_written, to_write_subrecord);
+      if (unlikely (to_write_subrecord < 0))
+	{
+	  generate_error (&dtp->common, LIBERROR_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 (unlikely (short_record))
+    {
+      generate_error (&dtp->common, LIBERROR_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)
+{
+  if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
+      || kind == 1)
+    {
+      if (type == BT_CHARACTER)
+	size *= GFC_SIZE_OF_CHAR_KIND(kind);
+      read_block_direct (dtp, dest, size * nelems);
+    }
+  else
+    {
+      char buffer[16];
+      char *p;
+      size_t i;
+
+      p = dest;
+
+      /* Handle wide chracters.  */
+      if (type == BT_CHARACTER && kind != 1)
+	{
+	  nelems *= size;
+	  size = kind;
+	}
+
+      /* Break up complex into its constituent reals.  */
+      if (type == BT_COMPLEX)
+	{
+	  nelems *= 2;
+	  size /= 2;
+	}
+      
+      /* By now, all complex variables have been split into their
+	 constituent reals.  */
+      
+      for (i = 0; i < nelems; i++)
+	{
+ 	  read_block_direct (dtp, buffer, size);
+ 	  reverse_memcpy (p, buffer, size);
+ 	  p += size;
+ 	}
+    }
+}
+
+
+/* Master function for unformatted writes.  NOTE: For kind=10 the size is 16
+   bytes on 64 bit machines.  The unused bytes are not initialized and never
+   used, which can show an error with memory checking analyzers like
+   valgrind.  */
+
+static void
+unformatted_write (st_parameter_dt *dtp, bt type,
+		   void *source, int kind, size_t size, size_t nelems)
+{
+  if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE) 
+      || kind == 1)
+    {
+      size_t stride = type == BT_CHARACTER ?
+		  size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
+
+      write_buf (dtp, source, stride * nelems);
+    }
+  else
+    {
+      char buffer[16];
+      char *p;
+      size_t i;
+
+      p = source;
+
+      /* Handle wide chracters.  */
+      if (type == BT_CHARACTER && kind != 1)
+	{
+	  nelems *= size;
+	  size = kind;
+	}
+  
+      /* Break up complex into its constituent reals.  */
+      if (type == BT_COMPLEX)
+	{
+	  nelems *= 2;
+	  size /= 2;
+	}      
+
+      /* By now, all complex variables have been split into their
+	 constituent reals.  */
+
+      for (i = 0; i < nelems; i++)
+	{
+	  reverse_memcpy(buffer, p, size);
+ 	  p += size;
+	  write_buf (dtp, buffer, size);
+	}
+    }
+}
+
+
+/* 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;
+
+  /* Adjust item_count before emitting error message.  */
+  sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
+	   type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
+
+  format_error (dtp, f, buffer);
+  return 1;
+}
+
+
+/* This function is in 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 function that supplies the address and type
+   of the next element, then comes back here to process it.  */
+
+static void
+formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind,
+				size_t 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 =
+    dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
+
+  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 (unlikely (n > 0))
+	    generate_error (&dtp->common, LIBERROR_FORMAT,
+		"Insufficient data descriptors in format after reversion");
+	  return;
+	}
+
+      t = f->format;
+
+      bytes_used = (int)(dtp->u.p.current_unit->recl
+		   - dtp->u.p.current_unit->bytes_left);
+
+      if (is_stream_io(dtp))
+	bytes_used = 0;
+
+      switch (t)
+	{
+	case FMT_I:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  read_decimal (dtp, f, p, kind);
+	  break;
+
+	case FMT_B:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (!(compile_options.allow_std & GFC_STD_GNU)
+              && require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  read_radix (dtp, f, p, kind, 2);
+	  break;
+
+	case FMT_O:
+	  if (n == 0)
+	    goto need_read_data; 
+	  if (!(compile_options.allow_std & GFC_STD_GNU)
+              && require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  read_radix (dtp, f, p, kind, 8);
+	  break;
+
+	case FMT_Z:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (!(compile_options.allow_std & GFC_STD_GNU)
+              && require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  read_radix (dtp, f, p, kind, 16);
+	  break;
+
+	case FMT_A:
+	  if (n == 0)
+	    goto need_read_data;
+
+	  /* It is possible to have FMT_A with something not BT_CHARACTER such
+	     as when writing out hollerith strings, so check both type
+	     and kind before calling wide character routines.  */
+	  if (type == BT_CHARACTER && kind == 4)
+	    read_a_char4 (dtp, f, p, size);
+	  else
+	    read_a (dtp, f, p, size);
+	  break;
+
+	case FMT_L:
+	  if (n == 0)
+	    goto need_read_data;
+	  read_l (dtp, f, p, kind);
+	  break;
+
+	case FMT_D:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  read_f (dtp, f, p, kind);
+	  break;
+
+	case FMT_E:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  read_f (dtp, f, p, kind);
+	  break;
+
+	case FMT_EN:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  read_f (dtp, f, p, kind);
+	  break;
+
+	case FMT_ES:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  read_f (dtp, f, p, kind);
+	  break;
+
+	case FMT_F:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  read_f (dtp, f, p, kind);
+	  break;
+
+	case FMT_G:
+	  if (n == 0)
+	    goto need_read_data;
+	  switch (type)
+	    {
+	      case BT_INTEGER:
+		read_decimal (dtp, f, p, kind);
+		break;
+	      case BT_LOGICAL:
+		read_l (dtp, f, p, kind);
+		break;
+	      case BT_CHARACTER:
+		if (kind == 4)
+		  read_a_char4 (dtp, f, p, size);
+		else
+		  read_a (dtp, f, p, size);
+		break;
+	      case BT_REAL:
+		read_f (dtp, f, p, kind);
+		break;
+	      default:
+		internal_error (&dtp->common, "formatted_transfer(): Bad type");
+	    }
+	  break;
+
+	case FMT_STRING:
+	  consume_data_flag = 0;
+	  format_error (dtp, f, "Constant string in input format");
+	  return;
+
+	/* Format codes that don't transfer data.  */
+	case FMT_X:
+	case FMT_TR:
+	  consume_data_flag = 0;
+	  dtp->u.p.skips += f->u.n;
+	  pos = bytes_used + dtp->u.p.skips - 1;
+	  dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
+	  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.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 */
+	    pos = f->u.n - 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;
+	  dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
+				    ? 0 : dtp->u.p.pending_spaces;
+	  if (dtp->u.p.skips == 0)
+	    break;
+
+	  /* Adjust everything for end-of-record condition */
+	  if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
+	    {
+              dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor;
+              dtp->u.p.skips -= dtp->u.p.sf_seen_eor;
+	      bytes_used = pos;
+	      dtp->u.p.sf_seen_eor = 0;
+	    }
+	  if (dtp->u.p.skips < 0)
+	    {
+              if (is_internal_unit (dtp))  
+                sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
+              else
+                fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
+	      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_DC:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
+	  break;
+
+	case FMT_DP:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
+	  break;
+
+	case FMT_RC:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
+	  break;
+
+	case FMT_RD:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_DOWN;
+	  break;
+
+	case FMT_RN:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_NEAREST;
+	  break;
+
+	case FMT_RP:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
+	  break;
+
+	case FMT_RU:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_UP;
+	  break;
+
+	case FMT_RZ:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_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");
+	}
+
+      /* Adjust the item count and data pointer.  */
+
+      if ((consume_data_flag > 0) && (n > 0))
+	{
+	  n--;
+	  p = ((char *) p) + size;
+	}
+
+      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_read_data:
+  unget_format (dtp, f);
+}
+
+
+static void
+formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
+				 size_t 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 =
+    dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
+
+  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 (unlikely (n > 0))
+	    generate_error (&dtp->common, LIBERROR_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)
+	    {
+	      int tmp;
+	      write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
+	      tmp = (int)(dtp->u.p.current_unit->recl
+			  - dtp->u.p.current_unit->bytes_left);
+	      dtp->u.p.max_pos = 
+		dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
+	    }
+	  if (dtp->u.p.skips < 0)
+	    {
+              if (is_internal_unit (dtp))  
+	        sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
+              else
+                fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
+	      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);
+
+      if (is_stream_io(dtp))
+	bytes_used = 0;
+
+      switch (t)
+	{
+	case FMT_I:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  write_i (dtp, f, p, kind);
+	  break;
+
+	case FMT_B:
+	  if (n == 0)
+	    goto need_data;
+	  if (!(compile_options.allow_std & GFC_STD_GNU)
+              && require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  write_b (dtp, f, p, kind);
+	  break;
+
+	case FMT_O:
+	  if (n == 0)
+	    goto need_data; 
+	  if (!(compile_options.allow_std & GFC_STD_GNU)
+              && require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  write_o (dtp, f, p, kind);
+	  break;
+
+	case FMT_Z:
+	  if (n == 0)
+	    goto need_data;
+	  if (!(compile_options.allow_std & GFC_STD_GNU)
+              && require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  write_z (dtp, f, p, kind);
+	  break;
+
+	case FMT_A:
+	  if (n == 0)
+	    goto need_data;
+
+	  /* It is possible to have FMT_A with something not BT_CHARACTER such
+	     as when writing out hollerith strings, so check both type
+	     and kind before calling wide character routines.  */
+	  if (type == BT_CHARACTER && kind == 4)
+	    write_a_char4 (dtp, f, p, size);
+	  else
+	    write_a (dtp, f, p, size);
+	  break;
+
+	case FMT_L:
+	  if (n == 0)
+	    goto need_data;
+	  write_l (dtp, f, p, kind);
+	  break;
+
+	case FMT_D:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  write_d (dtp, f, p, kind);
+	  break;
+
+	case FMT_E:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  write_e (dtp, f, p, kind);
+	  break;
+
+	case FMT_EN:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  write_en (dtp, f, p, kind);
+	  break;
+
+	case FMT_ES:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  write_es (dtp, f, p, kind);
+	  break;
+
+	case FMT_F:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  write_f (dtp, f, p, kind);
+	  break;
+
+	case FMT_G:
+	  if (n == 0)
+	    goto need_data;
+	  switch (type)
+	    {
+	      case BT_INTEGER:
+		write_i (dtp, f, p, kind);
+		break;
+	      case BT_LOGICAL:
+		write_l (dtp, f, p, kind);
+		break;
+	      case BT_CHARACTER:
+		if (kind == 4)
+		  write_a_char4 (dtp, f, p, size);
+		else
+		  write_a (dtp, f, p, size);
+		break;
+	      case BT_REAL:
+		if (f->u.real.w == 0)
+                  write_real_g0 (dtp, p, kind, f->u.real.d);
+		else
+		  write_d (dtp, f, p, kind);
+		break;
+	      default:
+		internal_error (&dtp->common,
+				"formatted_transfer(): Bad type");
+	    }
+	  break;
+
+	case FMT_STRING:
+	  consume_data_flag = 0;
+	  write_constant_string (dtp, f);
+	  break;
+
+	/* Format codes that don't transfer data.  */
+	case FMT_X:
+	case FMT_TR:
+	  consume_data_flag = 0;
+
+	  dtp->u.p.skips += f->u.n;
+	  pos = bytes_used + dtp->u.p.skips - 1;
+	  dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
+	  /* 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.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;
+	    }
+	  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.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 */
+	    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;
+	  dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
+				    ? 0 : dtp->u.p.pending_spaces;
+	  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_DC:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
+	  break;
+
+	case FMT_DP:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
+	  break;
+
+	case FMT_RC:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
+	  break;
+
+	case FMT_RD:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_DOWN;
+	  break;
+
+	case FMT_RN:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_NEAREST;
+	  break;
+
+	case FMT_RP:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
+	  break;
+
+	case FMT_RU:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_UP;
+	  break;
+
+	case FMT_RZ:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->round_status = ROUND_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");
+	}
+
+      /* Adjust the item count and data pointer.  */
+
+      if ((consume_data_flag > 0) && (n > 0))
+	{
+	  n--;
+	  p = ((char *) p) + size;
+	}
+
+      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);
+}
+
+  /* This function is first called from data_init_transfer to initiate the loop
+     over each item in the format, transferring data as required.  Subsequent
+     calls to this function occur for each data item foound in the READ/WRITE
+     statement.  The item_count is incremented for each call.  Since the first
+     call is from data_transfer_init, the item_count is always one greater than
+     the actual count number of the item being transferred.  */
+
+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;
+  size_t stride = type == BT_CHARACTER ?
+		  size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
+  if (dtp->u.p.mode == READING)
+    {
+      /* Big loop over all the elements.  */
+      for (elem = 0; elem < nelems; elem++)
+	{
+	  dtp->u.p.item_count++;
+	  formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size);
+	}
+    }
+  else
+    {
+      /* Big loop over all the elements.  */
+      for (elem = 0; elem < nelems; elem++)
+	{
+	  dtp->u.p.item_count++;
+	  formatted_transfer_scalar_write (dtp, type, tmp + stride*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_integer_write (st_parameter_dt *dtp, void *p, int kind)
+{
+  transfer_integer (dtp, p, kind);
+}
+
+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_real_write (st_parameter_dt *dtp, void *p, int kind)
+{
+  transfer_real (dtp, p, kind);
+}
+
+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_logical_write (st_parameter_dt *dtp, void *p, int kind)
+{
+  transfer_logical (dtp, p, kind);
+}
+
+void
+transfer_character (st_parameter_dt *dtp, void *p, int len)
+{
+  static char *empty_string[0];
+
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+
+  /* Strings of zero length can have p == NULL, which confuses the
+     transfer routines into thinking we need more data elements.  To avoid
+     this, we give them a nice pointer.  */
+  if (len == 0 && p == NULL)
+    p = empty_string;
+
+  /* Set kind here to 1.  */
+  dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
+}
+
+void
+transfer_character_write (st_parameter_dt *dtp, void *p, int len)
+{
+  transfer_character (dtp, p, len);
+}
+
+void
+transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
+{
+  static char *empty_string[0];
+
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+
+  /* Strings of zero length can have p == NULL, which confuses the
+     transfer routines into thinking we need more data elements.  To avoid
+     this, we give them a nice pointer.  */
+  if (len == 0 && p == NULL)
+    p = empty_string;
+
+  /* Here we pass the actual kind value.  */
+  dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
+}
+
+void
+transfer_character_wide_write (st_parameter_dt *dtp, void *p, int len, int kind)
+{
+  transfer_character_wide (dtp, p, len, kind);
+}
+
+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_complex_write (st_parameter_dt *dtp, void *p, int kind)
+{
+  transfer_complex (dtp, p, kind);
+}
+
+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, n;
+  size_t tsize;
+  char *data;
+  bt iotype;
+
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+
+  iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
+  size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc);
+
+  rank = GFC_DESCRIPTOR_RANK (desc);
+  for (n = 0; n < rank; n++)
+    {
+      count[n] = 0;
+      stride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(desc,n);
+      extent[n] = GFC_DESCRIPTOR_EXTENT(desc,n);
+
+      /* If the extent of even one dimension is zero, then the entire
+	 array section contains zero elements, so we return after writing
+	 a zero array record.  */
+      if (extent[n] <= 0)
+	{
+	  data = NULL;
+	  tsize = 0;
+	  dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
+	  return;
+	}
+    }
+
+  stride0 = stride[0];
+
+  /* If the innermost dimension has a stride of 1, we can do the transfer
+     in contiguous chunks.  */
+  if (stride0 == size)
+    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 * tsize;
+      count[0] += tsize;
+      n = 0;
+      while (count[n] == extent[n])
+	{
+	  count[n] = 0;
+	  data -= stride[n] * extent[n];
+	  n++;
+	  if (n == rank)
+	    {
+	      data = NULL;
+	      break;
+	    }
+	  else
+	    {
+	      count[n]++;
+	      data += stride[n];
+	    }
+	}
+    }
+}
+
+void
+transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+		      gfc_charlen_type charlen)
+{
+  transfer_array (dtp, desc, kind, charlen);
+}
+
+/* Preposition a sequential unformatted file while reading.  */
+
+static void
+us_read (st_parameter_dt *dtp, int continued)
+{
+  ssize_t n, nr;
+  GFC_INTEGER_4 i4;
+  GFC_INTEGER_8 i8;
+  gfc_offset i;
+
+  if (compile_options.record_marker == 0)
+    n = sizeof (GFC_INTEGER_4);
+  else
+    n = compile_options.record_marker;
+
+  nr = sread (dtp->u.p.current_unit->s, &i, n);
+  if (unlikely (nr < 0))
+    {
+      generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
+      return;
+    }
+  else if (nr == 0)
+    {
+      hit_eof (dtp);
+      return;  /* end of file */
+    }
+  else if (unlikely (n != nr))
+    {
+      generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
+      return;
+    }
+
+  /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
+  if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
+    {
+      switch (nr)
+	{
+	case sizeof(GFC_INTEGER_4):
+	  memcpy (&i4, &i, sizeof (i4));
+	  i = i4;
+	  break;
+
+	case sizeof(GFC_INTEGER_8):
+	  memcpy (&i8, &i, 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, &i, sizeof (i4));
+	  i = i4;
+	  break;
+
+	case sizeof(GFC_INTEGER_8):
+	  reverse_memcpy (&i8, &i, 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)
+{
+  ssize_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) != nbytes)
+    generate_error (&dtp->common, LIBERROR_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.  If the position was specified
+	 data_transfer_init has already positioned the file. If no position
+	 was specified, we continue from where we last left off.  I.e.
+	 there is nothing to do here.  */
+      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 ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+
+  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, LIBERROR_BAD_OPTION,
+			  "Bad unit number in 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.decimal = DECIMAL_UNSPECIFIED;
+      u_flags.encoding = ENCODING_UNSPECIFIED;
+      u_flags.async = ASYNC_UNSPECIFIED;
+      u_flags.round = ROUND_UNSPECIFIED;
+      u_flags.sign = SIGN_UNSPECIFIED;
+
+      u_flags.status = STATUS_UNKNOWN;
+
+      conv = get_unformatted_convert (dtp->common.unit);
+
+      if (conv == GFC_CONVERT_NONE)
+	conv = compile_options.convert;
+
+      /* We use big_endian, which is 0 on little-endian machines
+	 and 1 on big-endian machines.  */
+      switch (conv)
+	{
+	case GFC_CONVERT_NATIVE:
+	case GFC_CONVERT_SWAP:
+	  break;
+	 
+	case GFC_CONVERT_BIG:
+	  conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
+	  break;
+      
+	case GFC_CONVERT_LITTLE:
+	  conv = big_endian ? GFC_CONVERT_SWAP : GFC_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, LIBERROR_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, LIBERROR_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, LIBERROR_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, LIBERROR_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, LIBERROR_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, LIBERROR_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, LIBERROR_MISSING_OPTION,
+		      "Direct access data transfer requires record number");
+      return;
+    }
+
+  if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+    {
+      if ((cf & IOPARM_DT_HAS_REC) != 0)
+	{
+	  generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+			"Record number not allowed for sequential access "
+			"data transfer");
+	  return;
+	}
+
+      if (dtp->u.p.current_unit->endfile == AFTER_ENDFILE)
+      	{
+	  generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+			"Sequential READ or WRITE not allowed after "
+			"EOF marker, possibly use REWIND or BACKSPACE");
+	  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, LIBERROR_OPTION_CONFLICT,
+			  "ADVANCE specification conflicts with sequential "
+			  "access");
+	  return;
+	}
+
+      if (is_internal_unit (dtp))
+	{
+	  generate_error (&dtp->common, LIBERROR_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, LIBERROR_OPTION_CONFLICT,
+			  "ADVANCE specification requires an explicit format");
+	  return;
+	}
+    }
+
+  if (read_flag)
+    {
+      dtp->u.p.current_unit->previous_nonadvancing_write = 0;
+
+      if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
+	{
+	  generate_error (&dtp->common, LIBERROR_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, LIBERROR_MISSING_OPTION,
+			  "SIZE specification requires an ADVANCE "
+			  "specification of NO");
+	  return;
+	}
+    }
+  else
+    {				/* Write constraints.  */
+      if ((cf & IOPARM_END) != 0)
+	{
+	  generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+			  "END specification cannot appear in a write "
+			  "statement");
+	  return;
+	}
+
+      if ((cf & IOPARM_EOR) != 0)
+	{
+	  generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+			  "EOR specification cannot appear in a write "
+			  "statement");
+	  return;
+	}
+
+      if ((cf & IOPARM_DT_HAS_SIZE) != 0)
+	{
+	  generate_error (&dtp->common, LIBERROR_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;
+
+  /* Check the decimal mode.  */
+  dtp->u.p.current_unit->decimal_status
+	= !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
+	  find_option (&dtp->common, dtp->decimal, dtp->decimal_len,
+			decimal_opt, "Bad DECIMAL parameter in data transfer "
+			"statement");
+
+  if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
+	dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
+
+  /* Check the round mode.  */
+  dtp->u.p.current_unit->round_status
+	= !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED :
+	  find_option (&dtp->common, dtp->round, dtp->round_len,
+			round_opt, "Bad ROUND parameter in data transfer "
+			"statement");
+
+  if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED)
+	dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round;
+
+  /* Check the sign mode. */
+  dtp->u.p.sign_status
+	= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
+	  find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
+			"Bad SIGN parameter in data transfer statement");
+  
+  if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
+	dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
+
+  /* Check the blank mode.  */
+  dtp->u.p.blank_status
+	= !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
+	  find_option (&dtp->common, dtp->blank, dtp->blank_len,
+			blank_opt,
+			"Bad BLANK parameter in data transfer statement");
+  
+  if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
+	dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
+
+  /* Check the delim mode.  */
+  dtp->u.p.current_unit->delim_status
+	= !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
+	  find_option (&dtp->common, dtp->delim, dtp->delim_len,
+	  delim_opt, "Bad DELIM parameter in data transfer statement");
+  
+  if (dtp->u.p.current_unit->delim_status == DELIM_UNSPECIFIED)
+    dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim;
+
+  /* Check the pad mode.  */
+  dtp->u.p.current_unit->pad_status
+	= !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
+	  find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt,
+			"Bad PAD parameter in data transfer statement");
+  
+  if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
+	dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
+
+  /* Check to see if we might be reading what we wrote before  */
+
+  if (dtp->u.p.mode != dtp->u.p.current_unit->mode
+      && !is_internal_unit (dtp))
+    {
+      int pos = fbuf_reset (dtp->u.p.current_unit);
+      if (pos != 0)
+        sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR);
+      sflush(dtp->u.p.current_unit->s);
+    }
+
+  /* Check the POS= specifier: that it is in range and that it is used with a
+     unit that has been connected for STREAM access. F2003 9.5.1.10.  */
+  
+  if (((cf & IOPARM_DT_HAS_POS) != 0))
+    {
+      if (is_stream_io (dtp))
+        {
+          
+          if (dtp->pos <= 0)
+            {
+              generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+                              "POS=specifier must be positive");
+              return;
+            }
+          
+          if (dtp->pos >= dtp->u.p.current_unit->maxrec)
+            {
+              generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+                              "POS=specifier too large");
+              return;
+            }
+          
+          dtp->rec = dtp->pos;
+          
+          if (dtp->u.p.mode == READING)
+            {
+              /* Reset the endfile flag; if we hit EOF during reading
+                 we'll set the flag and generate an error at that point
+                 rather than worrying about it here.  */
+              dtp->u.p.current_unit->endfile = NO_ENDFILE;
+            }
+         
+          if (dtp->pos != dtp->u.p.current_unit->strm_pos)
+            {
+              fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+              if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0)
+                {
+                  generate_error (&dtp->common, LIBERROR_OS, NULL);
+                  return;
+                }
+              dtp->u.p.current_unit->strm_pos = dtp->pos;
+            }
+        }
+      else
+        {
+          generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+                          "POS=specifier not allowed, "
+                          "Try OPEN with ACCESS='stream'");
+          return;
+        }
+    }
+  
+
+  /* Sanity checks on the record number.  */
+  if ((cf & IOPARM_DT_HAS_REC) != 0)
+    {
+      if (dtp->rec <= 0)
+	{
+	  generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+			  "Record number must be positive");
+	  return;
+	}
+
+      if (dtp->rec >= dtp->u.p.current_unit->maxrec)
+	{
+	  generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+			  "Record number too large");
+	  return;
+	}
+
+      /* Make sure format buffer is reset.  */
+      if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
+        fbuf_reset (dtp->u.p.current_unit);
+
+
+      /* 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, LIBERROR_BAD_OPTION,
+			  "Non-existing record number");
+	  return;
+	}
+
+      /* Position the file.  */
+      if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
+                 * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
+        {
+          generate_error (&dtp->common, LIBERROR_OS, NULL);
+          return;
+        }
+
+      /* TODO: This is required to maintain compatibility between
+         4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
+
+      if (is_stream_io (dtp))
+        dtp->u.p.current_unit->strm_pos = dtp->rec;
+
+      /* TODO: Un-comment this code when ABI changes from 4.3.
+      if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
+       {
+         generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+                     "Record number not allowed for stream access "
+                     "data transfer");
+         return;
+       }  */
+    }
+
+  /* Bugware for badly written mixed C-Fortran I/O.  */
+  if (!is_internal_unit (dtp))
+    flush_if_preconnected(dtp->u.p.current_unit->s);
+
+  dtp->u.p.current_unit->mode = dtp->u.p.mode;
+
+  /* Set the maximum position reached from the previous I/O operation.  This
+     could be greater than zero from a previous non-advancing write.  */
+  dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
+
+  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.last_char = EOF - 1;
+		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, LIBERROR_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, and also returns
+   starting record, where the first I/O goes to (necessary in case of
+   negative strides).  */
+   
+gfc_offset
+init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
+		gfc_offset *start_record)
+{
+  int rank = GFC_DESCRIPTOR_RANK(desc);
+  int i;
+  gfc_offset index; 
+  int empty;
+
+  empty = 0;
+  index = 1;
+  *start_record = 0;
+
+  for (i=0; i<rank; i++)
+    {
+      ls[i].idx = GFC_DESCRIPTOR_LBOUND(desc,i);
+      ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i);
+      ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i);
+      ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i);
+      empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i) 
+			< GFC_DESCRIPTOR_LBOUND(desc,i));
+
+      if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
+	{
+	  index += (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
+	    * GFC_DESCRIPTOR_STRIDE(desc,i);
+	}
+      else
+	{
+	  index -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
+	    * GFC_DESCRIPTOR_STRIDE(desc,i);
+	  *start_record -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
+	    * GFC_DESCRIPTOR_STRIDE(desc,i);
+	}
+    }
+
+  if (empty)
+    return 0;
+  else
+    return index;
+}
+
+/* Determine the index to the next record in an internal unit array by
+   by incrementing through the array_loop_spec.  */
+   
+gfc_offset
+next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
+{
+  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;
+    }
+
+  *finished = carry;
+
+  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.  */
+
+static void
+skip_record (st_parameter_dt *dtp, ssize_t bytes)
+{
+  ssize_t rlength, readb;
+  static const ssize_t MAX_READ = 4096;
+  char p[MAX_READ];
+
+  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))
+    {
+      /* Direct access files do not generate END conditions,
+	 only I/O errors.  */
+      if (sseek (dtp->u.p.current_unit->s, 
+		 dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
+	generate_error (&dtp->common, LIBERROR_OS, NULL);
+
+      dtp->u.p.current_unit->bytes_left_subrecord = 0;
+    }
+  else
+    {			/* Seek by reading data.  */
+      while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
+	{
+	  rlength = 
+	    (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
+	    MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
+
+	  readb = sread (dtp->u.p.current_unit->s, p, rlength);
+	  if (readb < 0)
+	    {
+	      generate_error (&dtp->common, LIBERROR_OS, NULL);
+	      return;
+	    }
+
+	  dtp->u.p.current_unit->bytes_left_subrecord -= readb;
+	}
+    }
+
+}
+
+
+/* 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);
+    }
+}
+
+
+static inline gfc_offset
+min_off (gfc_offset a, gfc_offset b)
+{
+  return (a < b ? a : b);
+}
+
+
+/* Space to the next record for read mode.  */
+
+static void
+next_record_r (st_parameter_dt *dtp, int done)
+{
+  gfc_offset record;
+  int bytes_left;
+  char p;
+  int cc;
+
+  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, dtp->u.p.current_unit->bytes_left);
+      break;
+
+    case FORMATTED_STREAM:
+    case FORMATTED_SEQUENTIAL:
+      /* read_sf has already terminated input because of an '\n', or
+         we have hit EOF.  */
+      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))
+	    {
+	      int finished;
+
+	      record = next_array_record (dtp, dtp->u.p.current_unit->ls,
+					  &finished);
+	      if (!done && finished)
+		hit_eof (dtp);
+
+	      /* Now seek to this record.  */
+	      record = record * dtp->u.p.current_unit->recl;
+	      if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
+		{
+		  generate_error (&dtp->common, LIBERROR_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;
+	      bytes_left = min_off (bytes_left, 
+		      file_length (dtp->u.p.current_unit->s)
+		      - stell (dtp->u.p.current_unit->s));
+	      if (sseek (dtp->u.p.current_unit->s, 
+			 bytes_left, SEEK_CUR) < 0)
+	        {
+		  generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
+		  break;
+		}
+	      dtp->u.p.current_unit->bytes_left
+		= dtp->u.p.current_unit->recl;
+	    } 
+	  break;
+	}
+      else 
+	{
+	  do
+	    {
+              errno = 0;
+              cc = fbuf_getc (dtp->u.p.current_unit);
+	      if (cc == EOF) 
+		{
+                  if (errno != 0)
+                    generate_error (&dtp->common, LIBERROR_OS, NULL);
+		  else
+		    {
+		      if (is_stream_io (dtp)
+			  || dtp->u.p.current_unit->pad_status == PAD_NO
+			  || dtp->u.p.current_unit->bytes_left
+			     == dtp->u.p.current_unit->recl)
+			hit_eof (dtp);
+		    }
+		  break;
+                }
+	      
+	      if (is_stream_io (dtp))
+		dtp->u.p.current_unit->strm_pos++;
+              
+              p = (char) cc;
+	    }
+	  while (p != '\n');
+	}
+      break;
+    }
+}
+
+
+/* Small utility function to write a record marker, taking care of
+   byte swapping and of choosing the correct size.  */
+
+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 GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
+  if (likely (dtp->u.p.current_unit->flags.convert == GFC_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 m, m_write, record_marker;
+
+  /* Bytes written.  */
+  m = dtp->u.p.current_unit->recl_subrecord
+    - dtp->u.p.current_unit->bytes_left_subrecord;
+
+  /* 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 (unlikely (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 (unlikely (sseek (dtp->u.p.current_unit->s, - m - 2 * record_marker, 
+		       SEEK_CUR) < 0))
+    goto io_error;
+
+  if (next_subrecord)
+    m_write = -m;
+  else
+    m_write = m;
+
+  if (unlikely (write_us_marker (dtp, m_write) < 0))
+    goto io_error;
+
+  /* Seek past the end of the current record.  */
+
+  if (unlikely (sseek (dtp->u.p.current_unit->s, m + record_marker, 
+		       SEEK_CUR) < 0))
+    goto io_error;
+
+  return;
+
+ io_error:
+  generate_error (&dtp->common, LIBERROR_OS, NULL);
+  return;
+
+}
+
+
+/* Utility function like memset() but operating on streams. Return
+   value is same as for POSIX write().  */
+
+static ssize_t
+sset (stream * s, int c, ssize_t nbyte)
+{
+  static const int WRITE_CHUNK = 256;
+  char p[WRITE_CHUNK];
+  ssize_t bytes_left, trans;
+
+  if (nbyte < WRITE_CHUNK)
+    memset (p, c, nbyte);
+  else
+    memset (p, c, WRITE_CHUNK);
+
+  bytes_left = nbyte;
+  while (bytes_left > 0)
+    {
+      trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK;
+      trans = swrite (s, p, trans);
+      if (trans <= 0)
+	return trans;
+      bytes_left -= trans;
+    }
+	       
+  return nbyte - bytes_left;
+}
+
+static inline void
+memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
+{
+  int j;
+  for (j = 0; j < k; j++)
+    *p++ = c;
+}
+
+/* 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;
+
+  /* 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;
+
+      fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
+      fbuf_flush (dtp->u.p.current_unit, WRITING);
+      if (sset (dtp->u.p.current_unit->s, ' ', 
+		dtp->u.p.current_unit->bytes_left) 
+	  != dtp->u.p.current_unit->bytes_left)
+	goto io_error;
+
+      break;
+
+    case UNFORMATTED_DIRECT:
+      if (dtp->u.p.current_unit->bytes_left > 0)
+	{
+	  length = (int) dtp->u.p.current_unit->bytes_left;
+	  if (sset (dtp->u.p.current_unit->s, 0, length) != length)
+	    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))
+	{
+	  char *p;
+	  if (is_array_io (dtp))
+	    {
+	      int finished;
+
+	      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);
+		  if (sseek (dtp->u.p.current_unit->s, 
+			     length, SEEK_CUR) < 0)
+		    {
+		      generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
+		      return;
+		    }
+		  length = (int) (dtp->u.p.current_unit->recl - max_pos);
+		}
+
+	      p = write_block (dtp, length);
+	      if (p == NULL)
+		return;
+
+	      if (unlikely (is_char4_unit (dtp)))
+	        {
+		  gfc_char4_t *p4 = (gfc_char4_t *) p;
+		  memset4 (p4, ' ', length);
+		}
+	      else
+		memset (p, ' ', length);
+
+	      /* 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,
+					  &finished);
+	      if (finished)
+		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, SEEK_SET) < 0)
+		{
+		  generate_error (&dtp->common, LIBERROR_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);
+		      if (sseek (dtp->u.p.current_unit->s, 
+				 length, SEEK_CUR) < 0)
+		        {
+			  generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
+			  return;
+			}
+		      length = (int) (dtp->u.p.current_unit->recl - max_pos);
+		    }
+		  else
+		    length = (int) dtp->u.p.current_unit->bytes_left;
+		}
+	      if (length > 0)
+		{
+		  p = write_block (dtp, length);
+		  if (p == NULL)
+		    return;
+
+		  if (unlikely (is_char4_unit (dtp)))
+		    {
+		      gfc_char4_t *p4 = (gfc_char4_t *) p;
+		      memset4 (p4, (gfc_char4_t) ' ', length);
+		    }
+		  else
+		    memset (p, ' ', length);
+		}
+	    }
+	}
+      else
+	{
+#ifdef HAVE_CRLF
+	  const int len = 2;
+#else
+	  const int len = 1;
+#endif
+          fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
+          char * p = fbuf_alloc (dtp->u.p.current_unit, len);
+          if (!p)
+            goto io_error;
+#ifdef HAVE_CRLF
+          *(p++) = '\r';
+#endif
+          *p = '\n';
+	  if (is_stream_io (dtp))
+	    {
+	      dtp->u.p.current_unit->strm_pos += len;
+	      if (dtp->u.p.current_unit->strm_pos
+		  < file_length (dtp->u.p.current_unit->s))
+		unit_truncate (dtp->u.p.current_unit,
+                               dtp->u.p.current_unit->strm_pos - 1,
+                               &dtp->common);
+	    }
+	}
+
+      break;
+
+    io_error:
+      generate_error (&dtp->common, LIBERROR_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, done);
+  else
+    next_record_w (dtp, done);
+
+  if (!is_stream_io (dtp))
+    {
+      /* Keep position up to date for INQUIRE */
+      if (done)
+	update_position (dtp->u.p.current_unit);
+
+      dtp->u.p.current_unit->current_record = 0;
+      if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+	{
+	  fp = stell (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);
+
+  fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+}
+
+
+/* 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)
+{
+  GFC_INTEGER_4 cf = dtp->common.flags;
+
+  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+    *dtp->size = dtp->u.p.size_used;
+
+  if (dtp->u.p.eor_condition)
+    {
+      generate_error (&dtp->common, LIBERROR_EOR, NULL);
+      return;
+    }
+
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    {
+      if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)
+	dtp->u.p.current_unit->current_record = 0;
+      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;
+
+  if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
+    {
+      finish_list_read (dtp);
+      return;
+    }
+
+  if (dtp->u.p.mode == WRITING)
+    dtp->u.p.current_unit->previous_nonadvancing_write
+      = dtp->u.p.advance_status == ADVANCE_NO;
+
+  if (is_stream_io (dtp))
+    {
+      if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
+	  && dtp->u.p.advance_status != ADVANCE_NO)
+	next_record (dtp, 1);
+
+      return;
+    }
+
+  dtp->u.p.current_unit->current_record = 0;
+
+  if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
+    {
+      fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+      dtp->u.p.seen_dollar = 0;
+      return;
+    }
+
+  /* For non-advancing I/O, save the current maximum position for use in the
+     next I/O operation if needed.  */
+  if (dtp->u.p.advance_status == ADVANCE_NO)
+    {
+      int bytes_written = (int) (dtp->u.p.current_unit->recl
+	- dtp->u.p.current_unit->bytes_left);
+      dtp->u.p.current_unit->saved_pos =
+	dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
+      fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+      return;
+    }
+  else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED 
+           && dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
+      fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);    
+
+  dtp->u.p.current_unit->saved_pos = 0;
+
+  next_record (dtp, 1);
+}
+
+/* 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_IO_INT) (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);
+  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);
+}
+
+extern void st_read_done (st_parameter_dt *);
+export_proto(st_read_done);
+
+void
+st_read_done (st_parameter_dt *dtp)
+{
+  finalize_transfer (dtp);
+  if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
+    free_format_data (dtp->u.p.fmt);
+  free_ionml (dtp);
+  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))
+          unit_truncate (dtp->u.p.current_unit, 
+                         stell (dtp->u.p.current_unit->s),
+                         &dtp->common);
+	dtp->u.p.current_unit->endfile = AT_ENDFILE;
+	break;
+      }
+
+  if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
+    free_format_data (dtp->u.p.fmt);
+  free_ionml (dtp);
+  if (dtp->u.p.current_unit != NULL)
+    unlock_unit (dtp->u.p.current_unit);
+  
+  free_internal_unit (dtp);
+
+  library_end ();
+}
+
+
+/* F2003: This is a stub for the runtime portion of the WAIT statement.  */
+void
+st_wait (st_parameter_wait *wtp __attribute__((unused)))
+{
+}
+
+
+/* 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;
+  size_t var_name_len = strlen (var_name);
+
+  nml = (namelist_info*) get_mem (sizeof (namelist_info));
+
+  nml->mem_pos = var_addr;
+
+  nml->var_name = (char*) get_mem (var_name_len + 1);
+  memcpy (nml->var_name, var_name, var_name_len);
+  nml->var_name[var_name_len] = '\0';
+
+  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,
+				index_type, index_type,
+				index_type);
+export_proto(st_set_nml_var_dim);
+
+void
+st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
+		    index_type stride, index_type lbound,
+		    index_type ubound)
+{
+  namelist_info * nml;
+  int n;
+
+  n = (int)n_dim;
+
+  for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
+
+  GFC_DIMENSION_SET(nml->dim[n],lbound,ubound,stride);
+}
+
+/* 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--);
+}
+
+
+/* Once upon a time, a poor innocent Fortran program was reading a
+   file, when suddenly it hit the end-of-file (EOF).  Unfortunately
+   the OS doesn't tell whether we're at the EOF or whether we already
+   went past it.  Luckily our hero, libgfortran, keeps track of this.
+   Call this function when you detect an EOF condition.  See Section
+   9.10.2 in F2003.  */
+
+void
+hit_eof (st_parameter_dt * dtp)
+{
+  dtp->u.p.current_unit->flags.position = POSITION_APPEND;
+
+  if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+    switch (dtp->u.p.current_unit->endfile)
+      {
+      case NO_ENDFILE:
+      case AT_ENDFILE:
+        generate_error (&dtp->common, LIBERROR_END, NULL);
+	if (!is_internal_unit (dtp))
+	  {
+	    dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
+	    dtp->u.p.current_unit->current_record = 0;
+	  }
+        else
+          dtp->u.p.current_unit->endfile = AT_ENDFILE;
+	break;
+        
+      case AFTER_ENDFILE:
+	generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
+	dtp->u.p.current_unit->current_record = 0;
+	break;
+      }
+  else
+    {
+      /* Non-sequential files don't have an ENDFILE record, so we
+         can't be at AFTER_ENDFILE.  */
+      dtp->u.p.current_unit->endfile = AT_ENDFILE;
+      generate_error (&dtp->common, LIBERROR_END, NULL);
+      dtp->u.p.current_unit->current_record = 0;
+    }
+}
diff --git a/gcc-4.6/libgfortran/io/transfer128.c b/gcc-4.6/libgfortran/io/transfer128.c
new file mode 100644
index 000000000..d94ccacc0
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/transfer128.c
@@ -0,0 +1,98 @@
+/* Copyright (C) 2010, 2011
+   Free Software Foundation, Inc.
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+/* Note: This file needs to be a separate translation unit (.o file)
+   to make sure that for static linkage, the libquad dependence only
+   occurs if needed.  */
+
+#include "io.h"
+
+
+#if defined(GFC_REAL_16_IS_FLOAT128)
+
+/* The prototypes for the called procedures in transfer.c.  */
+
+extern void transfer_real (st_parameter_dt *, void *, int);
+export_proto(transfer_real);
+
+extern void transfer_real_write (st_parameter_dt *, void *, int);
+export_proto(transfer_real_write);
+
+extern void transfer_complex (st_parameter_dt *, void *, int);
+export_proto(transfer_complex);
+
+extern void transfer_complex_write (st_parameter_dt *, void *, int);
+export_proto(transfer_complex_write);
+
+
+/* The prototypes for the procedures in this file.  */
+
+extern void transfer_real128 (st_parameter_dt *, void *, int);
+export_proto(transfer_real128);
+
+extern void transfer_real128_write (st_parameter_dt *, void *, int);
+export_proto(transfer_real128_write);
+
+extern void transfer_complex128 (st_parameter_dt *, void *, int);
+export_proto(transfer_complex128);
+
+extern void transfer_complex128_write (st_parameter_dt *, void *, int);
+export_proto(transfer_complex128_write);
+
+
+/* Make sure that libquadmath is pulled in. The functions strtoflt128
+   and quadmath_snprintf are weakly referrenced in convert_real and
+   write_float; the pointer assignment with USED attribute make sure
+   that there is a non-weakref dependence if the quadmath functions
+   are used. That avoids segfault when libquadmath is statically linked.  */
+static void __attribute__((used)) *tmp1 = strtoflt128;
+static void __attribute__((used)) *tmp2 = quadmath_snprintf;
+
+void
+transfer_real128 (st_parameter_dt *dtp, void *p, int kind)
+{
+  transfer_real (dtp, p, kind);
+}
+
+
+void
+transfer_real128_write (st_parameter_dt *dtp, void *p, int kind)
+{
+  transfer_real (dtp, p, kind);
+}
+
+
+void
+transfer_complex128 (st_parameter_dt *dtp, void *p, int kind)
+{
+  transfer_complex (dtp, p, kind);
+}
+
+
+void
+transfer_complex128_write (st_parameter_dt *dtp, void *p, int kind)
+{
+  transfer_complex_write (dtp, p, kind);
+}
+#endif
diff --git a/gcc-4.6/libgfortran/io/unit.c b/gcc-4.6/libgfortran/io/unit.c
new file mode 100644
index 000000000..1d5221726
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/unit.c
@@ -0,0 +1,860 @@
+/* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009, 2010 
+   Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   F2003 I/O support contributed by Jerry DeLisle
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
+#include <stdlib.h>
+#include <string.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 */
+
+GFC_INTEGER_4 next_available_newunit;
+#define GFC_FIRST_NEWUNIT -10
+
+#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
+
+/* We use these filenames for error reporting.  */
+
+static char stdin_name[] = "stdin";
+static char stdout_name[] = "stdout";
+static char stderr_name[] = "stderr";
+
+/* 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;
+}
+
+
+/* destroy_unit_mutex()-- Destroy the mutex and free memory of unit.  */
+
+static void
+destroy_unit_mutex (gfc_unit * u)
+{
+  __gthread_mutex_destroy (&u->lock);
+  free (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)
+	    destroy_unit_mutex (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;
+  gfc_offset start_record = 0;
+
+  /* Allocate memory for a unit structure.  */
+
+  iunit = get_mem (sizeof (gfc_unit));
+  if (iunit == NULL)
+    {
+      generate_error (&dtp->common, LIBERROR_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, &start_record);
+
+      start_record *= iunit->recl;
+    }
+
+  /* Set initial values for unit parameters.  */
+  if (dtp->common.unit)
+    {
+      iunit->s = open_internal4 (dtp->internal_unit - start_record,
+				 dtp->internal_unit_len, -start_record);
+      fbuf_init (iunit, 256);
+    }
+  else
+    iunit->s = open_internal (dtp->internal_unit - start_record,
+			      dtp->internal_unit_len, -start_record);
+
+  iunit->bytes_left = iunit->recl;
+  iunit->last_record=0;
+  iunit->maxrec=0;
+  iunit->current_record=0;
+  iunit->read_bad = 0;
+  iunit->endfile = NO_ENDFILE;
+
+  /* Set flags for the internal unit.  */
+
+  iunit->flags.access = ACCESS_SEQUENTIAL;
+  iunit->flags.action = ACTION_READWRITE;
+  iunit->flags.blank = BLANK_NULL;
+  iunit->flags.form = FORM_FORMATTED;
+  iunit->flags.pad = PAD_YES;
+  iunit->flags.status = STATUS_UNSPECIFIED;
+  iunit->flags.sign = SIGN_SUPPRESS;
+  iunit->flags.decimal = DECIMAL_POINT;
+  iunit->flags.encoding = ENCODING_DEFAULT;
+  iunit->flags.async = ASYNC_NO;
+  iunit->flags.round = ROUND_COMPATIBLE;
+
+  /* Initialize the data transfer parameters.  */
+
+  dtp->u.p.advance_status = ADVANCE_YES;
+  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 (unlikely (is_char4_unit (dtp)))
+    fbuf_destroy (dtp->u.p.current_unit);
+
+  if (dtp->u.p.current_unit != NULL)
+    {
+      if (dtp->u.p.current_unit->ls != NULL)
+	free (dtp->u.p.current_unit->ls);
+  
+      if (dtp->u.p.current_unit->s)
+	free (dtp->u.p.current_unit->s);
+  
+      destroy_unit_mutex (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);
+}
+
+
+/*************************/
+/* Initialize everything.  */
+
+void
+init_units (void)
+{
+  gfc_unit *u;
+  unsigned int i;
+
+#ifndef __GTHREAD_MUTEX_INIT
+  __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
+#endif
+
+  next_available_newunit = GFC_FIRST_NEWUNIT;
+
+  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->flags.sign = SIGN_SUPPRESS;
+      u->flags.decimal = DECIMAL_POINT;
+      u->flags.encoding = ENCODING_DEFAULT;
+      u->flags.async = ASYNC_NO;
+      u->flags.round = ROUND_COMPATIBLE;
+     
+      u->recl = options.default_recl;
+      u->endfile = NO_ENDFILE;
+
+      u->file_len = strlen (stdin_name);
+      u->file = get_mem (u->file_len);
+      memmove (u->file, stdin_name, u->file_len);
+
+      fbuf_init (u, 0);
+    
+      __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->flags.sign = SIGN_SUPPRESS;
+      u->flags.decimal = DECIMAL_POINT;
+      u->flags.encoding = ENCODING_DEFAULT;
+      u->flags.async = ASYNC_NO;
+      u->flags.round = ROUND_COMPATIBLE;
+
+      u->recl = options.default_recl;
+      u->endfile = AT_ENDFILE;
+    
+      u->file_len = strlen (stdout_name);
+      u->file = get_mem (u->file_len);
+      memmove (u->file, stdout_name, u->file_len);
+      
+      fbuf_init (u, 0);
+
+      __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->flags.sign = SIGN_SUPPRESS;
+      u->flags.decimal = DECIMAL_POINT;
+      u->flags.encoding = ENCODING_DEFAULT;
+      u->flags.async = ASYNC_NO;
+      u->flags.round = ROUND_COMPATIBLE;
+
+      u->recl = options.default_recl;
+      u->endfile = AT_ENDFILE;
+
+      u->file_len = strlen (stderr_name);
+      u->file = get_mem (u->file_len);
+      memmove (u->file, stderr_name, u->file_len);
+      
+      fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
+                              any kind of exotic formatting to stderr.  */
+
+      __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;
+  
+  /* If there are previously written bytes from a write with ADVANCE="no"
+     Reposition the buffer before closing.  */
+  if (u->previous_nonadvancing_write)
+    finish_last_advance_record (u);
+
+  rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
+
+  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 (u->file);
+  u->file = NULL;
+  u->file_len = 0;
+
+  free_format_hash_table (u);  
+  fbuf_destroy (u);
+
+  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)
+    destroy_unit_mutex (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);
+}
+
+
+/* update_position()-- Update the flags position for later use by inquire.  */
+
+void
+update_position (gfc_unit *u)
+{
+  /* If unit is not seekable, this makes no sense (and the standard is
+     silent on this matter), and thus we don't change the position for
+     a non-seekable file.  */
+  if (is_seekable (u->s))
+    {
+      gfc_offset cur = stell (u->s);
+      if (cur == 0)
+	u->flags.position = POSITION_REWIND;
+      else if (cur != -1 && (file_length (u->s) == cur))
+	u->flags.position = POSITION_APPEND;
+      else
+	u->flags.position = POSITION_ASIS;
+    }
+}
+
+
+/* High level interface to truncate a file safely, i.e. flush format
+   buffers, check that it's a regular file, and generate error if that
+   occurs.  Just like POSIX ftruncate, returns 0 on success, -1 on
+   failure.  */
+
+int
+unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
+{
+  int ret;
+
+  /* Make sure format buffer is flushed.  */
+  if (u->flags.form == FORM_FORMATTED)
+    {
+      if (u->mode == READING)
+	pos += fbuf_reset (u);
+      else
+	fbuf_flush (u, u->mode);
+    }
+  
+  /* Don't try to truncate a special file, just pretend that it
+     succeeds.  */
+  if (is_special (u->s) || !is_seekable (u->s))
+    {
+      sflush (u->s);
+      return 0;
+    }
+
+  /* struncate() should flush the stream buffer if necessary, so don't
+     bother calling sflush() here.  */
+  ret = struncate (u->s, pos);
+
+  if (ret != 0)
+    {
+      generate_error (common, LIBERROR_OS, NULL);
+      u->endfile = NO_ENDFILE;
+      u->flags.position = POSITION_ASIS;
+    }
+  else
+    {
+      u->endfile = AT_ENDFILE;
+      u->flags.position = POSITION_APPEND;
+    }
+
+  return ret;
+}
+
+
+/* filename_from_unit()-- If the unit_number exists, return a pointer to the
+   name of the associated file, otherwise return the empty string.  The caller
+   must free memory allocated for the filename string.  */
+
+char *
+filename_from_unit (int n)
+{
+  char *filename;
+  gfc_unit *u;
+  int c;
+
+  /* Find the unit.  */
+  u = unit_root;
+  while (u != NULL)
+    {
+      c = compare (n, u->unit_number);
+      if (c < 0)
+	u = u->left;
+      if (c > 0)
+	u = u->right;
+      if (c == 0)
+	break;
+    }
+
+  /* Get the filename.  */
+  if (u != NULL)
+    {
+      filename = (char *) get_mem (u->file_len + 1);
+      unpack_filename (filename, u->file, u->file_len);
+      return filename;
+    }
+  else
+    return (char *) NULL;
+}
+
+void
+finish_last_advance_record (gfc_unit *u)
+{
+  
+  if (u->saved_pos > 0)
+    fbuf_seek (u, u->saved_pos, SEEK_CUR);
+
+  if (!(u->unit_number == options.stdout_unit
+	|| u->unit_number == options.stderr_unit))
+    {
+#ifdef HAVE_CRLF
+      const int len = 2;
+#else
+      const int len = 1;
+#endif
+      char *p = fbuf_alloc (u, len);
+      if (!p)
+	os_error ("Completing record after ADVANCE_NO failed");
+#ifdef HAVE_CRLF
+      *(p++) = '\r';
+#endif
+      *p = '\n';
+    }
+
+  fbuf_flush (u, u->mode);
+}
+
+/* Assign a negative number for NEWUNIT in OPEN statements.  */
+GFC_INTEGER_4
+get_unique_unit_number (st_parameter_open *opp)
+{
+  GFC_INTEGER_4 num;
+
+  __gthread_mutex_lock (&unit_lock);
+  num = next_available_newunit--;
+
+  /* Do not allow NEWUNIT numbers to wrap.  */
+  if (next_available_newunit >=  GFC_FIRST_NEWUNIT )
+    {
+      __gthread_mutex_unlock (&unit_lock);
+      generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted");
+      return 0;
+    }
+  __gthread_mutex_unlock (&unit_lock);
+  return num;
+}
diff --git a/gcc-4.6/libgfortran/io/unix.c b/gcc-4.6/libgfortran/io/unix.c
new file mode 100644
index 000000000..12536ca5c
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/unix.c
@@ -0,0 +1,1878 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+   2011
+   Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   F2003 I/O support contributed by Jerry DeLisle
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+/* Unix stream I/O module */
+
+#include "io.h"
+#include "unix.h"
+#include <stdlib.h>
+#include <limits.h>
+
+#include <unistd.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <assert.h>
+
+#include <string.h>
+#include <errno.h>
+
+
+/* For mingw, we don't identify files by their inode number, but by a
+   64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
+#ifdef __MINGW32__
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+
+#define lseek _lseeki64
+#define fstat _fstati64
+#define stat _stati64
+typedef struct _stati64 gfstat_t;
+
+#ifndef HAVE_WORKING_STAT
+static uint64_t
+id_from_handle (HANDLE hFile)
+{
+  BY_HANDLE_FILE_INFORMATION FileInformation;
+
+  if (hFile == INVALID_HANDLE_VALUE)
+      return 0;
+
+  memset (&FileInformation, 0, sizeof(FileInformation));
+  if (!GetFileInformationByHandle (hFile, &FileInformation))
+    return 0;
+
+  return ((uint64_t) FileInformation.nFileIndexLow)
+	 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
+}
+
+
+static uint64_t
+id_from_path (const char *path)
+{
+  HANDLE hFile;
+  uint64_t res;
+
+  if (!path || !*path || access (path, F_OK))
+    return (uint64_t) -1;
+
+  hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
+		      FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
+		      NULL);
+  res = id_from_handle (hFile);
+  CloseHandle (hFile);
+  return res;
+}
+
+
+static uint64_t
+id_from_fd (const int fd)
+{
+  return id_from_handle ((HANDLE) _get_osfhandle (fd));
+}
+
+#endif
+
+#else
+typedef struct stat gfstat_t;
+#endif
+
+#ifndef PATH_MAX
+#define PATH_MAX 1024
+#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
+
+
+#ifndef HAVE_ACCESS
+
+#ifndef W_OK
+#define W_OK 2
+#endif
+
+#ifndef R_OK
+#define R_OK 4
+#endif
+
+#ifndef F_OK
+#define F_OK 0
+#endif
+
+/* Fallback implementation of access() on systems that don't have it.
+   Only modes R_OK, W_OK and F_OK are used in this file.  */
+
+static int
+fallback_access (const char *path, int mode)
+{
+  int fd;
+
+  if ((mode & R_OK) && (fd = open (path, O_RDONLY)) < 0)
+    return -1;
+  close (fd);
+
+  if ((mode & W_OK) && (fd = open (path, O_WRONLY)) < 0)
+    return -1;
+  close (fd);
+
+  if (mode == F_OK)
+    {
+      gfstat_t st;
+      return stat (path, &st);
+    }
+
+  return 0;
+}
+
+#undef access
+#define access fallback_access
+#endif
+
+
+/* Unix and internal stream I/O module */
+
+static const int BUFFER_SIZE = 8192;
+
+typedef struct
+{
+  stream st;
+
+  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 file_length;	/* Length of the file, -1 if not seekable. */
+
+  char *buffer;                 /* Pointer to the buffer.  */
+  int fd;                       /* The POSIX file descriptor.  */
+
+  int active;			/* Length of valid bytes in the buffer */
+
+  int ndirty;			/* Dirty bytes starting at buffer_offset */
+
+  int special_file;             /* =1 if the fd refers to a special file */
+
+  /* Cached stat(2) values.  */
+  dev_t st_dev;
+  ino_t st_ino;
+}
+unix_stream;
+
+
+/* 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)
+{
+#ifdef HAVE_DUP
+  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);
+#endif
+
+  return fd;
+}
+
+
+/* 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);
+}
+
+
+/********************************************************************
+Raw I/O functions (read, write, seek, tell, truncate, close).
+
+These functions wrap the basic POSIX I/O syscalls. Any deviation in
+semantics is a bug, except the following: write restarts in case
+of being interrupted by a signal, and as the first argument the
+functions take the unix_stream struct rather than an integer file
+descriptor. Also, for POSIX read() and write() a nbyte argument larger
+than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
+than size_t as for POSIX read/write.
+*********************************************************************/
+
+static int
+raw_flush (unix_stream * s  __attribute__ ((unused)))
+{
+  return 0;
+}
+
+static ssize_t
+raw_read (unix_stream * s, void * buf, ssize_t nbyte)
+{
+  /* For read we can't do I/O in a loop like raw_write does, because
+     that will break applications that wait for interactive I/O.  */
+  return read (s->fd, buf, nbyte);
+}
+
+static ssize_t
+raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
+{
+  ssize_t trans, bytes_left;
+  char *buf_st;
+
+  bytes_left = nbyte;
+  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)
+    {
+      trans = write (s->fd, buf_st, bytes_left);
+      if (trans < 0)
+	{
+	  if (errno == EINTR)
+	    continue;
+	  else
+	    return trans;
+	}
+      buf_st += trans;
+      bytes_left -= trans;
+    }
+
+  return nbyte - bytes_left;
+}
+
+static gfc_offset
+raw_seek (unix_stream * s, gfc_offset offset, int whence)
+{
+  return lseek (s->fd, offset, whence);
+}
+
+static gfc_offset
+raw_tell (unix_stream * s)
+{
+  return lseek (s->fd, 0, SEEK_CUR);
+}
+
+static int
+raw_truncate (unix_stream * s, gfc_offset length)
+{
+#ifdef __MINGW32__
+  HANDLE h;
+  gfc_offset cur;
+
+  if (isatty (s->fd))
+    {
+      errno = EBADF;
+      return -1;
+    }
+  h = (HANDLE) _get_osfhandle (s->fd);
+  if (h == INVALID_HANDLE_VALUE)
+    {
+      errno = EBADF;
+      return -1;
+    }
+  cur = lseek (s->fd, 0, SEEK_CUR);
+  if (cur == -1)
+    return -1;
+  if (lseek (s->fd, length, SEEK_SET) == -1)
+    goto error;
+  if (!SetEndOfFile (h))
+    {
+      errno = EBADF;
+      goto error;
+    }
+  if (lseek (s->fd, cur, SEEK_SET) == -1)
+    return -1;
+  return 0;
+ error:
+  lseek (s->fd, cur, SEEK_SET);
+  return -1;
+#elif defined HAVE_FTRUNCATE
+  return ftruncate (s->fd, length);
+#elif defined HAVE_CHSIZE
+  return chsize (s->fd, length);
+#else
+  runtime_error ("required ftruncate or chsize support not present");
+  return -1;
+#endif
+}
+
+static int
+raw_close (unix_stream * s)
+{
+  int retval;
+  
+  if (s->fd != STDOUT_FILENO
+      && s->fd != STDERR_FILENO
+      && s->fd != STDIN_FILENO)
+    retval = close (s->fd);
+  else
+    retval = 0;
+  free (s);
+  return retval;
+}
+
+static int
+raw_init (unix_stream * s)
+{
+  s->st.read = (void *) raw_read;
+  s->st.write = (void *) raw_write;
+  s->st.seek = (void *) raw_seek;
+  s->st.tell = (void *) raw_tell;
+  s->st.trunc = (void *) raw_truncate;
+  s->st.close = (void *) raw_close;
+  s->st.flush = (void *) raw_flush;
+
+  s->buffer = NULL;
+  return 0;
+}
+
+
+/*********************************************************************
+Buffered I/O functions. These functions have the same semantics as the
+raw I/O functions above, except that they are buffered in order to
+improve performance. The buffer must be flushed when switching from
+reading to writing and vice versa.
+*********************************************************************/
+
+static int
+buf_flush (unix_stream * s)
+{
+  int writelen;
+
+  /* Flushing in read mode means discarding read bytes.  */
+  s->active = 0;
+
+  if (s->ndirty == 0)
+    return 0;
+  
+  if (s->file_length != -1 && s->physical_offset != s->buffer_offset
+      && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
+    return -1;
+
+  writelen = raw_write (s, s->buffer, s->ndirty);
+
+  s->physical_offset = s->buffer_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 -1;
+
+#ifdef _WIN32
+  _commit (s->fd);
+#endif
+
+  return 0;
+}
+
+static ssize_t
+buf_read (unix_stream * s, void * buf, ssize_t nbyte)
+{
+  if (s->active == 0)
+    s->buffer_offset = s->logical_offset;
+
+  /* Is the data we want in the buffer?  */
+  if (s->logical_offset + nbyte <= s->buffer_offset + s->active
+      && s->buffer_offset <= s->logical_offset)
+    memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
+  else
+    {
+      /* First copy the active bytes if applicable, then read the rest
+         either directly or filling the buffer.  */
+      char *p;
+      int nread = 0;
+      ssize_t to_read, did_read;
+      gfc_offset new_logical;
+      
+      p = (char *) buf;
+      if (s->logical_offset >= s->buffer_offset 
+          && s->buffer_offset + s->active >= s->logical_offset)
+        {
+          nread = s->active - (s->logical_offset - s->buffer_offset);
+          memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), 
+                  nread);
+          p += nread;
+        }
+      /* At this point we consider all bytes in the buffer discarded.  */
+      to_read = nbyte - nread;
+      new_logical = s->logical_offset + nread;
+      if (s->file_length != -1 && s->physical_offset != new_logical
+          && lseek (s->fd, new_logical, SEEK_SET) < 0)
+        return -1;
+      s->buffer_offset = s->physical_offset = new_logical;
+      if (to_read <= BUFFER_SIZE/2)
+        {
+          did_read = raw_read (s, s->buffer, BUFFER_SIZE);
+          s->physical_offset += did_read;
+          s->active = did_read;
+          did_read = (did_read > to_read) ? to_read : did_read;
+          memcpy (p, s->buffer, did_read);
+        }
+      else
+        {
+          did_read = raw_read (s, p, to_read);
+          s->physical_offset += did_read;
+          s->active = 0;
+        }
+      nbyte = did_read + nread;
+    }
+  s->logical_offset += nbyte;
+  return nbyte;
+}
+
+static ssize_t
+buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
+{
+  if (s->ndirty == 0)
+    s->buffer_offset = s->logical_offset;
+
+  /* Does the data fit into the buffer?  As a special case, if the
+     buffer is empty and the request is bigger than BUFFER_SIZE/2,
+     write directly. This avoids the case where the buffer would have
+     to be flushed at every write.  */
+  if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
+      && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
+      && s->buffer_offset <= s->logical_offset
+      && s->buffer_offset + s->ndirty >= s->logical_offset)
+    {
+      memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
+      int nd = (s->logical_offset - s->buffer_offset) + nbyte;
+      if (nd > s->ndirty)
+        s->ndirty = nd;
+    }
+  else
+    {
+      /* Flush, and either fill the buffer with the new data, or if
+         the request is bigger than the buffer size, write directly
+         bypassing the buffer.  */
+      buf_flush (s);
+      if (nbyte <= BUFFER_SIZE/2)
+        {
+          memcpy (s->buffer, buf, nbyte);
+          s->buffer_offset = s->logical_offset;
+          s->ndirty += nbyte;
+        }
+      else
+	{
+	  if (s->file_length != -1 && s->physical_offset != s->logical_offset)
+	    {
+	      if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
+		return -1;
+	      s->physical_offset = s->logical_offset;
+	    }
+
+	  nbyte = raw_write (s, buf, nbyte);
+	  s->physical_offset += nbyte;
+	}
+    }
+  s->logical_offset += nbyte;
+  /* 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;
+  return nbyte;
+}
+
+static gfc_offset
+buf_seek (unix_stream * s, gfc_offset offset, int whence)
+{
+  switch (whence)
+    {
+    case SEEK_SET:
+      break;
+    case SEEK_CUR:
+      offset += s->logical_offset;
+      break;
+    case SEEK_END:
+      offset += s->file_length;
+      break;
+    default:
+      return -1;
+    }
+  if (offset < 0)
+    {
+      errno = EINVAL;
+      return -1;
+    }
+  s->logical_offset = offset;
+  return offset;
+}
+
+static gfc_offset
+buf_tell (unix_stream * s)
+{
+  return s->logical_offset;
+}
+
+static int
+buf_truncate (unix_stream * s, gfc_offset length)
+{
+  int r;
+
+  if (buf_flush (s) != 0)
+    return -1;
+  r = raw_truncate (s, length);
+  if (r == 0)
+    s->file_length = length;
+  return r;
+}
+
+static int
+buf_close (unix_stream * s)
+{
+  if (buf_flush (s) != 0)
+    return -1;
+  free (s->buffer);
+  return raw_close (s);
+}
+
+static int
+buf_init (unix_stream * s)
+{
+  s->st.read = (void *) buf_read;
+  s->st.write = (void *) buf_write;
+  s->st.seek = (void *) buf_seek;
+  s->st.tell = (void *) buf_tell;
+  s->st.trunc = (void *) buf_truncate;
+  s->st.close = (void *) buf_close;
+  s->st.flush = (void *) buf_flush;
+
+  s->buffer = get_mem (BUFFER_SIZE);
+  return 0;
+}
+
+
+/*********************************************************************
+  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.
+
+*********************************************************************/
+
+char *
+mem_alloc_r (stream * strm, int * len)
+{
+  unix_stream * s = (unix_stream *) strm;
+  gfc_offset n;
+  gfc_offset where = s->logical_offset;
+
+  if (where < s->buffer_offset || where > s->buffer_offset + s->active)
+    return NULL;
+
+  n = s->buffer_offset + s->active - where;
+  if (*len > n)
+    *len = n;
+
+  s->logical_offset = where + *len;
+
+  return s->buffer + (where - s->buffer_offset);
+}
+
+
+char *
+mem_alloc_r4 (stream * strm, int * len)
+{
+  unix_stream * s = (unix_stream *) strm;
+  gfc_offset n;
+  gfc_offset where = s->logical_offset;
+
+  if (where < s->buffer_offset || where > s->buffer_offset + s->active)
+    return NULL;
+
+  n = s->buffer_offset + s->active - where;
+  if (*len > n)
+    *len = n;
+
+  s->logical_offset = where + *len;
+
+  return s->buffer + (where - s->buffer_offset) * 4;
+}
+
+
+char *
+mem_alloc_w (stream * strm, int * len)
+{
+  unix_stream * s = (unix_stream *) strm;
+  gfc_offset m;
+  gfc_offset 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);
+}
+
+
+gfc_char4_t *
+mem_alloc_w4 (stream * strm, int * len)
+{
+  unix_stream * s = (unix_stream *) strm;
+  gfc_offset m;
+  gfc_offset where = s->logical_offset;
+  gfc_char4_t *result = (gfc_char4_t *) s->buffer;
+
+  m = where + *len;
+
+  if (where < s->buffer_offset)
+    return NULL;
+
+  if (m > s->file_length)
+    return NULL;
+
+  s->logical_offset = m;
+  return &result[where - s->buffer_offset];
+}
+
+
+/* Stream read function for character(kine=1) internal units.  */
+
+static ssize_t
+mem_read (stream * s, void * buf, ssize_t nbytes)
+{
+  void *p;
+  int nb = nbytes;
+
+  p = mem_alloc_r (s, &nb);
+  if (p)
+    {
+      memcpy (buf, p, nb);
+      return (ssize_t) nb;
+    }
+  else
+    return 0;
+}
+
+
+/* Stream read function for chracter(kind=4) internal units.  */
+
+static ssize_t
+mem_read4 (stream * s, void * buf, ssize_t nbytes)
+{
+  void *p;
+  int nb = nbytes;
+
+  p = mem_alloc_r (s, &nb);
+  if (p)
+    {
+      memcpy (buf, p, nb);
+      return (ssize_t) nb;
+    }
+  else
+    return 0;
+}
+
+
+/* Stream write function for character(kind=1) internal units.  */
+
+static ssize_t
+mem_write (stream * s, const void * buf, ssize_t nbytes)
+{
+  void *p;
+  int nb = nbytes;
+
+  p = mem_alloc_w (s, &nb);
+  if (p)
+    {
+      memcpy (p, buf, nb);
+      return (ssize_t) nb;
+    }
+  else
+    return 0;
+}
+
+
+/* Stream write function for character(kind=4) internal units.  */
+
+static ssize_t
+mem_write4 (stream * s, const void * buf, ssize_t nwords)
+{
+  gfc_char4_t *p;
+  int nw = nwords;
+
+  p = mem_alloc_w4 (s, &nw);
+  if (p)
+    {
+      while (nw--)
+	*p++ = (gfc_char4_t) *((char *) buf);
+      return nwords;
+    }
+  else
+    return 0;
+}
+
+
+static gfc_offset
+mem_seek (stream * strm, gfc_offset offset, int whence)
+{
+  unix_stream * s = (unix_stream *) strm;
+  switch (whence)
+    {
+    case SEEK_SET:
+      break;
+    case SEEK_CUR:
+      offset += s->logical_offset;
+      break;
+    case SEEK_END:
+      offset += s->file_length;
+      break;
+    default:
+      return -1;
+    }
+
+  /* Note that for internal array I/O it's actually possible to have a
+     negative offset, so don't check for that.  */
+  if (offset > s->file_length)
+    {
+      errno = EINVAL;
+      return -1;
+    }
+
+  s->logical_offset = offset;
+
+  /* Returning < 0 is the error indicator for sseek(), so return 0 if
+     offset is negative.  Thus if the return value is 0, the caller
+     has to use stell() to get the real value of logical_offset.  */
+  if (offset >= 0)
+    return offset;
+  return 0;
+}
+
+
+static gfc_offset
+mem_tell (stream * s)
+{
+  return ((unix_stream *)s)->logical_offset;
+}
+
+
+static int
+mem_truncate (unix_stream * s __attribute__ ((unused)), 
+	      gfc_offset length __attribute__ ((unused)))
+{
+  return 0;
+}
+
+
+static int
+mem_flush (unix_stream * s __attribute__ ((unused)))
+{
+  return 0;
+}
+
+
+static int
+mem_close (unix_stream * s)
+{
+  if (s != NULL)
+    free (s);
+
+  return 0;
+}
+
+
+/*********************************************************************
+  Public functions -- A reimplementation of this module needs to
+  define functional equivalents of the following.
+*********************************************************************/
+
+/* open_internal()-- Returns a stream structure from a character(kind=1)
+   internal file */
+
+stream *
+open_internal (char *base, int length, gfc_offset offset)
+{
+  unix_stream *s;
+
+  s = get_mem (sizeof (unix_stream));
+  memset (s, '\0', sizeof (unix_stream));
+
+  s->buffer = base;
+  s->buffer_offset = offset;
+
+  s->logical_offset = 0;
+  s->active = s->file_length = length;
+
+  s->st.close = (void *) mem_close;
+  s->st.seek = (void *) mem_seek;
+  s->st.tell = (void *) mem_tell;
+  s->st.trunc = (void *) mem_truncate;
+  s->st.read = (void *) mem_read;
+  s->st.write = (void *) mem_write;
+  s->st.flush = (void *) mem_flush;
+
+  return (stream *) s;
+}
+
+/* open_internal4()-- Returns a stream structure from a character(kind=4)
+   internal file */
+
+stream *
+open_internal4 (char *base, int length, gfc_offset offset)
+{
+  unix_stream *s;
+
+  s = get_mem (sizeof (unix_stream));
+  memset (s, '\0', sizeof (unix_stream));
+
+  s->buffer = base;
+  s->buffer_offset = offset;
+
+  s->logical_offset = 0;
+  s->active = s->file_length = length;
+
+  s->st.close = (void *) mem_close;
+  s->st.seek = (void *) mem_seek;
+  s->st.tell = (void *) mem_tell;
+  s->st.trunc = (void *) mem_truncate;
+  s->st.read = (void *) mem_read4;
+  s->st.write = (void *) mem_write4;
+  s->st.flush = (void *) mem_flush;
+
+  return (stream *) s;
+}
+
+
+/* fd_to_stream()-- Given an open file descriptor, build a stream
+ * around it. */
+
+static stream *
+fd_to_stream (int fd)
+{
+  gfstat_t 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;
+
+  /* Get the current length of the file. */
+
+  fstat (fd, &statbuf);
+
+  s->st_dev = statbuf.st_dev;
+  s->st_ino = statbuf.st_ino;
+  s->special_file = !S_ISREG (statbuf.st_mode);
+
+  if (S_ISREG (statbuf.st_mode))
+    s->file_length = statbuf.st_size;
+  else if (S_ISBLK (statbuf.st_mode))
+    {
+      /* Hopefully more portable than ioctl(fd, BLKGETSIZE64, &size)?  */
+      gfc_offset cur = lseek (fd, 0, SEEK_CUR);
+      s->file_length = lseek (fd, 0, SEEK_END);
+      lseek (fd, cur, SEEK_SET);
+    }
+  else
+    s->file_length = -1;
+
+  if (!(S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
+      || options.all_unbuffered
+      ||(options.unbuffered_preconnected && 
+         (s->fd == STDIN_FILENO 
+          || s->fd == STDOUT_FILENO 
+          || s->fd == STDERR_FILENO))
+      || isatty (s->fd))
+    raw_init (s);
+  else
+    buf_init (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)
+{
+  if (fstring == NULL)
+    return 1;
+  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;
+  const char *slash = "/";
+  int fd;
+
+  tempdir = getenv ("GFORTRAN_TMPDIR");
+#ifdef __MINGW32__
+  if (tempdir == NULL)
+    {
+      char buffer[MAX_PATH + 1];
+      DWORD ret;
+      ret = GetTempPath (MAX_PATH, buffer);
+      /* If we are not able to get a temp-directory, we use
+	 current directory.  */
+      if (ret > MAX_PATH || !ret)
+        buffer[0] = 0;
+      else
+        buffer[ret] = 0;
+      tempdir = strdup (buffer);
+    }
+#else
+  if (tempdir == NULL)
+    tempdir = getenv ("TMP");
+  if (tempdir == NULL)
+    tempdir = getenv ("TEMP");
+  if (tempdir == NULL)
+    tempdir = DEFAULT_TEMPDIR;
+#endif
+  /* Check for special case that tempdir contains slash
+     or backslash at end.  */
+  if (*tempdir == 0 || tempdir[strlen (tempdir) - 1] == '/'
+#ifdef __MINGW32__
+      || tempdir[strlen (tempdir) - 1] == '\\'
+#endif
+     )
+    slash = "";
+
+  template = get_mem (strlen (tempdir) + 20);
+
+#ifdef HAVE_MKSTEMP
+  sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir, slash);
+
+  fd = mkstemp (template);
+
+#else /* HAVE_MKSTEMP */
+  fd = -1;
+  do
+    {
+      sprintf (template, "%s%sgfortrantmpXXXXXX", tempdir, slash);
+      if (!mktemp (template))
+	break;
+#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);
+#endif /* HAVE_MKSTEMP */
+
+  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;
+    }
+
+#ifdef __CYGWIN__
+  if (opp->file_len == 7)
+    {
+      if (strncmp (path, "CONOUT$", 7) == 0
+	  || strncmp (path, "CONERR$", 7) == 0)
+	{
+	  fd = open ("/dev/conout", O_WRONLY);
+	  flags->action = ACTION_WRITE;
+	  return fd;
+	}
+    }
+
+  if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
+    {
+      fd = open ("/dev/conin", O_RDONLY);
+      flags->action = ACTION_READ;
+      return fd;
+    }
+#endif
+
+
+#ifdef __MINGW32__
+  if (opp->file_len == 7)
+    {
+      if (strncmp (path, "CONOUT$", 7) == 0
+	  || strncmp (path, "CONERR$", 7) == 0)
+	{
+	  fd = open ("CONOUT$", O_WRONLY);
+	  flags->action = ACTION_WRITE;
+	  return fd;
+	}
+    }
+
+  if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
+    {
+      fd = open ("CONIN$", O_RDONLY);
+      flags->action = ACTION_READ;
+      return fd;
+    }
+#endif
+
+  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;
+
+  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);
+
+  return fd_to_stream (fd);
+}
+
+
+/* input_stream()-- Return a stream pointer to the default input stream.
+ * Called on initialization. */
+
+stream *
+input_stream (void)
+{
+  return fd_to_stream (STDIN_FILENO);
+}
+
+
+/* output_stream()-- Return a stream pointer to the default output stream.
+ * Called on initialization. */
+
+stream *
+output_stream (void)
+{
+  stream * s;
+
+#if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
+  setmode (STDOUT_FILENO, O_BINARY);
+#endif
+
+  s = fd_to_stream (STDOUT_FILENO);
+  return s;
+}
+
+
+/* error_stream()-- Return a stream pointer to the default error stream.
+ * Called on initialization. */
+
+stream *
+error_stream (void)
+{
+  stream * s;
+
+#if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
+  setmode (STDERR_FILENO, O_BINARY);
+#endif
+
+  s = fd_to_stream (STDERR_FILENO);
+  return s;
+}
+
+
+/* st_vprintf()-- vprintf function for error output.  To avoid buffer
+   overruns, we limit the length of the buffer to ST_VPRINTF_SIZE.  2k
+   is big enough to completely fill a 80x25 terminal, so it shuld be
+   OK.  We use a direct write() because it is simpler and least likely
+   to be clobbered by memory corruption.  Writing an error message
+   longer than that is an error.  */
+
+#define ST_VPRINTF_SIZE 2048
+
+int
+st_vprintf (const char *format, va_list ap)
+{
+  static char buffer[ST_VPRINTF_SIZE];
+  int written;
+  int fd;
+
+  fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
+#ifdef HAVE_VSNPRINTF
+  written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
+#else
+  written = vsprintf(buffer, format, ap);
+
+  if (written >= ST_VPRINTF_SIZE-1)
+    {
+      /* The error message was longer than our buffer.  Ouch.  Because
+	 we may have messed up things badly, report the error and
+	 quit.  */
+#define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
+      write (fd, buffer, ST_VPRINTF_SIZE-1);
+      write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
+      sys_exit(2);
+#undef ERROR_MESSAGE
+
+    }
+#endif
+
+  written = write (fd, buffer, written);
+  return written;
+}
+
+/* st_printf()-- printf() function for error output.  This just calls
+   st_vprintf() to do the actual work.  */
+
+int
+st_printf (const char *format, ...)
+{
+  int written;
+  va_list ap;
+  va_start (ap, format);
+  written = st_vprintf(format, ap);
+  va_end (ap);
+  return written;
+}
+
+
+/* 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];
+  gfstat_t st;
+#ifdef HAVE_WORKING_STAT
+  unix_stream *s;
+#else
+# ifdef __MINGW32__
+  uint64_t id1, id2;
+# endif
+#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, &st) < 0)
+    return 0;
+
+#ifdef HAVE_WORKING_STAT
+  s = (unix_stream *) (u->s);
+  return (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
+#else
+
+# ifdef __MINGW32__
+  /* We try to match files by a unique ID.  On some filesystems (network
+     fs and FAT), we can't generate this unique ID, and will simply compare
+     filenames.  */
+  id1 = id_from_path (path);
+  id2 = id_from_fd (((unix_stream *) (u->s))->fd);
+  if (id1 || id2)
+    return (id1 == id2);
+# endif
+
+  if (len != u->file_len)
+    return 0;
+  return (memcmp(path, u->file, len) == 0);
+#endif
+}
+
+
+#ifdef HAVE_WORKING_STAT
+# define FIND_FILE0_DECL gfstat_t *st
+# define FIND_FILE0_ARGS st
+#else
+# define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
+# define FIND_FILE0_ARGS id, 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 defined(__MINGW32__) && !HAVE_WORKING_STAT
+  uint64_t id1;
+#endif
+
+  if (u == NULL)
+    return NULL;
+
+#ifdef HAVE_WORKING_STAT
+  if (u->s != NULL)
+    {
+      unix_stream *s = (unix_stream *) (u->s);
+      if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
+	return u;
+    }
+#else
+# ifdef __MINGW32__ 
+  if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
+    {
+      if (id == id1)
+	return u;
+    }
+  else
+# endif
+    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];
+  gfstat_t st[1];
+  gfc_unit *u;
+#if defined(__MINGW32__) && !HAVE_WORKING_STAT
+  uint64_t id = 0ULL;
+#endif
+
+  if (unpack_filename (path, file, file_len))
+    return NULL;
+
+  if (stat (path, &st[0]) < 0)
+    return NULL;
+
+#if defined(__MINGW32__) && !HAVE_WORKING_STAT
+  id = id_from_path (path);
+#endif
+
+  __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 (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)
+	    sflush (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)
+	{
+	  sflush (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 (u);
+	}
+    }
+  while (1);
+}
+
+
+/* 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];
+
+  if (unpack_filename (path, file, file_len))
+    return 0;
+
+  return !(access (path, F_OK));
+}
+
+
+/* file_size()-- Returns the size of the file.  */
+
+GFC_IO_INT
+file_size (const char *file, gfc_charlen_type file_len)
+{
+  char path[PATH_MAX + 1];
+  gfstat_t statbuf;
+
+  if (unpack_filename (path, file, file_len))
+    return -1;
+
+  if (stat (path, &statbuf) < 0)
+    return -1;
+
+  return (GFC_IO_INT) statbuf.st_size;
+}
+
+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];
+  gfstat_t 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 unknown;
+
+  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];
+  gfstat_t 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 unknown;
+
+  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];
+  gfstat_t 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 unknown;
+
+  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)
+{
+  gfc_offset curr, end;
+  if (!is_seekable (s))
+    return -1;
+  curr = stell (s);
+  if (curr == -1)
+    return curr;
+  end = sseek (s, 0, SEEK_END);
+  sseek (s, curr, SEEK_SET);
+  return end;
+}
+
+
+/* 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;
+}
+
+
+/* is_special()-- Return nonzero if the stream is not a regular file.  */
+
+int
+is_special (stream *s)
+{
+  return ((unix_stream *) s)->special_file;
+}
+
+
+int
+stream_isatty (stream *s)
+{
+  return isatty (((unix_stream *) s)->fd);
+}
+
+int
+stream_ttyname (stream *s  __attribute__ ((unused)),
+		char * buf  __attribute__ ((unused)),
+		size_t buflen  __attribute__ ((unused)))
+{
+#ifdef HAVE_TTYNAME_R
+  return ttyname_r (((unix_stream *) s)->fd, buf, buflen);
+#elif defined HAVE_TTYNAME
+  char *p;
+  size_t plen;
+  p = ttyname (((unix_stream *) s)->fd);
+  if (!p)
+    return errno;
+  plen = strlen (p);
+  if (buflen < plen)
+    plen = buflen;
+  memcpy (buf, p, plen);
+  return 0;
+#else
+  return ENOSYS;
+#endif
+}
+
+
+
+
+/* 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.6/libgfortran/io/unix.h b/gcc-4.6/libgfortran/io/unix.h
new file mode 100644
index 000000000..f7d6f0864
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/unix.h
@@ -0,0 +1,189 @@
+/* Copyright (C) 2009, 2010
+   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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef GFOR_UNIX_H
+#define GFOR_UNIX_H
+
+#include "io.h"
+
+
+struct stream
+{
+  ssize_t (*read) (struct stream *, void *, ssize_t);
+  ssize_t (*write) (struct stream *, const void *, ssize_t);
+  gfc_offset (*seek) (struct stream *, gfc_offset, int);
+  gfc_offset (*tell) (struct stream *);
+  /* Avoid keyword truncate due to AIX namespace collision.  */
+  int (*trunc) (struct stream *, gfc_offset);
+  int (*flush) (struct stream *);
+  int (*close) (struct stream *);
+};
+
+
+/* Inline functions for doing file I/O given a stream.  */
+static inline ssize_t
+sread (stream * s, void * buf, ssize_t nbyte)
+{
+  return s->read (s, buf, nbyte);
+}
+
+static inline ssize_t
+swrite (stream * s, const void * buf, ssize_t nbyte)
+{
+  return s->write (s, buf, nbyte);
+}
+
+static inline gfc_offset
+sseek (stream * s, gfc_offset offset, int whence)
+{
+  return s->seek (s, offset, whence);
+}
+
+static inline gfc_offset
+stell (stream * s)
+{
+  return s->tell (s);
+}
+
+static inline int
+struncate (stream * s, gfc_offset length)
+{
+  return s->trunc (s, length);
+}
+
+static inline int
+sflush (stream * s)
+{
+  return s->flush (s);
+}
+
+static inline int
+sclose (stream * s)
+{
+  return s->close (s);
+}
+
+
+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, gfc_offset);
+internal_proto(open_internal);
+
+extern stream *open_internal4 (char *, int, gfc_offset);
+internal_proto(open_internal4);
+
+extern char * mem_alloc_w (stream *, int *);
+internal_proto(mem_alloc_w);
+
+extern char * mem_alloc_r (stream *, int *);
+internal_proto(mem_alloc_r);
+
+extern gfc_char4_t * mem_alloc_w4 (stream *, int *);
+internal_proto(mem_alloc_w4);
+
+extern char * mem_alloc_r4 (stream *, int *);
+internal_proto(mem_alloc_r4);
+
+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 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 GFC_IO_INT file_size (const char *file, gfc_charlen_type file_len);
+internal_proto(file_size);
+
+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 int is_seekable (stream *);
+internal_proto(is_seekable);
+
+extern int is_special (stream *);
+internal_proto(is_special);
+
+extern void flush_if_preconnected (stream *);
+internal_proto(flush_if_preconnected);
+
+extern int stream_isatty (stream *);
+internal_proto(stream_isatty);
+
+#ifndef TTY_NAME_MAX
+#ifdef _POSIX_TTY_NAME_MAX
+#define TTY_NAME_MAX _POSIX_TTY_NAME_MAX
+#else
+/* sysconf(_SC_TTY_NAME_MAX) = 32 which should be enough.  */
+#define TTY_NAME_MAX 32
+#endif
+#endif
+
+extern int stream_ttyname (stream *, char *, size_t);
+internal_proto(stream_ttyname);
+
+extern int unpack_filename (char *, const char *, int);
+internal_proto(unpack_filename);
+
+
+#endif
diff --git a/gcc-4.6/libgfortran/io/write.c b/gcc-4.6/libgfortran/io/write.c
new file mode 100644
index 000000000..987c3cd88
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/write.c
@@ -0,0 +1,1997 @@
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   Namelist output contributed by Paul Thomas
+   F2003 I/O support contributed by Jerry DeLisle
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "io.h"
+#include "format.h"
+#include "unix.h"
+#include <assert.h>
+#include <string.h>
+#include <ctype.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <errno.h>
+#define star_fill(p, n) memset(p, '*', n)
+
+typedef unsigned char uchar;
+
+/* Helper functions for character(kind=4) internal units.  These are needed
+   by write_float.def.  */
+
+static inline void
+memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
+{
+  int j;
+  for (j = 0; j < k; j++)
+    *p++ = c;
+}
+
+static inline void
+memcpy4 (gfc_char4_t *dest, const char *source, int k)
+{
+  int j;
+  
+  const char *p = source;
+  for (j = 0; j < k; j++)
+    *dest++ = (gfc_char4_t) *p++;
+}
+
+/* This include contains the heart and soul of formatted floating point.  */
+#include "write_float.def"
+
+/* Write out default char4.  */
+
+static void
+write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source,
+		     int src_len, int w_len)
+{
+  char *p;
+  int j, k = 0;
+  gfc_char4_t c;
+  uchar d;
+      
+  /* Take care of preceding blanks.  */
+  if (w_len > src_len)
+    {
+      k = w_len - src_len;
+      p = write_block (dtp, k);
+      if (p == NULL)
+	return;
+      if (is_char4_unit (dtp))
+	{
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;
+	  memset4 (p4, ' ', k);
+	}
+      else
+	memset (p, ' ', k);
+    }
+
+  /* Get ready to handle delimiters if needed.  */
+  switch (dtp->u.p.current_unit->delim_status)
+    {
+    case DELIM_APOSTROPHE:
+      d = '\'';
+      break;
+    case DELIM_QUOTE:
+      d = '"';
+      break;
+    default:
+      d = ' ';
+      break;
+    }
+
+  /* Now process the remaining characters, one at a time.  */
+  for (j = 0; j < src_len; j++)
+    {
+      c = source[j];
+      if (is_char4_unit (dtp))
+	{
+	  gfc_char4_t *q;
+	  /* Handle delimiters if any.  */
+	  if (c == d && d != ' ')
+	    {
+	      p = write_block (dtp, 2);
+	      if (p == NULL)
+		return;
+	      q = (gfc_char4_t *) p;
+	      *q++ = c;
+	    }
+	  else
+	    {
+	      p = write_block (dtp, 1);
+	      if (p == NULL)
+		return;
+	      q = (gfc_char4_t *) p;
+	    }
+	  *q = c;
+	}
+      else
+	{
+	  /* Handle delimiters if any.  */
+	  if (c == d && d != ' ')
+	    {
+	      p = write_block (dtp, 2);
+	      if (p == NULL)
+		return;
+	      *p++ = (uchar) c;
+	    }
+          else
+	    {
+	      p = write_block (dtp, 1);
+	      if (p == NULL)
+		return;
+	    }
+	    *p = c > 255 ? '?' : (uchar) c;
+	}
+    }
+}
+
+
+/* Write out UTF-8 converted from char4.  */
+
+static void
+write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
+		     int src_len, int w_len)
+{
+  char *p;
+  int j, k = 0;
+  gfc_char4_t c;
+  static const uchar masks[6] =  { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
+  static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
+  int nbytes;
+  uchar buf[6], d, *q; 
+
+  /* Take care of preceding blanks.  */
+  if (w_len > src_len)
+    {
+      k = w_len - src_len;
+      p = write_block (dtp, k);
+      if (p == NULL)
+	return;
+      memset (p, ' ', k);
+    }
+
+  /* Get ready to handle delimiters if needed.  */
+  switch (dtp->u.p.current_unit->delim_status)
+    {
+    case DELIM_APOSTROPHE:
+      d = '\'';
+      break;
+    case DELIM_QUOTE:
+      d = '"';
+      break;
+    default:
+      d = ' ';
+      break;
+    }
+
+  /* Now process the remaining characters, one at a time.  */
+  for (j = k; j < src_len; j++)
+    {
+      c = source[j];
+      if (c < 0x80)
+	{
+	  /* Handle the delimiters if any.  */
+	  if (c == d && d != ' ')
+	    {
+	      p = write_block (dtp, 2);
+	      if (p == NULL)
+		return;
+	      *p++ = (uchar) c;
+	    }
+	  else
+	    {
+	      p = write_block (dtp, 1);
+	      if (p == NULL)
+		return;
+	    }
+	  *p = (uchar) c;
+	}
+      else
+	{
+	  /* Convert to UTF-8 sequence.  */
+	  nbytes = 1;
+	  q = &buf[6];
+
+	  do
+	    {
+	      *--q = ((c & 0x3F) | 0x80);
+	      c >>= 6;
+	      nbytes++;
+	    }
+	  while (c >= 0x3F || (c & limits[nbytes-1]));
+
+	  *--q = (c | masks[nbytes-1]);
+
+	  p = write_block (dtp, nbytes);
+	  if (p == NULL)
+	    return;
+
+	  while (q < &buf[6])
+	    *p++ = *q++;
+	}
+    }
+}
+
+
+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
+	 || (f->format == FMT_G && 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 (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;
+	  if (wlen < len)
+	    memcpy4 (p4, source, wlen);
+	  else
+	    {
+	      memset4 (p4, ' ', wlen - len);
+	      memcpy4 (p4 + wlen - len, source, len);
+	    }
+	  return;
+	}
+
+      if (wlen < len)
+	memcpy (p, source, wlen);
+      else
+	{
+	  memset (p, ' ', wlen - len);
+	  memcpy (p + wlen - len, source, len);
+	}
+#ifdef HAVE_CRLF
+    }
+#endif
+}
+
+
+/* The primary difference between write_a_char4 and write_a is that we have to
+   deal with writing from the first byte of the 4-byte character and pay
+   attention to the most significant bytes.  For ENCODING="default" write the
+   lowest significant byte. If the 3 most significant bytes contain
+   non-zero values, emit a '?'.  For ENCODING="utf-8", convert the UCS-32 value
+   to the UTF-8 encoded string before writing out.  */
+
+void
+write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+  int wlen;
+  gfc_char4_t *q;
+
+  wlen = f->u.string.length < 0
+	 || (f->format == FMT_G && f->u.string.length == 0)
+	 ? len : f->u.string.length;
+
+  q = (gfc_char4_t *) source;
+#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 gfc_char4_t crlf[] = {0x000d,0x000a};
+      int i, bytes;
+      gfc_char4_t *qq;
+      bytes = 0;
+
+      /* Write out any padding if needed.  */
+      if (len < wlen)
+	{
+	  char *p;
+	  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.  */
+      qq = (gfc_char4_t *) source;
+      for (i = 0; i < wlen; i++)
+	{
+	  if (qq[i] == '\n')
+	    {
+	      /* Write out the previously scanned characters in the string.  */
+	      if (bytes > 0)
+		{
+		  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+		    write_utf8_char4 (dtp, q, bytes, 0);
+		  else
+		    write_default_char4 (dtp, q, bytes, 0);
+		  bytes = 0;
+		}
+
+	      /* Write out the CR_LF sequence.  */ 
+	      write_default_char4 (dtp, crlf, 2, 0);
+	    }
+	  else
+	    bytes++;
+	}
+
+      /*  Write out any remaining bytes if no LF was found.  */
+      if (bytes > 0)
+	{
+	  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+	    write_utf8_char4 (dtp, q, bytes, 0);
+	  else
+	    write_default_char4 (dtp, q, bytes, 0);
+	}
+    }
+  else
+    {
+#endif
+      if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+	write_utf8_char4 (dtp, q, len, wlen);
+      else
+	write_default_char4 (dtp, q, len, wlen);
+#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 10:
+    case 16:
+      {
+	GFC_INTEGER_16 tmp = 0;
+	memcpy ((void *) &tmp, p, len);
+	i = (GFC_UINTEGER_16) tmp;
+      }
+      break;
+#endif
+    default:
+      internal_error (NULL, "bad integer kind");
+    }
+
+  return i;
+}
+
+
+void
+write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
+{
+  char *p;
+  int wlen;
+  GFC_INTEGER_LARGEST n;
+
+  wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
+  
+  p = write_block (dtp, wlen);
+  if (p == NULL)
+    return;
+
+  n = extract_int (source, len);
+
+  if (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t *p4 = (gfc_char4_t *) p;
+      memset4 (p4, ' ', wlen -1);
+      p4[wlen - 1] = (n) ? 'T' : 'F';
+      return;
+    }
+
+  memset (p, ' ', wlen -1);
+  p[wlen - 1] = (n) ? 'T' : 'F';
+}
+
+
+static void
+write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
+{
+  int w, m, digits, nzero, nblank;
+  char *p;
+
+  w = f->u.integer.w;
+  m = f->u.integer.m;
+
+  /* Special case:  */
+
+  if (m == 0 && n == 0)
+    {
+      if (w == 0)
+        w = 1;
+
+      p = write_block (dtp, w);
+      if (p == NULL)
+        return;
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;
+	  memset4 (p4, ' ', w);
+	}
+      else
+	memset (p, ' ', w);
+      goto done;
+    }
+
+  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 (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t *p4 = (gfc_char4_t *) p;
+      if (nblank < 0)
+	{
+	  memset4 (p4, '*', w);
+	  return;
+	}
+
+      if (!dtp->u.p.no_leading_blank)
+	{
+	  memset4 (p4, ' ', nblank);
+	  q += nblank;
+	  memset4 (p4, '0', nzero);
+	  q += nzero;
+	  memcpy4 (p4, q, digits);
+	}
+      else
+	{
+	  memset4 (p4, '0', nzero);
+	  q += nzero;
+	  memcpy4 (p4, q, digits);
+	  q += digits;
+	  memset4 (p4, ' ', nblank);
+	  dtp->u.p.no_leading_blank = 0;
+	}
+      return;
+    }
+
+  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->format == FMT_G ? -1 : 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;
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;
+	  memset4 (p4, ' ', w);
+	}
+      else
+	memset (p, ' ', w);
+      goto done;
+    }
+
+  sign = calculate_sign (dtp, n < 0);
+  if (n < 0)
+    n = -n;
+  nsign = sign == S_NONE ? 0 : 1;
+  
+  /* conv calls itoa which sets the negative sign needed
+     by write_integer. The sign '+' or '-' is set below based on sign
+     calculated above, so we just point past the sign in the string
+     before proceeding to avoid double signs in corner cases.
+     (see PR38504)  */
+  q = conv (n, itoa_buf, sizeof (itoa_buf));
+  if (*q == '-')
+    q++;
+
+  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 (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t * p4 = (gfc_char4_t *) p;
+      if (nblank < 0)
+	{
+	  memset4 (p4, '*', w);
+	  goto done;
+	}
+
+      memset4 (p4, ' ', nblank);
+      p4 += nblank;
+
+      switch (sign)
+	{
+	case S_PLUS:
+	  *p4++ = '+';
+	  break;
+	case S_MINUS:
+	  *p4++ = '-';
+	  break;
+	case S_NONE:
+	  break;
+	}
+
+      memset4 (p4, '0', nzero);
+      p4 += nzero;
+
+      memcpy4 (p4, q, digits);
+      return;
+    }
+
+  if (nblank < 0)
+    {
+      star_fill (p, w);
+      goto done;
+    }
+
+  memset (p, ' ', nblank);
+  p += nblank;
+
+  switch (sign)
+    {
+    case S_PLUS:
+      *p++ = '+';
+      break;
+    case S_MINUS:
+      *p++ = '-';
+      break;
+    case S_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;
+}
+
+/* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
+   to convert large reals with kind sizes that exceed the largest integer type
+   available on certain platforms.  In these cases, byte by byte conversion is
+   performed. Endianess is taken into account.  */
+
+/* Conversion to binary.  */
+
+static const char *
+btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+  char *q;
+  int i, j;
+  
+  q = buffer;
+  if (big_endian)
+    {
+      const char *p = s;
+      for (i = 0; i < len; i++)
+	{
+	  char c = *p;
+
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 8; j++)
+	    {
+	      *q++ = (c & 128) ? '1' : '0';
+	      c <<= 1;
+	    }
+	  p++;
+	}
+    }
+  else
+    {
+      const char *p = s + len - 1;
+      for (i = 0; i < len; i++)
+	{
+	  char c = *p;
+
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 8; j++)
+	    {
+	      *q++ = (c & 128) ? '1' : '0';
+	      c <<= 1;
+	    }
+	  p--;
+	}
+    }
+
+  *q = '\0';
+
+  if (*n == 0)
+    return "0";
+
+  /* Move past any leading zeros.  */  
+  while (*buffer == '0')
+    buffer++;
+
+  return buffer;
+
+}
+
+/* Conversion to octal.  */
+
+static const char *
+otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+  char *q;
+  int i, j, k;
+  uint8_t octet;
+
+  q = buffer + GFC_OTOA_BUF_SIZE - 1;
+  *q = '\0';
+  i = k = octet = 0;
+
+  if (big_endian)
+    {
+      const char *p = s + len - 1;
+      char c = *p;
+      while (i < len)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 3 && i < len; j++)
+	    {
+	      octet |= (c & 1) << j;
+	      c >>= 1;
+	      if (++k > 7)
+	        {
+		  i++;
+		  k = 0;
+		  c = *--p;
+		}
+	    }
+	  *--q = '0' + octet;
+	  octet = 0;
+	}
+    }
+  else
+    {
+      const char *p = s;
+      char c = *p;
+      while (i < len)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 3 && i < len; j++)
+	    {
+	      octet |= (c & 1) << j;
+	      c >>= 1;
+	      if (++k > 7)
+	        {
+		  i++;
+		  k = 0;
+		  c = *++p;
+		}
+	    }
+	  *--q = '0' + octet;
+	  octet = 0;
+	}
+    }
+
+  if (*n == 0)
+    return "0";
+
+  /* Move past any leading zeros.  */  
+  while (*q == '0')
+    q++;
+
+  return q;
+}
+
+/* Conversion to hexidecimal.  */
+
+static const char *
+ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+  static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
+    '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
+
+  char *q;
+  uint8_t h, l;
+  int i;
+  
+  q = buffer;
+  
+  if (big_endian)
+    {
+      const char *p = s;
+      for (i = 0; i < len; i++)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  h = (*p >> 4) & 0x0F;
+	  l = *p++ & 0x0F;
+	  *q++ = a[h];
+	  *q++ = a[l];
+	}
+    }
+  else
+    {
+      const char *p = s + len - 1;
+      for (i = 0; i < len; i++)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  h = (*p >> 4) & 0x0F;
+	  l = *p-- & 0x0F;
+	  *q++ = a[h];
+	  *q++ = a[l];
+	}
+    }
+
+  *q = '\0';
+  
+  if (*n == 0)
+    return "0";
+    
+  /* Move past any leading zeros.  */  
+  while (*buffer == '0')
+    buffer++;
+
+  return buffer;
+}
+
+/* gfc_itoa()-- Integer to decimal conversion.
+   The itoa function is a widespread non-standard extension to standard
+   C, often declared in <stdlib.h>.  Even though the itoa defined here
+   is a static function we take care not to conflict with any prior
+   non-static declaration.  Hence the 'gfc_' prefix, which is normally
+   reserved for functions with external linkage.  */
+
+static const char *
+gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
+{
+  int negative;
+  char *p;
+  GFC_UINTEGER_LARGEST t;
+
+  assert (len >= GFC_ITOA_BUF_SIZE);
+
+  if (n == 0)
+    return "0";
+
+  negative = 0;
+  t = n;
+  if (n < 0)
+    {
+      negative = 1;
+      t = -n; /*must use unsigned to protect from overflow*/
+    }
+
+  p = buffer + GFC_ITOA_BUF_SIZE - 1;
+  *p = '\0';
+
+  while (t != 0)
+    {
+      *--p = '0' + (t % 10);
+      t /= 10;
+    }
+
+  if (negative)
+    *--p = '-';
+  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 *source, int len)
+{
+  const char *p;
+  char itoa_buf[GFC_BTOA_BUF_SIZE];
+  GFC_UINTEGER_LARGEST n = 0;
+
+  if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+    {
+      p = btoa_big (source, itoa_buf, len, &n);
+      write_boz (dtp, f, p, n);
+    }
+  else
+    {
+      n = extract_uint (source, len);
+      p = btoa (n, itoa_buf, sizeof (itoa_buf));
+      write_boz (dtp, f, p, n);
+    }
+}
+
+
+void
+write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+  const char *p;
+  char itoa_buf[GFC_OTOA_BUF_SIZE];
+  GFC_UINTEGER_LARGEST n = 0;
+  
+  if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+    {
+      p = otoa_big (source, itoa_buf, len, &n);
+      write_boz (dtp, f, p, n);
+    }
+  else
+    {
+      n = extract_uint (source, len);
+      p = otoa (n, itoa_buf, sizeof (itoa_buf));
+      write_boz (dtp, f, p, n);
+    }
+}
+
+void
+write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+  const char *p;
+  char itoa_buf[GFC_XTOA_BUF_SIZE];
+  GFC_UINTEGER_LARGEST n = 0;
+
+  if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+    {
+      p = ztoa_big (source, itoa_buf, len, &n);
+      write_boz (dtp, f, p, n);
+    }
+  else
+    {
+      n = extract_uint (source, len);
+      p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
+      write_boz (dtp, f, p, n);
+    }
+}
+
+
+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 && len - nspaces >= 0)
+    {
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;
+	  memset4 (&p4[len - nspaces], ' ', nspaces);
+	}
+      else
+	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, int c)
+{
+  char *p;
+
+  p = write_block (dtp, 1);
+  if (p == NULL)
+    return 1;
+  if (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t *p4 = (gfc_char4_t *) p;
+      *p4 = c;
+      return 0;
+    }
+
+  *p = (uchar) 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 (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t *p4 = (gfc_char4_t *) p;
+      if (dtp->u.p.no_leading_blank)
+	{
+	  memcpy4 (p4, q, digits);
+	  memset4 (p4 + digits, ' ', width - digits);
+	}
+      else
+	{
+	  memset4 (p4, ' ', width - digits);
+	  memcpy4 (p4 + width - digits, q, digits);
+	}
+      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 kind, int length)
+{
+  int i, extra;
+  char *p, d;
+
+  switch (dtp->u.p.current_unit->delim_status)
+    {
+    case DELIM_APOSTROPHE:
+      d = '\'';
+      break;
+    case DELIM_QUOTE:
+      d = '"';
+      break;
+    default:
+      d = ' ';
+      break;
+    }
+
+  if (kind == 1)
+    {
+      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 (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t d4 = (gfc_char4_t) d;
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;
+
+	  if (d4 == ' ')
+	    memcpy4 (p4, source, length);
+	  else
+	    {
+	      *p4++ = d4;
+
+	      for (i = 0; i < length; i++)
+		{
+		  *p4++ = (gfc_char4_t) source[i];
+		  if (source[i] == d)
+		    *p4++ = d4;
+		}
+
+	      *p4 = d4;
+	    }
+	  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;
+	}
+    }
+  else
+    {
+      if (d == ' ')
+	{
+	  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+	    write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
+	  else
+	    write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
+	}
+      else
+	{
+	  p = write_block (dtp, 1);
+	  *p = d;
+
+	  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+	    write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
+	  else
+	    write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
+
+	  p = write_block (dtp, 1);
+	  *p = d;
+	}
+    }
+}
+
+
+/* Set an fnode to default format.  */
+
+static void
+set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
+{
+  f->format = FMT_G;
+  switch (length)
+    {
+    case 4:
+      f->u.real.w = 15;
+      f->u.real.d = 8;
+      f->u.real.e = 2;
+      break;
+    case 8:
+      f->u.real.w = 25;
+      f->u.real.d = 17;
+      f->u.real.e = 3;
+      break;
+    case 10:
+      f->u.real.w = 29;
+      f->u.real.d = 20;
+      f->u.real.e = 4;
+      break;
+    case 16:
+      f->u.real.w = 44;
+      f->u.real.d = 35;
+      f->u.real.e = 4;
+      break;
+    default:
+      internal_error (&dtp->common, "bad real kind");
+      break;
+    }
+}
+/* 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).  */
+// FX -- FIXME: should we change the default format for __float128-real(16)?
+
+void
+write_real (st_parameter_dt *dtp, const char *source, int length)
+{
+  fnode f ;
+  int org_scale = dtp->u.p.scale_factor;
+  dtp->u.p.scale_factor = 1;
+  set_fnode_default (dtp, &f, length);
+  write_float (dtp, &f, source , length);
+  dtp->u.p.scale_factor = org_scale;
+}
+
+
+void
+write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
+{
+  fnode f ;
+  set_fnode_default (dtp, &f, length);
+  if (d > 0)
+    f.u.real.d = d;
+  dtp->u.p.g0_no_blanks = 1;
+  write_float (dtp, &f, source , length);
+  dtp->u.p.g0_no_blanks = 0;
+}
+
+
+static void
+write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
+{
+  char semi_comma =
+	dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
+
+  if (write_char (dtp, '('))
+    return;
+  write_real (dtp, source, kind);
+
+  if (write_char (dtp, semi_comma))
+    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;
+  if (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t *p4 = (gfc_char4_t *) p;
+      memcpy4 (p4, options.separator, options.separator_len);
+    }
+  else
+    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->delim_status != 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, size);
+      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;
+  size_t stride = type == BT_CHARACTER ?
+		  size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
+
+  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 + elem * stride, 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 void
+namelist_write_newline (st_parameter_dt *dtp)
+{
+  if (!is_internal_unit (dtp))
+    {
+#ifdef HAVE_CRLF
+      write_character (dtp, "\r\n", 1, 2);
+#else
+      write_character (dtp, "\n", 1, 1);
+#endif
+      return;
+    }
+
+  if (is_array_io (dtp))
+    {
+      gfc_offset record;
+      int finished;
+      char *p;
+      int length = dtp->u.p.current_unit->bytes_left;
+
+      p = write_block (dtp, length);
+      if (p == NULL)
+	return;
+
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;
+	  memset4 (p4, ' ', length);
+	}
+      else
+	memset (p, ' ', length);
+
+      /* 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,
+				  &finished);
+      if (finished)
+	dtp->u.p.current_unit->endfile = AT_ENDFILE;
+      else
+	{
+	  /* Now seek to this record */
+	  record = record * dtp->u.p.current_unit->recl;
+
+	  if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
+	    {
+	      generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
+	      return;
+	    }
+
+	  dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+	}
+    }
+  else
+    write_character (dtp, " ", 1, 1);
+}
+
+
+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;
+  int len;
+  index_type obj_size;
+  index_type nelem;
+  size_t dim_i;
+  size_t clen;
+  index_type elem_ctr;
+  size_t 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;
+  size_t base_name_len;
+  size_t base_var_name_len;
+  size_t tot_len;
+  unit_delim tmp_delim;
+  
+  /* Set the character to be used to separate values
+     to a comma or semi-colon.  */
+
+  char semi_comma =
+	dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
+
+  /* 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 != BT_DERIVED)
+    {
+      namelist_write_newline (dtp);
+      write_character (dtp, " ", 1, 1);
+
+      len = 0;
+      if (base)
+	{
+	  len = strlen (base->var_name);
+	  base_name_len = strlen (base_name);
+	  for (dim_i = 0; dim_i < base_name_len; dim_i++)
+            {
+	      cup = toupper ((int) base_name[dim_i]);
+	      write_character (dtp, &cup, 1, 1);
+            }
+	}
+      clen = strlen (obj->var_name);
+      for (dim_i = len; dim_i < clen; dim_i++)
+	{
+	  cup = toupper ((int) obj->var_name[dim_i]);
+	  write_character (dtp, &cup, 1, 1);
+	}
+      write_character (dtp, "=", 1, 1);
+    }
+
+  /* Counts the number of data output on a line, including names.  */
+
+  num = 1;
+
+  len = obj->len;
+
+  switch (obj->type)
+    {
+
+    case BT_REAL:
+      obj_size = size_from_real_kind (len);
+      break;
+
+    case BT_COMPLEX:
+      obj_size = size_from_complex_kind (len);
+      break;
+
+    case BT_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 < (size_t) obj->var_rank; dim_i++)
+    {
+      obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
+      nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
+    }
+
+  /* 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 != BT_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)
+	    {
+	      sprintf(rep_buff, " %d*", rep_ctr);
+	      write_character (dtp, rep_buff, 1, 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 BT_INTEGER:
+	      write_integer (dtp, p, len);
+              break;
+
+	    case BT_LOGICAL:
+	      write_logical (dtp, p, len);
+              break;
+
+	    case BT_CHARACTER:
+	      tmp_delim = dtp->u.p.current_unit->delim_status;
+	      if (dtp->u.p.nml_delim == '"')
+		dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
+	      if (dtp->u.p.nml_delim == '\'')
+		dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
+	      write_character (dtp, p, 1, obj->string_length);
+		dtp->u.p.current_unit->delim_status = tmp_delim;
+              break;
+
+	    case BT_REAL:
+	      write_real (dtp, p, len);
+              break;
+
+	   case BT_COMPLEX:
+	      dtp->u.p.no_leading_blank = 0;
+	      num++;
+              write_complex (dtp, p, len, obj_size);
+              break;
+
+	    case BT_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  */
+
+	      base_name_len = base_name ? strlen (base_name) : 0;
+	      base_var_name_len = base ? strlen (base->var_name) : 0;
+	      ext_name = (char*)get_mem ( base_name_len
+					+ base_var_name_len
+					+ strlen (obj->var_name)
+					+ obj->var_rank * NML_DIGITS
+					+ 1);
+
+	      memcpy (ext_name, base_name, base_name_len);
+	      clen = strlen (obj->var_name + base_var_name_len);
+	      memcpy (ext_name + base_name_len, 
+		      obj->var_name + base_var_name_len, clen);
+	      
+	      /* Append the qualifier.  */
+
+	      tot_len = base_name_len + clen;
+	      for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
+		{
+		  if (!dim_i)
+		    {
+		      ext_name[tot_len] = '(';
+		      tot_len++;
+		    }
+		  sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
+		  tot_len += strlen (ext_name + tot_len);
+		  ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
+		  tot_len++;
+		}
+
+	      ext_name[tot_len] = '\0';
+
+	      /* Now obj_name.  */
+
+	      obj_name_len = strlen (obj->var_name) + 1;
+	      obj_name = get_mem (obj_name_len+1);
+	      memcpy (obj_name, obj->var_name, obj_name_len-1);
+	      memcpy (obj_name + obj_name_len-1, "%", 2);
+
+	      /* 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 (obj_name);
+	      free (ext_name);
+	      goto obj_loop;
+
+            default:
+	      internal_error (&dtp->common, "Bad type for namelist write");
+            }
+
+	  /* Reset the leading blank suppression, write a comma (or semi-colon)
+	     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, &semi_comma, 1, 1);
+	  if (num > 5)
+	    {
+	      num = 0;
+	      namelist_write_newline (dtp);
+	      write_character (dtp, " ", 1, 1);
+	    }
+	  rep_ctr = 1;
+	}
+
+    /* Cycle through and increment the index vector.  */
+
+obj_loop:
+
+    nml_carry = 1;
+    for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
+      {
+	obj->ls[dim_i].idx += nml_carry ;
+	nml_carry = 0;
+ 	if (obj->ls[dim_i].idx  > (ssize_t) GFC_DESCRIPTOR_UBOUND(obj,dim_i))
+	  {
+ 	    obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
+	    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 = DELIM_UNSPECIFIED;
+
+  /* Set the delimiter for namelist output.  */
+  tmp_delim = dtp->u.p.current_unit->delim_status;
+
+  dtp->u.p.nml_delim = tmp_delim == DELIM_APOSTROPHE ? '\'' : '"';
+
+  /* Temporarily disable namelist delimters.  */
+  dtp->u.p.current_unit->delim_status = DELIM_NONE;
+
+  write_character (dtp, "&", 1, 1);
+
+  /* Write namelist name in upper case - f95 std.  */
+  for (i = 0 ;i < dtp->namelist_name_len ;i++ )
+    {
+      c = toupper ((int) dtp->namelist_name[i]);
+      write_character (dtp, &c, 1 ,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);
+	}
+    }
+
+  namelist_write_newline (dtp);
+  write_character (dtp, " /", 1, 2);
+  /* Restore the original delimiter.  */
+  dtp->u.p.current_unit->delim_status = tmp_delim;
+}
+
+#undef NML_DIGITS
diff --git a/gcc-4.6/libgfortran/io/write_float.def b/gcc-4.6/libgfortran/io/write_float.def
new file mode 100644
index 000000000..b72cf9f56
--- /dev/null
+++ b/gcc-4.6/libgfortran/io/write_float.def
@@ -0,0 +1,1087 @@
+/* Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   Write float code factoring to this file by Jerry DeLisle   
+   F2003 I/O support contributed by Jerry DeLisle
+
+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 3, 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.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+
+typedef enum
+{ S_NONE, S_MINUS, S_PLUS }
+sign_t;
+
+/* Given a flag that indicates 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 = S_NONE;
+
+  if (negative_flag)
+    s = S_MINUS;
+  else
+    switch (dtp->u.p.sign_status)
+      {
+      case SIGN_SP:	/* Show sign. */
+	s = S_PLUS;
+	break;
+      case SIGN_SS:	/* Suppress sign. */
+	s = S_NONE;
+	break;
+      case SIGN_S:	/* Processor defined. */
+      case SIGN_UNSPECIFIED:
+	s = options.optional_plus ? S_PLUS : S_NONE;
+	break;
+      }
+
+  return s;
+}
+
+
+/* Output a real number according to its format which is FMT_G free.  */
+
+static try
+output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, 
+	      int sign_bit, bool zero_flag, int ndigits, int edigits)
+{
+  char *out;
+  char *digits;
+  int e;
+  char expchar, rchar;
+  format_token ft;
+  int w;
+  int d;
+  /* 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;
+
+  rchar = '5';
+  nzero_real = -1;
+
+  /* We should always know the field width and precision.  */
+  if (d < 0)
+    internal_error (&dtp->common, "Unspecified precision");
+
+  sign = calculate_sign (dtp, sign_bit);
+  
+  /* The following code checks the given string has punctuation in the correct
+     places.  Uncomment if needed for debugging.
+     if (d != 0 && ((buffer[2] != '.' && 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 (zero_flag)
+    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:
+      if (d == 0 && e <= 0 && dtp->u.p.scale_factor == 0)
+	{
+	  memmove (digits + 1, digits, ndigits - 1);
+	  digits[0] = '0';
+	  e++;
+	}
+
+      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 (d <= 0 && i == 0)
+	{
+	  generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
+			  "greater than zero in format specifier 'E' or 'D'");
+	  return FAILURE;
+	}
+      if (i <= -d || i >= d + 2)
+	{
+	  generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
+			  "out of range in format specifier 'E' or 'D'");
+	  return FAILURE;
+	}
+
+      if (!zero_flag)
+	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 (!zero_flag)
+        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 (!zero_flag)
+        e--;
+      nbefore = 1;
+      nzero = 0;
+      nafter = d;
+      expchar = 'E';
+      break;
+
+    default:
+      /* Should never happen.  */
+      internal_error (&dtp->common, "Unexpected format token");
+    }
+
+  /* Round the value.  The value being rounded is an unsigned magnitude.
+     The ROUND_COMPATIBLE is rounding away from zero when there is a tie.  */
+  switch (dtp->u.p.current_unit->round_status)
+    {
+      case ROUND_ZERO: /* Do nothing and truncation occurs.  */
+	goto skip;
+      case ROUND_UP:
+	if (sign_bit)
+	  goto skip;
+	rchar = '0';
+	break;
+      case ROUND_DOWN:
+	if (!sign_bit)
+	  goto skip;
+	rchar = '0';
+	break;
+      case ROUND_NEAREST:
+	/* Round compatible unless there is a tie. A tie is a 5 with
+	   all trailing zero's.  */
+	i = nafter + nbefore;
+	if (digits[i] == '5')
+	  {
+	    for(i++ ; i < ndigits; i++)
+	      {
+		if (digits[i] != '0')
+		  goto do_rnd;
+	      }
+	    /* It is a  tie so round to even.  */
+	    switch (digits[nafter + nbefore - 1])
+	      {
+		case '1':
+		case '3':
+		case '5':
+		case '7':
+		case '9':
+		  /* If odd, round away from zero to even.  */
+		  break;
+		default:
+		  /* If even, skip rounding, truncate to even.  */
+		  goto skip;
+	      }
+	  }
+	 /* Fall through.  */ 
+      case ROUND_PROCDEFINED:
+      case ROUND_UNSPECIFIED:
+      case ROUND_COMPATIBLE:
+	rchar = '5';
+	/* Just fall through and do the actual rounding.  */
+    }
+    
+  do_rnd:
+ 
+  if (nbefore + nafter == 0)
+    {
+      ndigits = 0;
+      if (nzero_real == d && digits[0] >= rchar)
+	{
+	  /* 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] >= rchar)
+	{
+	  /* 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++;
+	    }
+	}
+    }
+
+  skip:
+
+  /* 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;
+
+  /* Scan the digits string and count the number of zeros.  If we make it
+     all the way through the loop, we know the value is zero after the
+     rounding completed above.  */
+  for (i = 0; i < ndigits; i++)
+    {
+      if (digits[i] != '0')
+	break;
+    }
+
+  /* To format properly, we need to know if the rounded result is zero and if
+     so, we set the zero_flag which may have been already set for
+     actual zero.  */
+  if (i == ndigits)
+    {
+      zero_flag = true;
+      /* The output is zero, so set the sign according to the sign bit unless
+	 -fno-sign-zero was specified.  */
+      if (compile_options.sign_zero == 1)
+        sign = calculate_sign (dtp, sign_bit);
+      else
+	sign = calculate_sign (dtp, 0);
+    }
+
+  /* Pick a field size if none was specified, taking into account small
+     values that may have been rounded to zero.  */
+  if (w <= 0)
+    {
+      if (zero_flag)
+	w = d + (sign != S_NONE ? 2 : 1) + (d == 0 ? 1 : 0);
+      else
+	{
+	  w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
+	  w = w == 1 ? 2 : w;
+	}
+    }
+  
+  /* Work out how much padding is needed.  */
+  nblanks = w - (nbefore + nzero + nafter + edigits + 1);
+  if (sign != S_NONE)
+    nblanks--;
+
+  if (dtp->u.p.g0_no_blanks)
+    {
+      w -= nblanks;
+      nblanks = 0;
+    }
+
+  /* Create the ouput buffer.  */
+  out = write_block (dtp, w);
+  if (out == NULL)
+    return FAILURE;
+
+  /* Check the value fits in the specified field width.  */
+  if (nblanks < 0 || edigits == -1 || w == 1 || (w == 2 && sign != S_NONE))
+    {
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t *out4 = (gfc_char4_t *) out;
+	  memset4 (out4, '*', w);
+	  return FAILURE;
+	}
+      star_fill (out, w);
+      return FAILURE;
+    }
+
+  /* See if we have space for a zero before the decimal point.  */
+  if (nbefore == 0 && nblanks > 0)
+    {
+      leadzero = 1;
+      nblanks--;
+    }
+  else
+    leadzero = 0;
+
+  /* For internal character(kind=4) units, we duplicate the code used for
+     regular output slightly modified.  This needs to be maintained
+     consistent with the regular code that follows this block.  */
+  if (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t *out4 = (gfc_char4_t *) out;
+      /* Pad to full field width.  */
+
+      if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
+	{
+	  memset4 (out4, ' ', nblanks);
+	  out4 += nblanks;
+	}
+
+      /* Output the initial sign (if any).  */
+      if (sign == S_PLUS)
+	*(out4++) = '+';
+      else if (sign == S_MINUS)
+	*(out4++) = '-';
+
+      /* Output an optional leading zero.  */
+      if (leadzero)
+	*(out4++) = '0';
+
+      /* Output the part before the decimal point, padding with zeros.  */
+      if (nbefore > 0)
+	{
+	  if (nbefore > ndigits)
+	    {
+	      i = ndigits;
+	      memcpy4 (out4, digits, i);
+	      ndigits = 0;
+	      while (i < nbefore)
+		out4[i++] = '0';
+	    }
+	  else
+	    {
+	      i = nbefore;
+	      memcpy4 (out4, digits, i);
+	      ndigits -= i;
+	    }
+
+	  digits += i;
+	  out4 += nbefore;
+	}
+
+      /* Output the decimal point.  */
+      *(out4++) = dtp->u.p.current_unit->decimal_status
+		    == DECIMAL_POINT ? '.' : ',';
+
+      /* Output leading zeros after the decimal point.  */
+      if (nzero > 0)
+	{
+	  for (i = 0; i < nzero; i++)
+	    *(out4++) = '0';
+	}
+
+      /* Output digits after the decimal point, padding with zeros.  */
+      if (nafter > 0)
+	{
+	  if (nafter > ndigits)
+	    i = ndigits;
+	  else
+	    i = nafter;
+
+	  memcpy4 (out4, digits, i);
+	  while (i < nafter)
+	    out4[i++] = '0';
+
+	  digits += i;
+	  ndigits -= i;
+	  out4 += nafter;
+	}
+
+      /* Output the exponent.  */
+      if (expchar)
+	{
+	  if (expchar != ' ')
+	    {
+	      *(out4++) = expchar;
+	      edigits--;
+	    }
+#if HAVE_SNPRINTF
+	  snprintf (buffer, size, "%+0*d", edigits, e);
+#else
+	  sprintf (buffer, "%+0*d", edigits, e);
+#endif
+	  memcpy4 (out4, buffer, edigits);
+	}
+
+      if (dtp->u.p.no_leading_blank)
+	{
+	  out4 += edigits;
+	  memset4 (out4, ' ' , nblanks);
+	  dtp->u.p.no_leading_blank = 0;
+	}
+      return SUCCESS;
+    } /* End of character(kind=4) internal unit code.  */
+
+  /* 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 == S_PLUS)
+    *(out++) = '+';
+  else if (sign == S_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;
+	  memcpy (out, digits, i);
+	  ndigits = 0;
+	  while (i < nbefore)
+	    out[i++] = '0';
+	}
+      else
+	{
+	  i = nbefore;
+	  memcpy (out, digits, i);
+	  ndigits -= i;
+	}
+
+      digits += i;
+      out += nbefore;
+    }
+
+  /* Output the decimal point.  */
+  *(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ',';
+
+  /* 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, size, "%+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
+  return SUCCESS;
+}
+
+
+/* Write "Infinite" or "Nan" as appropriate for the given format.  */
+
+static void
+write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit)
+{
+  char * p, fin;
+  int nb = 0;
+  sign_t sign;
+  int mark;
+
+  if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
+    {
+      sign = calculate_sign (dtp, sign_bit);
+      mark = (sign == S_PLUS || sign == S_MINUS) ? 8 : 7;
+
+      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)
+	{
+	  if (isnan_flag)
+	    nb = 3;
+	  else
+	    nb = (sign == S_PLUS || sign == S_MINUS) ? 4 : 3;
+	}
+      p = write_block (dtp, nb);
+      if (p == NULL)
+	return;
+      if (nb < 3)
+	{
+	  if (unlikely (is_char4_unit (dtp)))
+	    {
+	      gfc_char4_t *p4 = (gfc_char4_t *) p;
+	      memset4 (p4, '*', nb);
+	    }
+	  else
+	    memset (p, '*', nb);
+	  return;
+	}
+
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;
+	  memset4 (p4, ' ', nb);
+	}
+      else
+	memset(p, ' ', nb);
+
+      if (!isnan_flag)
+	{
+	  if (sign_bit)
+	    {
+	      /* If the sign is negative and the width is 3, there is
+		 insufficient room to output '-Inf', so output asterisks */
+	      if (nb == 3)
+		{
+		  if (unlikely (is_char4_unit (dtp)))
+		    {
+		      gfc_char4_t *p4 = (gfc_char4_t *) p;
+		      memset4 (p4, '*', nb);
+		    }
+		  else
+		    memset (p, '*', nb);
+		  return;
+		}
+	      /* The negative sign is mandatory */
+	      fin = '-';
+	    }    
+	  else
+	    /* The positive sign is optional, but we output it for
+	       consistency */
+	    fin = '+';
+	    
+	  if (unlikely (is_char4_unit (dtp)))
+	    {
+	      gfc_char4_t *p4 = (gfc_char4_t *) p;
+
+	      if (nb > mark)
+		/* We have room, so output 'Infinity' */
+		memcpy4 (p4 + nb - 8, "Infinity", 8);
+	      else
+		/* For the case of width equals mark, there is not enough room
+		   for the sign and 'Infinity' so we go with 'Inf' */
+		memcpy4 (p4 + nb - 3, "Inf", 3);
+
+	      if (sign == S_PLUS || sign == S_MINUS)
+		{
+		  if (nb < 9 && nb > 3)
+		    /* Put the sign in front of Inf */
+		    p4[nb - 4] = (gfc_char4_t) fin;
+		  else if (nb > 8)
+		    /* Put the sign in front of Infinity */
+		    p4[nb - 9] = (gfc_char4_t) fin;
+		}
+	      return;
+	    }
+
+	  if (nb > mark)
+	    /* 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 (sign == S_PLUS || sign == S_MINUS)
+	    {
+	      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
+        {
+	  if (unlikely (is_char4_unit (dtp)))
+	    {
+	      gfc_char4_t *p4 = (gfc_char4_t *) p;
+	      memcpy4 (p4 + nb - 3, "NaN", 3);
+	    }
+	  else
+	    memcpy(p + nb - 3, "NaN", 3);
+	}
+      return;
+    }
+}
+
+
+/* Returns the value of 10**d.  */
+
+#define CALCULATE_EXP(x) \
+inline static GFC_REAL_ ## x \
+calculate_exp_ ## x  (int d)\
+{\
+  int i;\
+  GFC_REAL_ ## x r = 1.0;\
+  for (i = 0; i< (d >= 0 ? d : -d); i++)\
+    r *= 10;\
+  r = (d >= 0) ? r : 1.0 / r;\
+  return r;\
+}
+
+CALCULATE_EXP(4)
+
+CALCULATE_EXP(8)
+
+#ifdef HAVE_GFC_REAL_10
+CALCULATE_EXP(10)
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+CALCULATE_EXP(16)
+#endif
+#undef CALCULATE_EXP
+
+/* Generate corresponding I/O format for FMT_G and 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  */
+
+#define OUTPUT_FLOAT_FMT_G(x) \
+static void \
+output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
+		      GFC_REAL_ ## x m, char *buffer, size_t size, \
+		      int sign_bit, bool zero_flag, int ndigits, int edigits) \
+{ \
+  int e = f->u.real.e;\
+  int d = f->u.real.d;\
+  int w = f->u.real.w;\
+  fnode *newf;\
+  GFC_REAL_ ## x rexp_d;\
+  int low, high, mid;\
+  int ubound, lbound;\
+  char *p, pad = ' ';\
+  int save_scale_factor, nb = 0;\
+  try result;\
+\
+  save_scale_factor = dtp->u.p.scale_factor;\
+  newf = (fnode *) get_mem (sizeof (fnode));\
+\
+  rexp_d = calculate_exp_ ## x (-d);\
+  if ((m > 0.0 && m < 0.1 - 0.05 * rexp_d) || (rexp_d * (m + 0.5) >= 1.0) ||\
+      ((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;\
+      nb = 0;\
+      goto finish;\
+    }\
+\
+  mid = 0;\
+  low = 0;\
+  high = d + 1;\
+  lbound = 0;\
+  ubound = d + 1;\
+\
+  while (low <= high)\
+    { \
+      GFC_REAL_ ## x temp;\
+      mid = (low + high) / 2;\
+\
+      temp = (calculate_exp_ ## x (mid - 1) * (1 - 0.5 * rexp_d));\
+\
+      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\
+	{\
+	  mid++;\
+	  break;\
+	}\
+    }\
+\
+  if (e > 4)\
+    e = 4;\
+  if (e < 0)\
+    nb = 4;\
+  else\
+    nb = e + 2;\
+\
+  nb = nb >= w ? 0 : nb;\
+  newf->format = FMT_F;\
+  newf->u.real.w = f->u.real.w - nb;\
+\
+  if (m == 0.0)\
+    newf->u.real.d = d - 1;\
+  else\
+    newf->u.real.d = - (mid - d - 1);\
+\
+  dtp->u.p.scale_factor = 0;\
+\
+ finish:\
+  result = output_float (dtp, newf, buffer, size, sign_bit, zero_flag, \
+			 ndigits, edigits);\
+  dtp->u.p.scale_factor = save_scale_factor;\
+\
+  free (newf);\
+\
+  if (nb > 0 && !dtp->u.p.g0_no_blanks)\
+    {\
+      p = write_block (dtp, nb);\
+      if (p == NULL)\
+	return;\
+      if (result == FAILURE)\
+        pad = '*';\
+      if (unlikely (is_char4_unit (dtp)))\
+	{\
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;\
+	  memset4 (p4, pad, nb);\
+	}\
+      else\
+	memset (p, pad, nb);\
+    }\
+}\
+
+OUTPUT_FLOAT_FMT_G(4)
+
+OUTPUT_FLOAT_FMT_G(8)
+
+#ifdef HAVE_GFC_REAL_10
+OUTPUT_FLOAT_FMT_G(10)
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+OUTPUT_FLOAT_FMT_G(16)
+#endif
+
+#undef OUTPUT_FLOAT_FMT_G
+
+
+/* Define a macro to build code for write_float.  */
+
+  /* Note: Before output_float is called, sprintf is used to print to buffer 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.
+
+     #   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.  */
+
+#ifdef HAVE_SNPRINTF
+
+#define DTOA \
+snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+	  "e", ndigits - 1, tmp);
+
+#define DTOAL \
+snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+	  "Le", ndigits - 1, tmp);
+
+#else
+
+#define DTOA \
+sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+	 "e", ndigits - 1, tmp);
+
+#define DTOAL \
+sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+	 "Le", ndigits - 1, tmp);
+
+#endif
+
+#if defined(GFC_REAL_16_IS_FLOAT128)
+#define DTOAQ \
+__qmath_(quadmath_snprintf) (buffer, sizeof buffer, \
+			     "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+			     "Qe", ndigits - 1, tmp);
+#endif
+
+#define WRITE_FLOAT(x,y)\
+{\
+	GFC_REAL_ ## x tmp;\
+	tmp = * (GFC_REAL_ ## x *)source;\
+	sign_bit = signbit (tmp);\
+	if (!isfinite (tmp))\
+	  { \
+	    write_infnan (dtp, f, isnan (tmp), sign_bit);\
+	    return;\
+	  }\
+	tmp = sign_bit ? -tmp : tmp;\
+	zero_flag = (tmp == 0.0);\
+\
+	DTOA ## y\
+\
+	if (f->format != FMT_G)\
+	  output_float (dtp, f, buffer, size, sign_bit, zero_flag, ndigits, \
+			edigits);\
+	else \
+	  output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
+				    zero_flag, ndigits, edigits);\
+}\
+
+/* Output a real number according to its format.  */
+
+static void
+write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+
+#if defined(HAVE_GFC_REAL_16) || __LDBL_DIG__ > 18
+# define MIN_FIELD_WIDTH 48
+#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];
+  int sign_bit, ndigits, edigits;
+  bool zero_flag;
+  size_t size;
+
+  size = MIN_FIELD_WIDTH+1;
+
+  /* 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 (f->format == FMT_F || f->format == FMT_EN || f->format == FMT_G 
+      || ((f->format == FMT_D || f->format == FMT_E)
+      && dtp->u.p.scale_factor != 0))
+    {
+      /* Always convert at full precision to avoid double rounding.  */
+      ndigits = MIN_FIELD_WIDTH - 4 - edigits;
+    }
+  else
+    {
+      /* The number of digits is known, so let printf do the rounding.  */
+      if (f->format == FMT_ES)
+	ndigits = f->u.real.d + 1;
+      else
+	ndigits = f->u.real.d;
+      if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
+	ndigits = MIN_FIELD_WIDTH - 4 - edigits;
+    }
+
+  switch (len)
+    {
+    case 4:
+      WRITE_FLOAT(4,)
+      break;
+
+    case 8:
+      WRITE_FLOAT(8,)
+      break;
+
+#ifdef HAVE_GFC_REAL_10
+    case 10:
+      WRITE_FLOAT(10,L)
+      break;
+#endif
+#ifdef HAVE_GFC_REAL_16
+    case 16:
+# ifdef GFC_REAL_16_IS_FLOAT128
+      WRITE_FLOAT(16,Q)
+# else
+      WRITE_FLOAT(16,L)
+# endif
+      break;
+#endif
+    default:
+      internal_error (NULL, "bad real kind");
+    }
+}