diff options
Diffstat (limited to 'gcc-4.8.1/libgfortran/io')
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/close.c | 102 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/fbuf.c | 269 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/fbuf.h | 86 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/file_pos.c | 463 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/format.c | 1401 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/format.h | 144 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/inquire.c | 743 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/intrinsics.c | 416 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/io.h | 811 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/list_read.c | 3155 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/lock.c | 66 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/open.c | 868 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/read.c | 1248 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/size_from_kind.c | 83 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/transfer.c | 3865 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/transfer128.c | 97 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/unit.c | 838 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/unix.c | 1884 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/unix.h | 189 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/write.c | 2006 | ||||
| -rw-r--r-- | gcc-4.8.1/libgfortran/io/write_float.def | 1268 |
21 files changed, 0 insertions, 20002 deletions
diff --git a/gcc-4.8.1/libgfortran/io/close.c b/gcc-4.8.1/libgfortran/io/close.c deleted file mode 100644 index fa9c1137f..000000000 --- a/gcc-4.8.1/libgfortran/io/close.c +++ /dev/null @@ -1,102 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of the GNU Fortran 95 runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "io.h" -#include "unix.h" -#include <limits.h> - -typedef enum -{ CLOSE_DELETE, CLOSE_KEEP, CLOSE_UNSPECIFIED } -close_status; - -static const st_option status_opt[] = { - {"keep", CLOSE_KEEP}, - {"delete", CLOSE_DELETE}, - {NULL, 0} -}; - - -extern void st_close (st_parameter_close *); -export_proto(st_close); - -void -st_close (st_parameter_close *clp) -{ - close_status status; - gfc_unit *u; -#if !HAVE_UNLINK_OPEN_FILE - char * path; - - path = NULL; -#endif - - library_start (&clp->common); - - status = !(clp->common.flags & IOPARM_CLOSE_HAS_STATUS) ? CLOSE_UNSPECIFIED : - find_option (&clp->common, clp->status, clp->status_len, - status_opt, "Bad STATUS parameter in CLOSE statement"); - - if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) - { - library_end (); - return; - } - - u = find_unit (clp->common.unit); - if (u != NULL) - { - if (u->flags.status == STATUS_SCRATCH) - { - if (status == CLOSE_KEEP) - generate_error (&clp->common, LIBERROR_BAD_OPTION, - "Can't KEEP a scratch file on CLOSE"); -#if !HAVE_UNLINK_OPEN_FILE - path = (char *) gfc_alloca (u->file_len + 1); - unpack_filename (path, u->file, u->file_len); -#endif - } - else - { - if (status == CLOSE_DELETE) - { -#if HAVE_UNLINK_OPEN_FILE - delete_file (u); -#else - path = (char *) gfc_alloca (u->file_len + 1); - unpack_filename (path, u->file, u->file_len); -#endif - } - } - - close_unit (u); - -#if !HAVE_UNLINK_OPEN_FILE - if (path != NULL) - unlink (path); -#endif - } - - /* CLOSE on unconnected unit is legal and a no-op: F95 std., 9.3.5. */ - library_end (); -} diff --git a/gcc-4.8.1/libgfortran/io/fbuf.c b/gcc-4.8.1/libgfortran/io/fbuf.c deleted file mode 100644 index ace990db8..000000000 --- a/gcc-4.8.1/libgfortran/io/fbuf.c +++ /dev/null @@ -1,269 +0,0 @@ -/* Copyright (C) 2008-2013 Free Software Foundation, Inc. - Contributed by Janne Blomqvist - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - - -#include "io.h" -#include "fbuf.h" -#include "unix.h" -#include <string.h> -#include <stdlib.h> - - -//#define FBUF_DEBUG - - -void -fbuf_init (gfc_unit * u, int len) -{ - if (len == 0) - len = 512; /* Default size. */ - - u->fbuf = xmalloc (sizeof (struct fbuf)); - u->fbuf->buf = xmalloc (len); - u->fbuf->len = len; - u->fbuf->act = u->fbuf->pos = 0; -} - - -void -fbuf_destroy (gfc_unit * u) -{ - if (u->fbuf == NULL) - return; - free (u->fbuf->buf); - free (u->fbuf); - u->fbuf = NULL; -} - - -static void -#ifdef FBUF_DEBUG -fbuf_debug (gfc_unit * u, const char * format, ...) -{ - va_list args; - va_start(args, format); - vfprintf(stderr, format, args); - va_end(args); - fprintf (stderr, "fbuf_debug pos: %d, act: %d, buf: ''", - u->fbuf->pos, u->fbuf->act); - for (int ii = 0; ii < u->fbuf->act; ii++) - { - putc (u->fbuf->buf[ii], stderr); - } - fprintf (stderr, "''\n"); -} -#else -fbuf_debug (gfc_unit * u __attribute__ ((unused)), - const char * format __attribute__ ((unused)), - ...) {} -#endif - - - -/* You should probably call this before doing a physical seek on the - underlying device. Returns how much the physical position was - modified. */ - -int -fbuf_reset (gfc_unit * u) -{ - int seekval = 0; - - if (!u->fbuf) - return 0; - - fbuf_debug (u, "fbuf_reset: "); - fbuf_flush (u, u->mode); - /* If we read past the current position, seek the underlying device - back. */ - if (u->mode == READING && u->fbuf->act > u->fbuf->pos) - { - seekval = - (u->fbuf->act - u->fbuf->pos); - fbuf_debug (u, "fbuf_reset seekval %d, ", seekval); - } - u->fbuf->act = u->fbuf->pos = 0; - return seekval; -} - - -/* Return a pointer to the current position in the buffer, and increase - the pointer by len. Makes sure that the buffer is big enough, - reallocating if necessary. */ - -char * -fbuf_alloc (gfc_unit * u, int len) -{ - int newlen; - char *dest; - fbuf_debug (u, "fbuf_alloc len %d, ", len); - if (u->fbuf->pos + len > u->fbuf->len) - { - /* Round up to nearest multiple of the current buffer length. */ - newlen = ((u->fbuf->pos + len) / u->fbuf->len + 1) * u->fbuf->len; - dest = realloc (u->fbuf->buf, newlen); - if (dest == NULL) - return NULL; - u->fbuf->buf = dest; - u->fbuf->len = newlen; - } - - dest = u->fbuf->buf + u->fbuf->pos; - u->fbuf->pos += len; - if (u->fbuf->pos > u->fbuf->act) - u->fbuf->act = u->fbuf->pos; - return dest; -} - - -/* mode argument is WRITING for write mode and READING for read - mode. Return value is 0 for success, -1 on failure. */ - -int -fbuf_flush (gfc_unit * u, unit_mode mode) -{ - int nwritten; - - if (!u->fbuf) - return 0; - - fbuf_debug (u, "fbuf_flush with mode %d: ", mode); - - if (mode == WRITING) - { - if (u->fbuf->pos > 0) - { - nwritten = swrite (u->s, u->fbuf->buf, u->fbuf->pos); - if (nwritten < 0) - return -1; - } - } - /* Salvage remaining bytes for both reading and writing. This - happens with the combination of advance='no' and T edit - descriptors leaving the final position somewhere not at the end - of the record. For reading, this also happens if we sread() past - the record boundary. */ - if (u->fbuf->act > u->fbuf->pos && u->fbuf->pos > 0) - memmove (u->fbuf->buf, u->fbuf->buf + u->fbuf->pos, - u->fbuf->act - u->fbuf->pos); - - u->fbuf->act -= u->fbuf->pos; - u->fbuf->pos = 0; - - return 0; -} - - -int -fbuf_seek (gfc_unit * u, int off, int whence) -{ - if (!u->fbuf) - return -1; - - switch (whence) - { - case SEEK_SET: - break; - case SEEK_CUR: - off += u->fbuf->pos; - break; - case SEEK_END: - off += u->fbuf->act; - break; - default: - return -1; - } - - fbuf_debug (u, "fbuf_seek, off %d ", off); - /* The start of the buffer is always equal to the left tab - limit. Moving to the left past the buffer is illegal in C and - would also imply moving past the left tab limit, which is never - allowed in Fortran. Similarly, seeking past the end of the buffer - is not possible, in that case the user must make sure to allocate - space with fbuf_alloc(). So return error if that is - attempted. */ - if (off < 0 || off > u->fbuf->act) - return -1; - u->fbuf->pos = off; - return off; -} - - -/* Fill the buffer with bytes for reading. Returns a pointer to start - reading from. If we hit EOF, returns a short read count. If any - other error occurs, return NULL. After reading, the caller is - expected to call fbuf_seek to update the position with the number - of bytes actually processed. */ - -char * -fbuf_read (gfc_unit * u, int * len) -{ - char *ptr; - int oldact, oldpos; - int readlen = 0; - - fbuf_debug (u, "fbuf_read, len %d: ", *len); - oldact = u->fbuf->act; - oldpos = u->fbuf->pos; - ptr = fbuf_alloc (u, *len); - u->fbuf->pos = oldpos; - if (oldpos + *len > oldact) - { - fbuf_debug (u, "reading %d bytes starting at %d ", - oldpos + *len - oldact, oldact); - readlen = sread (u->s, u->fbuf->buf + oldact, oldpos + *len - oldact); - if (readlen < 0) - return NULL; - *len = oldact - oldpos + readlen; - } - u->fbuf->act = oldact + readlen; - fbuf_debug (u, "fbuf_read done: "); - return ptr; -} - - -/* When the fbuf_getc() inline function runs out of buffer space, it - calls this function to fill the buffer with bytes for - reading. Never call this function directly. */ - -int -fbuf_getc_refill (gfc_unit * u) -{ - int nread; - char *p; - - fbuf_debug (u, "fbuf_getc_refill "); - - /* Read 80 bytes (average line length?). This is a compromise - between not needing to call the read() syscall all the time and - not having to memmove unnecessary stuff when switching to the - next record. */ - nread = 80; - - p = fbuf_read (u, &nread); - - if (p && nread > 0) - return (unsigned char) u->fbuf->buf[u->fbuf->pos++]; - else - return EOF; -} diff --git a/gcc-4.8.1/libgfortran/io/fbuf.h b/gcc-4.8.1/libgfortran/io/fbuf.h deleted file mode 100644 index d125a2cf6..000000000 --- a/gcc-4.8.1/libgfortran/io/fbuf.h +++ /dev/null @@ -1,86 +0,0 @@ -/* Copyright (C) 2009-2013 Free Software Foundation, Inc. - Contributed by Janne Blomqvist - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#ifndef GFOR_FBUF_H -#define GFOR_FBUF_H - -#include "io.h" - - -/* Formatting buffer. This is a temporary scratch buffer used by - formatted read and writes. After every formatted I/O statement, - this buffer is flushed. This buffer is needed since not all devices - are seekable, and T or TL edit descriptors require moving backwards - in the record. However, advance='no' complicates the situation, so - the buffer must only be partially flushed from the end of the last - flush until the current position in the record. */ - -struct fbuf -{ - char *buf; /* Start of buffer. */ - int len; /* Length of buffer. */ - int act; /* Active bytes in buffer. */ - int pos; /* Current position in buffer. */ -}; - -extern void fbuf_init (gfc_unit *, int); -internal_proto(fbuf_init); - -extern void fbuf_destroy (gfc_unit *); -internal_proto(fbuf_destroy); - -extern int fbuf_reset (gfc_unit *); -internal_proto(fbuf_reset); - -extern char * fbuf_alloc (gfc_unit *, int); -internal_proto(fbuf_alloc); - -extern int fbuf_flush (gfc_unit *, unit_mode); -internal_proto(fbuf_flush); - -extern int fbuf_seek (gfc_unit *, int, int); -internal_proto(fbuf_seek); - -extern char * fbuf_read (gfc_unit *, int *); -internal_proto(fbuf_read); - -/* Never call this function, only use fbuf_getc(). */ -extern int fbuf_getc_refill (gfc_unit *); -internal_proto(fbuf_getc_refill); - -static inline int -fbuf_getc (gfc_unit * u) -{ - if (u->fbuf->pos < u->fbuf->act) - return (unsigned char) u->fbuf->buf[u->fbuf->pos++]; - return fbuf_getc_refill (u); -} - -static inline char * -fbuf_getptr (gfc_unit * u) -{ - return (char*) (u->fbuf->buf + u->fbuf->pos); -} - -#endif diff --git a/gcc-4.8.1/libgfortran/io/file_pos.c b/gcc-4.8.1/libgfortran/io/file_pos.c deleted file mode 100644 index 8b4fda3dd..000000000 --- a/gcc-4.8.1/libgfortran/io/file_pos.c +++ /dev/null @@ -1,463 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught and Janne Blomqvist - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "io.h" -#include "fbuf.h" -#include "unix.h" -#include <string.h> - -/* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE, - ENDFILE, and REWIND as well as the FLUSH statement. */ - - -/* formatted_backspace(fpp, u)-- Move the file back one line. The - current position is after the newline that terminates the previous - record, and we have to sift backwards to find the newline before - that or the start of the file, whichever comes first. */ - -static const int READ_CHUNK = 4096; - -static void -formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u) -{ - gfc_offset base; - char p[READ_CHUNK]; - ssize_t n; - - base = stell (u->s) - 1; - - do - { - n = (base < READ_CHUNK) ? base : READ_CHUNK; - base -= n; - if (sseek (u->s, base, SEEK_SET) < 0) - goto io_error; - if (sread (u->s, p, n) != n) - goto io_error; - - /* We have moved backwards from the current position, it should - not be possible to get a short read. Because it is not - clear what to do about such thing, we ignore the possibility. */ - - /* There is no memrchr() in the C library, so we have to do it - ourselves. */ - - while (n > 0) - { - n--; - if (p[n] == '\n') - { - base += n + 1; - goto done; - } - } - - } - while (base != 0); - - /* base is the new pointer. Seek to it exactly. */ - done: - if (sseek (u->s, base, SEEK_SET) < 0) - goto io_error; - u->last_record--; - u->endfile = NO_ENDFILE; - - return; - - io_error: - generate_error (&fpp->common, LIBERROR_OS, NULL); -} - - -/* unformatted_backspace(fpp) -- Move the file backwards for an unformatted - sequential file. We are guaranteed to be between records on entry and - we have to shift to the previous record. Loop over subrecords. */ - -static void -unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u) -{ - gfc_offset m, slen; - GFC_INTEGER_4 m4; - GFC_INTEGER_8 m8; - ssize_t length; - int continued; - char p[sizeof (GFC_INTEGER_8)]; - - if (compile_options.record_marker == 0) - length = sizeof (GFC_INTEGER_4); - else - length = compile_options.record_marker; - - do - { - slen = - (gfc_offset) length; - if (sseek (u->s, slen, SEEK_CUR) < 0) - goto io_error; - if (sread (u->s, p, length) != length) - goto io_error; - - /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */ - if (likely (u->flags.convert == GFC_CONVERT_NATIVE)) - { - switch (length) - { - case sizeof(GFC_INTEGER_4): - memcpy (&m4, p, sizeof (m4)); - m = m4; - break; - - case sizeof(GFC_INTEGER_8): - memcpy (&m8, p, sizeof (m8)); - m = m8; - break; - - default: - runtime_error ("Illegal value for record marker"); - break; - } - } - else - { - uint32_t u32; - uint64_t u64; - switch (length) - { - case sizeof(GFC_INTEGER_4): - memcpy (&u32, p, sizeof (u32)); - u32 = __builtin_bswap32 (u32); - memcpy (&m4, &u32, sizeof (m4)); - m = m4; - break; - - case sizeof(GFC_INTEGER_8): - memcpy (&u64, p, sizeof (u64)); - u64 = __builtin_bswap64 (u64); - memcpy (&m8, &u64, 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); - - /* Set this for compatibilty with g77 for /dev/null. */ - if (ssize (u->s) == 0) - u->endfile = AT_ENDFILE; - else - { - /* We are rewinding so we are not at the end. */ - u->endfile = NO_ENDFILE; - } - - u->current_record = 0; - u->strm_pos = 1; - u->read_bad = 0; - } - /* Update position for INQUIRE. */ - u->flags.position = POSITION_REWIND; - unlock_unit (u); - } - - library_end (); -} - - -extern void st_flush (st_parameter_filepos *); -export_proto(st_flush); - -void -st_flush (st_parameter_filepos *fpp) -{ - gfc_unit *u; - - library_start (&fpp->common); - - u = find_unit (fpp->common.unit); - if (u != NULL) - { - /* Make sure format buffer is flushed. */ - if (u->flags.form == FORM_FORMATTED) - fbuf_flush (u, u->mode); - - sflush (u->s); - unlock_unit (u); - } - else - /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */ - generate_error (&fpp->common, LIBERROR_BAD_OPTION, - "Specified UNIT in FLUSH is not connected"); - - library_end (); -} diff --git a/gcc-4.8.1/libgfortran/io/format.c b/gcc-4.8.1/libgfortran/io/format.c deleted file mode 100644 index 3c685e34e..000000000 --- a/gcc-4.8.1/libgfortran/io/format.c +++ /dev/null @@ -1,1401 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - F2003 I/O support contributed by Jerry DeLisle - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - - -/* format.c-- parse a FORMAT string into a binary format suitable for - * interpretation during I/O statements */ - -#include "io.h" -#include "format.h" -#include <ctype.h> -#include <string.h> -#include <stdbool.h> -#include <stdlib.h> - - -static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0, - NULL }; - -/* Error messages. */ - -static const char posint_required[] = "Positive width required in format", - period_required[] = "Period required in format", - nonneg_required[] = "Nonnegative width required in format", - unexpected_element[] = "Unexpected element '%c' in format\n", - unexpected_end[] = "Unexpected end of format string", - bad_string[] = "Unterminated character constant in format", - bad_hollerith[] = "Hollerith constant extends past the end of the format", - reversion_error[] = "Exhausted data descriptors in format", - zero_width[] = "Zero width in format descriptor"; - -/* The following routines support caching format data from parsed format strings - into a hash table. This avoids repeatedly parsing duplicate format strings - or format strings in I/O statements that are repeated in loops. */ - - -/* Traverse the table and free all data. */ - -void -free_format_hash_table (gfc_unit *u) -{ - size_t i; - - /* free_format_data handles any NULL pointers. */ - for (i = 0; i < FORMAT_HASH_SIZE; i++) - { - if (u->format_hash_table[i].hashed_fmt != NULL) - { - free_format_data (u->format_hash_table[i].hashed_fmt); - free (u->format_hash_table[i].key); - } - u->format_hash_table[i].key = NULL; - u->format_hash_table[i].key_len = 0; - u->format_hash_table[i].hashed_fmt = NULL; - } -} - -/* Traverse the format_data structure and reset the fnode counters. */ - -static void -reset_node (fnode *fn) -{ - fnode *f; - - fn->count = 0; - fn->current = NULL; - - if (fn->format != FMT_LPAREN) - return; - - for (f = fn->u.child; f; f = f->next) - { - if (f->format == FMT_RPAREN) - break; - reset_node (f); - } -} - -static void -reset_fnode_counters (st_parameter_dt *dtp) -{ - fnode *f; - format_data *fmt; - - fmt = dtp->u.p.fmt; - - /* Clear this pointer at the head so things start at the right place. */ - fmt->array.array[0].current = NULL; - - for (f = fmt->array.array[0].u.child; f; f = f->next) - reset_node (f); -} - - -/* A simple hashing function to generate an index into the hash table. */ - -static 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; - - 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 = xmalloc (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; -#define BUFLEN 300 - char *p, buffer[BUFLEN]; - format_data *fmt = dtp->u.p.fmt; - - if (f != NULL) - fmt->format_string = f->source; - - if (message == unexpected_element) - snprintf (buffer, BUFLEN, message, fmt->error_element); - else - snprintf (buffer, BUFLEN, "%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 = xmalloc (dtp->format_len); - memcpy (fmt_string, dtp->format, dtp->format_len); - dtp->format = fmt_string; - } - - dtp->u.p.fmt = fmt = xmalloc (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/gcc-4.8.1/libgfortran/io/format.h b/gcc-4.8.1/libgfortran/io/format.h deleted file mode 100644 index 529b93e98..000000000 --- a/gcc-4.8.1/libgfortran/io/format.h +++ /dev/null @@ -1,144 +0,0 @@ -/* Copyright (C) 2009-2013 Free Software Foundation, Inc. - Contributed by Janne Blomqvist - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#ifndef GFOR_FORMAT_H -#define GFOR_FORMAT_H - -#include "io.h" - - -/* Format tokens. Only about half of these can be stored in the - format nodes. */ - -typedef enum -{ - FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, - FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL, - FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING, - FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F, - FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC, - FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ -} -format_token; - - -/* Format nodes. A format string is converted into a tree of these - structures, which is traversed as part of a data transfer statement. */ - -struct fnode -{ - format_token format; - int repeat; - struct fnode *next; - char *source; - - union - { - struct - { - int w, d, e; - } - real; - - struct - { - int length; - char *p; - } - string; - - struct - { - int w, m; - } - integer; - - int w; - int k; - int r; - int n; - - struct fnode *child; - } - u; - - /* Members for traversing the tree during data transfer. */ - - int count; - struct fnode *current; - -}; - - -/* A storage structures for format node data. */ - -#define FARRAY_SIZE 64 - -typedef struct fnode_array -{ - struct fnode_array *next; - fnode array[FARRAY_SIZE]; -} -fnode_array; - - -typedef struct format_data -{ - char *format_string, *string; - const char *error; - char error_element; - format_token saved_token; - int value, format_string_len, reversion_ok; - fnode *avail; - const fnode *saved_format; - fnode_array *last; - fnode_array array; -} -format_data; - -extern void parse_format (st_parameter_dt *); -internal_proto(parse_format); - -extern const fnode *next_format (st_parameter_dt *); -internal_proto(next_format); - -extern void unget_format (st_parameter_dt *, const fnode *); -internal_proto(unget_format); - -extern void format_error (st_parameter_dt *, const fnode *, const char *); -internal_proto(format_error); - -extern void free_format_data (struct format_data *); -internal_proto(free_format_data); - -extern void free_format_hash_table (gfc_unit *); -internal_proto(free_format_hash_table); - -extern void init_format_hash (st_parameter_dt *); -internal_proto(init_format_hash); - -extern void free_format_hash (st_parameter_dt *); -internal_proto(free_format_hash); - -#endif diff --git a/gcc-4.8.1/libgfortran/io/inquire.c b/gcc-4.8.1/libgfortran/io/inquire.c deleted file mode 100644 index d91982a65..000000000 --- a/gcc-4.8.1/libgfortran/io/inquire.c +++ /dev/null @@ -1,743 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - - -/* Implement the non-IOLENGTH variant of the INQUIRY statement */ - -#include "io.h" -#include "unix.h" -#include <string.h> - - -static const char undefined[] = "UNDEFINED"; - - -/* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */ - -static void -inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) -{ - const char *p; - GFC_INTEGER_4 cf = iqp->common.flags; - - if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0) - { - *iqp->exist = (iqp->common.unit >= 0 - && iqp->common.unit <= GFC_INTEGER_4_HUGE); - - if ((cf & IOPARM_INQUIRE_HAS_FILE) == 0) - { - if (!(*iqp->exist)) - *iqp->common.iostat = LIBERROR_BAD_UNIT; - *iqp->exist = *iqp->exist - && (*iqp->common.iostat != LIBERROR_BAD_UNIT); - } - } - - if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0) - *iqp->opened = (u != NULL); - - if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0) - *iqp->number = (u != NULL) ? u->unit_number : -1; - - if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0) - *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH); - - if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0 - && u != NULL && u->flags.status != STATUS_SCRATCH) - { -#if defined(HAVE_TTYNAME_R) || defined(HAVE_TTYNAME) - if (u->unit_number == options.stdin_unit - || u->unit_number == options.stdout_unit - || u->unit_number == options.stderr_unit) - { - int err = stream_ttyname (u->s, iqp->name, iqp->name_len); - if (err == 0) - { - gfc_charlen_type tmplen = strlen (iqp->name); - if (iqp->name_len > tmplen) - memset (&iqp->name[tmplen], ' ', iqp->name_len - tmplen); - } - else /* If ttyname does not work, go with the default. */ - fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len); - } - else - fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len); -#elif defined __MINGW32__ - if (u->unit_number == options.stdin_unit) - fstrcpy (iqp->name, iqp->name_len, "CONIN$", sizeof("CONIN$")); - else if (u->unit_number == options.stdout_unit) - fstrcpy (iqp->name, iqp->name_len, "CONOUT$", sizeof("CONOUT$")); - else if (u->unit_number == options.stderr_unit) - fstrcpy (iqp->name, iqp->name_len, "CONERR$", sizeof("CONERR$")); - else - fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len); -#else - fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len); -#endif - } - - if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0) - { - if (u == NULL) - p = undefined; - else - switch (u->flags.access) - { - case ACCESS_SEQUENTIAL: - p = "SEQUENTIAL"; - break; - case ACCESS_DIRECT: - p = "DIRECT"; - break; - case ACCESS_STREAM: - p = "STREAM"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad access"); - } - - cf_strcpy (iqp->access, iqp->access_len, p); - } - - if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0) - { - if (u == NULL) - p = inquire_sequential (NULL, 0); - else - switch (u->flags.access) - { - case ACCESS_DIRECT: - case ACCESS_STREAM: - p = "NO"; - break; - case ACCESS_SEQUENTIAL: - p = "YES"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad access"); - } - - cf_strcpy (iqp->sequential, iqp->sequential_len, p); - } - - if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0) - { - if (u == NULL) - p = inquire_direct (NULL, 0); - else - switch (u->flags.access) - { - case ACCESS_SEQUENTIAL: - case ACCESS_STREAM: - p = "NO"; - break; - case ACCESS_DIRECT: - p = "YES"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad access"); - } - - cf_strcpy (iqp->direct, iqp->direct_len, p); - } - - if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0) - { - if (u == NULL) - p = undefined; - else - switch (u->flags.form) - { - case FORM_FORMATTED: - p = "FORMATTED"; - break; - case FORM_UNFORMATTED: - p = "UNFORMATTED"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad form"); - } - - cf_strcpy (iqp->form, iqp->form_len, p); - } - - if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0) - { - if (u == NULL) - p = inquire_formatted (NULL, 0); - else - switch (u->flags.form) - { - case FORM_FORMATTED: - p = "YES"; - break; - case FORM_UNFORMATTED: - p = "NO"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad form"); - } - - cf_strcpy (iqp->formatted, iqp->formatted_len, p); - } - - if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0) - { - if (u == NULL) - p = inquire_unformatted (NULL, 0); - else - switch (u->flags.form) - { - case FORM_FORMATTED: - p = "NO"; - break; - case FORM_UNFORMATTED: - p = "YES"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad form"); - } - - cf_strcpy (iqp->unformatted, iqp->unformatted_len, p); - } - - if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0) - *iqp->recl_out = (u != NULL) ? u->recl : 0; - - if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0) - *iqp->strm_pos_out = (u != NULL) ? u->strm_pos : 0; - - if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0) - { - /* This only makes sense in the context of DIRECT access. */ - if (u != NULL && u->flags.access == ACCESS_DIRECT) - *iqp->nextrec = u->last_record + 1; - else - *iqp->nextrec = 0; - } - - if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0) - { - if (u == NULL || u->flags.form != FORM_FORMATTED) - p = undefined; - else - switch (u->flags.blank) - { - case BLANK_NULL: - p = "NULL"; - break; - case BLANK_ZERO: - p = "ZERO"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad blank"); - } - - cf_strcpy (iqp->blank, iqp->blank_len, p); - } - - if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0) - { - if (u == NULL || u->flags.form != FORM_FORMATTED) - p = undefined; - else - switch (u->flags.pad) - { - case PAD_YES: - p = "YES"; - break; - case PAD_NO: - p = "NO"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad pad"); - } - - cf_strcpy (iqp->pad, iqp->pad_len, p); - } - - if (cf & IOPARM_INQUIRE_HAS_FLAGS2) - { - GFC_INTEGER_4 cf2 = iqp->flags2; - - if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0) - *iqp->pending = 0; - - if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0) - *iqp->id = 0; - - if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0) - { - if (u == NULL || u->flags.form != FORM_FORMATTED) - p = undefined; - else - switch (u->flags.encoding) - { - case ENCODING_DEFAULT: - p = "UNKNOWN"; - break; - case ENCODING_UTF8: - p = "UTF-8"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad encoding"); - } - - cf_strcpy (iqp->encoding, iqp->encoding_len, p); - } - - if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0) - { - if (u == NULL || u->flags.form != FORM_FORMATTED) - p = undefined; - else - switch (u->flags.decimal) - { - case DECIMAL_POINT: - p = "POINT"; - break; - case DECIMAL_COMMA: - p = "COMMA"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad comma"); - } - - cf_strcpy (iqp->decimal, iqp->decimal_len, p); - } - - if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0) - { - if (u == NULL) - p = undefined; - else - switch (u->flags.async) - { - case ASYNC_YES: - p = "YES"; - break; - case ASYNC_NO: - p = "NO"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad async"); - } - - cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p); - } - - if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0) - { - if (u == NULL) - p = undefined; - else - switch (u->flags.sign) - { - case SIGN_PROCDEFINED: - p = "PROCESSOR_DEFINED"; - break; - case SIGN_SUPPRESS: - p = "SUPPRESS"; - break; - case SIGN_PLUS: - p = "PLUS"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad sign"); - } - - cf_strcpy (iqp->sign, iqp->sign_len, p); - } - - if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0) - { - if (u == NULL) - p = undefined; - else - switch (u->flags.round) - { - case ROUND_UP: - p = "UP"; - break; - case ROUND_DOWN: - p = "DOWN"; - break; - case ROUND_ZERO: - p = "ZERO"; - break; - case ROUND_NEAREST: - p = "NEAREST"; - break; - case ROUND_COMPATIBLE: - p = "COMPATIBLE"; - break; - case ROUND_PROCDEFINED: - p = "PROCESSOR_DEFINED"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad round"); - } - - cf_strcpy (iqp->round, iqp->round_len, p); - } - - if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0) - { - if (u == NULL) - *iqp->size = -1; - else - { - sflush (u->s); - *iqp->size = ssize (u->s); - } - } - - if ((cf2 & IOPARM_INQUIRE_HAS_IQSTREAM) != 0) - { - if (u == NULL) - p = "UNKNOWN"; - else - switch (u->flags.access) - { - case ACCESS_SEQUENTIAL: - case ACCESS_DIRECT: - p = "NO"; - break; - case ACCESS_STREAM: - p = "YES"; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad pad"); - } - - cf_strcpy (iqp->iqstream, iqp->iqstream_len, p); - } - } - - if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0) - { - if (u == NULL || u->flags.access == ACCESS_DIRECT) - p = undefined; - else - { - /* If the position is unspecified, check if we can figure - out whether it's at the beginning or end. */ - if (u->flags.position == POSITION_UNSPECIFIED) - { - gfc_offset cur = stell (u->s); - if (cur == 0) - u->flags.position = POSITION_REWIND; - else if (cur != -1 && (ssize (u->s) == cur)) - u->flags.position = POSITION_APPEND; - } - switch (u->flags.position) - { - case POSITION_REWIND: - p = "REWIND"; - break; - case POSITION_APPEND: - p = "APPEND"; - break; - case POSITION_ASIS: - p = "ASIS"; - break; - default: - /* If the position has changed and is not rewind or - append, it must be set to a processor-dependent - value. */ - p = "UNSPECIFIED"; - 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 ((cf2 & IOPARM_INQUIRE_HAS_IQSTREAM) != 0) - cf_strcpy (iqp->iqstream, iqp->iqstream_len, "UNKNOWN"); - } - - if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0) - cf_strcpy (iqp->position, iqp->position_len, undefined); - - if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0) - cf_strcpy (iqp->access, iqp->access_len, undefined); - - if ((cf & IOPARM_INQUIRE_HAS_READ) != 0) - { - p = inquire_read (iqp->file, iqp->file_len); - cf_strcpy (iqp->read, iqp->read_len, p); - } - - if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0) - { - p = inquire_write (iqp->file, iqp->file_len); - cf_strcpy (iqp->write, iqp->write_len, p); - } - - if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0) - { - p = inquire_read (iqp->file, iqp->file_len); - cf_strcpy (iqp->readwrite, iqp->readwrite_len, p); - } -} - - -/* Library entry point for the INQUIRE statement (non-IOLENGTH - form). */ - -extern void st_inquire (st_parameter_inquire *); -export_proto(st_inquire); - -void -st_inquire (st_parameter_inquire *iqp) -{ - gfc_unit *u; - - library_start (&iqp->common); - - if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0) - { - u = find_unit (iqp->common.unit); - inquire_via_unit (iqp, u); - } - else - { - u = find_file (iqp->file, iqp->file_len); - if (u == NULL) - inquire_via_filename (iqp); - else - inquire_via_unit (iqp, u); - } - if (u != NULL) - unlock_unit (u); - - library_end (); -} diff --git a/gcc-4.8.1/libgfortran/io/intrinsics.c b/gcc-4.8.1/libgfortran/io/intrinsics.c deleted file mode 100644 index 1573434d6..000000000 --- a/gcc-4.8.1/libgfortran/io/intrinsics.c +++ /dev/null @@ -1,416 +0,0 @@ -/* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH - FTELL, TTYNAM and ISATTY intrinsics. - Copyright (C) 2005-2013 Free Software Foundation, Inc. - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "io.h" -#include "fbuf.h" -#include "unix.h" -#include <stdlib.h> -#include <string.h> - - -static const int five = 5; -static const int six = 6; - -extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type); -export_proto_np(PREFIX(fgetc)); - -int -PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len) -{ - int ret; - gfc_unit * u = find_unit (*unit); - - if (u == NULL) - return -1; - - fbuf_reset (u); - if (u->mode == WRITING) - { - sflush (u->s); - u->mode = READING; - } - - memset (c, ' ', c_len); - ret = sread (u->s, c, 1); - unlock_unit (u); - - if (ret < 0) - return ret; - - if (ret != 1) - return -1; - else - return 0; -} - - -#define FGETC_SUB(kind) \ - extern void fgetc_i ## kind ## _sub \ - (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \ - export_proto(fgetc_i ## kind ## _sub); \ - void fgetc_i ## kind ## _sub \ - (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \ - { if (st != NULL) \ - *st = PREFIX(fgetc) (unit, c, c_len); \ - else \ - PREFIX(fgetc) (unit, c, c_len); } - -FGETC_SUB(1) -FGETC_SUB(2) -FGETC_SUB(4) -FGETC_SUB(8) - - -extern int PREFIX(fget) (char *, gfc_charlen_type); -export_proto_np(PREFIX(fget)); - -int -PREFIX(fget) (char * c, gfc_charlen_type c_len) -{ - return PREFIX(fgetc) (&five, c, c_len); -} - - -#define FGET_SUB(kind) \ - extern void fget_i ## kind ## _sub \ - (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \ - export_proto(fget_i ## kind ## _sub); \ - void fget_i ## kind ## _sub \ - (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \ - { if (st != NULL) \ - *st = PREFIX(fgetc) (&five, c, c_len); \ - else \ - PREFIX(fgetc) (&five, c, c_len); } - -FGET_SUB(1) -FGET_SUB(2) -FGET_SUB(4) -FGET_SUB(8) - - - -extern int PREFIX(fputc) (const int *, char *, gfc_charlen_type); -export_proto_np(PREFIX(fputc)); - -int -PREFIX(fputc) (const int * unit, char * c, - gfc_charlen_type c_len __attribute__((unused))) -{ - ssize_t s; - gfc_unit * u = find_unit (*unit); - - if (u == NULL) - return -1; - - fbuf_reset (u); - if (u->mode == READING) - { - sflush (u->s); - u->mode = WRITING; - } - - s = swrite (u->s, c, 1); - unlock_unit (u); - if (s < 0) - return -1; - return 0; -} - - -#define FPUTC_SUB(kind) \ - extern void fputc_i ## kind ## _sub \ - (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \ - export_proto(fputc_i ## kind ## _sub); \ - void fputc_i ## kind ## _sub \ - (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \ - { if (st != NULL) \ - *st = PREFIX(fputc) (unit, c, c_len); \ - else \ - PREFIX(fputc) (unit, c, c_len); } - -FPUTC_SUB(1) -FPUTC_SUB(2) -FPUTC_SUB(4) -FPUTC_SUB(8) - - -extern int PREFIX(fput) (char *, gfc_charlen_type); -export_proto_np(PREFIX(fput)); - -int -PREFIX(fput) (char * c, gfc_charlen_type c_len) -{ - return PREFIX(fputc) (&six, c, c_len); -} - - -#define FPUT_SUB(kind) \ - extern void fput_i ## kind ## _sub \ - (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \ - export_proto(fput_i ## kind ## _sub); \ - void fput_i ## kind ## _sub \ - (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \ - { if (st != NULL) \ - *st = PREFIX(fputc) (&six, c, c_len); \ - else \ - PREFIX(fputc) (&six, c, c_len); } - -FPUT_SUB(1) -FPUT_SUB(2) -FPUT_SUB(4) -FPUT_SUB(8) - - -/* SUBROUTINE FLUSH(UNIT) - INTEGER, INTENT(IN), OPTIONAL :: UNIT */ - -extern void flush_i4 (GFC_INTEGER_4 *); -export_proto(flush_i4); - -void -flush_i4 (GFC_INTEGER_4 *unit) -{ - gfc_unit *us; - - /* flush all streams */ - if (unit == NULL) - flush_all_units (); - else - { - us = find_unit (*unit); - if (us != NULL) - { - sflush (us->s); - unlock_unit (us); - } - } -} - - -extern void flush_i8 (GFC_INTEGER_8 *); -export_proto(flush_i8); - -void -flush_i8 (GFC_INTEGER_8 *unit) -{ - gfc_unit *us; - - /* flush all streams */ - if (unit == NULL) - flush_all_units (); - else - { - us = find_unit (*unit); - if (us != NULL) - { - sflush (us->s); - unlock_unit (us); - } - } -} - -/* FSEEK intrinsic */ - -extern void fseek_sub (int *, GFC_IO_INT *, int *, int *); -export_proto(fseek_sub); - -void -fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status) -{ - gfc_unit * u = find_unit (*unit); - ssize_t result = -1; - - if (u != NULL) - { - 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; -} - - -/* Here is the ftell function with an incorrect return type; retained - due to ABI compatibility. */ - -extern size_t PREFIX(ftell) (int *); -export_proto_np(PREFIX(ftell)); - -size_t -PREFIX(ftell) (int * unit) -{ - return gf_ftell (*unit); -} - - -/* Here is the ftell function with the correct return type, ensuring - that large files can be supported as long as the target supports - large integers; as of 4.8 the FTELL intrinsic function will call - this one instead of the old ftell above. */ - -extern GFC_IO_INT PREFIX(ftell2) (int *); -export_proto_np(PREFIX(ftell2)); - -GFC_IO_INT -PREFIX(ftell2) (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 = xmalloc (TTY_NAME_MAX); - int err = stream_ttyname (u->s, *name, TTY_NAME_MAX); - if (err == 0) - { - *name_len = strlen (*name); - unlock_unit (u); - return; - } - free (*name); - unlock_unit (u); - } - - *name_len = 0; - *name = NULL; -} diff --git a/gcc-4.8.1/libgfortran/io/io.h b/gcc-4.8.1/libgfortran/io/io.h deleted file mode 100644 index 8ea932667..000000000 --- a/gcc-4.8.1/libgfortran/io/io.h +++ /dev/null @@ -1,811 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - F2003 I/O support contributed by Jerry DeLisle - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#ifndef GFOR_IO_H -#define GFOR_IO_H - -/* IO library include. */ - -#include "libgfortran.h" - -#include <gthr.h> - -/* Forward declarations. */ -struct st_parameter_dt; -typedef struct stream stream; -struct fbuf; -struct format_data; -typedef struct fnode fnode; -struct gfc_unit; - - -/* Macros for testing what kinds of I/O we are doing. */ - -#define is_array_io(dtp) ((dtp)->internal_unit_desc) - -#define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal) - -#define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM) - -#define is_char4_unit(dtp) ((dtp)->u.p.unit_is_internal && (dtp)->common.unit) - -/* The array_loop_spec contains the variables for the loops over index ranges - that are encountered. */ - -typedef struct array_loop_spec -{ - /* Index counter for this dimension. */ - index_type idx; - - /* Start for the index counter. */ - index_type start; - - /* End for the index counter. */ - index_type end; - - /* Step for the index counter. */ - index_type step; -} -array_loop_spec; - -/* A structure 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) -#define IOPARM_INQUIRE_HAS_IQSTREAM (1 << 8) - -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; - CHARACTER1 (iqstream); -} -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 (e.g. 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 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 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 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 si_max (int); -internal_proto(si_max); - -extern int convert_real (st_parameter_dt *, void *, const char *, int); -internal_proto(convert_real); - -extern int convert_infnan (st_parameter_dt *, void *, const char *, int); -internal_proto(convert_infnan); - -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 -} - - -static inline void -memset4 (gfc_char4_t *p, gfc_char4_t c, int k) -{ - int j; - for (j = 0; j < k; j++) - *p++ = c; -} - -#endif - diff --git a/gcc-4.8.1/libgfortran/io/list_read.c b/gcc-4.8.1/libgfortran/io/list_read.c deleted file mode 100644 index 5a44bdf78..000000000 --- a/gcc-4.8.1/libgfortran/io/list_read.c +++ /dev/null @@ -1,3155 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - Namelist input contributed by Paul Thomas - F2003 I/O support contributed by Jerry DeLisle - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - - -#include "io.h" -#include "fbuf.h" -#include "unix.h" -#include <string.h> -#include <stdlib.h> -#include <ctype.h> - - -/* List directed input. Several parsing subroutines are practically - reimplemented from formatted input, the reason being that there are - all kinds of small differences between formatted and list directed - parsing. */ - - -/* Subroutines for reading characters from the input. Because a - repeat count is ambiguous with an integer, we have to read the - whole digit string before seeing if there is a '*' which signals - the repeat count. Since we can have a lot of potential leading - zeros, we have to be able to back up by arbitrary amount. Because - the input might not be seekable, we have to buffer the data - ourselves. */ - -#define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \ - case '5': case '6': case '7': case '8': case '9' - -#define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \ - case '\r': case ';' - -/* This macro assumes that we're operating on a variable. */ - -#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \ - || c == '\t' || c == '\r' || c == ';') - -/* Maximum repeat count. Less than ten times the maximum signed int32. */ - -#define MAX_REPEAT 200000000 - - -#define MSGLEN 100 - -/* 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) - { - // Plain malloc should suffice here, zeroing not needed? - dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, 1); - 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)) - { - /* Check for kind=4 internal unit. */ - if (dtp->common.unit) - length = sread (dtp->u.p.current_unit->s, &c, sizeof (gfc_char4_t)); - else - { - 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[MSGLEN]; - int m; - GFC_UINTEGER_LARGEST v, max, max10; - GFC_INTEGER_LARGEST value; - - buffer = dtp->u.p.saved_string; - v = 0; - - if (length == -1) - max = MAX_REPEAT; - else - { - max = si_max (length); - if (negative) - max++; - } - 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) - value = -v; - else - value = v; - set_integer (dtp->u.p.value, value, length); - } - else - { - dtp->u.p.repeat_count = v; - - if (dtp->u.p.repeat_count == 0) - { - snprintf (message, MSGLEN, "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) - snprintf (message, MSGLEN, "Repeat count overflow in item %d of list input", - dtp->u.p.item_count); - else - snprintf (message, MSGLEN, "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[MSGLEN]; - 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) - { - snprintf (message, MSGLEN, - "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) - { - snprintf (message, MSGLEN, - "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); - snprintf (message, MSGLEN, "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 = xcalloc (SCRATCH_SIZE, 1); - - 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[MSGLEN]; - 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: - case EOF: - 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); - snprintf (message, MSGLEN, "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[MSGLEN]; - 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: - case EOF: - 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); - snprintf (message, MSGLEN, "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[MSGLEN]; - 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: - case EOF: - unget_char (dtp, c); /* NULL value. */ - eat_separator (dtp); - return; - - case '"': - case '\'': - quote = c; - goto get_string; - - default: - if (dtp->u.p.namelist_mode) - { - unget_char (dtp, c); - return; - } - - push_char (dtp, c); - goto get_string; - } - - /* Deal with a possible repeat count. */ - - for (;;) - { - c = next_char (dtp); - switch (c) - { - CASE_DIGITS: - push_char (dtp, c); - break; - - CASE_SEPARATORS: - case EOF: - 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 done_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); - snprintf (message, MSGLEN, "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[MSGLEN]; - 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': - case 'q': - case 'Q': - 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: - case EOF: - 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: - case EOF: - 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; - - done_infnan: - unget_char (dtp, c); - push_char (dtp, '\0'); - - m = convert_infnan (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) || (c == EOF)) - unget_char (dtp, c); - push_char (dtp, 'i'); - push_char (dtp, 'n'); - push_char (dtp, 'f'); - goto done_infnan; - } - } /* 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) || (c == EOF)) - 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) || (c == EOF)) - unget_char (dtp, c); - } - goto done_infnan; - } - - 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); - snprintf (message, MSGLEN, "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[MSGLEN]; - int c; - - if (parse_repeat (dtp)) - return; - - c = next_char (dtp); - switch (c) - { - case '(': - break; - - CASE_SEPARATORS: - case EOF: - 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) && (c != EOF)) - 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); - snprintf (message, MSGLEN, "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[MSGLEN]; - 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': - case 'Q': - case 'q': - 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: - case EOF: - 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': - case 'Q': - case 'q': - 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) && (c != EOF)) - { - 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) && (c != EOF)) - 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); - unget_char (dtp, c); - eat_separator (dtp); - push_char (dtp, '\0'); - if (convert_infnan (dtp, dest, dtp->u.p.saved_string, length)) - return; - - free_saved (dtp); - dtp->u.p.saved_type = BT_REAL; - return; - - 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); - - snprintf (message, MSGLEN, "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[MSGLEN]; - - if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type) - { - snprintf (message, MSGLEN, "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) - { - snprintf (message, MSGLEN, - "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, size); - 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, bt nml_elem_type, - char *parse_err_msg, size_t parse_err_msg_size, - 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) - goto err_ret; - - /* 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) - goto err_ret; - switch (c) - { - case '-': - neg = 1; - break; - - case '+': - break; - - default: - unget_char (dtp, c); - break; - } - - /* Process characters up to the next ':' , ',' or ')'. */ - for (;;) - { - c = next_char (dtp); - switch (c) - { - case EOF: - goto err_ret; - - case ':': - is_array_section = 1; - break; - - case ',': case ')': - if ((c==',' && dim == rank -1) - || (c==')' && dim < rank -1)) - { - if (is_char) - snprintf (parse_err_msg, parse_err_msg_size, - "Bad substring qualifier"); - else - snprintf (parse_err_msg, parse_err_msg_size, - "Bad number of index fields"); - goto err_ret; - } - break; - - CASE_DIGITS: - push_char (dtp, c); - continue; - - case ' ': case '\t': case '\r': case '\n': - eat_spaces (dtp); - break; - - default: - if (is_char) - snprintf (parse_err_msg, parse_err_msg_size, - "Bad character in substring qualifier"); - else - snprintf (parse_err_msg, parse_err_msg_size, - "Bad character in index"); - goto err_ret; - } - - if ((c == ',' || c == ')') && indx == 0 - && dtp->u.p.saved_string == 0) - { - if (is_char) - snprintf (parse_err_msg, parse_err_msg_size, - "Null substring qualifier"); - else - snprintf (parse_err_msg, parse_err_msg_size, - "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) - snprintf (parse_err_msg, parse_err_msg_size, - "Bad substring qualifier"); - else - snprintf (parse_err_msg, parse_err_msg_size, - "Bad index triplet"); - goto err_ret; - } - - if (is_char && !is_array_section) - { - snprintf (parse_err_msg, parse_err_msg_size, - "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(index_type), neg)) - { - if (is_char) - snprintf (parse_err_msg, parse_err_msg_size, - "Bad integer substring qualifier"); - else - snprintf (parse_err_msg, parse_err_msg_size, - "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(index_type)); - if (indx == 1) - memcpy (&ls[dim].end, dtp->u.p.value, sizeof(index_type)); - if (indx == 2) - memcpy (&ls[dim].step, dtp->u.p.value, sizeof(index_type)); - } - - /* Singlet or doublet indices. */ - if (c==',' || c==')') - { - if (indx == 0) - { - memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type)); - - /* 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) - || nml_elem_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 > GFC_DIMENSION_UBOUND(ad[dim])) - || (ls[dim].start < GFC_DIMENSION_LBOUND(ad[dim])) - || (ls[dim].end > GFC_DIMENSION_UBOUND(ad[dim])) - || (ls[dim].end < GFC_DIMENSION_LBOUND(ad[dim]))) - { - if (is_char) - snprintf (parse_err_msg, parse_err_msg_size, - "Substring out of range"); - else - snprintf (parse_err_msg, parse_err_msg_size, - "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)) - { - snprintf (parse_err_msg, parse_err_msg_size, - "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: - - /* The EOF error message is issued by hit_eof. Return true so that the - caller does not use parse_err_msg and parse_err_msg_size to generate - an unrelated error message. */ - if (c == EOF) - { - hit_eof (dtp); - dtp->u.p.input_complete = 1; - return SUCCESS; - } - 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*)xmalloc (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 = xmalloc (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. */ - - for (cmp = nl->next; - cmp && - !strncmp (cmp->var_name, obj_name, obj_name_len); - cmp = cmp->next) - { - /* Jump over nested derived type by testing if the potential - component name contains '%'. */ - if (strchr (cmp->var_name + obj_name_len, '%')) - continue; - - 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) - goto nml_err_ret; - switch (c) - { - case '=': - if ((c = next_char (dtp)) == EOF) - goto nml_err_ret; - if (c != '?') - { - snprintf (nml_err_msg, nml_err_msg_size, - "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) - { - snprintf (nml_err_msg, nml_err_msg_size, - "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) - goto nml_err_ret; - } - 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, - nl->type, nml_err_msg, nml_err_msg_size, - &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) - goto nml_err_ret; - 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; - } - - /* Don't move first_nl further in the list if a qualifier was found. */ - if ((*pprev_nl == NULL && !qualifier_flag) || !component_flag) - first_nl = nl; - - root_nl = nl; - - component_flag = 1; - if ((c = next_char (dtp)) == EOF) - goto nml_err_ret; - 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, nl->type, - nml_err_msg, nml_err_msg_size, &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) - goto nml_err_ret; - 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) - goto nml_err_ret; - - 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: - - /* The EOF error message is issued by hit_eof. Return true so that the - caller does not use nml_err_msg and nml_err_msg_size to generate - an unrelated error message. */ - if (c == EOF) - { - dtp->u.p.input_complete = 1; - unget_char (dtp, c); - hit_eof (dtp); - return SUCCESS; - } - - 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 latitude here, 10.9.1. */ - c = next_char (dtp); - if (!is_separator(c) && c != '!') - { - unget_char (dtp, c); - goto find_nml_name; - } - - unget_char (dtp, c); - eat_separator (dtp); - - /* Ready to read namelist objects. If there is an error in input - from stdin, output the error message and continue. */ - - while (!dtp->u.p.input_complete) - { - if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg) - == FAILURE) - { - if (dtp->u.p.current_unit->unit_number != options.stdin_unit) - goto nml_err_ret; - generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg); - } - - /* Reset the previous namelist pointer if we know we are not going - to be doing multiple reads within a single namelist object. */ - if (prev_nl && prev_nl->var_rank == 0) - prev_nl = NULL; - } - - free_saved (dtp); - free_line (dtp); - return; - - -nml_err_ret: - - /* All namelist error calls return from here */ - free_saved (dtp); - free_line (dtp); - generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg); - return; -} diff --git a/gcc-4.8.1/libgfortran/io/lock.c b/gcc-4.8.1/libgfortran/io/lock.c deleted file mode 100644 index dbb61a7dc..000000000 --- a/gcc-4.8.1/libgfortran/io/lock.c +++ /dev/null @@ -1,66 +0,0 @@ -/* Thread/recursion locking - Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Paul Brook <paul@nowt.org> and Andy Vaught - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "io.h" -#include <string.h> -#include <stdlib.h> - -/* library_start()-- Called with a library call is entered. */ - -void -library_start (st_parameter_common *cmp) -{ - if ((cmp->flags & IOPARM_LIBRETURN_ERROR) != 0) - return; - - cmp->flags &= ~IOPARM_LIBRETURN_MASK; -} - - -void -free_ionml (st_parameter_dt *dtp) -{ - namelist_info * t1, *t2; - - /* Delete the namelist, if it exists. */ - - if (dtp->u.p.ionml != NULL) - { - t1 = dtp->u.p.ionml; - while (t1 != NULL) - { - t2 = t1; - t1 = t1->next; - free (t2->var_name); - if (t2->var_rank) - { - free (t2->dim); - free (t2->ls); - } - free (t2); - } - } - dtp->u.p.ionml = NULL; -} diff --git a/gcc-4.8.1/libgfortran/io/open.c b/gcc-4.8.1/libgfortran/io/open.c deleted file mode 100644 index d9cfde853..000000000 --- a/gcc-4.8.1/libgfortran/io/open.c +++ /dev/null @@ -1,868 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - F2003 I/O support contributed by Jerry DeLisle - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "io.h" -#include "fbuf.h" -#include "unix.h" -#include <unistd.h> -#include <string.h> -#include <errno.h> -#include <stdlib.h> - - -static const st_option access_opt[] = { - {"sequential", ACCESS_SEQUENTIAL}, - {"direct", ACCESS_DIRECT}, - {"append", ACCESS_APPEND}, - {"stream", ACCESS_STREAM}, - {NULL, 0} -}; - -static const st_option action_opt[] = -{ - { "read", ACTION_READ}, - { "write", ACTION_WRITE}, - { "readwrite", ACTION_READWRITE}, - { NULL, 0} -}; - -static const st_option blank_opt[] = -{ - { "null", BLANK_NULL}, - { "zero", BLANK_ZERO}, - { NULL, 0} -}; - -static const st_option delim_opt[] = -{ - { "none", DELIM_NONE}, - { "apostrophe", DELIM_APOSTROPHE}, - { "quote", DELIM_QUOTE}, - { NULL, 0} -}; - -static const st_option form_opt[] = -{ - { "formatted", FORM_FORMATTED}, - { "unformatted", FORM_UNFORMATTED}, - { NULL, 0} -}; - -static const st_option position_opt[] = -{ - { "asis", POSITION_ASIS}, - { "rewind", POSITION_REWIND}, - { "append", POSITION_APPEND}, - { NULL, 0} -}; - -static const st_option status_opt[] = -{ - { "unknown", STATUS_UNKNOWN}, - { "old", STATUS_OLD}, - { "new", STATUS_NEW}, - { "replace", STATUS_REPLACE}, - { "scratch", STATUS_SCRATCH}, - { NULL, 0} -}; - -static const st_option pad_opt[] = -{ - { "yes", PAD_YES}, - { "no", PAD_NO}, - { NULL, 0} -}; - -static const st_option decimal_opt[] = -{ - { "point", DECIMAL_POINT}, - { "comma", DECIMAL_COMMA}, - { NULL, 0} -}; - -static const st_option encoding_opt[] = -{ - { "utf-8", ENCODING_UTF8}, - { "default", ENCODING_DEFAULT}, - { NULL, 0} -}; - -static const st_option round_opt[] = -{ - { "up", ROUND_UP}, - { "down", ROUND_DOWN}, - { "zero", ROUND_ZERO}, - { "nearest", ROUND_NEAREST}, - { "compatible", ROUND_COMPATIBLE}, - { "processor_defined", ROUND_PROCDEFINED}, - { NULL, 0} -}; - -static const st_option sign_opt[] = -{ - { "plus", SIGN_PLUS}, - { "suppress", SIGN_SUPPRESS}, - { "processor_defined", SIGN_PROCDEFINED}, - { NULL, 0} -}; - -static const st_option convert_opt[] = -{ - { "native", GFC_CONVERT_NATIVE}, - { "swap", GFC_CONVERT_SWAP}, - { "big_endian", GFC_CONVERT_BIG}, - { "little_endian", GFC_CONVERT_LITTLE}, - { NULL, 0} -}; - -static const st_option async_opt[] = -{ - { "yes", ASYNC_YES}, - { "no", ASYNC_NO}, - { NULL, 0} -}; - -/* Given a unit, test to see if the file is positioned at the terminal - point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE. - This prevents us from changing the state from AFTER_ENDFILE to - AT_ENDFILE. */ - -static void -test_endfile (gfc_unit * u) -{ - if (u->endfile == NO_ENDFILE) - { - gfc_offset sz = ssize (u->s); - if (sz == 0 || sz == 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; - opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d", - (int) opp->common.unit); - break; - - default: - internal_error (&opp->common, "new_unit(): Bad status"); - } - - /* Make sure the file isn't already open someplace else. - Do not error if opening file preconnected to stdin, stdout, stderr. */ - - u2 = NULL; - if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0) - u2 = find_file (opp->file, opp->file_len); - if (u2 != NULL - && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit) - && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit) - && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit)) - { - unlock_unit (u2); - generate_error (&opp->common, 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; - size_t msglen; - path = (char *) gfc_alloca (opp->file_len + 1); - msglen = opp->file_len + 51; - msg = (char *) gfc_alloca (msglen); - unpack_filename (path, opp->file, opp->file_len); - - switch (errno) - { - case ENOENT: - snprintf (msg, msglen, "File '%s' does not exist", path); - break; - - case EEXIST: - snprintf (msg, msglen, "File '%s' already exists", path); - break; - - case EACCES: - snprintf (msg, msglen, - "Permission denied trying to open file '%s'", path); - break; - - case EISDIR: - snprintf (msg, msglen, "'%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 = xmalloc (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 (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; - 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->common.unit = get_unique_unit_number(opp); - - 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); - } - - if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT) - && (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK) - *opp->newunit = opp->common.unit; - - library_end (); -} diff --git a/gcc-4.8.1/libgfortran/io/read.c b/gcc-4.8.1/libgfortran/io/read.c deleted file mode 100644 index 2da1048f8..000000000 --- a/gcc-4.8.1/libgfortran/io/read.c +++ /dev/null @@ -1,1248 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - F2003 I/O support contributed by Jerry DeLisle - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "io.h" -#include "fbuf.h" -#include "format.h" -#include "unix.h" -#include <string.h> -#include <errno.h> -#include <ctype.h> -#include <stdlib.h> -#include <assert.h> - -typedef unsigned char uchar; - -/* read.c -- Deal with formatted reads */ - - -/* set_integer()-- All of the integer assignments come here to - actually place the value into memory. */ - -void -set_integer (void *dest, GFC_INTEGER_LARGEST value, int length) -{ - switch (length) - { -#ifdef HAVE_GFC_INTEGER_16 -/* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */ - case 10: - case 16: - { - GFC_INTEGER_16 tmp = value; - memcpy (dest, (void *) &tmp, length); - } - break; -#endif - case 8: - { - GFC_INTEGER_8 tmp = value; - memcpy (dest, (void *) &tmp, length); - } - break; - case 4: - { - GFC_INTEGER_4 tmp = value; - memcpy (dest, (void *) &tmp, length); - } - break; - case 2: - { - GFC_INTEGER_2 tmp = value; - memcpy (dest, (void *) &tmp, length); - } - break; - case 1: - { - GFC_INTEGER_1 tmp = value; - memcpy (dest, (void *) &tmp, length); - } - break; - default: - internal_error (NULL, "Bad integer kind"); - } -} - - -/* Max signed value of size give by length argument. */ - -GFC_UINTEGER_LARGEST -si_max (int length) -{ - GFC_UINTEGER_LARGEST value; - - switch (length) - { -#if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10 - case 16: - case 10: - value = 1; - for (int n = 1; n < 4 * length; n++) - value = (value << 2) + 3; - return value; -#endif - case 8: - return GFC_INTEGER_8_HUGE; - case 4: - return GFC_INTEGER_4_HUGE; - case 2: - return GFC_INTEGER_2_HUGE; - case 1: - return GFC_INTEGER_1_HUGE; - default: - internal_error (NULL, "Bad integer kind"); - } -} - - -/* convert_real()-- Convert a character representation of a floating - point number to the machine number. Returns nonzero if there is an - invalid input. 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) -{ - char *endptr = NULL; - - switch (length) - { - case 4: - *((GFC_REAL_4*) dest) = -#if defined(HAVE_STRTOF) - gfc_strtof (buffer, &endptr); -#else - (GFC_REAL_4) gfc_strtod (buffer, &endptr); -#endif - break; - - case 8: - *((GFC_REAL_8*) dest) = gfc_strtod (buffer, &endptr); - break; - -#if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD) - case 10: - *((GFC_REAL_10*) dest) = gfc_strtold (buffer, &endptr); - break; -#endif - -#if defined(HAVE_GFC_REAL_16) -# if defined(GFC_REAL_16_IS_FLOAT128) - case 16: - *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, &endptr); - break; -# elif defined(HAVE_STRTOLD) - case 16: - *((GFC_REAL_16*) dest) = gfc_strtold (buffer, &endptr); - break; -# endif -#endif - - default: - internal_error (&dtp->common, "Unsupported real kind during IO"); - } - - if (buffer == endptr) - { - generate_error (&dtp->common, LIBERROR_READ_VALUE, - "Error during floating point read"); - next_record (dtp, 1); - return 1; - } - - return 0; -} - -/* convert_infnan()-- Convert character INF/NAN representation to the - machine number. 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_infnan (st_parameter_dt *dtp, void *dest, const char *buffer, - int length) -{ - const char *s = buffer; - int is_inf, plus = 1; - - if (*s == '+') - s++; - else if (*s == '-') - { - s++; - plus = 0; - } - - is_inf = *s == 'i'; - - switch (length) - { - case 4: - if (is_inf) - *((GFC_REAL_4*) dest) = plus ? __builtin_inff () : -__builtin_inff (); - else - *((GFC_REAL_4*) dest) = plus ? __builtin_nanf ("") : -__builtin_nanf (""); - break; - - case 8: - if (is_inf) - *((GFC_REAL_8*) dest) = plus ? __builtin_inf () : -__builtin_inf (); - else - *((GFC_REAL_8*) dest) = plus ? __builtin_nan ("") : -__builtin_nan (""); - break; - -#if defined(HAVE_GFC_REAL_10) - case 10: - if (is_inf) - *((GFC_REAL_10*) dest) = plus ? __builtin_infl () : -__builtin_infl (); - else - *((GFC_REAL_10*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl (""); - 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; -# else - case 16: - if (is_inf) - *((GFC_REAL_16*) dest) = plus ? __builtin_infl () : -__builtin_infl (); - else - *((GFC_REAL_16*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl (""); - break; -# endif -#endif - - default: - internal_error (&dtp->common, "Unsupported real kind during IO"); - } - - 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; - } - - negative = 0; - - switch (*p) - { - case '-': - negative = 1; - /* Fall through */ - - case '+': - p++; - if (--w == 0) - goto bad; - /* Fall through */ - - default: - break; - } - - maxv = si_max (length); - if (negative) - maxv++; - maxv_10 = maxv / 10; - - /* At this point we have a digit-string */ - value = 0; - - for (;;) - { - c = next_char (dtp, &p, &w); - if (c == '\0') - break; - - if (c == ' ') - { - if (dtp->u.p.blank_status == BLANK_NULL) continue; - if (dtp->u.p.blank_status == BLANK_ZERO) c = '0'; - } - - if (c < '0' || c > '9') - goto bad; - - if (value > maxv_10) - goto overflow; - - c -= '0'; - value = 10 * value; - - if (value > maxv - c) - goto overflow; - value += c; - } - - if (negative) - v = -value; - else - v = value; - - 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; - } - - /* Maximum unsigned value, assuming two's complement. */ - maxv = 2 * si_max (length) + 1; - 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_infnan (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': - case 'q': - case 'Q': - ++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'; - /* Handle input of style "E+NN" by inserting a 0 for the - significand. */ - else if (!seen_int_digit && !seen_dec_digit) - { - notify_std (&dtp->common, GFC_STD_LEGACY, - "REAL input of style 'E+NN'"); - *(out++) = '0'; - } - - /* Print out the exponent to finish the reformatted number. Maximum 4 - digits for the exponent. */ - if (exponent != 0) - { - int dig; - - *(out++) = 'e'; - if (exponent < 0) - { - *(out++) = '-'; - exponent = - exponent; - } - - assert (exponent < 10000); - for (dig = 3; dig >= 0; --dig) - { - out[dig] = (char) ('0' + exponent % 10); - exponent /= 10; - } - out += 4; - } - *(out++) = '\0'; - - /* Do the actual conversion. */ - convert_real (dtp, dest, buffer, length); - - return; - - /* The value read is zero. */ -zero: - switch (length) - { - case 4: - *((GFC_REAL_4 *) dest) = 0.0; - break; - - case 8: - *((GFC_REAL_8 *) dest) = 0.0; - break; - -#ifdef HAVE_GFC_REAL_10 - case 10: - *((GFC_REAL_10 *) dest) = 0.0; - break; -#endif - -#ifdef HAVE_GFC_REAL_16 - case 16: - *((GFC_REAL_16 *) dest) = 0.0; - break; -#endif - - default: - internal_error (&dtp->common, "Unsupported real kind during IO"); - } - return; - -bad_float: - generate_error (&dtp->common, LIBERROR_READ_VALUE, - "Bad value during floating point read"); - next_record (dtp, 1); - return; -} - - -/* read_x()-- Deal with the X/TR descriptor. We just read some data - * and never look at it. */ - -void -read_x (st_parameter_dt *dtp, int n) -{ - int length, q, q2; - - if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp)) - && dtp->u.p.current_unit->bytes_left < n) - n = dtp->u.p.current_unit->bytes_left; - - if (n == 0) - return; - - length = n; - - if (is_internal_unit (dtp)) - { - mem_alloc_r (dtp->u.p.current_unit->s, &length); - if (unlikely (length < n)) - n = length; - goto done; - } - - if (dtp->u.p.sf_seen_eor) - return; - - n = 0; - while (n < length) - { - q = fbuf_getc (dtp->u.p.current_unit); - if (q == EOF) - break; - else if (q == '\n' || q == '\r') - { - /* Unexpected end of line. Set the position. */ - dtp->u.p.sf_seen_eor = 1; - - /* If we see an EOR during non-advancing I/O, we need to skip - the rest of the I/O statement. Set the corresponding flag. */ - if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) - dtp->u.p.eor_condition = 1; - - /* If we encounter a CR, it might be a CRLF. */ - if (q == '\r') /* Probably a CRLF */ - { - /* See if there is an LF. */ - q2 = fbuf_getc (dtp->u.p.current_unit); - if (q2 == '\n') - dtp->u.p.sf_seen_eor = 2; - else if (q2 != EOF) /* Oops, seek back. */ - fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR); - } - goto done; - } - n++; - } - - done: - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) n; - dtp->u.p.current_unit->bytes_left -= n; - dtp->u.p.current_unit->strm_pos += (gfc_offset) n; -} - diff --git a/gcc-4.8.1/libgfortran/io/size_from_kind.c b/gcc-4.8.1/libgfortran/io/size_from_kind.c deleted file mode 100644 index 8bf992eb3..000000000 --- a/gcc-4.8.1/libgfortran/io/size_from_kind.c +++ /dev/null @@ -1,83 +0,0 @@ -/* Copyright (C) 2005-2013 Free Software Foundation, Inc. - Contributed by Janne Blomqvist - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - - -/* This file contains utility functions for determining the size of a - variable given its kind. */ - -#include "io.h" - -size_t -size_from_real_kind (int kind) -{ - switch (kind) - { -#ifdef HAVE_GFC_REAL_4 - case 4: - return sizeof (GFC_REAL_4); -#endif -#ifdef HAVE_GFC_REAL_8 - case 8: - return sizeof (GFC_REAL_8); -#endif -#ifdef HAVE_GFC_REAL_10 - case 10: - return sizeof (GFC_REAL_10); -#endif -#ifdef HAVE_GFC_REAL_16 - case 16: - return sizeof (GFC_REAL_16); -#endif - default: - return kind; - } -} - - -size_t -size_from_complex_kind (int kind) -{ - switch (kind) - { -#ifdef HAVE_GFC_COMPLEX_4 - case 4: - return sizeof (GFC_COMPLEX_4); -#endif -#ifdef HAVE_GFC_COMPLEX_8 - case 8: - return sizeof (GFC_COMPLEX_8); -#endif -#ifdef HAVE_GFC_COMPLEX_10 - case 10: - return sizeof (GFC_COMPLEX_10); -#endif -#ifdef HAVE_GFC_COMPLEX_16 - case 16: - return sizeof (GFC_COMPLEX_16); -#endif - default: - return 2 * kind; - } -} - diff --git a/gcc-4.8.1/libgfortran/io/transfer.c b/gcc-4.8.1/libgfortran/io/transfer.c deleted file mode 100644 index 5260be740..000000000 --- a/gcc-4.8.1/libgfortran/io/transfer.c +++ /dev/null @@ -1,3865 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - Namelist transfer functions contributed by Paul Thomas - F2003 I/O support contributed by Jerry DeLisle - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - - -/* transfer.c -- Top level handling of data transfer statements. */ - -#include "io.h" -#include "fbuf.h" -#include "format.h" -#include "unix.h" -#include <string.h> -#include <assert.h> -#include <stdlib.h> -#include <errno.h> - - -/* Calling conventions: Data transfer statements are unlike other - library calls in that they extend over several calls. - - The first call is always a call to st_read() or st_write(). These - subroutines return no status unless a namelist read or write is - being done, in which case there is the usual status. No further - calls are necessary in this case. - - For other sorts of data transfer, there are zero or more data - transfer statement that depend on the format of the data transfer - statement. For READ (and for backwards compatibily: for WRITE), one has - - transfer_integer - transfer_logical - transfer_character - transfer_character_wide - transfer_real - transfer_complex - transfer_real128 - transfer_complex128 - - and for WRITE - - transfer_integer_write - transfer_logical_write - transfer_character_write - transfer_character_wide_write - transfer_real_write - transfer_complex_write - transfer_real128_write - transfer_complex128_write - - These subroutines do not return status. The *128 functions - are in the file transfer128.c. - - The last call is a call to st_[read|write]_done(). While - something can easily go wrong with the initial st_read() or - st_write(), an error inhibits any data from actually being - transferred. */ - -extern void transfer_integer (st_parameter_dt *, void *, int); -export_proto(transfer_integer); - -extern void transfer_integer_write (st_parameter_dt *, void *, int); -export_proto(transfer_integer_write); - -extern void transfer_real (st_parameter_dt *, void *, int); -export_proto(transfer_real); - -extern void transfer_real_write (st_parameter_dt *, void *, int); -export_proto(transfer_real_write); - -extern void transfer_logical (st_parameter_dt *, void *, int); -export_proto(transfer_logical); - -extern void transfer_logical_write (st_parameter_dt *, void *, int); -export_proto(transfer_logical_write); - -extern void transfer_character (st_parameter_dt *, void *, int); -export_proto(transfer_character); - -extern void transfer_character_write (st_parameter_dt *, void *, int); -export_proto(transfer_character_write); - -extern void transfer_character_wide (st_parameter_dt *, void *, int, int); -export_proto(transfer_character_wide); - -extern void transfer_character_wide_write (st_parameter_dt *, - void *, int, int); -export_proto(transfer_character_wide_write); - -extern void transfer_complex (st_parameter_dt *, void *, int); -export_proto(transfer_complex); - -extern void transfer_complex_write (st_parameter_dt *, void *, int); -export_proto(transfer_complex_write); - -extern void transfer_array (st_parameter_dt *, gfc_array_char *, int, - gfc_charlen_type); -export_proto(transfer_array); - -extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int, - gfc_charlen_type); -export_proto(transfer_array_write); - -static void us_read (st_parameter_dt *, int); -static void us_write (st_parameter_dt *, int); -static void next_record_r_unf (st_parameter_dt *, int); -static void next_record_w_unf (st_parameter_dt *, int); - -static const st_option advance_opt[] = { - {"yes", ADVANCE_YES}, - {"no", ADVANCE_NO}, - {NULL, 0} -}; - - -static const st_option decimal_opt[] = { - {"point", DECIMAL_POINT}, - {"comma", DECIMAL_COMMA}, - {NULL, 0} -}; - -static const st_option round_opt[] = { - {"up", ROUND_UP}, - {"down", ROUND_DOWN}, - {"zero", ROUND_ZERO}, - {"nearest", ROUND_NEAREST}, - {"compatible", ROUND_COMPATIBLE}, - {"processor_defined", ROUND_PROCDEFINED}, - {NULL, 0} -}; - - -static const st_option sign_opt[] = { - {"plus", SIGN_SP}, - {"suppress", SIGN_SS}, - {"processor_defined", SIGN_S}, - {NULL, 0} -}; - -static const st_option blank_opt[] = { - {"null", BLANK_NULL}, - {"zero", BLANK_ZERO}, - {NULL, 0} -}; - -static const st_option delim_opt[] = { - {"apostrophe", DELIM_APOSTROPHE}, - {"quote", DELIM_QUOTE}, - {"none", DELIM_NONE}, - {NULL, 0} -}; - -static const st_option pad_opt[] = { - {"yes", PAD_YES}, - {"no", PAD_NO}, - {NULL, 0} -}; - -typedef enum -{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL, - FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM -} -file_mode; - - -static file_mode -current_mode (st_parameter_dt *dtp) -{ - file_mode m; - - m = FORM_UNSPECIFIED; - - if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) - { - m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? - FORMATTED_DIRECT : UNFORMATTED_DIRECT; - } - else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) - { - m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? - FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL; - } - else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM) - { - m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? - FORMATTED_STREAM : UNFORMATTED_STREAM; - } - - return m; -} - - -/* Mid level data transfer statements. */ - -/* Read sequential file - internal unit */ - -static char * -read_sf_internal (st_parameter_dt *dtp, int * length) -{ - static char *empty_string[0]; - char *base; - int lorig; - - /* Zero size array gives internal unit len of 0. Nothing to read. */ - if (dtp->internal_unit_len == 0 - && dtp->u.p.current_unit->pad_status == PAD_NO) - hit_eof (dtp); - - /* If we have seen an eor previously, return a length of 0. The - caller is responsible for correctly padding the input field. */ - if (dtp->u.p.sf_seen_eor) - { - *length = 0; - /* Just return something that isn't a NULL pointer, otherwise the - caller thinks an error occured. */ - return (char*) empty_string; - } - - lorig = *length; - if (is_char4_unit(dtp)) - { - int i; - gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, - length); - base = fbuf_alloc (dtp->u.p.current_unit, lorig); - for (i = 0; i < *length; i++, p++) - base[i] = *p > 255 ? '?' : (unsigned char) *p; - } - else - base = mem_alloc_r (dtp->u.p.current_unit->s, length); - - if (unlikely (lorig > *length)) - { - hit_eof (dtp); - return NULL; - } - - dtp->u.p.current_unit->bytes_left -= *length; - - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) *length; - - return base; - -} - -/* When reading sequential formatted records we have a problem. We - don't know how long the line is until we read the trailing newline, - and we don't want to read too much. If we read too much, we might - have to do a physical seek backwards depending on how much data is - present, and devices like terminals aren't seekable and would cause - an I/O error. - - Given this, the solution is to read a byte at a time, stopping if - we hit the newline. For small allocations, we use a static buffer. - For larger allocations, we are forced to allocate memory on the - heap. Hopefully this won't happen very often. */ - -/* Read sequential file - external unit */ - -static char * -read_sf (st_parameter_dt *dtp, int * length) -{ - static char *empty_string[0]; - int q, q2; - int n, lorig, seen_comma; - - /* If we have seen an eor previously, return a length of 0. The - caller is responsible for correctly padding the input field. */ - if (dtp->u.p.sf_seen_eor) - { - *length = 0; - /* Just return something that isn't a NULL pointer, otherwise the - caller thinks an error occured. */ - return (char*) empty_string; - } - - n = seen_comma = 0; - - /* Read data into format buffer and scan through it. */ - lorig = *length; - - while (n < *length) - { - q = fbuf_getc (dtp->u.p.current_unit); - if (q == EOF) - break; - else if (q == '\n' || q == '\r') - { - /* Unexpected end of line. Set the position. */ - dtp->u.p.sf_seen_eor = 1; - - /* If we see an EOR during non-advancing I/O, we need to skip - the rest of the I/O statement. Set the corresponding flag. */ - if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) - dtp->u.p.eor_condition = 1; - - /* If we encounter a CR, it might be a CRLF. */ - if (q == '\r') /* Probably a CRLF */ - { - /* See if there is an LF. */ - q2 = fbuf_getc (dtp->u.p.current_unit); - if (q2 == '\n') - dtp->u.p.sf_seen_eor = 2; - else if (q2 != EOF) /* Oops, seek back. */ - fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR); - } - - /* Without padding, terminate the I/O statement without assigning - the value. With padding, the value still needs to be assigned, - so we can just continue with a short read. */ - if (dtp->u.p.current_unit->pad_status == PAD_NO) - { - generate_error (&dtp->common, LIBERROR_EOR, NULL); - return NULL; - } - - *length = n; - goto done; - } - /* Short circuit the read if a comma is found during numeric input. - The flag is set to zero during character reads so that commas in - strings are not ignored */ - else if (q == ',') - if (dtp->u.p.sf_read_comma == 1) - { - seen_comma = 1; - notify_std (&dtp->common, GFC_STD_GNU, - "Comma in formatted numeric read."); - break; - } - n++; - } - - *length = n; - - /* A short read implies we hit EOF, unless we hit EOR, a comma, or - some other stuff. Set the relevant flags. */ - if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma) - { - if (n > 0) - { - if (dtp->u.p.advance_status == ADVANCE_NO) - { - if (dtp->u.p.current_unit->pad_status == PAD_NO) - { - hit_eof (dtp); - return NULL; - } - else - dtp->u.p.eor_condition = 1; - } - else - dtp->u.p.at_eof = 1; - } - else if (dtp->u.p.advance_status == ADVANCE_NO - || dtp->u.p.current_unit->pad_status == PAD_NO - || dtp->u.p.current_unit->bytes_left - == dtp->u.p.current_unit->recl) - { - hit_eof (dtp); - return NULL; - } - } - - done: - - dtp->u.p.current_unit->bytes_left -= n; - - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) n; - - /* We can't call fbuf_getptr before the loop doing fbuf_getc, because - fbuf_getc might reallocate the buffer. So return current pointer - minus all the advances, which is n plus up to two characters - of newline or comma. */ - return fbuf_getptr (dtp->u.p.current_unit) - - n - dtp->u.p.sf_seen_eor - seen_comma; -} - - -/* Function for reading the next couple of bytes from the current - file, advancing the current position. We return FAILURE on end of record or - end of file. This function is only for formatted I/O, unformatted uses - read_block_direct. - - If the read is short, then it is because the current record does not - have enough data to satisfy the read request and the file was - opened with PAD=YES. The caller must assume tailing spaces for - short reads. */ - -void * -read_block_form (st_parameter_dt *dtp, int * nbytes) -{ - char *source; - int norig; - - if (!is_stream_io (dtp)) - { - if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes) - { - /* For preconnected units with default record length, set bytes left - to unit record length and proceed, otherwise error. */ - if (dtp->u.p.current_unit->unit_number == options.stdin_unit - && dtp->u.p.current_unit->recl == DEFAULT_RECL) - dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; - else - { - if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO) - && !is_internal_unit (dtp)) - { - /* Not enough data left. */ - generate_error (&dtp->common, LIBERROR_EOR, NULL); - return NULL; - } - } - - if (unlikely (dtp->u.p.current_unit->bytes_left == 0 - && !is_internal_unit(dtp))) - { - hit_eof (dtp); - return NULL; - } - - *nbytes = dtp->u.p.current_unit->bytes_left; - } - } - - if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && - (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL || - dtp->u.p.current_unit->flags.access == ACCESS_STREAM)) - { - if (is_internal_unit (dtp)) - source = read_sf_internal (dtp, nbytes); - else - source = read_sf (dtp, nbytes); - - dtp->u.p.current_unit->strm_pos += - (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor); - return source; - } - - /* If we reach here, we can assume it's direct access. */ - - dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes; - - norig = *nbytes; - source = fbuf_read (dtp->u.p.current_unit, nbytes); - fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR); - - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) *nbytes; - - if (norig != *nbytes) - { - /* Short read, this shouldn't happen. */ - if (!dtp->u.p.current_unit->pad_status == PAD_YES) - { - generate_error (&dtp->common, LIBERROR_EOR, NULL); - source = NULL; - } - } - - dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes; - - return source; -} - - -/* Read a block from a character(kind=4) internal unit, to be transferred into - a character(kind=4) variable. Note: Portions of this code borrowed from - read_sf_internal. */ -void * -read_block_form4 (st_parameter_dt *dtp, int * nbytes) -{ - static gfc_char4_t *empty_string[0]; - gfc_char4_t *source; - int lorig; - - if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes) - *nbytes = dtp->u.p.current_unit->bytes_left; - - /* Zero size array gives internal unit len of 0. Nothing to read. */ - if (dtp->internal_unit_len == 0 - && dtp->u.p.current_unit->pad_status == PAD_NO) - hit_eof (dtp); - - /* If we have seen an eor previously, return a length of 0. The - caller is responsible for correctly padding the input field. */ - if (dtp->u.p.sf_seen_eor) - { - *nbytes = 0; - /* Just return something that isn't a NULL pointer, otherwise the - caller thinks an error occured. */ - return empty_string; - } - - lorig = *nbytes; - source = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, nbytes); - - if (unlikely (lorig > *nbytes)) - { - hit_eof (dtp); - return NULL; - } - - dtp->u.p.current_unit->bytes_left -= *nbytes; - - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) *nbytes; - - return source; -} - - -/* Reads a block directly into application data space. This is for - unformatted files. */ - -static void -read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes) -{ - ssize_t to_read_record; - ssize_t have_read_record; - ssize_t to_read_subrecord; - ssize_t have_read_subrecord; - int short_record; - - if (is_stream_io (dtp)) - { - have_read_record = sread (dtp->u.p.current_unit->s, buf, - nbytes); - if (unlikely (have_read_record < 0)) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return; - } - - dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record; - - if (unlikely ((ssize_t) nbytes != have_read_record)) - { - /* Short read, e.g. if we hit EOF. For stream files, - we have to set the end-of-file condition. */ - hit_eof (dtp); - } - return; - } - - if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) - { - if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes) - { - short_record = 1; - to_read_record = dtp->u.p.current_unit->bytes_left; - nbytes = to_read_record; - } - else - { - short_record = 0; - to_read_record = nbytes; - } - - dtp->u.p.current_unit->bytes_left -= to_read_record; - - to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record); - if (unlikely (to_read_record < 0)) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return; - } - - if (to_read_record != (ssize_t) nbytes) - { - /* Short read, e.g. if we hit EOF. Apparently, we read - more than was written to the last record. */ - return; - } - - if (unlikely (short_record)) - { - generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); - } - return; - } - - /* Unformatted sequential. We loop over the subrecords, reading - until the request has been fulfilled or the record has run out - of continuation subrecords. */ - - /* Check whether we exceed the total record length. */ - - if (dtp->u.p.current_unit->flags.has_recl - && ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)) - { - to_read_record = dtp->u.p.current_unit->bytes_left; - short_record = 1; - } - else - { - to_read_record = nbytes; - short_record = 0; - } - have_read_record = 0; - - while(1) - { - if (dtp->u.p.current_unit->bytes_left_subrecord - < (gfc_offset) to_read_record) - { - to_read_subrecord = dtp->u.p.current_unit->bytes_left_subrecord; - to_read_record -= to_read_subrecord; - } - else - { - to_read_subrecord = to_read_record; - to_read_record = 0; - } - - dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord; - - have_read_subrecord = sread (dtp->u.p.current_unit->s, - buf + have_read_record, to_read_subrecord); - if (unlikely (have_read_subrecord < 0)) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return; - } - - have_read_record += have_read_subrecord; - - if (unlikely (to_read_subrecord != have_read_subrecord)) - { - /* Short read, e.g. if we hit EOF. This means the record - structure has been corrupted, or the trailing record - marker would still be present. */ - - generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL); - return; - } - - if (to_read_record > 0) - { - if (likely (dtp->u.p.current_unit->continued)) - { - next_record_r_unf (dtp, 0); - us_read (dtp, 1); - } - else - { - /* Let's make sure the file position is correctly pre-positioned - for the next read statement. */ - - dtp->u.p.current_unit->current_record = 0; - next_record_r_unf (dtp, 0); - generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); - return; - } - } - else - { - /* Normal exit, the read request has been fulfilled. */ - break; - } - } - - dtp->u.p.current_unit->bytes_left -= have_read_record; - if (unlikely (short_record)) - { - generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); - return; - } - return; -} - - -/* Function for writing a block of bytes to the current file at the - current position, advancing the file pointer. We are given a length - and return a pointer to a buffer that the caller must (completely) - fill in. Returns NULL on error. */ - -void * -write_block (st_parameter_dt *dtp, int length) -{ - char *dest; - - if (!is_stream_io (dtp)) - { - if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length) - { - /* For preconnected units with default record length, set bytes left - to unit record length and proceed, otherwise error. */ - if (likely ((dtp->u.p.current_unit->unit_number - == options.stdout_unit - || dtp->u.p.current_unit->unit_number - == options.stderr_unit) - && dtp->u.p.current_unit->recl == DEFAULT_RECL)) - dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; - else - { - generate_error (&dtp->common, LIBERROR_EOR, NULL); - return NULL; - } - } - - dtp->u.p.current_unit->bytes_left -= (gfc_offset) length; - } - - if (is_internal_unit (dtp)) - { - if (dtp->common.unit) /* char4 internel unit. */ - { - gfc_char4_t *dest4; - dest4 = mem_alloc_w4 (dtp->u.p.current_unit->s, &length); - if (dest4 == NULL) - { - generate_error (&dtp->common, LIBERROR_END, NULL); - return NULL; - } - return dest4; - } - else - dest = mem_alloc_w (dtp->u.p.current_unit->s, &length); - - if (dest == NULL) - { - generate_error (&dtp->common, LIBERROR_END, NULL); - return NULL; - } - - if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE)) - generate_error (&dtp->common, LIBERROR_END, NULL); - } - else - { - dest = fbuf_alloc (dtp->u.p.current_unit, length); - if (dest == NULL) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return NULL; - } - } - - if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) length; - - dtp->u.p.current_unit->strm_pos += (gfc_offset) length; - - return dest; -} - - -/* High level interface to swrite(), taking care of errors. This is only - called for unformatted files. There are three cases to consider: - Stream I/O, unformatted direct, unformatted sequential. */ - -static try -write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) -{ - - ssize_t have_written; - ssize_t to_write_subrecord; - int short_record; - - /* Stream I/O. */ - - if (is_stream_io (dtp)) - { - have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); - if (unlikely (have_written < 0)) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return FAILURE; - } - - dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; - - return SUCCESS; - } - - /* Unformatted direct access. */ - - if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) - { - if (unlikely (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)) - { - generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL); - return FAILURE; - } - - if (buf == NULL && nbytes == 0) - return SUCCESS; - - have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); - if (unlikely (have_written < 0)) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return FAILURE; - } - - dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; - dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written; - - return SUCCESS; - } - - /* Unformatted sequential. */ - - have_written = 0; - - if (dtp->u.p.current_unit->flags.has_recl - && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left) - { - nbytes = dtp->u.p.current_unit->bytes_left; - short_record = 1; - } - else - { - short_record = 0; - } - - while (1) - { - - to_write_subrecord = - (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ? - (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes; - - dtp->u.p.current_unit->bytes_left_subrecord -= - (gfc_offset) to_write_subrecord; - - to_write_subrecord = swrite (dtp->u.p.current_unit->s, - buf + have_written, to_write_subrecord); - if (unlikely (to_write_subrecord < 0)) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return FAILURE; - } - - dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord; - nbytes -= to_write_subrecord; - have_written += to_write_subrecord; - - if (nbytes == 0) - break; - - next_record_w_unf (dtp, 1); - us_write (dtp, 1); - } - dtp->u.p.current_unit->bytes_left -= have_written; - if (unlikely (short_record)) - { - generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); - return FAILURE; - } - return SUCCESS; -} - - -/* Reverse memcpy - used for byte swapping. */ - -static void -reverse_memcpy (void *dest, const void *src, size_t n) -{ - char *d, *s; - size_t i; - - d = (char *) dest; - s = (char *) src + n - 1; - - /* Write with ascending order - this is likely faster - on modern architectures because of write combining. */ - for (i=0; i<n; i++) - *(d++) = *(s--); -} - - -/* Utility function for byteswapping an array, using the bswap - builtins if possible. dest and src can overlap completely, or then - they must point to separate objects; partial overlaps are not - allowed. */ - -static void -bswap_array (void *dest, const void *src, size_t size, size_t nelems) -{ - const char *ps; - char *pd; - - switch (size) - { - case 1: - break; - case 2: - for (size_t i = 0; i < nelems; i++) - ((uint16_t*)dest)[i] = __builtin_bswap16 (((uint16_t*)src)[i]); - break; - case 4: - for (size_t i = 0; i < nelems; i++) - ((uint32_t*)dest)[i] = __builtin_bswap32 (((uint32_t*)src)[i]); - break; - case 8: - for (size_t i = 0; i < nelems; i++) - ((uint64_t*)dest)[i] = __builtin_bswap64 (((uint64_t*)src)[i]); - break; - case 12: - ps = src; - pd = dest; - for (size_t i = 0; i < nelems; i++) - { - uint32_t tmp; - memcpy (&tmp, ps, 4); - *(uint32_t*)pd = __builtin_bswap32 (*(uint32_t*)(ps + 8)); - *(uint32_t*)(pd + 4) = __builtin_bswap32 (*(uint32_t*)(ps + 4)); - *(uint32_t*)(pd + 8) = __builtin_bswap32 (tmp); - ps += size; - pd += size; - } - break; - case 16: - ps = src; - pd = dest; - for (size_t i = 0; i < nelems; i++) - { - uint64_t tmp; - memcpy (&tmp, ps, 8); - *(uint64_t*)pd = __builtin_bswap64 (*(uint64_t*)(ps + 8)); - *(uint64_t*)(pd + 8) = __builtin_bswap64 (tmp); - ps += size; - pd += size; - } - break; - default: - pd = dest; - if (dest != src) - { - ps = src; - for (size_t i = 0; i < nelems; i++) - { - reverse_memcpy (pd, ps, size); - ps += size; - pd += size; - } - } - else - { - /* In-place byte swap. */ - for (size_t i = 0; i < nelems; i++) - { - char tmp, *low = pd, *high = pd + size - 1; - for (size_t j = 0; j < size/2; j++) - { - tmp = *low; - *low = *high; - *high = tmp; - low++; - high--; - } - pd += size; - } - } - } -} - - -/* 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 (type == BT_CHARACTER) - size *= GFC_SIZE_OF_CHAR_KIND(kind); - read_block_direct (dtp, dest, size * nelems); - - if (unlikely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_SWAP) - && kind != 1) - { - /* Handle wide chracters. */ - if (type == BT_CHARACTER) - { - nelems *= size; - size = kind; - } - - /* Break up complex into its constituent reals. */ - else if (type == BT_COMPLEX) - { - nelems *= 2; - size /= 2; - } - bswap_array (dest, dest, size, nelems); - } -} - - -/* 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 - { -#define BSWAP_BUFSZ 512 - char buffer[BSWAP_BUFSZ]; - char *p; - size_t nrem; - - 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. */ - - nrem = nelems; - do - { - size_t nc; - if (size * nrem > BSWAP_BUFSZ) - nc = BSWAP_BUFSZ / size; - else - nc = nrem; - - bswap_array (buffer, p, size, nc); - write_buf (dtp, buffer, size * nc); - p += size * nc; - nrem -= nc; - } - while (nrem > 0); - } -} - - -/* 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) -{ -#define BUFLEN 100 - char buffer[BUFLEN]; - - if (actual == expected) - return 0; - - /* Adjust item_count before emitting error message. */ - snprintf (buffer, BUFLEN, - "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; -} - - -static int -require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f) -{ -#define BUFLEN 100 - char buffer[BUFLEN]; - - if (actual == BT_INTEGER || actual == BT_REAL || actual == BT_COMPLEX) - return 0; - - /* Adjust item_count before emitting error message. */ - snprintf (buffer, BUFLEN, - "Expected numeric type for item %d in formatted transfer, got %s", - 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_numeric_type (dtp, type, f)) - return; - if (!(compile_options.allow_std & GFC_STD_F2008) - && 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_numeric_type (dtp, type, f)) - return; - if (!(compile_options.allow_std & GFC_STD_F2008) - && 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_numeric_type (dtp, type, f)) - return; - if (!(compile_options.allow_std & GFC_STD_F2008) - && 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_numeric_type (dtp, type, f)) - return; - if (!(compile_options.allow_std & GFC_STD_F2008) - && 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_numeric_type (dtp, type, f)) - return; - if (!(compile_options.allow_std & GFC_STD_F2008) - && 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_numeric_type (dtp, type, f)) - return; - if (!(compile_options.allow_std & GFC_STD_F2008) - && 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 - { - uint32_t u32; - uint64_t u64; - switch (nr) - { - case sizeof(GFC_INTEGER_4): - memcpy (&u32, &i, sizeof (u32)); - u32 = __builtin_bswap32 (u32); - memcpy (&i4, &u32, sizeof (i4)); - i = i4; - break; - - case sizeof(GFC_INTEGER_8): - memcpy (&u64, &i, sizeof (u64)); - u64 = __builtin_bswap64 (u64); - memcpy (&i8, &u64, 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 >= ssize (dtp->u.p.current_unit->s)) - { - generate_error (&dtp->common, LIBERROR_BAD_OPTION, - "Non-existing record number"); - return; - } - - /* Position the file. */ - if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1) - * dtp->u.p.current_unit->recl, SEEK_SET) < 0) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return; - } - - /* TODO: This is required to maintain compatibility between - 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */ - - if (is_stream_io (dtp)) - dtp->u.p.current_unit->strm_pos = dtp->rec; - - /* TODO: Un-comment this code when ABI changes from 4.3. - if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM) - { - generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, - "Record number not allowed for stream access " - "data transfer"); - return; - } */ - } - - /* Bugware for badly written mixed C-Fortran I/O. */ - if (!is_internal_unit (dtp)) - flush_if_preconnected(dtp->u.p.current_unit->s); - - dtp->u.p.current_unit->mode = dtp->u.p.mode; - - /* Set the maximum position reached from the previous I/O operation. This - could be greater than zero from a previous non-advancing write. */ - dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos; - - pre_position (dtp); - - - /* Set up the subroutine that will handle the transfers. */ - - if (read_flag) - { - if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) - dtp->u.p.transfer = unformatted_read; - else - { - if ((cf & IOPARM_DT_LIST_FORMAT) != 0) - { - dtp->u.p.last_char = EOF - 1; - dtp->u.p.transfer = list_formatted_read; - } - else - dtp->u.p.transfer = formatted_transfer; - } - } - else - { - if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) - dtp->u.p.transfer = unformatted_write; - else - { - if ((cf & IOPARM_DT_LIST_FORMAT) != 0) - dtp->u.p.transfer = list_formatted_write; - else - dtp->u.p.transfer = formatted_transfer; - } - } - - /* Make sure that we don't do a read after a nonadvancing write. */ - - if (read_flag) - { - if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp)) - { - generate_error (&dtp->common, LIBERROR_BAD_OPTION, - "Cannot READ after a nonadvancing WRITE"); - return; - } - } - else - { - if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar) - dtp->u.p.current_unit->read_bad = 1; - } - - /* Start the data transfer if we are doing a formatted transfer. */ - if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED - && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0) - && dtp->u.p.ionml == NULL) - formatted_transfer (dtp, 0, NULL, 0, 0, 1); -} - -/* Initialize an array_loop_spec given the array descriptor. The function - returns the index of the last element of the array, and also returns - starting record, where the first I/O goes to (necessary in case of - negative strides). */ - -gfc_offset -init_loop_spec (gfc_array_char *desc, array_loop_spec *ls, - gfc_offset *start_record) -{ - int rank = GFC_DESCRIPTOR_RANK(desc); - int i; - gfc_offset index; - int empty; - - empty = 0; - index = 1; - *start_record = 0; - - for (i=0; i<rank; i++) - { - ls[i].idx = GFC_DESCRIPTOR_LBOUND(desc,i); - ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i); - ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i); - ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i); - empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i) - < GFC_DESCRIPTOR_LBOUND(desc,i)); - - if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0) - { - index += (GFC_DESCRIPTOR_EXTENT(desc,i) - 1) - * GFC_DESCRIPTOR_STRIDE(desc,i); - } - else - { - index -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1) - * GFC_DESCRIPTOR_STRIDE(desc,i); - *start_record -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1) - * GFC_DESCRIPTOR_STRIDE(desc,i); - } - } - - if (empty) - return 0; - else - return index; -} - -/* Determine the index to the next record in an internal unit array by - by incrementing through the array_loop_spec. */ - -gfc_offset -next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished) -{ - int i, carry; - gfc_offset index; - - carry = 1; - index = 0; - - for (i = 0; i < dtp->u.p.current_unit->rank; i++) - { - if (carry) - { - ls[i].idx++; - if (ls[i].idx > ls[i].end) - { - ls[i].idx = ls[i].start; - carry = 1; - } - else - carry = 0; - } - index = index + (ls[i].idx - ls[i].start) * ls[i].step; - } - - *finished = carry; - - return index; -} - - - -/* Skip to the end of the current record, taking care of an optional - record marker of size bytes. If the file is not seekable, we - read chunks of size MAX_READ until we get to the right - position. */ - -static void -skip_record (st_parameter_dt *dtp, ssize_t bytes) -{ - ssize_t rlength, readb; - static const ssize_t MAX_READ = 4096; - char p[MAX_READ]; - - dtp->u.p.current_unit->bytes_left_subrecord += bytes; - if (dtp->u.p.current_unit->bytes_left_subrecord == 0) - return; - - /* 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) - { - /* Seeking failed, fall back to seeking 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; - } - return; - } - dtp->u.p.current_unit->bytes_left_subrecord = 0; -} - - -/* 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 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, - ssize (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; - - 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 - { - uint32_t u32; - uint64_t u64; - switch (len) - { - case sizeof (GFC_INTEGER_4): - buf4 = buf; - memcpy (&u32, &buf4, sizeof (u32)); - u32 = __builtin_bswap32 (u32); - return swrite (dtp->u.p.current_unit->s, &u32, len); - break; - - case sizeof (GFC_INTEGER_8): - buf8 = buf; - memcpy (&u64, &buf8, sizeof (u64)); - u64 = __builtin_bswap64 (u64); - return swrite (dtp->u.p.current_unit->s, &u64, 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; -} - - -/* 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 - < ssize (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)) - { - /* Since we have changed the position, set it to unspecified so - that INQUIRE(POSITION=) knows it needs to look into it. */ - if (done) - dtp->u.p.current_unit->flags.position = POSITION_UNSPECIFIED; - - 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*) xmalloc (sizeof (namelist_info)); - - nml->mem_pos = var_addr; - - nml->var_name = (char*) xmalloc (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*) - xmalloc (nml->var_rank * sizeof (descriptor_dimension)); - nml->ls = (array_loop_spec*) - xmalloc (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); -} - - -/* Once upon a time, a poor innocent Fortran program was reading a - file, when suddenly it hit the end-of-file (EOF). Unfortunately - the OS doesn't tell whether we're at the EOF or whether we already - went past it. Luckily our hero, libgfortran, keeps track of this. - Call this function when you detect an EOF condition. See Section - 9.10.2 in F2003. */ - -void -hit_eof (st_parameter_dt * dtp) -{ - dtp->u.p.current_unit->flags.position = POSITION_APPEND; - - if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) - switch (dtp->u.p.current_unit->endfile) - { - case NO_ENDFILE: - case AT_ENDFILE: - generate_error (&dtp->common, LIBERROR_END, NULL); - if (!is_internal_unit (dtp) && !dtp->u.p.namelist_mode) - { - dtp->u.p.current_unit->endfile = AFTER_ENDFILE; - dtp->u.p.current_unit->current_record = 0; - } - else - dtp->u.p.current_unit->endfile = AT_ENDFILE; - break; - - case AFTER_ENDFILE: - generate_error (&dtp->common, LIBERROR_ENDFILE, NULL); - dtp->u.p.current_unit->current_record = 0; - break; - } - else - { - /* Non-sequential files don't have an ENDFILE record, so we - can't be at AFTER_ENDFILE. */ - dtp->u.p.current_unit->endfile = AT_ENDFILE; - generate_error (&dtp->common, LIBERROR_END, NULL); - dtp->u.p.current_unit->current_record = 0; - } -} diff --git a/gcc-4.8.1/libgfortran/io/transfer128.c b/gcc-4.8.1/libgfortran/io/transfer128.c deleted file mode 100644 index 962a700b4..000000000 --- a/gcc-4.8.1/libgfortran/io/transfer128.c +++ /dev/null @@ -1,97 +0,0 @@ -/* Copyright (C) 2010-2013 Free Software Foundation, Inc. - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -/* Note: This file needs to be a separate translation unit (.o file) - to make sure that for static linkage, the libquad dependence only - occurs if needed. */ - -#include "io.h" - - -#if defined(GFC_REAL_16_IS_FLOAT128) - -/* The prototypes for the called procedures in transfer.c. */ - -extern void transfer_real (st_parameter_dt *, void *, int); -export_proto(transfer_real); - -extern void transfer_real_write (st_parameter_dt *, void *, int); -export_proto(transfer_real_write); - -extern void transfer_complex (st_parameter_dt *, void *, int); -export_proto(transfer_complex); - -extern void transfer_complex_write (st_parameter_dt *, void *, int); -export_proto(transfer_complex_write); - - -/* The prototypes for the procedures in this file. */ - -extern void transfer_real128 (st_parameter_dt *, void *, int); -export_proto(transfer_real128); - -extern void transfer_real128_write (st_parameter_dt *, void *, int); -export_proto(transfer_real128_write); - -extern void transfer_complex128 (st_parameter_dt *, void *, int); -export_proto(transfer_complex128); - -extern void transfer_complex128_write (st_parameter_dt *, void *, int); -export_proto(transfer_complex128_write); - - -/* Make sure that libquadmath is pulled in. The functions strtoflt128 - and quadmath_snprintf are weakly referrenced in convert_real and - write_float; the pointer assignment with USED attribute make sure - that there is a non-weakref dependence if the quadmath functions - are used. That avoids segfault when libquadmath is statically linked. */ -static void __attribute__((used)) *tmp1 = strtoflt128; -static void __attribute__((used)) *tmp2 = quadmath_snprintf; - -void -transfer_real128 (st_parameter_dt *dtp, void *p, int kind) -{ - transfer_real (dtp, p, kind); -} - - -void -transfer_real128_write (st_parameter_dt *dtp, void *p, int kind) -{ - transfer_real (dtp, p, kind); -} - - -void -transfer_complex128 (st_parameter_dt *dtp, void *p, int kind) -{ - transfer_complex (dtp, p, kind); -} - - -void -transfer_complex128_write (st_parameter_dt *dtp, void *p, int kind) -{ - transfer_complex_write (dtp, p, kind); -} -#endif diff --git a/gcc-4.8.1/libgfortran/io/unit.c b/gcc-4.8.1/libgfortran/io/unit.c deleted file mode 100644 index f8c1516e0..000000000 --- a/gcc-4.8.1/libgfortran/io/unit.c +++ /dev/null @@ -1,838 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - F2003 I/O support contributed by Jerry DeLisle - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "io.h" -#include "fbuf.h" -#include "format.h" -#include "unix.h" -#include <stdlib.h> -#include <string.h> - - -/* IO locking rules: - UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE. - Concurrent use of different units should be supported, so - each unit has its own lock, LOCK. - Open should be atomic with its reopening of units and list_read.c - in several places needs find_unit another unit while holding stdin - unit's lock, so it must be possible to acquire UNIT_LOCK while holding - some unit's lock. Therefore to avoid deadlocks, it is forbidden - to acquire unit's private locks while holding UNIT_LOCK, except - for freshly created units (where no other thread can get at their - address yet) or when using just trylock rather than lock operation. - In addition to unit's private lock each unit has a WAITERS counter - and CLOSED flag. WAITERS counter must be either only - atomically incremented/decremented in all places (if atomic builtins - are supported), or protected by UNIT_LOCK in all places (otherwise). - CLOSED flag must be always protected by unit's LOCK. - After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held, - WAITERS must be incremented to avoid concurrent close from freeing - the unit between unlocking UNIT_LOCK and acquiring unit's LOCK. - Unit freeing is always done under UNIT_LOCK. If close_unit sees any - WAITERS, it doesn't free the unit but instead sets the CLOSED flag - and the thread that decrements WAITERS to zero while CLOSED flag is - set is responsible for freeing it (while holding UNIT_LOCK). - flush_all_units operation is iterating over the unit tree with - increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to - flush each unit (and therefore needs the unit's LOCK held as well). - To avoid deadlocks, it just trylocks the LOCK and if unsuccessful, - remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires - unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with - the smallest UNIT_NUMBER above the last one flushed. - - If find_unit/find_or_create_unit/find_file/get_unit routines return - non-NULL, the returned unit has its private lock locked and when the - caller is done with it, it must call either unlock_unit or close_unit - on it. unlock_unit or close_unit must be always called only with the - private lock held. */ - -/* Subroutines related to units */ - -/* Unit number to be assigned when NEWUNIT is used in an OPEN statement. */ -#define GFC_FIRST_NEWUNIT -10 -static GFC_INTEGER_4 next_available_newunit = GFC_FIRST_NEWUNIT; - -#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 = xcalloc (1, 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 = xcalloc (1, 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 *) - xmalloc (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; - } - else - { - /* If we are not processing an array, adjust the unit record length not - to include trailing blanks for list-formatted reads. */ - if (dtp->u.p.mode == READING && !(dtp->common.flags & IOPARM_DT_HAS_FORMAT)) - { - if (dtp->common.unit == 0) - { - dtp->internal_unit_len = - string_len_trim (dtp->internal_unit_len, dtp->internal_unit); - iunit->recl = dtp->internal_unit_len; - } - else - { - dtp->internal_unit_len = - string_len_trim_char4 (dtp->internal_unit_len, - (const gfc_char4_t*) dtp->internal_unit); - iunit->recl = dtp->internal_unit_len; - } - } - } - - /* 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_UNSPECIFIED; - - /* 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) - { - free (dtp->u.p.current_unit->ls); - - 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 - - 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_UNSPECIFIED; - - u->recl = options.default_recl; - u->endfile = NO_ENDFILE; - - u->file_len = strlen (stdin_name); - u->file = xmalloc (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_UNSPECIFIED; - - u->recl = options.default_recl; - u->endfile = AT_ENDFILE; - - u->file_len = strlen (stdout_name); - u->file = xmalloc (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_UNSPECIFIED; - - u->recl = options.default_recl; - u->endfile = AT_ENDFILE; - - u->file_len = strlen (stderr_name); - u->file = xmalloc (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); - - 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); -} - - -/* High level interface to truncate a file, i.e. flush format buffers, - and generate an error or set some flags. 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); - } - - /* 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); - 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 *) xmalloc (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; - -#ifdef HAVE_SYNC_FETCH_AND_ADD - num = __sync_fetch_and_add (&next_available_newunit, -1); -#else - __gthread_mutex_lock (&unit_lock); - num = next_available_newunit--; - __gthread_mutex_unlock (&unit_lock); -#endif - - /* Do not allow NEWUNIT numbers to wrap. */ - if (num > GFC_FIRST_NEWUNIT) - { - generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted"); - return 0; - } - return num; -} diff --git a/gcc-4.8.1/libgfortran/io/unix.c b/gcc-4.8.1/libgfortran/io/unix.c deleted file mode 100644 index 8b9d7a773..000000000 --- a/gcc-4.8.1/libgfortran/io/unix.c +++ /dev/null @@ -1,1884 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - F2003 I/O support contributed by Jerry DeLisle - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -/* Unix stream I/O module */ - -#include "io.h" -#include "unix.h" -#include <stdlib.h> -#include <limits.h> - -#include <unistd.h> -#include <sys/stat.h> -#include <fcntl.h> -#include <assert.h> - -#include <string.h> -#include <errno.h> - - -/* For mingw, we don't identify files by their inode number, but by a - 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */ -#ifdef __MINGW32__ - -#define WIN32_LEAN_AND_MEAN -#include <windows.h> - -#if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64 -#undef lseek -#define lseek _lseeki64 -#undef fstat -#define fstat _fstati64 -#undef stat -#define stat _stati64 -#endif - -#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 /* HAVE_WORKING_STAT */ -#endif /* __MINGW32__ */ - - -/* min macro that evaluates its arguments only once. */ -#ifdef min -#undef min -#endif - -#define min(a,b) \ - ({ typeof (a) _a = (a); \ - typeof (b) _b = (b); \ - _a < _b ? _a : _b; }) - -#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) - { - struct stat st; - return stat (path, &st); - } - - return 0; -} - -#undef access -#define access fallback_access -#endif - - -/* Fallback directory for creating temporary files. P_tmpdir is - defined on many POSIX platforms. */ -#ifndef P_tmpdir -#ifdef _P_tmpdir -#define P_tmpdir _P_tmpdir /* MinGW */ -#else -#define P_tmpdir "/tmp" -#endif -#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. */ - - 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 */ - - /* 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 gfc_offset -raw_size (unix_stream * s) -{ - struct stat statbuf; - int ret = fstat (s->fd, &statbuf); - if (ret == -1) - return ret; - if (S_ISREG (statbuf.st_mode)) - return statbuf.st_size; - else - return 0; -} - -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 const struct stream_vtable raw_vtable = { - .read = (void *) raw_read, - .write = (void *) raw_write, - .seek = (void *) raw_seek, - .tell = (void *) raw_tell, - .size = (void *) raw_size, - .trunc = (void *) raw_truncate, - .close = (void *) raw_close, - .flush = (void *) raw_flush -}; - -static int -raw_init (unix_stream * s) -{ - s->st.vptr = &raw_vtable; - - 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. Only supported for regular files. -*********************************************************************/ - -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->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; - - if (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->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->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; - if (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 buf_seek (s, 0, SEEK_CUR); -} - -static gfc_offset -buf_size (unix_stream * s) -{ - return s->file_length; -} - -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 const struct stream_vtable buf_vtable = { - .read = (void *) buf_read, - .write = (void *) buf_write, - .seek = (void *) buf_seek, - .tell = (void *) buf_tell, - .size = (void *) buf_size, - .trunc = (void *) buf_truncate, - .close = (void *) buf_close, - .flush = (void *) buf_flush -}; - -static int -buf_init (unix_stream * s) -{ - s->st.vptr = &buf_vtable; - - s->buffer = xmalloc (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(kind=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) -{ - free (s); - - return 0; -} - -static const struct stream_vtable mem_vtable = { - .read = (void *) mem_read, - .write = (void *) mem_write, - .seek = (void *) mem_seek, - .tell = (void *) mem_tell, - /* buf_size is not a typo, we just reuse an identical - implementation. */ - .size = (void *) buf_size, - .trunc = (void *) mem_truncate, - .close = (void *) mem_close, - .flush = (void *) mem_flush -}; - -static const struct stream_vtable mem4_vtable = { - .read = (void *) mem_read4, - .write = (void *) mem_write4, - .seek = (void *) mem_seek, - .tell = (void *) mem_tell, - /* buf_size is not a typo, we just reuse an identical - implementation. */ - .size = (void *) buf_size, - .trunc = (void *) mem_truncate, - .close = (void *) mem_close, - .flush = (void *) mem_flush -}; - -/********************************************************************* - 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 = xcalloc (1, sizeof (unix_stream)); - - s->buffer = base; - s->buffer_offset = offset; - - s->active = s->file_length = length; - - s->st.vptr = &mem_vtable; - - 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 = xcalloc (1, sizeof (unix_stream)); - - s->buffer = base; - s->buffer_offset = offset; - - s->active = s->file_length = length * sizeof (gfc_char4_t); - - s->st.vptr = &mem4_vtable; - - return (stream *) s; -} - - -/* fd_to_stream()-- Given an open file descriptor, build a stream - * around it. */ - -static stream * -fd_to_stream (int fd) -{ - struct stat statbuf; - unix_stream *s; - - s = xcalloc (1, sizeof (unix_stream)); - - s->fd = fd; - - /* Get the current length of the file. */ - - fstat (fd, &statbuf); - - s->st_dev = statbuf.st_dev; - s->st_ino = statbuf.st_ino; - s->file_length = statbuf.st_size; - - /* Only use buffered IO for regular files. */ - if (S_ISREG (statbuf.st_mode) - && !options.all_unbuffered - && !(options.unbuffered_preconnected && - (s->fd == STDIN_FILENO - || s->fd == STDOUT_FILENO - || s->fd == STDERR_FILENO))) - buf_init (s); - else - raw_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 EFAULT; - len = fstrlen (fstring, len); - if (len >= PATH_MAX) - return ENAMETOOLONG; - - memmove (cstring, fstring, len); - cstring[len] = '\0'; - - return 0; -} - - -/* Helper function for tempfile(). Tries to open a temporary file in - the directory specified by tempdir. If successful, the file name is - stored in fname and the descriptor returned. Returns -1 on - failure. */ - -static int -tempfile_open (const char *tempdir, char **fname) -{ - int fd; - const char *slash = "/"; -#if defined(HAVE_UMASK) && defined(HAVE_MKSTEMP) - mode_t mode_mask; -#endif - - if (!tempdir) - return -1; - - /* Check for the special case that tempdir ends with a slash or - backslash. */ - size_t tempdirlen = strlen (tempdir); - if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/' -#ifdef __MINGW32__ - || tempdir[tempdirlen - 1] == '\\' -#endif - ) - slash = ""; - - // Take care that the template is longer in the mktemp() branch. - char * template = xmalloc (tempdirlen + 23); - -#ifdef HAVE_MKSTEMP - snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX", - tempdir, slash); - -#ifdef HAVE_UMASK - /* Temporarily set the umask such that the file has 0600 permissions. */ - mode_mask = umask (S_IXUSR | S_IRWXG | S_IRWXO); -#endif - - fd = mkstemp (template); - -#ifdef HAVE_UMASK - (void) umask (mode_mask); -#endif - -#else /* HAVE_MKSTEMP */ - fd = -1; - int count = 0; - size_t slashlen = strlen (slash); - do - { - snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX", - tempdir, slash); - if (count > 0) - { - int c = count; - template[tempdirlen + slashlen + 13] = 'a' + (c% 26); - c /= 26; - template[tempdirlen + slashlen + 12] = 'a' + (c % 26); - c /= 26; - template[tempdirlen + slashlen + 11] = 'a' + (c % 26); - if (c >= 26) - break; - } - - if (!mktemp (template)) - { - errno = EEXIST; - count++; - continue; - } - -#if defined(HAVE_CRLF) && defined(O_BINARY) - fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY, - S_IRUSR | S_IWUSR); -#else - fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR); -#endif - } - while (fd == -1 && errno == EEXIST); -#endif /* HAVE_MKSTEMP */ - - *fname = template; - return fd; -} - - -/* 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 *fname; - int fd = -1; - - tempdir = secure_getenv ("TMPDIR"); - fd = tempfile_open (tempdir, &fname); -#ifdef __MINGW32__ - if (fd == -1) - { - 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); - fd = tempfile_open (tempdir, &fname); - } -#elif defined(__CYGWIN__) - if (fd == -1) - { - tempdir = secure_getenv ("TMP"); - fd = tempfile_open (tempdir, &fname); - } - if (fd == -1) - { - tempdir = secure_getenv ("TEMP"); - fd = tempfile_open (tempdir, &fname); - } -#endif - if (fd == -1) - fd = tempfile_open (P_tmpdir, &fname); - - opp->file = fname; - opp->file_len = strlen (fname); /* 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[min(PATH_MAX, opp->file_len + 1)]; - int mode; - int rwflag; - int crflag; - int fd; - int err; - - err = unpack_filename (path, opp->file, opp->file_len); - if (err) - { - errno = err; /* 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; -} - - -/* 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[min(PATH_MAX, len + 1)]; - struct stat 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 struct stat *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[min(PATH_MAX, file_len + 1)]; - struct stat st[1]; - gfc_unit *u; -#if defined(__MINGW32__) && !HAVE_WORKING_STAT - uint64_t id = 0ULL; -#endif - - if (unpack_filename (path, file, file_len)) - return NULL; - - if (stat (path, &st[0]) < 0) - return NULL; - -#if defined(__MINGW32__) && !HAVE_WORKING_STAT - id = id_from_path (path); -#endif - - __gthread_mutex_lock (&unit_lock); -retry: - u = find_file0 (unit_root, FIND_FILE0_ARGS); - if (u != NULL) - { - /* Fast path. */ - if (! __gthread_mutex_trylock (&u->lock)) - { - /* assert (u->closed == 0); */ - __gthread_mutex_unlock (&unit_lock); - return u; - } - - inc_waiting_locked (u); - } - __gthread_mutex_unlock (&unit_lock); - if (u != NULL) - { - __gthread_mutex_lock (&u->lock); - if (u->closed) - { - __gthread_mutex_lock (&unit_lock); - __gthread_mutex_unlock (&u->lock); - if (predec_waiting_locked (u) == 0) - free (u); - goto retry; - } - - dec_waiting_unlocked (u); - } - return u; -} - -static gfc_unit * -flush_all_units_1 (gfc_unit *u, int min_unit) -{ - while (u != NULL) - { - if (u->unit_number > min_unit) - { - gfc_unit *r = flush_all_units_1 (u->left, min_unit); - if (r != NULL) - return r; - } - if (u->unit_number >= min_unit) - { - if (__gthread_mutex_trylock (&u->lock)) - return u; - if (u->s) - sflush (u->s); - __gthread_mutex_unlock (&u->lock); - } - u = u->right; - } - return NULL; -} - -void -flush_all_units (void) -{ - gfc_unit *u; - int min_unit = 0; - - __gthread_mutex_lock (&unit_lock); - do - { - u = flush_all_units_1 (unit_root, min_unit); - if (u != NULL) - inc_waiting_locked (u); - __gthread_mutex_unlock (&unit_lock); - if (u == NULL) - return; - - __gthread_mutex_lock (&u->lock); - - min_unit = u->unit_number + 1; - - if (u->closed == 0) - { - sflush (u->s); - __gthread_mutex_lock (&unit_lock); - __gthread_mutex_unlock (&u->lock); - (void) predec_waiting_locked (u); - } - else - { - __gthread_mutex_lock (&unit_lock); - __gthread_mutex_unlock (&u->lock); - if (predec_waiting_locked (u) == 0) - free (u); - } - } - while (1); -} - - -/* delete_file()-- Given a unit structure, delete the file associated - * with the unit. Returns nonzero if something went wrong. */ - -int -delete_file (gfc_unit * u) -{ - char path[min(PATH_MAX, u->file_len + 1)]; - int err = unpack_filename (path, u->file, u->file_len); - - if (err) - { /* Shouldn't be possible */ - errno = err; - 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[min(PATH_MAX, file_len + 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[min(PATH_MAX, file_len + 1)]; - struct stat 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[min(PATH_MAX, len + 1)]; - struct stat statbuf; - - if (string == NULL || - unpack_filename (path, string, len) || stat (path, &statbuf) < 0) - return unknown; - - if (S_ISREG (statbuf.st_mode) || - S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode)) - return 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[min(PATH_MAX, len + 1)]; - struct stat statbuf; - - if (string == NULL || - unpack_filename (path, string, len) || stat (path, &statbuf) < 0) - return unknown; - - if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode)) - return 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[min(PATH_MAX, len + 1)]; - struct stat statbuf; - - if (string == NULL || - unpack_filename (path, string, len) || stat (path, &statbuf) < 0) - return unknown; - - if (S_ISREG (statbuf.st_mode) || - S_ISBLK (statbuf.st_mode) || - S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode)) - return 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[min(PATH_MAX, len + 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); -} - - -int -stream_isatty (stream *s) -{ - return isatty (((unix_stream *) s)->fd); -} - -int -stream_ttyname (stream *s __attribute__ ((unused)), - char * buf __attribute__ ((unused)), - size_t buflen __attribute__ ((unused))) -{ -#ifdef HAVE_TTYNAME_R - return ttyname_r (((unix_stream *) s)->fd, buf, buflen); -#elif defined HAVE_TTYNAME - char *p; - size_t plen; - p = ttyname (((unix_stream *) s)->fd); - if (!p) - return errno; - plen = strlen (p); - if (buflen < plen) - plen = buflen; - memcpy (buf, p, plen); - return 0; -#else - return ENOSYS; -#endif -} - - - - -/* How files are stored: This is an operating-system specific issue, - and therefore belongs here. There are three cases to consider. - - Direct Access: - Records are written as block of bytes corresponding to the record - length of the file. This goes for both formatted and unformatted - records. Positioning is done explicitly for each data transfer, - so positioning is not much of an issue. - - Sequential Formatted: - Records are separated by newline characters. The newline character - is prohibited from appearing in a string. If it does, this will be - messed up on the next read. End of file is also the end of a record. - - Sequential Unformatted: - In this case, we are merely copying bytes to and from main storage, - yet we need to keep track of varying record lengths. We adopt - the solution used by f2c. Each record contains a pair of length - markers: - - Length of record n in bytes - Data of record n - Length of record n in bytes - - Length of record n+1 in bytes - Data of record n+1 - Length of record n+1 in bytes - - The length is stored at the end of a record to allow backspacing to the - previous record. Between data transfer statements, the file pointer - is left pointing to the first length of the current record. - - ENDFILE records are never explicitly stored. - -*/ diff --git a/gcc-4.8.1/libgfortran/io/unix.h b/gcc-4.8.1/libgfortran/io/unix.h deleted file mode 100644 index bf59a8ee1..000000000 --- a/gcc-4.8.1/libgfortran/io/unix.h +++ /dev/null @@ -1,189 +0,0 @@ -/* Copyright (C) 2009-2013 Free Software Foundation, Inc. - Contributed by Janne Blomqvist - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#ifndef GFOR_UNIX_H -#define GFOR_UNIX_H - -#include "io.h" - -struct stream_vtable -{ - ssize_t (* const read) (struct stream *, void *, ssize_t); - ssize_t (* const write) (struct stream *, const void *, ssize_t); - gfc_offset (* const seek) (struct stream *, gfc_offset, int); - gfc_offset (* const tell) (struct stream *); - gfc_offset (* const size) (struct stream *); - /* Avoid keyword truncate due to AIX namespace collision. */ - int (* const trunc) (struct stream *, gfc_offset); - int (* const flush) (struct stream *); - int (* const close) (struct stream *); -}; - -struct stream -{ - const struct stream_vtable *vptr; -}; - -/* Inline functions for doing file I/O given a stream. */ -static inline ssize_t -sread (stream * s, void * buf, ssize_t nbyte) -{ - return s->vptr->read (s, buf, nbyte); -} - -static inline ssize_t -swrite (stream * s, const void * buf, ssize_t nbyte) -{ - return s->vptr->write (s, buf, nbyte); -} - -static inline gfc_offset -sseek (stream * s, gfc_offset offset, int whence) -{ - return s->vptr->seek (s, offset, whence); -} - -static inline gfc_offset -stell (stream * s) -{ - return s->vptr->tell (s); -} - -static inline gfc_offset -ssize (stream * s) -{ - return s->vptr->size (s); -} - -static inline int -struncate (stream * s, gfc_offset length) -{ - return s->vptr->trunc (s, length); -} - -static inline int -sflush (stream * s) -{ - return s->vptr->flush (s); -} - -static inline int -sclose (stream * s) -{ - return s->vptr->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 void flush_if_preconnected (stream *); -internal_proto(flush_if_preconnected); - -extern int stream_isatty (stream *); -internal_proto(stream_isatty); - -#ifndef TTY_NAME_MAX -#ifdef _POSIX_TTY_NAME_MAX -#define TTY_NAME_MAX _POSIX_TTY_NAME_MAX -#else -/* sysconf(_SC_TTY_NAME_MAX) = 32 which should be enough. */ -#define TTY_NAME_MAX 32 -#endif -#endif - -extern int stream_ttyname (stream *, char *, size_t); -internal_proto(stream_ttyname); - -extern int unpack_filename (char *, const char *, int); -internal_proto(unpack_filename); - - -#endif diff --git a/gcc-4.8.1/libgfortran/io/write.c b/gcc-4.8.1/libgfortran/io/write.c deleted file mode 100644 index f17528edc..000000000 --- a/gcc-4.8.1/libgfortran/io/write.c +++ /dev/null @@ -1,2006 +0,0 @@ -/* Copyright (C) 2002-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - Namelist output contributed by Paul Thomas - F2003 I/O support contributed by Jerry DeLisle - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "io.h" -#include "format.h" -#include "unix.h" -#include <assert.h> -#include <string.h> -#include <ctype.h> -#include <stdlib.h> -#include <stdbool.h> -#include <errno.h> -#define star_fill(p, n) memset(p, '*', n) - -typedef unsigned char uchar; - -/* Helper functions for character(kind=4) internal units. These are needed - by write_float.def. */ - -static void -memcpy4 (gfc_char4_t *dest, const char *source, int k) -{ - int j; - - const char *p = source; - for (j = 0; j < k; j++) - *dest++ = (gfc_char4_t) *p++; -} - -/* This include contains the heart and soul of formatted floating point. */ -#include "write_float.def" - -/* Write out default char4. */ - -static void -write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source, - int src_len, int w_len) -{ - char *p; - int j, k = 0; - gfc_char4_t c; - uchar d; - - /* Take care of preceding blanks. */ - if (w_len > src_len) - { - k = w_len - src_len; - p = write_block (dtp, k); - if (p == NULL) - return; - if (is_char4_unit (dtp)) - { - gfc_char4_t *p4 = (gfc_char4_t *) p; - memset4 (p4, ' ', k); - } - else - memset (p, ' ', k); - } - - /* Get ready to handle delimiters if needed. */ - switch (dtp->u.p.current_unit->delim_status) - { - case DELIM_APOSTROPHE: - d = '\''; - break; - case DELIM_QUOTE: - d = '"'; - break; - default: - d = ' '; - break; - } - - /* Now process the remaining characters, one at a time. */ - for (j = 0; j < src_len; j++) - { - c = source[j]; - if (is_char4_unit (dtp)) - { - gfc_char4_t *q; - /* Handle delimiters if any. */ - if (c == d && d != ' ') - { - p = write_block (dtp, 2); - if (p == NULL) - return; - q = (gfc_char4_t *) p; - *q++ = c; - } - else - { - p = write_block (dtp, 1); - if (p == NULL) - return; - q = (gfc_char4_t *) p; - } - *q = c; - } - else - { - /* Handle delimiters if any. */ - if (c == d && d != ' ') - { - p = write_block (dtp, 2); - if (p == NULL) - return; - *p++ = (uchar) c; - } - else - { - p = write_block (dtp, 1); - if (p == NULL) - return; - } - *p = c > 255 ? '?' : (uchar) c; - } - } -} - - -/* Write out UTF-8 converted from char4. */ - -static void -write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source, - int src_len, int w_len) -{ - char *p; - int j, k = 0; - gfc_char4_t c; - static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC }; - static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE }; - int nbytes; - uchar buf[6], d, *q; - - /* Take care of preceding blanks. */ - if (w_len > src_len) - { - k = w_len - src_len; - p = write_block (dtp, k); - if (p == NULL) - return; - memset (p, ' ', k); - } - - /* Get ready to handle delimiters if needed. */ - switch (dtp->u.p.current_unit->delim_status) - { - case DELIM_APOSTROPHE: - d = '\''; - break; - case DELIM_QUOTE: - d = '"'; - break; - default: - d = ' '; - break; - } - - /* Now process the remaining characters, one at a time. */ - for (j = k; j < src_len; j++) - { - c = source[j]; - if (c < 0x80) - { - /* Handle the delimiters if any. */ - if (c == d && d != ' ') - { - p = write_block (dtp, 2); - if (p == NULL) - return; - *p++ = (uchar) c; - } - else - { - p = write_block (dtp, 1); - if (p == NULL) - return; - } - *p = (uchar) c; - } - else - { - /* Convert to UTF-8 sequence. */ - nbytes = 1; - q = &buf[6]; - - do - { - *--q = ((c & 0x3F) | 0x80); - c >>= 6; - nbytes++; - } - while (c >= 0x3F || (c & limits[nbytes-1])); - - *--q = (c | masks[nbytes-1]); - - p = write_block (dtp, nbytes); - if (p == NULL) - return; - - while (q < &buf[6]) - *p++ = *q++; - } - } -} - - -void -write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len) -{ - int wlen; - char *p; - - wlen = f->u.string.length < 0 - || (f->format == FMT_G && f->u.string.length == 0) - ? len : f->u.string.length; - -#ifdef HAVE_CRLF - /* If this is formatted STREAM IO convert any embedded line feed characters - to CR_LF on systems that use that sequence for newlines. See F2003 - Standard sections 10.6.3 and 9.9 for further information. */ - if (is_stream_io (dtp)) - { - const char crlf[] = "\r\n"; - int i, q, bytes; - q = bytes = 0; - - /* Write out any padding if needed. */ - if (len < wlen) - { - p = write_block (dtp, wlen - len); - if (p == NULL) - return; - memset (p, ' ', wlen - len); - } - - /* Scan the source string looking for '\n' and convert it if found. */ - for (i = 0; i < wlen; i++) - { - if (source[i] == '\n') - { - /* Write out the previously scanned characters in the string. */ - if (bytes > 0) - { - p = write_block (dtp, bytes); - if (p == NULL) - return; - memcpy (p, &source[q], bytes); - q += bytes; - bytes = 0; - } - - /* Write out the CR_LF sequence. */ - q++; - p = write_block (dtp, 2); - if (p == NULL) - return; - memcpy (p, crlf, 2); - } - else - bytes++; - } - - /* Write out any remaining bytes if no LF was found. */ - if (bytes > 0) - { - p = write_block (dtp, bytes); - if (p == NULL) - return; - memcpy (p, &source[q], bytes); - } - } - else - { -#endif - p = write_block (dtp, wlen); - if (p == NULL) - return; - - if (unlikely (is_char4_unit (dtp))) - { - gfc_char4_t *p4 = (gfc_char4_t *) p; - if (wlen < len) - memcpy4 (p4, source, wlen); - else - { - memset4 (p4, ' ', wlen - len); - memcpy4 (p4 + wlen - len, source, len); - } - return; - } - - if (wlen < len) - memcpy (p, source, wlen); - else - { - memset (p, ' ', wlen - len); - memcpy (p + wlen - len, source, len); - } -#ifdef HAVE_CRLF - } -#endif -} - - -/* The primary difference between write_a_char4 and write_a is that we have to - deal with writing from the first byte of the 4-byte character and pay - attention to the most significant bytes. For ENCODING="default" write the - lowest significant byte. If the 3 most significant bytes contain - non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value - to the UTF-8 encoded string before writing out. */ - -void -write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len) -{ - int wlen; - gfc_char4_t *q; - - wlen = f->u.string.length < 0 - || (f->format == FMT_G && f->u.string.length == 0) - ? len : f->u.string.length; - - q = (gfc_char4_t *) source; -#ifdef HAVE_CRLF - /* If this is formatted STREAM IO convert any embedded line feed characters - to CR_LF on systems that use that sequence for newlines. See F2003 - Standard sections 10.6.3 and 9.9 for further information. */ - if (is_stream_io (dtp)) - { - const gfc_char4_t crlf[] = {0x000d,0x000a}; - int i, bytes; - gfc_char4_t *qq; - bytes = 0; - - /* Write out any padding if needed. */ - if (len < wlen) - { - char *p; - p = write_block (dtp, wlen - len); - if (p == NULL) - return; - memset (p, ' ', wlen - len); - } - - /* Scan the source string looking for '\n' and convert it if found. */ - qq = (gfc_char4_t *) source; - for (i = 0; i < wlen; i++) - { - if (qq[i] == '\n') - { - /* Write out the previously scanned characters in the string. */ - if (bytes > 0) - { - if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8) - write_utf8_char4 (dtp, q, bytes, 0); - else - write_default_char4 (dtp, q, bytes, 0); - bytes = 0; - } - - /* Write out the CR_LF sequence. */ - write_default_char4 (dtp, crlf, 2, 0); - } - else - bytes++; - } - - /* Write out any remaining bytes if no LF was found. */ - if (bytes > 0) - { - if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8) - write_utf8_char4 (dtp, q, bytes, 0); - else - write_default_char4 (dtp, q, bytes, 0); - } - } - else - { -#endif - if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8) - write_utf8_char4 (dtp, q, len, wlen); - else - write_default_char4 (dtp, q, len, wlen); -#ifdef HAVE_CRLF - } -#endif -} - - -static GFC_INTEGER_LARGEST -extract_int (const void *p, int len) -{ - GFC_INTEGER_LARGEST i = 0; - - if (p == NULL) - return i; - - switch (len) - { - case 1: - { - GFC_INTEGER_1 tmp; - memcpy ((void *) &tmp, p, len); - i = tmp; - } - break; - case 2: - { - GFC_INTEGER_2 tmp; - memcpy ((void *) &tmp, p, len); - i = tmp; - } - break; - case 4: - { - GFC_INTEGER_4 tmp; - memcpy ((void *) &tmp, p, len); - i = tmp; - } - break; - case 8: - { - GFC_INTEGER_8 tmp; - memcpy ((void *) &tmp, p, len); - i = tmp; - } - break; -#ifdef HAVE_GFC_INTEGER_16 - case 16: - { - GFC_INTEGER_16 tmp; - memcpy ((void *) &tmp, p, len); - i = tmp; - } - break; -#endif - default: - internal_error (NULL, "bad integer kind"); - } - - return i; -} - -static GFC_UINTEGER_LARGEST -extract_uint (const void *p, int len) -{ - GFC_UINTEGER_LARGEST i = 0; - - if (p == NULL) - return i; - - switch (len) - { - case 1: - { - GFC_INTEGER_1 tmp; - memcpy ((void *) &tmp, p, len); - i = (GFC_UINTEGER_1) tmp; - } - break; - case 2: - { - GFC_INTEGER_2 tmp; - memcpy ((void *) &tmp, p, len); - i = (GFC_UINTEGER_2) tmp; - } - break; - case 4: - { - GFC_INTEGER_4 tmp; - memcpy ((void *) &tmp, p, len); - i = (GFC_UINTEGER_4) tmp; - } - break; - case 8: - { - GFC_INTEGER_8 tmp; - memcpy ((void *) &tmp, p, len); - i = (GFC_UINTEGER_8) tmp; - } - break; -#ifdef HAVE_GFC_INTEGER_16 - case 10: - case 16: - { - GFC_INTEGER_16 tmp = 0; - memcpy ((void *) &tmp, p, len); - i = (GFC_UINTEGER_16) tmp; - } - break; -#endif - default: - internal_error (NULL, "bad integer kind"); - } - - return i; -} - - -void -write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len) -{ - char *p; - int wlen; - GFC_INTEGER_LARGEST n; - - wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w; - - p = write_block (dtp, wlen); - if (p == NULL) - return; - - n = extract_int (source, len); - - if (unlikely (is_char4_unit (dtp))) - { - gfc_char4_t *p4 = (gfc_char4_t *) p; - memset4 (p4, ' ', wlen -1); - p4[wlen - 1] = (n) ? 'T' : 'F'; - return; - } - - memset (p, ' ', wlen -1); - p[wlen - 1] = (n) ? 'T' : 'F'; -} - - -static void -write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n) -{ - int w, m, digits, nzero, nblank; - char *p; - - w = f->u.integer.w; - m = f->u.integer.m; - - /* Special case: */ - - if (m == 0 && n == 0) - { - if (w == 0) - w = 1; - - p = write_block (dtp, w); - if (p == NULL) - return; - if (unlikely (is_char4_unit (dtp))) - { - gfc_char4_t *p4 = (gfc_char4_t *) p; - memset4 (p4, ' ', w); - } - else - memset (p, ' ', w); - goto done; - } - - digits = strlen (q); - - /* Select a width if none was specified. The idea here is to always - print something. */ - - if (w == 0) - w = ((digits < m) ? m : digits); - - p = write_block (dtp, w); - if (p == NULL) - return; - - nzero = 0; - if (digits < m) - nzero = m - digits; - - /* See if things will work. */ - - nblank = w - (nzero + digits); - - if (unlikely (is_char4_unit (dtp))) - { - gfc_char4_t *p4 = (gfc_char4_t *) p; - if (nblank < 0) - { - memset4 (p4, '*', w); - return; - } - - if (!dtp->u.p.no_leading_blank) - { - memset4 (p4, ' ', nblank); - q += nblank; - memset4 (p4, '0', nzero); - q += nzero; - memcpy4 (p4, q, digits); - } - else - { - memset4 (p4, '0', nzero); - q += nzero; - memcpy4 (p4, q, digits); - q += digits; - memset4 (p4, ' ', nblank); - dtp->u.p.no_leading_blank = 0; - } - return; - } - - if (nblank < 0) - { - star_fill (p, w); - goto done; - } - - if (!dtp->u.p.no_leading_blank) - { - memset (p, ' ', nblank); - p += nblank; - memset (p, '0', nzero); - p += nzero; - memcpy (p, q, digits); - } - else - { - memset (p, '0', nzero); - p += nzero; - memcpy (p, q, digits); - p += digits; - memset (p, ' ', nblank); - dtp->u.p.no_leading_blank = 0; - } - - done: - return; -} - -static void -write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source, - int len, - const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t)) -{ - GFC_INTEGER_LARGEST n = 0; - int w, m, digits, nsign, nzero, nblank; - char *p; - const char *q; - sign_t sign; - char itoa_buf[GFC_BTOA_BUF_SIZE]; - - w = f->u.integer.w; - m = f->format == FMT_G ? -1 : f->u.integer.m; - - n = extract_int (source, len); - - /* Special case: */ - if (m == 0 && n == 0) - { - if (w == 0) - w = 1; - - p = write_block (dtp, w); - if (p == NULL) - return; - if (unlikely (is_char4_unit (dtp))) - { - gfc_char4_t *p4 = (gfc_char4_t *) p; - memset4 (p4, ' ', w); - } - else - memset (p, ' ', w); - goto done; - } - - sign = calculate_sign (dtp, n < 0); - if (n < 0) - n = -n; - nsign = sign == S_NONE ? 0 : 1; - - /* conv calls itoa which sets the negative sign needed - by write_integer. The sign '+' or '-' is set below based on sign - calculated above, so we just point past the sign in the string - before proceeding to avoid double signs in corner cases. - (see PR38504) */ - q = conv (n, itoa_buf, sizeof (itoa_buf)); - if (*q == '-') - q++; - - digits = strlen (q); - - /* Select a width if none was specified. The idea here is to always - print something. */ - - if (w == 0) - w = ((digits < m) ? m : digits) + nsign; - - p = write_block (dtp, w); - if (p == NULL) - return; - - nzero = 0; - if (digits < m) - nzero = m - digits; - - /* See if things will work. */ - - nblank = w - (nsign + nzero + digits); - - if (unlikely (is_char4_unit (dtp))) - { - gfc_char4_t * p4 = (gfc_char4_t *) p; - if (nblank < 0) - { - memset4 (p4, '*', w); - goto done; - } - - memset4 (p4, ' ', nblank); - p4 += nblank; - - switch (sign) - { - case S_PLUS: - *p4++ = '+'; - break; - case S_MINUS: - *p4++ = '-'; - break; - case S_NONE: - break; - } - - memset4 (p4, '0', nzero); - p4 += nzero; - - memcpy4 (p4, q, digits); - return; - } - - if (nblank < 0) - { - star_fill (p, w); - goto done; - } - - memset (p, ' ', nblank); - p += nblank; - - switch (sign) - { - case S_PLUS: - *p++ = '+'; - break; - case S_MINUS: - *p++ = '-'; - break; - case S_NONE: - break; - } - - memset (p, '0', nzero); - p += nzero; - - memcpy (p, q, digits); - - done: - return; -} - - -/* Convert unsigned octal to ascii. */ - -static const char * -otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) -{ - char *p; - - assert (len >= GFC_OTOA_BUF_SIZE); - - if (n == 0) - return "0"; - - p = buffer + GFC_OTOA_BUF_SIZE - 1; - *p = '\0'; - - while (n != 0) - { - *--p = '0' + (n & 7); - n >>= 3; - } - - return p; -} - - -/* Convert unsigned binary to ascii. */ - -static const char * -btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) -{ - char *p; - - assert (len >= GFC_BTOA_BUF_SIZE); - - if (n == 0) - return "0"; - - p = buffer + GFC_BTOA_BUF_SIZE - 1; - *p = '\0'; - - while (n != 0) - { - *--p = '0' + (n & 1); - n >>= 1; - } - - return p; -} - -/* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed - to convert large reals with kind sizes that exceed the largest integer type - available on certain platforms. In these cases, byte by byte conversion is - performed. Endianess is taken into account. */ - -/* Conversion to binary. */ - -static const char * -btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) -{ - char *q; - int i, j; - - q = buffer; - if (big_endian) - { - const char *p = s; - for (i = 0; i < len; i++) - { - char c = *p; - - /* Test for zero. Needed by write_boz later. */ - if (*p != 0) - *n = 1; - - for (j = 0; j < 8; j++) - { - *q++ = (c & 128) ? '1' : '0'; - c <<= 1; - } - p++; - } - } - else - { - const char *p = s + len - 1; - for (i = 0; i < len; i++) - { - char c = *p; - - /* Test for zero. Needed by write_boz later. */ - if (*p != 0) - *n = 1; - - for (j = 0; j < 8; j++) - { - *q++ = (c & 128) ? '1' : '0'; - c <<= 1; - } - p--; - } - } - - *q = '\0'; - - if (*n == 0) - return "0"; - - /* Move past any leading zeros. */ - while (*buffer == '0') - buffer++; - - return buffer; - -} - -/* Conversion to octal. */ - -static const char * -otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) -{ - char *q; - int i, j, k; - uint8_t octet; - - q = buffer + GFC_OTOA_BUF_SIZE - 1; - *q = '\0'; - i = k = octet = 0; - - if (big_endian) - { - const char *p = s + len - 1; - char c = *p; - while (i < len) - { - /* Test for zero. Needed by write_boz later. */ - if (*p != 0) - *n = 1; - - for (j = 0; j < 3 && i < len; j++) - { - octet |= (c & 1) << j; - c >>= 1; - if (++k > 7) - { - i++; - k = 0; - c = *--p; - } - } - *--q = '0' + octet; - octet = 0; - } - } - else - { - const char *p = s; - char c = *p; - while (i < len) - { - /* Test for zero. Needed by write_boz later. */ - if (*p != 0) - *n = 1; - - for (j = 0; j < 3 && i < len; j++) - { - octet |= (c & 1) << j; - c >>= 1; - if (++k > 7) - { - i++; - k = 0; - c = *++p; - } - } - *--q = '0' + octet; - octet = 0; - } - } - - if (*n == 0) - return "0"; - - /* Move past any leading zeros. */ - while (*q == '0') - q++; - - return q; -} - -/* Conversion to hexidecimal. */ - -static const char * -ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) -{ - static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7', - '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'}; - - char *q; - uint8_t h, l; - int i; - - q = buffer; - - if (big_endian) - { - const char *p = s; - for (i = 0; i < len; i++) - { - /* Test for zero. Needed by write_boz later. */ - if (*p != 0) - *n = 1; - - h = (*p >> 4) & 0x0F; - l = *p++ & 0x0F; - *q++ = a[h]; - *q++ = a[l]; - } - } - else - { - const char *p = s + len - 1; - for (i = 0; i < len; i++) - { - /* Test for zero. Needed by write_boz later. */ - if (*p != 0) - *n = 1; - - h = (*p >> 4) & 0x0F; - l = *p-- & 0x0F; - *q++ = a[h]; - *q++ = a[l]; - } - } - - *q = '\0'; - - if (*n == 0) - return "0"; - - /* Move past any leading zeros. */ - while (*buffer == '0') - buffer++; - - return buffer; -} - -/* gfc_itoa()-- Integer to decimal conversion. - The itoa function is a widespread non-standard extension to standard - C, often declared in <stdlib.h>. Even though the itoa defined here - is a static function we take care not to conflict with any prior - non-static declaration. Hence the 'gfc_' prefix, which is normally - reserved for functions with external linkage. */ - -static const char * -gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len) -{ - int negative; - char *p; - GFC_UINTEGER_LARGEST t; - - assert (len >= GFC_ITOA_BUF_SIZE); - - if (n == 0) - return "0"; - - negative = 0; - t = n; - if (n < 0) - { - negative = 1; - t = -n; /*must use unsigned to protect from overflow*/ - } - - p = buffer + GFC_ITOA_BUF_SIZE - 1; - *p = '\0'; - - while (t != 0) - { - *--p = '0' + (t % 10); - t /= 10; - } - - if (negative) - *--p = '-'; - return p; -} - - -void -write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len) -{ - write_decimal (dtp, f, p, len, (void *) gfc_itoa); -} - - -void -write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len) -{ - const char *p; - char itoa_buf[GFC_BTOA_BUF_SIZE]; - GFC_UINTEGER_LARGEST n = 0; - - if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) - { - p = btoa_big (source, itoa_buf, len, &n); - write_boz (dtp, f, p, n); - } - else - { - n = extract_uint (source, len); - p = btoa (n, itoa_buf, sizeof (itoa_buf)); - write_boz (dtp, f, p, n); - } -} - - -void -write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len) -{ - const char *p; - char itoa_buf[GFC_OTOA_BUF_SIZE]; - GFC_UINTEGER_LARGEST n = 0; - - if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) - { - p = otoa_big (source, itoa_buf, len, &n); - write_boz (dtp, f, p, n); - } - else - { - n = extract_uint (source, len); - p = otoa (n, itoa_buf, sizeof (itoa_buf)); - write_boz (dtp, f, p, n); - } -} - -void -write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len) -{ - const char *p; - char itoa_buf[GFC_XTOA_BUF_SIZE]; - GFC_UINTEGER_LARGEST n = 0; - - if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) - { - p = ztoa_big (source, itoa_buf, len, &n); - write_boz (dtp, f, p, n); - } - else - { - n = extract_uint (source, len); - p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf)); - write_boz (dtp, f, p, n); - } -} - - -void -write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len) -{ - write_float (dtp, f, p, len, 0); -} - - -void -write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len) -{ - write_float (dtp, f, p, len, 0); -} - - -void -write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len) -{ - write_float (dtp, f, p, len, 0); -} - - -void -write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len) -{ - write_float (dtp, f, p, len, 0); -} - - -void -write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len) -{ - write_float (dtp, f, p, len, 0); -} - - -/* 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 = 16; - f->u.real.d = 9; - 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 = 30; - f->u.real.d = 21; - f->u.real.e = 4; - break; - case 16: - f->u.real.w = 45; - f->u.real.d = 36; - f->u.real.e = 4; - break; - default: - internal_error (&dtp->common, "bad real kind"); - break; - } -} - -/* Output a real number with default format. To guarantee that a - binary -> decimal -> binary roundtrip conversion recovers the - original value, IEEE 754-2008 requires 9, 17, 21 and 36 significant - digits for REAL kinds 4, 8, 10, and 16, respectively. Thus, we use - 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4 for - REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the - Fortran standard requires outputting an extra digit when the scale - factor is 1 and when the magnitude of the value is such that E - editing is used. However, gfortran compensates for this, and thus - for list formatted the same number of significant digits is - generated both when using F and E editing. */ - -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, 1); - dtp->u.p.scale_factor = org_scale; -} - -/* Similar to list formatted REAL output, for kPG0 where k > 0 we - compensate for the extra digit. */ - -void -write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d) -{ - fnode f; - int comp_d; - set_fnode_default (dtp, &f, length); - if (d > 0) - f.u.real.d = d; - - /* Compensate for extra digits when using scale factor, d is not - specified, and the magnitude is such that E editing is used. */ - if (dtp->u.p.scale_factor > 0 && d == 0) - comp_d = 1; - else - comp_d = 0; - dtp->u.p.g0_no_blanks = 1; - write_float (dtp, &f, source , length, comp_d); - 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; - size_t ext_name_len; - 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) - { - snprintf(rep_buff, NML_DIGITS, " %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_len = base_name_len + base_var_name_len - + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1; - ext_name = (char*)xmalloc (ext_name_len); - - 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++; - } - snprintf (ext_name + tot_len, ext_name_len - 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 = xmalloc (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 > GFC_DESCRIPTOR_UBOUND(obj,dim_i)) - { - obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i); - nml_carry = 1; - } - } - } - - /* Return a pointer beyond the furthest object accessed. */ - - return retval; -} - - -/* This is the entry function for namelist writes. It outputs the name - of the namelist and iterates through the namelist by calls to - nml_write_obj. The call below has dummys in the arguments used in - the treatment of derived types. */ - -void -namelist_write (st_parameter_dt *dtp) -{ - namelist_info * t1, *t2, *dummy = NULL; - index_type i; - index_type dummy_offset = 0; - char c; - char * dummy_name = NULL; - unit_delim tmp_delim = DELIM_UNSPECIFIED; - - /* Set the delimiter for namelist output. */ - tmp_delim = dtp->u.p.current_unit->delim_status; - - dtp->u.p.nml_delim = tmp_delim == DELIM_APOSTROPHE ? '\'' : '"'; - - /* Temporarily disable namelist delimters. */ - dtp->u.p.current_unit->delim_status = DELIM_NONE; - - write_character (dtp, "&", 1, 1); - - /* Write namelist name in upper case - f95 std. */ - for (i = 0 ;i < dtp->namelist_name_len ;i++ ) - { - c = toupper ((int) dtp->namelist_name[i]); - write_character (dtp, &c, 1 ,1); - } - - if (dtp->u.p.ionml != NULL) - { - t1 = dtp->u.p.ionml; - while (t1 != NULL) - { - t2 = t1; - t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name); - } - } - - namelist_write_newline (dtp); - write_character (dtp, " /", 1, 2); - /* Restore the original delimiter. */ - dtp->u.p.current_unit->delim_status = tmp_delim; -} - -#undef NML_DIGITS diff --git a/gcc-4.8.1/libgfortran/io/write_float.def b/gcc-4.8.1/libgfortran/io/write_float.def deleted file mode 100644 index 5b76fd596..000000000 --- a/gcc-4.8.1/libgfortran/io/write_float.def +++ /dev/null @@ -1,1268 +0,0 @@ -/* Copyright (C) 2007-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught - Write float code factoring to this file by Jerry DeLisle - F2003 I/O support contributed by Jerry DeLisle - -This file is part of the GNU Fortran runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3, or (at your option) -any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "config.h" - -typedef enum -{ S_NONE, S_MINUS, S_PLUS } -sign_t; - -/* Given a flag that indicates if a value is negative or not, return a - sign_t that gives the sign that we need to produce. */ - -static sign_t -calculate_sign (st_parameter_dt *dtp, int negative_flag) -{ - sign_t s = S_NONE; - - if (negative_flag) - s = S_MINUS; - else - switch (dtp->u.p.sign_status) - { - case SIGN_SP: /* Show sign. */ - s = S_PLUS; - break; - case SIGN_SS: /* Suppress sign. */ - s = S_NONE; - break; - case SIGN_S: /* Processor defined. */ - case SIGN_UNSPECIFIED: - s = options.optional_plus ? S_PLUS : S_NONE; - break; - } - - return s; -} - - -/* Determine the precision except for EN format. For G format, - determines an upper bound to be used for sizing the buffer. */ - -static int -determine_precision (st_parameter_dt * dtp, const fnode * f, int len) -{ - int precision = f->u.real.d; - - switch (f->format) - { - case FMT_F: - case FMT_G: - precision += dtp->u.p.scale_factor; - break; - case FMT_ES: - /* Scale factor has no effect on output. */ - break; - case FMT_E: - case FMT_D: - /* See F2008 10.7.2.3.3.6 */ - if (dtp->u.p.scale_factor <= 0) - precision += dtp->u.p.scale_factor - 1; - break; - default: - return -1; - } - - /* If the scale factor has a large negative value, we must do our - own rounding? Use ROUND='NEAREST', which should be what snprintf - is using as well. */ - if (precision < 0 && - (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED - || dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED)) - dtp->u.p.current_unit->round_status = ROUND_NEAREST; - - /* Add extra guard digits up to at least full precision when we do - our own rounding. */ - if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED - && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED) - { - precision += 2 * len + 4; - if (precision < 0) - precision = 0; - } - - return precision; -} - - -/* 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 nprinted, int precision, int sign_bit, bool zero_flag) -{ - char *out; - char *digits; - int e, w, d, p, i; - char expchar, rchar; - format_token ft; - /* 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 ndigits, edigits; - sign_t sign; - - ft = f->format; - w = f->u.real.w; - d = f->u.real.d; - p = dtp->u.p.scale_factor; - - 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); - - /* Calculate total number of digits. */ - if (ft == FMT_F) - ndigits = nprinted - 2; - else - ndigits = precision + 1; - - /* Read the exponent back in. */ - if (ft != FMT_F) - e = atoi (&buffer[ndigits + 3]) + 1; - else - e = 0; - - /* Make sure zero comes out as 0.0e0. */ - if (zero_flag) - e = 0; - - /* Normalize the fractional component. */ - if (ft != FMT_F) - { - buffer[2] = buffer[1]; - digits = &buffer[2]; - } - else - digits = &buffer[1]; - - /* Figure out where to place the decimal point. */ - switch (ft) - { - case FMT_F: - nbefore = ndigits - precision; - /* Make sure the decimal point is a '.'; depending on the - locale, this might not be the case otherwise. */ - digits[nbefore] = '.'; - if (p != 0) - { - if (p > 0) - { - - memmove (digits + nbefore, digits + nbefore + 1, p); - digits[nbefore + p] = '.'; - nbefore += p; - nafter = d - p; - if (nafter < 0) - nafter = 0; - nafter = d; - nzero = nzero_real = 0; - } - else /* p < 0 */ - { - if (nbefore + p >= 0) - { - nzero = 0; - memmove (digits + nbefore + p + 1, digits + nbefore + p, -p); - nbefore += p; - digits[nbefore] = '.'; - nafter = d; - } - else - { - nzero = -(nbefore + p); - memmove (digits + 1, digits, nbefore); - digits++; - nafter = d + nbefore; - nbefore = 0; - } - nzero_real = nzero; - if (nzero > d) - nzero = d; - } - } - else - { - nzero = nzero_real = 0; - nafter = d; - } - - while (digits[0] == '0' && nbefore > 0) - { - digits++; - nbefore--; - ndigits--; - } - - expchar = 0; - /* If we need to do rounding ourselves, get rid of the dot by - moving the fractional part. */ - if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED - && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED) - memmove (digits + nbefore, digits + nbefore + 1, ndigits - nbefore); - break; - - case FMT_E: - case FMT_D: - i = dtp->u.p.scale_factor; - if (d <= 0 && p == 0) - { - generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not " - "greater than zero in format specifier 'E' or 'D'"); - return FAILURE; - } - if (p <= -d || p >= 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 -= p; - if (p < 0) - { - nbefore = 0; - nzero = -p; - nafter = d + p; - } - else if (p > 0) - { - nbefore = p; - nzero = 0; - nafter = (d - p) + 1; - } - else /* p == 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"); - } - - if (zero_flag) - goto skip; - - /* Round the value. The value being rounded is an unsigned magnitude. */ - switch (dtp->u.p.current_unit->round_status) - { - /* For processor defined and unspecified rounding we use - snprintf to print the exact number of digits needed, and thus - let snprintf handle the rounding. On system claiming support - for IEEE 754, this ought to be round to nearest, ties to - even, corresponding to the Fortran ROUND='NEAREST'. */ - case ROUND_PROCDEFINED: - case ROUND_UNSPECIFIED: - case ROUND_ZERO: /* Do nothing and truncation occurs. */ - goto skip; - case ROUND_UP: - if (sign_bit) - goto skip; - goto updown; - case ROUND_DOWN: - if (!sign_bit) - goto skip; - goto updown; - 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. */ - /* The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */ - case ROUND_COMPATIBLE: - rchar = '5'; - goto do_rnd; - } - - updown: - - rchar = '0'; - if (w > 0 && d == 0 && p == 0) - nbefore = 1; - /* Scan for trailing zeros to see if we really need to round it. */ - for(i = nbefore + nafter; i < ndigits; i++) - { - if (digits[i] != '0') - goto do_rnd; - } - goto skip; - - 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) - { - i = ndigits = nbefore + nafter; - 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. */ - int hasdot = 0; - for (i = 0; i < ndigits + hasdot; i++) - { - if (digits[i] == '.') - hasdot = 1; - else 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 + hasdot) - { - 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 ? '.' : ','; - if (ft == FMT_F - && (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED - || dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED)) - digits++; - - /* 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--; - } - snprintf (buffer, size, "%+0*d", edigits, e); - 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 ? '.' : ','; - if (ft == FMT_F - && (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED - || dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED)) - digits++; - - /* 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--; - } - snprintf (buffer, size, "%+0*d", edigits, e); - memcpy (out, buffer, edigits); - } - - if (dtp->u.p.no_leading_blank) - { - out += edigits; - memset( out , ' ' , nblanks ); - dtp->u.p.no_leading_blank = 0; - } - - 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) || dtp->u.p.g0_no_blanks) - { - 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) \ -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 - - -/* Define a macro to build code for write_float. */ - - /* Note: Before output_float is called, snprintf is used to print to buffer the - number in the format +D.DDDDe+ddd. - - # 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 - - * prec 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. */ - - -#define TOKENPASTE(x, y) TOKENPASTE2(x, y) -#define TOKENPASTE2(x, y) x ## y - -#define DTOA(suff,prec,val) TOKENPASTE(DTOA2,suff)(prec,val) - -#define DTOA2(prec,val) \ -snprintf (buffer, size, "%+-#.*e", (prec), (val)) - -#define DTOA2L(prec,val) \ -snprintf (buffer, size, "%+-#.*Le", (prec), (val)) - - -#if defined(GFC_REAL_16_IS_FLOAT128) -#define DTOA2Q(prec,val) \ -__qmath_(quadmath_snprintf) (buffer, size, "%+-#.*Qe", (prec), (val)) -#endif - -#define FDTOA(suff,prec,val) TOKENPASTE(FDTOA2,suff)(prec,val) - -/* For F format, we print to the buffer with f format. */ -#define FDTOA2(prec,val) \ -snprintf (buffer, size, "%+-#.*f", (prec), (val)) - -#define FDTOA2L(prec,val) \ -snprintf (buffer, size, "%+-#.*Lf", (prec), (val)) - - -#if defined(GFC_REAL_16_IS_FLOAT128) -#define FDTOA2Q(prec,val) \ -__qmath_(quadmath_snprintf) (buffer, size, "%+-#.*Qf", \ - (prec), (val)) -#endif - - -/* 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 - for rounding modes adjustment, r, See Fortran F2008 10.7.5.2.2 - the asm volatile is required for 32-bit x86 platforms. */ - -#define OUTPUT_FLOAT_FMT_G(x,y) \ -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 comp_d) \ -{ \ - 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, r = 0.5;\ - int low, high, mid;\ - int ubound, lbound;\ - char *p, pad = ' ';\ - int save_scale_factor, nb = 0;\ - try result;\ - int nprinted, precision;\ -\ - save_scale_factor = dtp->u.p.scale_factor;\ -\ - switch (dtp->u.p.current_unit->round_status)\ - {\ - case ROUND_ZERO:\ - r = sign_bit ? 1.0 : 0.0;\ - break;\ - case ROUND_UP:\ - r = 1.0;\ - break;\ - case ROUND_DOWN:\ - r = 0.0;\ - break;\ - default:\ - break;\ - }\ -\ - rexp_d = calculate_exp_ ## x (-d);\ - if ((m > 0.0 && ((m < 0.1 - 0.1 * r * rexp_d) || (rexp_d * (m + r) >= 1.0)))\ - || ((m == 0.0) && !(compile_options.allow_std\ - & (GFC_STD_F2003 | GFC_STD_F2008))))\ - { \ - newf.format = FMT_E;\ - newf.u.real.w = w;\ - newf.u.real.d = d - comp_d;\ - newf.u.real.e = e;\ - nb = 0;\ - precision = determine_precision (dtp, &newf, x);\ - nprinted = DTOA(y,precision,m); \ - goto finish;\ - }\ -\ - mid = 0;\ - low = 0;\ - high = d + 1;\ - lbound = 0;\ - ubound = d + 1;\ -\ - while (low <= high)\ - { \ - volatile GFC_REAL_ ## x temp;\ - mid = (low + high) / 2;\ -\ - temp = (calculate_exp_ ## x (mid - 1) * (1 - r * 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;\ - }\ - }\ -\ - nb = e <= 0 ? 4 : e + 2;\ - nb = nb >= w ? w - 1 : nb;\ - newf.format = FMT_F;\ - newf.u.real.w = w - nb;\ - newf.u.real.d = m == 0.0 ? d - 1 : -(mid - d - 1) ;\ - dtp->u.p.scale_factor = 0;\ - precision = determine_precision (dtp, &newf, x); \ - nprinted = FDTOA(y,precision,m); \ -\ - finish:\ - result = output_float (dtp, &newf, buffer, size, nprinted, precision,\ - sign_bit, zero_flag);\ - dtp->u.p.scale_factor = save_scale_factor;\ -\ -\ - 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,L) -#endif - -#ifdef HAVE_GFC_REAL_16 -# ifdef GFC_REAL_16_IS_FLOAT128 -OUTPUT_FLOAT_FMT_G(16,Q) -#else -OUTPUT_FLOAT_FMT_G(16,L) -#endif -#endif - -#undef OUTPUT_FLOAT_FMT_G - - -/* EN format is tricky since the number of significant digits depends - on the magnitude. Solve it by first printing a temporary value and - figure out the number of significant digits from the printed - exponent. */ - -#define EN_PREC(x,y)\ -{\ - GFC_REAL_ ## x tmp; \ - tmp = * (GFC_REAL_ ## x *)source; \ - if (isfinite (tmp)) \ - nprinted = DTOA(y,0,tmp); \ - else\ - nprinted = -1;\ -}\ - -static int -determine_en_precision (st_parameter_dt *dtp, const fnode *f, - const char *source, int len) -{ - int nprinted; - char buffer[10]; - const size_t size = 10; - - switch (len) - { - case 4: - EN_PREC(4,) - break; - - case 8: - EN_PREC(8,) - break; - -#ifdef HAVE_GFC_REAL_10 - case 10: - EN_PREC(10,L) - break; -#endif -#ifdef HAVE_GFC_REAL_16 - case 16: -# ifdef GFC_REAL_16_IS_FLOAT128 - EN_PREC(16,Q) -# else - EN_PREC(16,L) -# endif - break; -#endif - default: - internal_error (NULL, "bad real kind"); - } - - if (nprinted == -1) - return -1; - - int e = atoi (&buffer[5]); - int nbefore; /* digits before decimal point - 1. */ - if (e >= 0) - nbefore = e % 3; - else - { - nbefore = (-e) % 3; - if (nbefore != 0) - nbefore = 3 - nbefore; - } - int prec = f->u.real.d + nbefore; - if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED - && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED) - prec += 2 * len + 4; - return prec; -} - - -#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);\ - if (f->format == FMT_G)\ - output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \ - zero_flag, comp_d);\ - else\ - {\ - if (f->format == FMT_F)\ - nprinted = FDTOA(y,precision,tmp); \ - else\ - nprinted = DTOA(y,precision,tmp); \ - output_float (dtp, f, buffer, size, nprinted, precision,\ - sign_bit, zero_flag);\ - }\ -}\ - -/* Output a real number according to its format. */ - -static void -write_float (st_parameter_dt *dtp, const fnode *f, const char *source, \ - int len, int comp_d) -{ - int sign_bit, nprinted; - int precision; /* Precision for snprintf call. */ - bool zero_flag; - - if (f->format != FMT_EN) - precision = determine_precision (dtp, f, len); - else - precision = determine_en_precision (dtp, f, source, len); - - /* 4932 is the maximum exponent of long double and quad precision, 3 - extra characters for the sign, the decimal point, and the - trailing null, and finally some extra digits depending on the - requested precision. */ - const size_t size = 4932 + 3 + precision; - char buffer[size]; - - 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"); - } -} |