summaryrefslogtreecommitdiff
path: root/libgfortran/io
diff options
context:
space:
mode:
Diffstat (limited to 'libgfortran/io')
-rw-r--r--libgfortran/io/close.c102
-rw-r--r--libgfortran/io/fbuf.c270
-rw-r--r--libgfortran/io/fbuf.h87
-rw-r--r--libgfortran/io/file_pos.c463
-rw-r--r--libgfortran/io/format.c1402
-rw-r--r--libgfortran/io/format.h145
-rw-r--r--libgfortran/io/inquire.c708
-rw-r--r--libgfortran/io/intrinsics.c400
-rw-r--r--libgfortran/io/io.h809
-rw-r--r--libgfortran/io/list_read.c3077
-rw-r--r--libgfortran/io/lock.c67
-rw-r--r--libgfortran/io/open.c866
-rw-r--r--libgfortran/io/read.c1179
-rw-r--r--libgfortran/io/size_from_kind.c83
-rw-r--r--libgfortran/io/transfer.c3745
-rw-r--r--libgfortran/io/transfer128.c98
-rw-r--r--libgfortran/io/unit.c860
-rw-r--r--libgfortran/io/unix.c1891
-rw-r--r--libgfortran/io/unix.h192
-rw-r--r--libgfortran/io/write.c1997
-rw-r--r--libgfortran/io/write_float.def1087
21 files changed, 19528 insertions, 0 deletions
diff --git a/libgfortran/io/close.c b/libgfortran/io/close.c
new file mode 100644
index 000000000..1a4d7d16e
--- /dev/null
+++ b/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/libgfortran/io/fbuf.c b/libgfortran/io/fbuf.c
new file mode 100644
index 000000000..82b3f6ba6
--- /dev/null
+++ b/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/libgfortran/io/fbuf.h b/libgfortran/io/fbuf.h
new file mode 100644
index 000000000..3a2883bc5
--- /dev/null
+++ b/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/libgfortran/io/file_pos.c b/libgfortran/io/file_pos.c
new file mode 100644
index 000000000..da83aa594
--- /dev/null
+++ b/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);
+
+ flush_sync (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/libgfortran/io/format.c b/libgfortran/io/format.c
new file mode 100644
index 000000000..17b58126b
--- /dev/null
+++ b/libgfortran/io/format.c
@@ -0,0 +1,1402 @@
+/* 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 = dtp->format;
+
+ 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 *seen_dd)
+{
+ fnode *head, *tail;
+ format_token t, u, t2;
+ int repeat;
+ format_data *fmt = dtp->u.p.fmt;
+ bool seen_data_desc = false;
+
+ head = tail = NULL;
+
+ /* 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, &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, &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, &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:
+ 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:
+
+ 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. */
+
+ if (format_cache_ok)
+ {
+ char *fmt_string = get_mem (dtp->format_len);
+ memcpy (fmt_string, dtp->format, dtp->format_len);
+ dtp->format = fmt_string;
+ }
+
+ 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, &seen_data_desc);
+ else
+ fmt->error = "Missing initial left parenthesis in format";
+
+ if (fmt->error)
+ {
+ format_error (dtp, NULL, fmt->error);
+ if (format_cache_ok)
+ free (dtp->format);
+ 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/libgfortran/io/format.h b/libgfortran/io/format.h
new file mode 100644
index 000000000..87d86419b
--- /dev/null
+++ b/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/libgfortran/io/inquire.c b/libgfortran/io/inquire.c
new file mode 100644
index 000000000..97bd9b638
--- /dev/null
+++ b/libgfortran/io/inquire.c
@@ -0,0 +1,708 @@
+/* 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
+ {
+ sflush (u->s);
+ *iqp->size = file_length (u->s);
+ }
+ }
+ }
+
+ 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/libgfortran/io/intrinsics.c b/libgfortran/io/intrinsics.c
new file mode 100644
index 000000000..2d00a6649
--- /dev/null
+++ b/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)
+ {
+ flush_sync (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)
+ {
+ flush_sync (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/libgfortran/io/io.h b/libgfortran/io/io.h
new file mode 100644
index 000000000..ebe7f7cc1
--- /dev/null
+++ b/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/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
new file mode 100644
index 000000000..198f9a702
--- /dev/null
+++ b/libgfortran/io/list_read.c
@@ -0,0 +1,3077 @@
+/* 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;
+ c = '\n';
+ }
+ }
+ 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->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 = 2;
+ static const char endl[] = "\r\n";
+ static const char nmlend[] = "&end\r\n";
+#else
+ static const index_type endlen = 1;
+ 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 - 1 + endlen);
+ if (!p)
+ goto query_return;
+ memcpy (p, "&", 1);
+ memcpy ((char*)(p + 1), dtp->namelist_name, len);
+ memcpy ((char*)(p + len + 1), &endl, endlen);
+ 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);
+ }
+
+ /* "&end\n" */
+
+ p = write_block (dtp, endlen + 4);
+ if (!p)
+ goto query_return;
+ memcpy (p, &nmlend, endlen + 4);
+ }
+
+ /* 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, '?');
+ goto find_nml_name;
+
+ 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/libgfortran/io/lock.c b/libgfortran/io/lock.c
new file mode 100644
index 000000000..9e7e9513e
--- /dev/null
+++ b/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/libgfortran/io/open.c b/libgfortran/io/open.c
new file mode 100644
index 000000000..d7448c007
--- /dev/null
+++ b/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/libgfortran/io/read.c b/libgfortran/io/read.c
new file mode 100644
index 000000000..4eda4a2f8
--- /dev/null
+++ b/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/libgfortran/io/size_from_kind.c b/libgfortran/io/size_from_kind.c
new file mode 100644
index 000000000..d467df015
--- /dev/null
+++ b/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/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
new file mode 100644
index 000000000..15f90e767
--- /dev/null
+++ b/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/libgfortran/io/transfer128.c b/libgfortran/io/transfer128.c
new file mode 100644
index 000000000..d94ccacc0
--- /dev/null
+++ b/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/libgfortran/io/unit.c b/libgfortran/io/unit.c
new file mode 100644
index 000000000..1d5221726
--- /dev/null
+++ b/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/libgfortran/io/unix.c b/libgfortran/io/unix.c
new file mode 100644
index 000000000..26bb06a09
--- /dev/null
+++ b/libgfortran/io/unix.c
@@ -0,0 +1,1891 @@
+/* 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;
+
+ 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;
+}
+
+
+/* Flush dirty data, making sure that OS metadata is updated as
+ well. Note that this is VERY slow on mingw due to committing data
+ to stable storage. */
+int
+flush_sync (stream * s)
+{
+ if (sflush (s) == -1)
+ return -1;
+#ifdef __MINGW32__
+ if (_commit (((unix_stream *)s)->fd) == -1)
+ return -1;
+#endif
+ return 0;
+}
+
+
+static gfc_unit *
+flush_all_units_1 (gfc_unit *u, int min_unit)
+{
+ while (u != NULL)
+ {
+ if (u->unit_number > min_unit)
+ {
+ gfc_unit *r = flush_all_units_1 (u->left, min_unit);
+ if (r != NULL)
+ return r;
+ }
+ if (u->unit_number >= min_unit)
+ {
+ if (__gthread_mutex_trylock (&u->lock))
+ return u;
+ if (u->s)
+ flush_sync (u->s);
+ __gthread_mutex_unlock (&u->lock);
+ }
+ u = u->right;
+ }
+ return NULL;
+}
+
+void
+flush_all_units (void)
+{
+ gfc_unit *u;
+ int min_unit = 0;
+
+ __gthread_mutex_lock (&unit_lock);
+ do
+ {
+ u = flush_all_units_1 (unit_root, min_unit);
+ if (u != NULL)
+ inc_waiting_locked (u);
+ __gthread_mutex_unlock (&unit_lock);
+ if (u == NULL)
+ return;
+
+ __gthread_mutex_lock (&u->lock);
+
+ min_unit = u->unit_number + 1;
+
+ if (u->closed == 0)
+ {
+ flush_sync (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/libgfortran/io/unix.h b/libgfortran/io/unix.h
new file mode 100644
index 000000000..5e42268e6
--- /dev/null
+++ b/libgfortran/io/unix.h
@@ -0,0 +1,192 @@
+/* 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 flush_sync (stream *);
+internal_proto(flush_sync);
+
+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/libgfortran/io/write.c b/libgfortran/io/write.c
new file mode 100644
index 000000000..987c3cd88
--- /dev/null
+++ b/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/libgfortran/io/write_float.def b/libgfortran/io/write_float.def
new file mode 100644
index 000000000..b72cf9f56
--- /dev/null
+++ b/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");
+ }
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 06:30:15 +0000