From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- libgfortran/io/close.c | 102 ++ libgfortran/io/fbuf.c | 270 +++ libgfortran/io/fbuf.h | 87 + libgfortran/io/file_pos.c | 463 +++++ libgfortran/io/format.c | 1402 +++++++++++++++ libgfortran/io/format.h | 145 ++ libgfortran/io/inquire.c | 708 ++++++++ libgfortran/io/intrinsics.c | 400 +++++ libgfortran/io/io.h | 809 +++++++++ libgfortran/io/list_read.c | 3077 ++++++++++++++++++++++++++++++++ libgfortran/io/lock.c | 67 + libgfortran/io/open.c | 866 +++++++++ libgfortran/io/read.c | 1179 ++++++++++++ libgfortran/io/size_from_kind.c | 83 + libgfortran/io/transfer.c | 3745 +++++++++++++++++++++++++++++++++++++++ libgfortran/io/transfer128.c | 98 + libgfortran/io/unit.c | 860 +++++++++ libgfortran/io/unix.c | 1891 ++++++++++++++++++++ libgfortran/io/unix.h | 192 ++ libgfortran/io/write.c | 1997 +++++++++++++++++++++ libgfortran/io/write_float.def | 1087 ++++++++++++ 21 files changed, 19528 insertions(+) create mode 100644 libgfortran/io/close.c create mode 100644 libgfortran/io/fbuf.c create mode 100644 libgfortran/io/fbuf.h create mode 100644 libgfortran/io/file_pos.c create mode 100644 libgfortran/io/format.c create mode 100644 libgfortran/io/format.h create mode 100644 libgfortran/io/inquire.c create mode 100644 libgfortran/io/intrinsics.c create mode 100644 libgfortran/io/io.h create mode 100644 libgfortran/io/list_read.c create mode 100644 libgfortran/io/lock.c create mode 100644 libgfortran/io/open.c create mode 100644 libgfortran/io/read.c create mode 100644 libgfortran/io/size_from_kind.c create mode 100644 libgfortran/io/transfer.c create mode 100644 libgfortran/io/transfer128.c create mode 100644 libgfortran/io/unit.c create mode 100644 libgfortran/io/unix.c create mode 100644 libgfortran/io/unix.h create mode 100644 libgfortran/io/write.c create mode 100644 libgfortran/io/write_float.def (limited to 'libgfortran/io') 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 +. */ + +#include "io.h" +#include "unix.h" +#include + +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 +. */ + + +#include "io.h" +#include "fbuf.h" +#include "unix.h" +#include +#include + + +//#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 +. */ + +#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 +. */ + +#include "io.h" +#include "fbuf.h" +#include "unix.h" +#include + +/* 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 +. */ + + +/* format.c-- parse a FORMAT string into a binary format suitable for + * interpretation during I/O statements */ + +#include "io.h" +#include "format.h" +#include +#include +#include +#include + + +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 +. */ + +#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 +. */ + + +/* Implement the non-IOLENGTH variant of the INQUIRY statement */ + +#include "io.h" +#include "unix.h" +#include + + +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 +. */ + +#include "io.h" +#include "fbuf.h" +#include "unix.h" + +#ifdef HAVE_STDLIB_H +#include +#endif + +#include + +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 +. */ + +#ifndef GFOR_IO_H +#define GFOR_IO_H + +/* IO library include. */ + +#include "libgfortran.h" + +#include + +/* 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 +. */ + + +#include "io.h" +#include "fbuf.h" +#include "unix.h" +#include +#include +#include + + +/* 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 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 +. */ + +#include "io.h" +#include +#include + +/* 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 +. */ + +#include "io.h" +#include "fbuf.h" +#include "unix.h" +#include +#include +#include +#include + + +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 +. */ + +#include "io.h" +#include "fbuf.h" +#include "format.h" +#include "unix.h" +#include +#include +#include +#include +#include + +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 +. */ + + +/* 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 +. */ + + +/* transfer.c -- Top level handling of data transfer statements. */ + +#include "io.h" +#include "fbuf.h" +#include "format.h" +#include "unix.h" +#include +#include +#include +#include + + +/* 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 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; iu.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 +. */ + +/* 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 +. */ + +#include "io.h" +#include "fbuf.h" +#include "format.h" +#include "unix.h" +#include +#include + + +/* 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 +. */ + +/* Unix stream I/O module */ + +#include "io.h" +#include "unix.h" +#include +#include + +#include +#include +#include +#include + +#include +#include + + +/* 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 + +#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 +. */ + +#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 +. */ + +#include "io.h" +#include "format.h" +#include "unix.h" +#include +#include +#include +#include +#include +#include +#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 . 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 +. */ + +#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"); + } +} -- cgit v1.2.3