/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. Contributed by Andy Vaught Namelist transfer functions contributed by Paul Thomas F2003 I/O support contributed by Jerry DeLisle This file is part of the GNU Fortran runtime library (libgfortran). Libgfortran is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3, or (at your option) any later version. Libgfortran is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. Under Section 7 of GPL version 3, you are granted additional permissions described in the GCC Runtime Library Exception, version 3.1, as published by the Free Software Foundation. You should have received a copy of the GNU General Public License and a copy of the GCC Runtime Library Exception along with this program; see the files COPYING3 and COPYING.RUNTIME respectively. If not, see . */ /* transfer.c -- Top level handling of data transfer statements. */ #include "io.h" #include "fbuf.h" #include "format.h" #include "unix.h" #include #include #include #include /* Calling conventions: Data transfer statements are unlike other library calls in that they extend over several calls. The first call is always a call to st_read() or st_write(). These subroutines return no status unless a namelist read or write is being done, in which case there is the usual status. No further calls are necessary in this case. For other sorts of data transfer, there are zero or more data transfer statement that depend on the format of the data transfer statement. For READ (and for backwards compatibily: for WRITE), one has transfer_integer transfer_logical transfer_character transfer_character_wide transfer_real transfer_complex transfer_real128 transfer_complex128 and for WRITE transfer_integer_write transfer_logical_write transfer_character_write transfer_character_wide_write transfer_real_write transfer_complex_write transfer_real128_write transfer_complex128_write These subroutines do not return status. The *128 functions are in the file transfer128.c. The last call is a call to st_[read|write]_done(). While something can easily go wrong with the initial st_read() or st_write(), an error inhibits any data from actually being transferred. */ extern void transfer_integer (st_parameter_dt *, void *, int); export_proto(transfer_integer); extern void transfer_integer_write (st_parameter_dt *, void *, int); export_proto(transfer_integer_write); extern void transfer_real (st_parameter_dt *, void *, int); export_proto(transfer_real); extern void transfer_real_write (st_parameter_dt *, void *, int); export_proto(transfer_real_write); extern void transfer_logical (st_parameter_dt *, void *, int); export_proto(transfer_logical); extern void transfer_logical_write (st_parameter_dt *, void *, int); export_proto(transfer_logical_write); extern void transfer_character (st_parameter_dt *, void *, int); export_proto(transfer_character); extern void transfer_character_write (st_parameter_dt *, void *, int); export_proto(transfer_character_write); extern void transfer_character_wide (st_parameter_dt *, void *, int, int); export_proto(transfer_character_wide); extern void transfer_character_wide_write (st_parameter_dt *, void *, int, int); export_proto(transfer_character_wide_write); extern void transfer_complex (st_parameter_dt *, void *, int); export_proto(transfer_complex); extern void transfer_complex_write (st_parameter_dt *, void *, int); export_proto(transfer_complex_write); extern void transfer_array (st_parameter_dt *, gfc_array_char *, int, gfc_charlen_type); export_proto(transfer_array); extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int, gfc_charlen_type); export_proto(transfer_array_write); static void us_read (st_parameter_dt *, int); static void us_write (st_parameter_dt *, int); static void next_record_r_unf (st_parameter_dt *, int); static void next_record_w_unf (st_parameter_dt *, int); static const st_option advance_opt[] = { {"yes", ADVANCE_YES}, {"no", ADVANCE_NO}, {NULL, 0} }; static const st_option decimal_opt[] = { {"point", DECIMAL_POINT}, {"comma", DECIMAL_COMMA}, {NULL, 0} }; static const st_option round_opt[] = { {"up", ROUND_UP}, {"down", ROUND_DOWN}, {"zero", ROUND_ZERO}, {"nearest", ROUND_NEAREST}, {"compatible", ROUND_COMPATIBLE}, {"processor_defined", ROUND_PROCDEFINED}, {NULL, 0} }; static const st_option sign_opt[] = { {"plus", SIGN_SP}, {"suppress", SIGN_SS}, {"processor_defined", SIGN_S}, {NULL, 0} }; static const st_option blank_opt[] = { {"null", BLANK_NULL}, {"zero", BLANK_ZERO}, {NULL, 0} }; static const st_option delim_opt[] = { {"apostrophe", DELIM_APOSTROPHE}, {"quote", DELIM_QUOTE}, {"none", DELIM_NONE}, {NULL, 0} }; static const st_option pad_opt[] = { {"yes", PAD_YES}, {"no", PAD_NO}, {NULL, 0} }; typedef enum { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL, FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM } file_mode; static file_mode current_mode (st_parameter_dt *dtp) { file_mode m; m = FORM_UNSPECIFIED; if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? FORMATTED_DIRECT : UNFORMATTED_DIRECT; } else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) { m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL; } else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM) { m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? FORMATTED_STREAM : UNFORMATTED_STREAM; } return m; } /* Mid level data transfer statements. */ /* Read sequential file - internal unit */ static char * read_sf_internal (st_parameter_dt *dtp, int * length) { static char *empty_string[0]; char *base; int lorig; /* Zero size array gives internal unit len of 0. Nothing to read. */ if (dtp->internal_unit_len == 0 && dtp->u.p.current_unit->pad_status == PAD_NO) hit_eof (dtp); /* If we have seen an eor previously, return a length of 0. The caller is responsible for correctly padding the input field. */ if (dtp->u.p.sf_seen_eor) { *length = 0; /* Just return something that isn't a NULL pointer, otherwise the caller thinks an error occured. */ return (char*) empty_string; } lorig = *length; if (is_char4_unit(dtp)) { int i; gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, length); base = fbuf_alloc (dtp->u.p.current_unit, lorig); for (i = 0; i < *length; i++, p++) base[i] = *p > 255 ? '?' : (unsigned char) *p; } else base = mem_alloc_r (dtp->u.p.current_unit->s, length); if (unlikely (lorig > *length)) { hit_eof (dtp); return NULL; } dtp->u.p.current_unit->bytes_left -= *length; if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) dtp->u.p.size_used += (GFC_IO_INT) *length; return base; } /* When reading sequential formatted records we have a problem. We don't know how long the line is until we read the trailing newline, and we don't want to read too much. If we read too much, we might have to do a physical seek backwards depending on how much data is present, and devices like terminals aren't seekable and would cause an I/O error. Given this, the solution is to read a byte at a time, stopping if we hit the newline. For small allocations, we use a static buffer. For larger allocations, we are forced to allocate memory on the heap. Hopefully this won't happen very often. */ /* Read sequential file - external unit */ static char * read_sf (st_parameter_dt *dtp, int * length) { static char *empty_string[0]; int q, q2; int n, lorig, seen_comma; /* If we have seen an eor previously, return a length of 0. The caller is responsible for correctly padding the input field. */ if (dtp->u.p.sf_seen_eor) { *length = 0; /* Just return something that isn't a NULL pointer, otherwise the caller thinks an error occured. */ return (char*) empty_string; } n = seen_comma = 0; /* Read data into format buffer and scan through it. */ lorig = *length; while (n < *length) { q = fbuf_getc (dtp->u.p.current_unit); if (q == EOF) break; else if (q == '\n' || q == '\r') { /* Unexpected end of line. Set the position. */ dtp->u.p.sf_seen_eor = 1; /* If we see an EOR during non-advancing I/O, we need to skip the rest of the I/O statement. Set the corresponding flag. */ if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) dtp->u.p.eor_condition = 1; /* If we encounter a CR, it might be a CRLF. */ if (q == '\r') /* Probably a CRLF */ { /* See if there is an LF. */ q2 = fbuf_getc (dtp->u.p.current_unit); if (q2 == '\n') dtp->u.p.sf_seen_eor = 2; else if (q2 != EOF) /* Oops, seek back. */ fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR); } /* Without padding, terminate the I/O statement without assigning the value. With padding, the value still needs to be assigned, so we can just continue with a short read. */ if (dtp->u.p.current_unit->pad_status == PAD_NO) { generate_error (&dtp->common, LIBERROR_EOR, NULL); return NULL; } *length = n; goto done; } /* Short circuit the read if a comma is found during numeric input. The flag is set to zero during character reads so that commas in strings are not ignored */ else if (q == ',') if (dtp->u.p.sf_read_comma == 1) { seen_comma = 1; notify_std (&dtp->common, GFC_STD_GNU, "Comma in formatted numeric read."); break; } n++; } *length = n; /* A short read implies we hit EOF, unless we hit EOR, a comma, or some other stuff. Set the relevant flags. */ if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma) { if (n > 0) { if (dtp->u.p.advance_status == ADVANCE_NO) { if (dtp->u.p.current_unit->pad_status == PAD_NO) { hit_eof (dtp); return NULL; } else dtp->u.p.eor_condition = 1; } else dtp->u.p.at_eof = 1; } else if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.current_unit->pad_status == PAD_NO || dtp->u.p.current_unit->bytes_left == dtp->u.p.current_unit->recl) { hit_eof (dtp); return NULL; } } done: dtp->u.p.current_unit->bytes_left -= n; if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) dtp->u.p.size_used += (GFC_IO_INT) n; /* We can't call fbuf_getptr before the loop doing fbuf_getc, because fbuf_getc might reallocate the buffer. So return current pointer minus all the advances, which is n plus up to two characters of newline or comma. */ return fbuf_getptr (dtp->u.p.current_unit) - n - dtp->u.p.sf_seen_eor - seen_comma; } /* Function for reading the next couple of bytes from the current file, advancing the current position. We return FAILURE on end of record or end of file. This function is only for formatted I/O, unformatted uses read_block_direct. If the read is short, then it is because the current record does not have enough data to satisfy the read request and the file was opened with PAD=YES. The caller must assume tailing spaces for short reads. */ void * read_block_form (st_parameter_dt *dtp, int * nbytes) { char *source; int norig; if (!is_stream_io (dtp)) { if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes) { /* For preconnected units with default record length, set bytes left to unit record length and proceed, otherwise error. */ if (dtp->u.p.current_unit->unit_number == options.stdin_unit && dtp->u.p.current_unit->recl == DEFAULT_RECL) dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; else { if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO) && !is_internal_unit (dtp)) { /* Not enough data left. */ generate_error (&dtp->common, LIBERROR_EOR, NULL); return NULL; } } if (unlikely (dtp->u.p.current_unit->bytes_left == 0 && !is_internal_unit(dtp))) { hit_eof (dtp); return NULL; } *nbytes = dtp->u.p.current_unit->bytes_left; } } if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL || dtp->u.p.current_unit->flags.access == ACCESS_STREAM)) { if (is_internal_unit (dtp)) source = read_sf_internal (dtp, nbytes); else source = read_sf (dtp, nbytes); dtp->u.p.current_unit->strm_pos += (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor); return source; } /* If we reach here, we can assume it's direct access. */ dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes; norig = *nbytes; source = fbuf_read (dtp->u.p.current_unit, nbytes); fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR); if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) dtp->u.p.size_used += (GFC_IO_INT) *nbytes; if (norig != *nbytes) { /* Short read, this shouldn't happen. */ if (!dtp->u.p.current_unit->pad_status == PAD_YES) { generate_error (&dtp->common, LIBERROR_EOR, NULL); source = NULL; } } dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes; return source; } /* Read a block from a character(kind=4) internal unit, to be transferred into a character(kind=4) variable. Note: Portions of this code borrowed from read_sf_internal. */ void * read_block_form4 (st_parameter_dt *dtp, int * nbytes) { static gfc_char4_t *empty_string[0]; gfc_char4_t *source; int lorig; if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes) *nbytes = dtp->u.p.current_unit->bytes_left; /* Zero size array gives internal unit len of 0. Nothing to read. */ if (dtp->internal_unit_len == 0 && dtp->u.p.current_unit->pad_status == PAD_NO) hit_eof (dtp); /* If we have seen an eor previously, return a length of 0. The caller is responsible for correctly padding the input field. */ if (dtp->u.p.sf_seen_eor) { *nbytes = 0; /* Just return something that isn't a NULL pointer, otherwise the caller thinks an error occured. */ return empty_string; } lorig = *nbytes; source = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, nbytes); if (unlikely (lorig > *nbytes)) { hit_eof (dtp); return NULL; } dtp->u.p.current_unit->bytes_left -= *nbytes; if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) dtp->u.p.size_used += (GFC_IO_INT) *nbytes; return source; } /* Reads a block directly into application data space. This is for unformatted files. */ static void read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes) { ssize_t to_read_record; ssize_t have_read_record; ssize_t to_read_subrecord; ssize_t have_read_subrecord; int short_record; if (is_stream_io (dtp)) { have_read_record = sread (dtp->u.p.current_unit->s, buf, nbytes); if (unlikely (have_read_record < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record; if (unlikely ((ssize_t) nbytes != have_read_record)) { /* Short read, e.g. if we hit EOF. For stream files, we have to set the end-of-file condition. */ hit_eof (dtp); } return; } if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes) { short_record = 1; to_read_record = dtp->u.p.current_unit->bytes_left; nbytes = to_read_record; } else { short_record = 0; to_read_record = nbytes; } dtp->u.p.current_unit->bytes_left -= to_read_record; to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record); if (unlikely (to_read_record < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } if (to_read_record != (ssize_t) nbytes) { /* Short read, e.g. if we hit EOF. Apparently, we read more than was written to the last record. */ return; } if (unlikely (short_record)) { generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); } return; } /* Unformatted sequential. We loop over the subrecords, reading until the request has been fulfilled or the record has run out of continuation subrecords. */ /* Check whether we exceed the total record length. */ if (dtp->u.p.current_unit->flags.has_recl && ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)) { to_read_record = dtp->u.p.current_unit->bytes_left; short_record = 1; } else { to_read_record = nbytes; short_record = 0; } have_read_record = 0; while(1) { if (dtp->u.p.current_unit->bytes_left_subrecord < (gfc_offset) to_read_record) { to_read_subrecord = dtp->u.p.current_unit->bytes_left_subrecord; to_read_record -= to_read_subrecord; } else { to_read_subrecord = to_read_record; to_read_record = 0; } dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord; have_read_subrecord = sread (dtp->u.p.current_unit->s, buf + have_read_record, to_read_subrecord); if (unlikely (have_read_subrecord) < 0) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } have_read_record += have_read_subrecord; if (unlikely (to_read_subrecord != have_read_subrecord)) { /* Short read, e.g. if we hit EOF. This means the record structure has been corrupted, or the trailing record marker would still be present. */ generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL); return; } if (to_read_record > 0) { if (likely (dtp->u.p.current_unit->continued)) { next_record_r_unf (dtp, 0); us_read (dtp, 1); } else { /* Let's make sure the file position is correctly pre-positioned for the next read statement. */ dtp->u.p.current_unit->current_record = 0; next_record_r_unf (dtp, 0); generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); return; } } else { /* Normal exit, the read request has been fulfilled. */ break; } } dtp->u.p.current_unit->bytes_left -= have_read_record; if (unlikely (short_record)) { generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); return; } return; } /* Function for writing a block of bytes to the current file at the current position, advancing the file pointer. We are given a length and return a pointer to a buffer that the caller must (completely) fill in. Returns NULL on error. */ void * write_block (st_parameter_dt *dtp, int length) { char *dest; if (!is_stream_io (dtp)) { if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length) { /* For preconnected units with default record length, set bytes left to unit record length and proceed, otherwise error. */ if (likely ((dtp->u.p.current_unit->unit_number == options.stdout_unit || dtp->u.p.current_unit->unit_number == options.stderr_unit) && dtp->u.p.current_unit->recl == DEFAULT_RECL)) dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; else { generate_error (&dtp->common, LIBERROR_EOR, NULL); return NULL; } } dtp->u.p.current_unit->bytes_left -= (gfc_offset) length; } if (is_internal_unit (dtp)) { if (dtp->common.unit) /* char4 internel unit. */ { gfc_char4_t *dest4; dest4 = mem_alloc_w4 (dtp->u.p.current_unit->s, &length); if (dest4 == NULL) { generate_error (&dtp->common, LIBERROR_END, NULL); return NULL; } return dest4; } else dest = mem_alloc_w (dtp->u.p.current_unit->s, &length); if (dest == NULL) { generate_error (&dtp->common, LIBERROR_END, NULL); return NULL; } if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE)) generate_error (&dtp->common, LIBERROR_END, NULL); } else { dest = fbuf_alloc (dtp->u.p.current_unit, length); if (dest == NULL) { generate_error (&dtp->common, LIBERROR_OS, NULL); return NULL; } } if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) dtp->u.p.size_used += (GFC_IO_INT) length; dtp->u.p.current_unit->strm_pos += (gfc_offset) length; return dest; } /* High level interface to swrite(), taking care of errors. This is only called for unformatted files. There are three cases to consider: Stream I/O, unformatted direct, unformatted sequential. */ static try write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) { ssize_t have_written; ssize_t to_write_subrecord; int short_record; /* Stream I/O. */ if (is_stream_io (dtp)) { have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); if (unlikely (have_written < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; return SUCCESS; } /* Unformatted direct access. */ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { if (unlikely (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)) { generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL); return FAILURE; } if (buf == NULL && nbytes == 0) return SUCCESS; have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); if (unlikely (have_written < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written; return SUCCESS; } /* Unformatted sequential. */ have_written = 0; if (dtp->u.p.current_unit->flags.has_recl && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left) { nbytes = dtp->u.p.current_unit->bytes_left; short_record = 1; } else { short_record = 0; } while (1) { to_write_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ? (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes; dtp->u.p.current_unit->bytes_left_subrecord -= (gfc_offset) to_write_subrecord; to_write_subrecord = swrite (dtp->u.p.current_unit->s, buf + have_written, to_write_subrecord); if (unlikely (to_write_subrecord < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord; nbytes -= to_write_subrecord; have_written += to_write_subrecord; if (nbytes == 0) break; next_record_w_unf (dtp, 1); us_write (dtp, 1); } dtp->u.p.current_unit->bytes_left -= have_written; if (unlikely (short_record)) { generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); return FAILURE; } return SUCCESS; } /* Master function for unformatted reads. */ static void unformatted_read (st_parameter_dt *dtp, bt type, void *dest, int kind, size_t size, size_t nelems) { if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE) || kind == 1) { if (type == BT_CHARACTER) size *= GFC_SIZE_OF_CHAR_KIND(kind); read_block_direct (dtp, dest, size * nelems); } else { char buffer[16]; char *p; size_t i; p = dest; /* Handle wide chracters. */ if (type == BT_CHARACTER && kind != 1) { nelems *= size; size = kind; } /* Break up complex into its constituent reals. */ if (type == BT_COMPLEX) { nelems *= 2; size /= 2; } /* By now, all complex variables have been split into their constituent reals. */ for (i = 0; i < nelems; i++) { read_block_direct (dtp, buffer, size); reverse_memcpy (p, buffer, size); p += size; } } } /* Master function for unformatted writes. NOTE: For kind=10 the size is 16 bytes on 64 bit machines. The unused bytes are not initialized and never used, which can show an error with memory checking analyzers like valgrind. */ static void unformatted_write (st_parameter_dt *dtp, bt type, void *source, int kind, size_t size, size_t nelems) { if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE) || kind == 1) { size_t stride = type == BT_CHARACTER ? size * GFC_SIZE_OF_CHAR_KIND(kind) : size; write_buf (dtp, source, stride * nelems); } else { char buffer[16]; char *p; size_t i; p = source; /* Handle wide chracters. */ if (type == BT_CHARACTER && kind != 1) { nelems *= size; size = kind; } /* Break up complex into its constituent reals. */ if (type == BT_COMPLEX) { nelems *= 2; size /= 2; } /* By now, all complex variables have been split into their constituent reals. */ for (i = 0; i < nelems; i++) { reverse_memcpy(buffer, p, size); p += size; write_buf (dtp, buffer, size); } } } /* Return a pointer to the name of a type. */ const char * type_name (bt type) { const char *p; switch (type) { case BT_INTEGER: p = "INTEGER"; break; case BT_LOGICAL: p = "LOGICAL"; break; case BT_CHARACTER: p = "CHARACTER"; break; case BT_REAL: p = "REAL"; break; case BT_COMPLEX: p = "COMPLEX"; break; default: internal_error (NULL, "type_name(): Bad type"); } return p; } /* Write a constant string to the output. This is complicated because the string can have doubled delimiters in it. The length in the format node is the true length. */ static void write_constant_string (st_parameter_dt *dtp, const fnode *f) { char c, delimiter, *p, *q; int length; length = f->u.string.length; if (length == 0) return; p = write_block (dtp, length); if (p == NULL) return; q = f->u.string.p; delimiter = q[-1]; for (; length > 0; length--) { c = *p++ = *q++; if (c == delimiter && c != 'H' && c != 'h') q++; /* Skip the doubled delimiter. */ } } /* Given actual and expected types in a formatted data transfer, make sure they agree. If not, an error message is generated. Returns nonzero if something went wrong. */ static int require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f) { char buffer[100]; if (actual == expected) return 0; /* Adjust item_count before emitting error message. */ sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s", type_name (expected), dtp->u.p.item_count - 1, type_name (actual)); format_error (dtp, f, buffer); return 1; } /* This function is in the main loop for a formatted data transfer statement. It would be natural to implement this as a coroutine with the user program, but C makes that awkward. We loop, processing format elements. When we actually have to transfer data instead of just setting flags, we return control to the user program which calls a function that supplies the address and type of the next element, then comes back here to process it. */ static void formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind, size_t size) { int pos, bytes_used; const fnode *f; format_token t; int n; int consume_data_flag; /* Change a complex data item into a pair of reals. */ n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2); if (type == BT_COMPLEX) { type = BT_REAL; size /= 2; } /* If there's an EOR condition, we simulate finalizing the transfer by doing nothing. */ if (dtp->u.p.eor_condition) return; /* Set this flag so that commas in reads cause the read to complete before the entire field has been read. The next read field will start right after the comma in the stream. (Set to 0 for character reads). */ dtp->u.p.sf_read_comma = dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1; for (;;) { /* If reversion has occurred and there is another real data item, then we have to move to the next record. */ if (dtp->u.p.reversion_flag && n > 0) { dtp->u.p.reversion_flag = 0; next_record (dtp, 0); } consume_data_flag = 1; if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) break; f = next_format (dtp); if (f == NULL) { /* No data descriptors left. */ if (unlikely (n > 0)) generate_error (&dtp->common, LIBERROR_FORMAT, "Insufficient data descriptors in format after reversion"); return; } t = f->format; bytes_used = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); if (is_stream_io(dtp)) bytes_used = 0; switch (t) { case FMT_I: if (n == 0) goto need_read_data; if (require_type (dtp, BT_INTEGER, type, f)) return; read_decimal (dtp, f, p, kind); break; case FMT_B: if (n == 0) goto need_read_data; if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; read_radix (dtp, f, p, kind, 2); break; case FMT_O: if (n == 0) goto need_read_data; if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; read_radix (dtp, f, p, kind, 8); break; case FMT_Z: if (n == 0) goto need_read_data; if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; read_radix (dtp, f, p, kind, 16); break; case FMT_A: if (n == 0) goto need_read_data; /* It is possible to have FMT_A with something not BT_CHARACTER such as when writing out hollerith strings, so check both type and kind before calling wide character routines. */ if (type == BT_CHARACTER && kind == 4) read_a_char4 (dtp, f, p, size); else read_a (dtp, f, p, size); break; case FMT_L: if (n == 0) goto need_read_data; read_l (dtp, f, p, kind); break; case FMT_D: if (n == 0) goto need_read_data; if (require_type (dtp, BT_REAL, type, f)) return; read_f (dtp, f, p, kind); break; case FMT_E: if (n == 0) goto need_read_data; if (require_type (dtp, BT_REAL, type, f)) return; read_f (dtp, f, p, kind); break; case FMT_EN: if (n == 0) goto need_read_data; if (require_type (dtp, BT_REAL, type, f)) return; read_f (dtp, f, p, kind); break; case FMT_ES: if (n == 0) goto need_read_data; if (require_type (dtp, BT_REAL, type, f)) return; read_f (dtp, f, p, kind); break; case FMT_F: if (n == 0) goto need_read_data; if (require_type (dtp, BT_REAL, type, f)) return; read_f (dtp, f, p, kind); break; case FMT_G: if (n == 0) goto need_read_data; switch (type) { case BT_INTEGER: read_decimal (dtp, f, p, kind); break; case BT_LOGICAL: read_l (dtp, f, p, kind); break; case BT_CHARACTER: if (kind == 4) read_a_char4 (dtp, f, p, size); else read_a (dtp, f, p, size); break; case BT_REAL: read_f (dtp, f, p, kind); break; default: internal_error (&dtp->common, "formatted_transfer(): Bad type"); } break; case FMT_STRING: consume_data_flag = 0; format_error (dtp, f, "Constant string in input format"); return; /* Format codes that don't transfer data. */ case FMT_X: case FMT_TR: consume_data_flag = 0; dtp->u.p.skips += f->u.n; pos = bytes_used + dtp->u.p.skips - 1; dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1; read_x (dtp, f->u.n); break; case FMT_TL: case FMT_T: consume_data_flag = 0; if (f->format == FMT_TL) { /* Handle the special case when no bytes have been used yet. Cannot go below zero. */ if (bytes_used == 0) { dtp->u.p.pending_spaces -= f->u.n; dtp->u.p.skips -= f->u.n; dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips; } pos = bytes_used - f->u.n; } else /* FMT_T */ pos = f->u.n - 1; /* Standard 10.6.1.1: excessive left tabbing is reset to the left tab limit. We do not check if the position has gone beyond the end of record because a subsequent tab could bring us back again. */ pos = pos < 0 ? 0 : pos; dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used; dtp->u.p.pending_spaces = dtp->u.p.pending_spaces + pos - dtp->u.p.max_pos; dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0 : dtp->u.p.pending_spaces; if (dtp->u.p.skips == 0) break; /* Adjust everything for end-of-record condition */ if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp)) { dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor; dtp->u.p.skips -= dtp->u.p.sf_seen_eor; bytes_used = pos; dtp->u.p.sf_seen_eor = 0; } if (dtp->u.p.skips < 0) { if (is_internal_unit (dtp)) sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR); else fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR); dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips; dtp->u.p.skips = dtp->u.p.pending_spaces = 0; } else read_x (dtp, dtp->u.p.skips); break; case FMT_S: consume_data_flag = 0; dtp->u.p.sign_status = SIGN_S; break; case FMT_SS: consume_data_flag = 0; dtp->u.p.sign_status = SIGN_SS; break; case FMT_SP: consume_data_flag = 0; dtp->u.p.sign_status = SIGN_SP; break; case FMT_BN: consume_data_flag = 0 ; dtp->u.p.blank_status = BLANK_NULL; break; case FMT_BZ: consume_data_flag = 0; dtp->u.p.blank_status = BLANK_ZERO; break; case FMT_DC: consume_data_flag = 0; dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA; break; case FMT_DP: consume_data_flag = 0; dtp->u.p.current_unit->decimal_status = DECIMAL_POINT; break; case FMT_RC: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE; break; case FMT_RD: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_DOWN; break; case FMT_RN: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_NEAREST; break; case FMT_RP: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED; break; case FMT_RU: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_UP; break; case FMT_RZ: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_ZERO; break; case FMT_P: consume_data_flag = 0; dtp->u.p.scale_factor = f->u.k; break; case FMT_DOLLAR: consume_data_flag = 0; dtp->u.p.seen_dollar = 1; break; case FMT_SLASH: consume_data_flag = 0; dtp->u.p.skips = dtp->u.p.pending_spaces = 0; next_record (dtp, 0); break; case FMT_COLON: /* A colon descriptor causes us to exit this loop (in particular preventing another / descriptor from being processed) unless there is another data item to be transferred. */ consume_data_flag = 0; if (n == 0) return; break; default: internal_error (&dtp->common, "Bad format node"); } /* Adjust the item count and data pointer. */ if ((consume_data_flag > 0) && (n > 0)) { n--; p = ((char *) p) + size; } dtp->u.p.skips = 0; pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos; } return; /* Come here when we need a data descriptor but don't have one. We push the current format node back onto the input, then return and let the user program call us back with the data. */ need_read_data: unget_format (dtp, f); } static void formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind, size_t size) { int pos, bytes_used; const fnode *f; format_token t; int n; int consume_data_flag; /* Change a complex data item into a pair of reals. */ n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2); if (type == BT_COMPLEX) { type = BT_REAL; size /= 2; } /* If there's an EOR condition, we simulate finalizing the transfer by doing nothing. */ if (dtp->u.p.eor_condition) return; /* Set this flag so that commas in reads cause the read to complete before the entire field has been read. The next read field will start right after the comma in the stream. (Set to 0 for character reads). */ dtp->u.p.sf_read_comma = dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1; for (;;) { /* If reversion has occurred and there is another real data item, then we have to move to the next record. */ if (dtp->u.p.reversion_flag && n > 0) { dtp->u.p.reversion_flag = 0; next_record (dtp, 0); } consume_data_flag = 1; if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) break; f = next_format (dtp); if (f == NULL) { /* No data descriptors left. */ if (unlikely (n > 0)) generate_error (&dtp->common, LIBERROR_FORMAT, "Insufficient data descriptors in format after reversion"); return; } /* Now discharge T, TR and X movements to the right. This is delayed until a data producing format to suppress trailing spaces. */ t = f->format; if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F || t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L || t == FMT_A || t == FMT_D)) || t == FMT_STRING)) { if (dtp->u.p.skips > 0) { int tmp; write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); tmp = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); dtp->u.p.max_pos = dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp; } if (dtp->u.p.skips < 0) { if (is_internal_unit (dtp)) sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR); else fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR); dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips; } dtp->u.p.skips = dtp->u.p.pending_spaces = 0; } bytes_used = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); if (is_stream_io(dtp)) bytes_used = 0; switch (t) { case FMT_I: if (n == 0) goto need_data; if (require_type (dtp, BT_INTEGER, type, f)) return; write_i (dtp, f, p, kind); break; case FMT_B: if (n == 0) goto need_data; if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; write_b (dtp, f, p, kind); break; case FMT_O: if (n == 0) goto need_data; if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; write_o (dtp, f, p, kind); break; case FMT_Z: if (n == 0) goto need_data; if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; write_z (dtp, f, p, kind); break; case FMT_A: if (n == 0) goto need_data; /* It is possible to have FMT_A with something not BT_CHARACTER such as when writing out hollerith strings, so check both type and kind before calling wide character routines. */ if (type == BT_CHARACTER && kind == 4) write_a_char4 (dtp, f, p, size); else write_a (dtp, f, p, size); break; case FMT_L: if (n == 0) goto need_data; write_l (dtp, f, p, kind); break; case FMT_D: if (n == 0) goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; write_d (dtp, f, p, kind); break; case FMT_E: if (n == 0) goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; write_e (dtp, f, p, kind); break; case FMT_EN: if (n == 0) goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; write_en (dtp, f, p, kind); break; case FMT_ES: if (n == 0) goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; write_es (dtp, f, p, kind); break; case FMT_F: if (n == 0) goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; write_f (dtp, f, p, kind); break; case FMT_G: if (n == 0) goto need_data; switch (type) { case BT_INTEGER: write_i (dtp, f, p, kind); break; case BT_LOGICAL: write_l (dtp, f, p, kind); break; case BT_CHARACTER: if (kind == 4) write_a_char4 (dtp, f, p, size); else write_a (dtp, f, p, size); break; case BT_REAL: if (f->u.real.w == 0) write_real_g0 (dtp, p, kind, f->u.real.d); else write_d (dtp, f, p, kind); break; default: internal_error (&dtp->common, "formatted_transfer(): Bad type"); } break; case FMT_STRING: consume_data_flag = 0; write_constant_string (dtp, f); break; /* Format codes that don't transfer data. */ case FMT_X: case FMT_TR: consume_data_flag = 0; dtp->u.p.skips += f->u.n; pos = bytes_used + dtp->u.p.skips - 1; dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1; /* Writes occur just before the switch on f->format, above, so that trailing blanks are suppressed, unless we are doing a non-advancing write in which case we want to output the blanks now. */ if (dtp->u.p.advance_status == ADVANCE_NO) { write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); dtp->u.p.skips = dtp->u.p.pending_spaces = 0; } break; case FMT_TL: case FMT_T: consume_data_flag = 0; if (f->format == FMT_TL) { /* Handle the special case when no bytes have been used yet. Cannot go below zero. */ if (bytes_used == 0) { dtp->u.p.pending_spaces -= f->u.n; dtp->u.p.skips -= f->u.n; dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips; } pos = bytes_used - f->u.n; } else /* FMT_T */ pos = f->u.n - dtp->u.p.pending_spaces - 1; /* Standard 10.6.1.1: excessive left tabbing is reset to the left tab limit. We do not check if the position has gone beyond the end of record because a subsequent tab could bring us back again. */ pos = pos < 0 ? 0 : pos; dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used; dtp->u.p.pending_spaces = dtp->u.p.pending_spaces + pos - dtp->u.p.max_pos; dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0 : dtp->u.p.pending_spaces; break; case FMT_S: consume_data_flag = 0; dtp->u.p.sign_status = SIGN_S; break; case FMT_SS: consume_data_flag = 0; dtp->u.p.sign_status = SIGN_SS; break; case FMT_SP: consume_data_flag = 0; dtp->u.p.sign_status = SIGN_SP; break; case FMT_BN: consume_data_flag = 0 ; dtp->u.p.blank_status = BLANK_NULL; break; case FMT_BZ: consume_data_flag = 0; dtp->u.p.blank_status = BLANK_ZERO; break; case FMT_DC: consume_data_flag = 0; dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA; break; case FMT_DP: consume_data_flag = 0; dtp->u.p.current_unit->decimal_status = DECIMAL_POINT; break; case FMT_RC: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE; break; case FMT_RD: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_DOWN; break; case FMT_RN: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_NEAREST; break; case FMT_RP: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED; break; case FMT_RU: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_UP; break; case FMT_RZ: consume_data_flag = 0; dtp->u.p.current_unit->round_status = ROUND_ZERO; break; case FMT_P: consume_data_flag = 0; dtp->u.p.scale_factor = f->u.k; break; case FMT_DOLLAR: consume_data_flag = 0; dtp->u.p.seen_dollar = 1; break; case FMT_SLASH: consume_data_flag = 0; dtp->u.p.skips = dtp->u.p.pending_spaces = 0; next_record (dtp, 0); break; case FMT_COLON: /* A colon descriptor causes us to exit this loop (in particular preventing another / descriptor from being processed) unless there is another data item to be transferred. */ consume_data_flag = 0; if (n == 0) return; break; default: internal_error (&dtp->common, "Bad format node"); } /* Adjust the item count and data pointer. */ if ((consume_data_flag > 0) && (n > 0)) { n--; p = ((char *) p) + size; } pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos; } return; /* Come here when we need a data descriptor but don't have one. We push the current format node back onto the input, then return and let the user program call us back with the data. */ need_data: unget_format (dtp, f); } /* This function is first called from data_init_transfer to initiate the loop over each item in the format, transferring data as required. Subsequent calls to this function occur for each data item foound in the READ/WRITE statement. The item_count is incremented for each call. Since the first call is from data_transfer_init, the item_count is always one greater than the actual count number of the item being transferred. */ static void formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind, size_t size, size_t nelems) { size_t elem; char *tmp; tmp = (char *) p; size_t stride = type == BT_CHARACTER ? size * GFC_SIZE_OF_CHAR_KIND(kind) : size; if (dtp->u.p.mode == READING) { /* Big loop over all the elements. */ for (elem = 0; elem < nelems; elem++) { dtp->u.p.item_count++; formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size); } } else { /* Big loop over all the elements. */ for (elem = 0; elem < nelems; elem++) { dtp->u.p.item_count++; formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size); } } } /* Data transfer entry points. The type of the data entity is implicit in the subroutine call. This prevents us from having to share a common enum with the compiler. */ void transfer_integer (st_parameter_dt *dtp, void *p, int kind) { if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1); } void transfer_integer_write (st_parameter_dt *dtp, void *p, int kind) { transfer_integer (dtp, p, kind); } void transfer_real (st_parameter_dt *dtp, void *p, int kind) { size_t size; if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; size = size_from_real_kind (kind); dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1); } void transfer_real_write (st_parameter_dt *dtp, void *p, int kind) { transfer_real (dtp, p, kind); } void transfer_logical (st_parameter_dt *dtp, void *p, int kind) { if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1); } void transfer_logical_write (st_parameter_dt *dtp, void *p, int kind) { transfer_logical (dtp, p, kind); } void transfer_character (st_parameter_dt *dtp, void *p, int len) { static char *empty_string[0]; if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; /* Strings of zero length can have p == NULL, which confuses the transfer routines into thinking we need more data elements. To avoid this, we give them a nice pointer. */ if (len == 0 && p == NULL) p = empty_string; /* Set kind here to 1. */ dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1); } void transfer_character_write (st_parameter_dt *dtp, void *p, int len) { transfer_character (dtp, p, len); } void transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind) { static char *empty_string[0]; if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; /* Strings of zero length can have p == NULL, which confuses the transfer routines into thinking we need more data elements. To avoid this, we give them a nice pointer. */ if (len == 0 && p == NULL) p = empty_string; /* Here we pass the actual kind value. */ dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1); } void transfer_character_wide_write (st_parameter_dt *dtp, void *p, int len, int kind) { transfer_character_wide (dtp, p, len, kind); } void transfer_complex (st_parameter_dt *dtp, void *p, int kind) { size_t size; if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; size = size_from_complex_kind (kind); dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1); } void transfer_complex_write (st_parameter_dt *dtp, void *p, int kind) { transfer_complex (dtp, p, kind); } void transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, gfc_charlen_type charlen) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type stride[GFC_MAX_DIMENSIONS]; index_type stride0, rank, size, n; size_t tsize; char *data; bt iotype; if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; iotype = (bt) GFC_DESCRIPTOR_TYPE (desc); size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc); rank = GFC_DESCRIPTOR_RANK (desc); for (n = 0; n < rank; n++) { count[n] = 0; stride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(desc,n); extent[n] = GFC_DESCRIPTOR_EXTENT(desc,n); /* If the extent of even one dimension is zero, then the entire array section contains zero elements, so we return after writing a zero array record. */ if (extent[n] <= 0) { data = NULL; tsize = 0; dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize); return; } } stride0 = stride[0]; /* If the innermost dimension has a stride of 1, we can do the transfer in contiguous chunks. */ if (stride0 == size) tsize = extent[0]; else tsize = 1; data = GFC_DESCRIPTOR_DATA (desc); while (data) { dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize); data += stride0 * tsize; count[0] += tsize; n = 0; while (count[n] == extent[n]) { count[n] = 0; data -= stride[n] * extent[n]; n++; if (n == rank) { data = NULL; break; } else { count[n]++; data += stride[n]; } } } } void transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind, gfc_charlen_type charlen) { transfer_array (dtp, desc, kind, charlen); } /* Preposition a sequential unformatted file while reading. */ static void us_read (st_parameter_dt *dtp, int continued) { ssize_t n, nr; GFC_INTEGER_4 i4; GFC_INTEGER_8 i8; gfc_offset i; if (compile_options.record_marker == 0) n = sizeof (GFC_INTEGER_4); else n = compile_options.record_marker; nr = sread (dtp->u.p.current_unit->s, &i, n); if (unlikely (nr < 0)) { generate_error (&dtp->common, LIBERROR_BAD_US, NULL); return; } else if (nr == 0) { hit_eof (dtp); return; /* end of file */ } else if (unlikely (n != nr)) { generate_error (&dtp->common, LIBERROR_BAD_US, NULL); return; } /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */ if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)) { switch (nr) { case sizeof(GFC_INTEGER_4): memcpy (&i4, &i, sizeof (i4)); i = i4; break; case sizeof(GFC_INTEGER_8): memcpy (&i8, &i, sizeof (i8)); i = i8; break; default: runtime_error ("Illegal value for record marker"); break; } } else switch (nr) { case sizeof(GFC_INTEGER_4): reverse_memcpy (&i4, &i, sizeof (i4)); i = i4; break; case sizeof(GFC_INTEGER_8): reverse_memcpy (&i8, &i, sizeof (i8)); i = i8; break; default: runtime_error ("Illegal value for record marker"); break; } if (i >= 0) { dtp->u.p.current_unit->bytes_left_subrecord = i; dtp->u.p.current_unit->continued = 0; } else { dtp->u.p.current_unit->bytes_left_subrecord = -i; dtp->u.p.current_unit->continued = 1; } if (! continued) dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; } /* Preposition a sequential unformatted file while writing. This amount to writing a bogus length that will be filled in later. */ static void us_write (st_parameter_dt *dtp, int continued) { ssize_t nbytes; gfc_offset dummy; dummy = 0; if (compile_options.record_marker == 0) nbytes = sizeof (GFC_INTEGER_4); else nbytes = compile_options.record_marker ; if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes) generate_error (&dtp->common, LIBERROR_OS, NULL); /* For sequential unformatted, if RECL= was not specified in the OPEN we write until we have more bytes than can fit in the subrecord markers, then we write a new subrecord. */ dtp->u.p.current_unit->bytes_left_subrecord = dtp->u.p.current_unit->recl_subrecord; dtp->u.p.current_unit->continued = continued; } /* Position to the next record prior to transfer. We are assumed to be before the next record. We also calculate the bytes in the next record. */ static void pre_position (st_parameter_dt *dtp) { if (dtp->u.p.current_unit->current_record) return; /* Already positioned. */ switch (current_mode (dtp)) { case FORMATTED_STREAM: case UNFORMATTED_STREAM: /* There are no records with stream I/O. If the position was specified data_transfer_init has already positioned the file. If no position was specified, we continue from where we last left off. I.e. there is nothing to do here. */ break; case UNFORMATTED_SEQUENTIAL: if (dtp->u.p.mode == READING) us_read (dtp, 0); else us_write (dtp, 0); break; case FORMATTED_SEQUENTIAL: case FORMATTED_DIRECT: case UNFORMATTED_DIRECT: dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; break; } dtp->u.p.current_unit->current_record = 1; } /* Initialize things for a data transfer. This code is common for both reading and writing. */ static void data_transfer_init (st_parameter_dt *dtp, int read_flag) { unit_flags u_flags; /* Used for creating a unit if needed. */ GFC_INTEGER_4 cf = dtp->common.flags; namelist_info *ionml; ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL; memset (&dtp->u.p, 0, sizeof (dtp->u.p)); dtp->u.p.ionml = ionml; dtp->u.p.mode = read_flag ? READING : WRITING; if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; if ((cf & IOPARM_DT_HAS_SIZE) != 0) dtp->u.p.size_used = 0; /* Initialize the count. */ dtp->u.p.current_unit = get_unit (dtp, 1); if (dtp->u.p.current_unit->s == NULL) { /* Open the unit with some default flags. */ st_parameter_open opp; unit_convert conv; if (dtp->common.unit < 0) { close_unit (dtp->u.p.current_unit); dtp->u.p.current_unit = NULL; generate_error (&dtp->common, LIBERROR_BAD_OPTION, "Bad unit number in statement"); return; } memset (&u_flags, '\0', sizeof (u_flags)); u_flags.access = ACCESS_SEQUENTIAL; u_flags.action = ACTION_READWRITE; /* Is it unformatted? */ if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT | IOPARM_DT_IONML_SET))) u_flags.form = FORM_UNFORMATTED; else u_flags.form = FORM_UNSPECIFIED; u_flags.delim = DELIM_UNSPECIFIED; u_flags.blank = BLANK_UNSPECIFIED; u_flags.pad = PAD_UNSPECIFIED; u_flags.decimal = DECIMAL_UNSPECIFIED; u_flags.encoding = ENCODING_UNSPECIFIED; u_flags.async = ASYNC_UNSPECIFIED; u_flags.round = ROUND_UNSPECIFIED; u_flags.sign = SIGN_UNSPECIFIED; u_flags.status = STATUS_UNKNOWN; conv = get_unformatted_convert (dtp->common.unit); if (conv == GFC_CONVERT_NONE) conv = compile_options.convert; /* We use big_endian, which is 0 on little-endian machines and 1 on big-endian machines. */ switch (conv) { case GFC_CONVERT_NATIVE: case GFC_CONVERT_SWAP: break; case GFC_CONVERT_BIG: conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP; break; case GFC_CONVERT_LITTLE: conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE; break; default: internal_error (&opp.common, "Illegal value for CONVERT"); break; } u_flags.convert = conv; opp.common = dtp->common; opp.common.flags &= IOPARM_COMMON_MASK; dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags); dtp->common.flags &= ~IOPARM_COMMON_MASK; dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK); if (dtp->u.p.current_unit == NULL) return; } /* Check the action. */ if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE) { generate_error (&dtp->common, LIBERROR_BAD_ACTION, "Cannot read from file opened for WRITE"); return; } if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ) { generate_error (&dtp->common, LIBERROR_BAD_ACTION, "Cannot write to file opened for READ"); return; } dtp->u.p.first_item = 1; /* Check the format. */ if ((cf & IOPARM_DT_HAS_FORMAT) != 0) parse_format (dtp); if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) != 0) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "Format present for UNFORMATTED data transfer"); return; } if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL) { if ((cf & IOPARM_DT_HAS_FORMAT) != 0) generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "A format cannot be specified with a namelist"); } else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "Missing format for FORMATTED data transfer"); } if (is_internal_unit (dtp) && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "Internal file cannot be accessed by UNFORMATTED " "data transfer"); return; } /* Check the record or position number. */ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT && (cf & IOPARM_DT_HAS_REC) == 0) { generate_error (&dtp->common, LIBERROR_MISSING_OPTION, "Direct access data transfer requires record number"); return; } if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) { if ((cf & IOPARM_DT_HAS_REC) != 0) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "Record number not allowed for sequential access " "data transfer"); return; } if (dtp->u.p.current_unit->endfile == AFTER_ENDFILE) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "Sequential READ or WRITE not allowed after " "EOF marker, possibly use REWIND or BACKSPACE"); return; } } /* Process the ADVANCE option. */ dtp->u.p.advance_status = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED : find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt, "Bad ADVANCE parameter in data transfer statement"); if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED) { if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "ADVANCE specification conflicts with sequential " "access"); return; } if (is_internal_unit (dtp)) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "ADVANCE specification conflicts with internal file"); return; } if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) != IOPARM_DT_HAS_FORMAT) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "ADVANCE specification requires an explicit format"); return; } } if (read_flag) { dtp->u.p.current_unit->previous_nonadvancing_write = 0; if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO) { generate_error (&dtp->common, LIBERROR_MISSING_OPTION, "EOR specification requires an ADVANCE specification " "of NO"); return; } if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO) { generate_error (&dtp->common, LIBERROR_MISSING_OPTION, "SIZE specification requires an ADVANCE " "specification of NO"); return; } } else { /* Write constraints. */ if ((cf & IOPARM_END) != 0) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "END specification cannot appear in a write " "statement"); return; } if ((cf & IOPARM_EOR) != 0) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "EOR specification cannot appear in a write " "statement"); return; } if ((cf & IOPARM_DT_HAS_SIZE) != 0) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "SIZE specification cannot appear in a write " "statement"); return; } } if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED) dtp->u.p.advance_status = ADVANCE_YES; /* Check the decimal mode. */ dtp->u.p.current_unit->decimal_status = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED : find_option (&dtp->common, dtp->decimal, dtp->decimal_len, decimal_opt, "Bad DECIMAL parameter in data transfer " "statement"); if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED) dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal; /* Check the round mode. */ dtp->u.p.current_unit->round_status = !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED : find_option (&dtp->common, dtp->round, dtp->round_len, round_opt, "Bad ROUND parameter in data transfer " "statement"); if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED) dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round; /* Check the sign mode. */ dtp->u.p.sign_status = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED : find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt, "Bad SIGN parameter in data transfer statement"); if (dtp->u.p.sign_status == SIGN_UNSPECIFIED) dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign; /* Check the blank mode. */ dtp->u.p.blank_status = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED : find_option (&dtp->common, dtp->blank, dtp->blank_len, blank_opt, "Bad BLANK parameter in data transfer statement"); if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank; /* Check the delim mode. */ dtp->u.p.current_unit->delim_status = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED : find_option (&dtp->common, dtp->delim, dtp->delim_len, delim_opt, "Bad DELIM parameter in data transfer statement"); if (dtp->u.p.current_unit->delim_status == DELIM_UNSPECIFIED) dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim; /* Check the pad mode. */ dtp->u.p.current_unit->pad_status = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED : find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt, "Bad PAD parameter in data transfer statement"); if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED) dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad; /* Check to see if we might be reading what we wrote before */ if (dtp->u.p.mode != dtp->u.p.current_unit->mode && !is_internal_unit (dtp)) { int pos = fbuf_reset (dtp->u.p.current_unit); if (pos != 0) sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR); sflush(dtp->u.p.current_unit->s); } /* Check the POS= specifier: that it is in range and that it is used with a unit that has been connected for STREAM access. F2003 9.5.1.10. */ if (((cf & IOPARM_DT_HAS_POS) != 0)) { if (is_stream_io (dtp)) { if (dtp->pos <= 0) { generate_error (&dtp->common, LIBERROR_BAD_OPTION, "POS=specifier must be positive"); return; } if (dtp->pos >= dtp->u.p.current_unit->maxrec) { generate_error (&dtp->common, LIBERROR_BAD_OPTION, "POS=specifier too large"); return; } dtp->rec = dtp->pos; if (dtp->u.p.mode == READING) { /* Reset the endfile flag; if we hit EOF during reading we'll set the flag and generate an error at that point rather than worrying about it here. */ dtp->u.p.current_unit->endfile = NO_ENDFILE; } if (dtp->pos != dtp->u.p.current_unit->strm_pos) { fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } dtp->u.p.current_unit->strm_pos = dtp->pos; } } else { generate_error (&dtp->common, LIBERROR_BAD_OPTION, "POS=specifier not allowed, " "Try OPEN with ACCESS='stream'"); return; } } /* Sanity checks on the record number. */ if ((cf & IOPARM_DT_HAS_REC) != 0) { if (dtp->rec <= 0) { generate_error (&dtp->common, LIBERROR_BAD_OPTION, "Record number must be positive"); return; } if (dtp->rec >= dtp->u.p.current_unit->maxrec) { generate_error (&dtp->common, LIBERROR_BAD_OPTION, "Record number too large"); return; } /* Make sure format buffer is reset. */ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED) fbuf_reset (dtp->u.p.current_unit); /* Check whether the record exists to be read. Only a partial record needs to exist. */ if (dtp->u.p.mode == READING && (dtp->rec - 1) * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s)) { generate_error (&dtp->common, LIBERROR_BAD_OPTION, "Non-existing record number"); return; } /* Position the file. */ if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1) * dtp->u.p.current_unit->recl, SEEK_SET) < 0) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } /* TODO: This is required to maintain compatibility between 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */ if (is_stream_io (dtp)) dtp->u.p.current_unit->strm_pos = dtp->rec; /* TODO: Un-comment this code when ABI changes from 4.3. if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM) { generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "Record number not allowed for stream access " "data transfer"); return; } */ } /* Bugware for badly written mixed C-Fortran I/O. */ if (!is_internal_unit (dtp)) flush_if_preconnected(dtp->u.p.current_unit->s); dtp->u.p.current_unit->mode = dtp->u.p.mode; /* Set the maximum position reached from the previous I/O operation. This could be greater than zero from a previous non-advancing write. */ dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos; pre_position (dtp); /* Set up the subroutine that will handle the transfers. */ if (read_flag) { if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) dtp->u.p.transfer = unformatted_read; else { if ((cf & IOPARM_DT_LIST_FORMAT) != 0) { dtp->u.p.last_char = EOF - 1; dtp->u.p.transfer = list_formatted_read; } else dtp->u.p.transfer = formatted_transfer; } } else { if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) dtp->u.p.transfer = unformatted_write; else { if ((cf & IOPARM_DT_LIST_FORMAT) != 0) dtp->u.p.transfer = list_formatted_write; else dtp->u.p.transfer = formatted_transfer; } } /* Make sure that we don't do a read after a nonadvancing write. */ if (read_flag) { if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp)) { generate_error (&dtp->common, LIBERROR_BAD_OPTION, "Cannot READ after a nonadvancing WRITE"); return; } } else { if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar) dtp->u.p.current_unit->read_bad = 1; } /* Start the data transfer if we are doing a formatted transfer. */ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0) && dtp->u.p.ionml == NULL) formatted_transfer (dtp, 0, NULL, 0, 0, 1); } /* Initialize an array_loop_spec given the array descriptor. The function returns the index of the last element of the array, and also returns starting record, where the first I/O goes to (necessary in case of negative strides). */ gfc_offset init_loop_spec (gfc_array_char *desc, array_loop_spec *ls, gfc_offset *start_record) { int rank = GFC_DESCRIPTOR_RANK(desc); int i; gfc_offset index; int empty; empty = 0; index = 1; *start_record = 0; for (i=0; i 0) { index += (GFC_DESCRIPTOR_EXTENT(desc,i) - 1) * GFC_DESCRIPTOR_STRIDE(desc,i); } else { index -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1) * GFC_DESCRIPTOR_STRIDE(desc,i); *start_record -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1) * GFC_DESCRIPTOR_STRIDE(desc,i); } } if (empty) return 0; else return index; } /* Determine the index to the next record in an internal unit array by by incrementing through the array_loop_spec. */ gfc_offset next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished) { int i, carry; gfc_offset index; carry = 1; index = 0; for (i = 0; i < dtp->u.p.current_unit->rank; i++) { if (carry) { ls[i].idx++; if (ls[i].idx > ls[i].end) { ls[i].idx = ls[i].start; carry = 1; } else carry = 0; } index = index + (ls[i].idx - ls[i].start) * ls[i].step; } *finished = carry; return index; } /* Skip to the end of the current record, taking care of an optional record marker of size bytes. If the file is not seekable, we read chunks of size MAX_READ until we get to the right position. */ static void skip_record (st_parameter_dt *dtp, ssize_t bytes) { ssize_t rlength, readb; static const ssize_t MAX_READ = 4096; char p[MAX_READ]; dtp->u.p.current_unit->bytes_left_subrecord += bytes; if (dtp->u.p.current_unit->bytes_left_subrecord == 0) return; if (is_seekable (dtp->u.p.current_unit->s)) { /* Direct access files do not generate END conditions, only I/O errors. */ if (sseek (dtp->u.p.current_unit->s, dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0) generate_error (&dtp->common, LIBERROR_OS, NULL); dtp->u.p.current_unit->bytes_left_subrecord = 0; } else { /* Seek by reading data. */ while (dtp->u.p.current_unit->bytes_left_subrecord > 0) { rlength = (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ? MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord; readb = sread (dtp->u.p.current_unit->s, p, rlength); if (readb < 0) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } dtp->u.p.current_unit->bytes_left_subrecord -= readb; } } } /* Advance to the next record reading unformatted files, taking care of subrecords. If complete_record is nonzero, we loop until all subrecords are cleared. */ static void next_record_r_unf (st_parameter_dt *dtp, int complete_record) { size_t bytes; bytes = compile_options.record_marker == 0 ? sizeof (GFC_INTEGER_4) : compile_options.record_marker; while(1) { /* Skip over tail */ skip_record (dtp, bytes); if ( ! (complete_record && dtp->u.p.current_unit->continued)) return; us_read (dtp, 1); } } static inline gfc_offset min_off (gfc_offset a, gfc_offset b) { return (a < b ? a : b); } /* Space to the next record for read mode. */ static void next_record_r (st_parameter_dt *dtp, int done) { gfc_offset record; int bytes_left; char p; int cc; switch (current_mode (dtp)) { /* No records in unformatted STREAM I/O. */ case UNFORMATTED_STREAM: return; case UNFORMATTED_SEQUENTIAL: next_record_r_unf (dtp, 1); dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; break; case FORMATTED_DIRECT: case UNFORMATTED_DIRECT: skip_record (dtp, dtp->u.p.current_unit->bytes_left); break; case FORMATTED_STREAM: case FORMATTED_SEQUENTIAL: /* read_sf has already terminated input because of an '\n', or we have hit EOF. */ if (dtp->u.p.sf_seen_eor) { dtp->u.p.sf_seen_eor = 0; break; } if (is_internal_unit (dtp)) { if (is_array_io (dtp)) { int finished; record = next_array_record (dtp, dtp->u.p.current_unit->ls, &finished); if (!done && finished) hit_eof (dtp); /* Now seek to this record. */ record = record * dtp->u.p.current_unit->recl; if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); break; } dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; } else { bytes_left = (int) dtp->u.p.current_unit->bytes_left; bytes_left = min_off (bytes_left, file_length (dtp->u.p.current_unit->s) - stell (dtp->u.p.current_unit->s)); if (sseek (dtp->u.p.current_unit->s, bytes_left, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); break; } dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; } break; } else { do { errno = 0; cc = fbuf_getc (dtp->u.p.current_unit); if (cc == EOF) { if (errno != 0) generate_error (&dtp->common, LIBERROR_OS, NULL); else { if (is_stream_io (dtp) || dtp->u.p.current_unit->pad_status == PAD_NO || dtp->u.p.current_unit->bytes_left == dtp->u.p.current_unit->recl) hit_eof (dtp); } break; } if (is_stream_io (dtp)) dtp->u.p.current_unit->strm_pos++; p = (char) cc; } while (p != '\n'); } break; } } /* Small utility function to write a record marker, taking care of byte swapping and of choosing the correct size. */ static int write_us_marker (st_parameter_dt *dtp, const gfc_offset buf) { size_t len; GFC_INTEGER_4 buf4; GFC_INTEGER_8 buf8; char p[sizeof (GFC_INTEGER_8)]; if (compile_options.record_marker == 0) len = sizeof (GFC_INTEGER_4); else len = compile_options.record_marker; /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */ if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)) { switch (len) { case sizeof (GFC_INTEGER_4): buf4 = buf; return swrite (dtp->u.p.current_unit->s, &buf4, len); break; case sizeof (GFC_INTEGER_8): buf8 = buf; return swrite (dtp->u.p.current_unit->s, &buf8, len); break; default: runtime_error ("Illegal value for record marker"); break; } } else { switch (len) { case sizeof (GFC_INTEGER_4): buf4 = buf; reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4)); return swrite (dtp->u.p.current_unit->s, p, len); break; case sizeof (GFC_INTEGER_8): buf8 = buf; reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8)); return swrite (dtp->u.p.current_unit->s, p, len); break; default: runtime_error ("Illegal value for record marker"); break; } } } /* Position to the next (sub)record in write mode for unformatted sequential files. */ static void next_record_w_unf (st_parameter_dt *dtp, int next_subrecord) { gfc_offset m, m_write, record_marker; /* Bytes written. */ m = dtp->u.p.current_unit->recl_subrecord - dtp->u.p.current_unit->bytes_left_subrecord; /* Write the length tail. If we finish a record containing subrecords, we write out the negative length. */ if (dtp->u.p.current_unit->continued) m_write = -m; else m_write = m; if (unlikely (write_us_marker (dtp, m_write) < 0)) goto io_error; if (compile_options.record_marker == 0) record_marker = sizeof (GFC_INTEGER_4); else record_marker = compile_options.record_marker; /* Seek to the head and overwrite the bogus length with the real length. */ if (unlikely (sseek (dtp->u.p.current_unit->s, - m - 2 * record_marker, SEEK_CUR) < 0)) goto io_error; if (next_subrecord) m_write = -m; else m_write = m; if (unlikely (write_us_marker (dtp, m_write) < 0)) goto io_error; /* Seek past the end of the current record. */ if (unlikely (sseek (dtp->u.p.current_unit->s, m + record_marker, SEEK_CUR) < 0)) goto io_error; return; io_error: generate_error (&dtp->common, LIBERROR_OS, NULL); return; } /* Utility function like memset() but operating on streams. Return value is same as for POSIX write(). */ static ssize_t sset (stream * s, int c, ssize_t nbyte) { static const int WRITE_CHUNK = 256; char p[WRITE_CHUNK]; ssize_t bytes_left, trans; if (nbyte < WRITE_CHUNK) memset (p, c, nbyte); else memset (p, c, WRITE_CHUNK); bytes_left = nbyte; while (bytes_left > 0) { trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK; trans = swrite (s, p, trans); if (trans <= 0) return trans; bytes_left -= trans; } return nbyte - bytes_left; } static inline void memset4 (gfc_char4_t *p, gfc_char4_t c, int k) { int j; for (j = 0; j < k; j++) *p++ = c; } /* Position to the next record in write mode. */ static void next_record_w (st_parameter_dt *dtp, int done) { gfc_offset m, record, max_pos; int length; /* Zero counters for X- and T-editing. */ max_pos = dtp->u.p.max_pos; dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0; switch (current_mode (dtp)) { /* No records in unformatted STREAM I/O. */ case UNFORMATTED_STREAM: return; case FORMATTED_DIRECT: if (dtp->u.p.current_unit->bytes_left == 0) break; fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); fbuf_flush (dtp->u.p.current_unit, WRITING); if (sset (dtp->u.p.current_unit->s, ' ', dtp->u.p.current_unit->bytes_left) != dtp->u.p.current_unit->bytes_left) goto io_error; break; case UNFORMATTED_DIRECT: if (dtp->u.p.current_unit->bytes_left > 0) { length = (int) dtp->u.p.current_unit->bytes_left; if (sset (dtp->u.p.current_unit->s, 0, length) != length) goto io_error; } break; case UNFORMATTED_SEQUENTIAL: next_record_w_unf (dtp, 0); dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; break; case FORMATTED_STREAM: case FORMATTED_SEQUENTIAL: if (is_internal_unit (dtp)) { char *p; if (is_array_io (dtp)) { int finished; length = (int) dtp->u.p.current_unit->bytes_left; /* If the farthest position reached is greater than current position, adjust the position and set length to pad out whats left. Otherwise just pad whats left. (for character array unit) */ m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left; if (max_pos > m) { length = (int) (max_pos - m); if (sseek (dtp->u.p.current_unit->s, length, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; } length = (int) (dtp->u.p.current_unit->recl - max_pos); } p = write_block (dtp, length); if (p == NULL) return; if (unlikely (is_char4_unit (dtp))) { gfc_char4_t *p4 = (gfc_char4_t *) p; memset4 (p4, ' ', length); } else memset (p, ' ', length); /* Now that the current record has been padded out, determine where the next record in the array is. */ record = next_array_record (dtp, dtp->u.p.current_unit->ls, &finished); if (finished) dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Now seek to this record */ record = record * dtp->u.p.current_unit->recl; if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; } dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; } else { length = 1; /* If this is the last call to next_record move to the farthest position reached and set length to pad out the remainder of the record. (for character scaler unit) */ if (done) { m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left; if (max_pos > m) { length = (int) (max_pos - m); if (sseek (dtp->u.p.current_unit->s, length, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; } length = (int) (dtp->u.p.current_unit->recl - max_pos); } else length = (int) dtp->u.p.current_unit->bytes_left; } if (length > 0) { p = write_block (dtp, length); if (p == NULL) return; if (unlikely (is_char4_unit (dtp))) { gfc_char4_t *p4 = (gfc_char4_t *) p; memset4 (p4, (gfc_char4_t) ' ', length); } else memset (p, ' ', length); } } } else { #ifdef HAVE_CRLF const int len = 2; #else const int len = 1; #endif fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); char * p = fbuf_alloc (dtp->u.p.current_unit, len); if (!p) goto io_error; #ifdef HAVE_CRLF *(p++) = '\r'; #endif *p = '\n'; if (is_stream_io (dtp)) { dtp->u.p.current_unit->strm_pos += len; if (dtp->u.p.current_unit->strm_pos < file_length (dtp->u.p.current_unit->s)) unit_truncate (dtp->u.p.current_unit, dtp->u.p.current_unit->strm_pos - 1, &dtp->common); } } break; io_error: generate_error (&dtp->common, LIBERROR_OS, NULL); break; } } /* Position to the next record, which means moving to the end of the current record. This can happen under several different conditions. If the done flag is not set, we get ready to process the next record. */ void next_record (st_parameter_dt *dtp, int done) { gfc_offset fp; /* File position. */ dtp->u.p.current_unit->read_bad = 0; if (dtp->u.p.mode == READING) next_record_r (dtp, done); else next_record_w (dtp, done); if (!is_stream_io (dtp)) { /* Keep position up to date for INQUIRE */ if (done) update_position (dtp->u.p.current_unit); dtp->u.p.current_unit->current_record = 0; if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { fp = stell (dtp->u.p.current_unit->s); /* Calculate next record, rounding up partial records. */ dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1) / dtp->u.p.current_unit->recl; } else dtp->u.p.current_unit->last_record++; } if (!done) pre_position (dtp); fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); } /* Finalize the current data transfer. For a nonadvancing transfer, this means advancing to the next record. For internal units close the stream associated with the unit. */ static void finalize_transfer (st_parameter_dt *dtp) { GFC_INTEGER_4 cf = dtp->common.flags; if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) *dtp->size = dtp->u.p.size_used; if (dtp->u.p.eor_condition) { generate_error (&dtp->common, LIBERROR_EOR, NULL); return; } if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) { if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL) dtp->u.p.current_unit->current_record = 0; return; } if ((dtp->u.p.ionml != NULL) && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0) { if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0) namelist_read (dtp); else namelist_write (dtp); } dtp->u.p.transfer = NULL; if (dtp->u.p.current_unit == NULL) return; if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING) { finish_list_read (dtp); return; } if (dtp->u.p.mode == WRITING) dtp->u.p.current_unit->previous_nonadvancing_write = dtp->u.p.advance_status == ADVANCE_NO; if (is_stream_io (dtp)) { if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && dtp->u.p.advance_status != ADVANCE_NO) next_record (dtp, 1); return; } dtp->u.p.current_unit->current_record = 0; if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar) { fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); dtp->u.p.seen_dollar = 0; return; } /* For non-advancing I/O, save the current maximum position for use in the next I/O operation if needed. */ if (dtp->u.p.advance_status == ADVANCE_NO) { int bytes_written = (int) (dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); dtp->u.p.current_unit->saved_pos = dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0; fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); return; } else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && dtp->u.p.mode == WRITING && !is_internal_unit (dtp)) fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); dtp->u.p.current_unit->saved_pos = 0; next_record (dtp, 1); } /* Transfer function for IOLENGTH. It doesn't actually do any data transfer, it just updates the length counter. */ static void iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), void *dest __attribute__ ((unused)), int kind __attribute__((unused)), size_t size, size_t nelems) { if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) *dtp->iolength += (GFC_IO_INT) (size * nelems); } /* Initialize the IOLENGTH data transfer. This function is in essence a very much simplified version of data_transfer_init(), because it doesn't have to deal with units at all. */ static void iolength_transfer_init (st_parameter_dt *dtp) { if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) *dtp->iolength = 0; memset (&dtp->u.p, 0, sizeof (dtp->u.p)); /* Set up the subroutine that will handle the transfers. */ dtp->u.p.transfer = iolength_transfer; } /* Library entry point for the IOLENGTH form of the INQUIRE statement. The IOLENGTH form requires no I/O to be performed, but it must still be a runtime library call so that we can determine the iolength for dynamic arrays and such. */ extern void st_iolength (st_parameter_dt *); export_proto(st_iolength); void st_iolength (st_parameter_dt *dtp) { library_start (&dtp->common); iolength_transfer_init (dtp); } extern void st_iolength_done (st_parameter_dt *); export_proto(st_iolength_done); void st_iolength_done (st_parameter_dt *dtp __attribute__((unused))) { free_ionml (dtp); library_end (); } /* The READ statement. */ extern void st_read (st_parameter_dt *); export_proto(st_read); void st_read (st_parameter_dt *dtp) { library_start (&dtp->common); data_transfer_init (dtp, 1); } extern void st_read_done (st_parameter_dt *); export_proto(st_read_done); void st_read_done (st_parameter_dt *dtp) { finalize_transfer (dtp); if (is_internal_unit (dtp) || dtp->u.p.format_not_saved) free_format_data (dtp->u.p.fmt); free_ionml (dtp); if (dtp->u.p.current_unit != NULL) unlock_unit (dtp->u.p.current_unit); free_internal_unit (dtp); library_end (); } extern void st_write (st_parameter_dt *); export_proto(st_write); void st_write (st_parameter_dt *dtp) { library_start (&dtp->common); data_transfer_init (dtp, 0); } extern void st_write_done (st_parameter_dt *); export_proto(st_write_done); void st_write_done (st_parameter_dt *dtp) { finalize_transfer (dtp); /* Deal with endfile conditions associated with sequential files. */ if (dtp->u.p.current_unit != NULL && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) switch (dtp->u.p.current_unit->endfile) { case AT_ENDFILE: /* Remain at the endfile record. */ break; case AFTER_ENDFILE: dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */ break; case NO_ENDFILE: /* Get rid of whatever is after this record. */ if (!is_internal_unit (dtp)) unit_truncate (dtp->u.p.current_unit, stell (dtp->u.p.current_unit->s), &dtp->common); dtp->u.p.current_unit->endfile = AT_ENDFILE; break; } if (is_internal_unit (dtp) || dtp->u.p.format_not_saved) free_format_data (dtp->u.p.fmt); free_ionml (dtp); if (dtp->u.p.current_unit != NULL) unlock_unit (dtp->u.p.current_unit); free_internal_unit (dtp); library_end (); } /* F2003: This is a stub for the runtime portion of the WAIT statement. */ void st_wait (st_parameter_wait *wtp __attribute__((unused))) { } /* Receives the scalar information for namelist objects and stores it in a linked list of namelist_info types. */ extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *, GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4); export_proto(st_set_nml_var); void st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name, GFC_INTEGER_4 len, gfc_charlen_type string_length, GFC_INTEGER_4 dtype) { namelist_info *t1 = NULL; namelist_info *nml; size_t var_name_len = strlen (var_name); nml = (namelist_info*) get_mem (sizeof (namelist_info)); nml->mem_pos = var_addr; nml->var_name = (char*) get_mem (var_name_len + 1); memcpy (nml->var_name, var_name, var_name_len); nml->var_name[var_name_len] = '\0'; nml->len = (int) len; nml->string_length = (index_type) string_length; nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK); nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT); nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT); if (nml->var_rank > 0) { nml->dim = (descriptor_dimension*) get_mem (nml->var_rank * sizeof (descriptor_dimension)); nml->ls = (array_loop_spec*) get_mem (nml->var_rank * sizeof (array_loop_spec)); } else { nml->dim = NULL; nml->ls = NULL; } nml->next = NULL; if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0) { dtp->common.flags |= IOPARM_DT_IONML_SET; dtp->u.p.ionml = nml; } else { for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next); t1->next = nml; } } /* Store the dimensional information for the namelist object. */ extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4, index_type, index_type, index_type); export_proto(st_set_nml_var_dim); void st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim, index_type stride, index_type lbound, index_type ubound) { namelist_info * nml; int n; n = (int)n_dim; for (nml = dtp->u.p.ionml; nml->next; nml = nml->next); GFC_DIMENSION_SET(nml->dim[n],lbound,ubound,stride); } /* Reverse memcpy - used for byte swapping. */ void reverse_memcpy (void *dest, const void *src, size_t n) { char *d, *s; size_t i; d = (char *) dest; s = (char *) src + n - 1; /* Write with ascending order - this is likely faster on modern architectures because of write combining. */ for (i=0; iu.p.current_unit->flags.position = POSITION_APPEND; if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) switch (dtp->u.p.current_unit->endfile) { case NO_ENDFILE: case AT_ENDFILE: generate_error (&dtp->common, LIBERROR_END, NULL); if (!is_internal_unit (dtp)) { dtp->u.p.current_unit->endfile = AFTER_ENDFILE; dtp->u.p.current_unit->current_record = 0; } else dtp->u.p.current_unit->endfile = AT_ENDFILE; break; case AFTER_ENDFILE: generate_error (&dtp->common, LIBERROR_ENDFILE, NULL); dtp->u.p.current_unit->current_record = 0; break; } else { /* Non-sequential files don't have an ENDFILE record, so we can't be at AFTER_ENDFILE. */ dtp->u.p.current_unit->endfile = AT_ENDFILE; generate_error (&dtp->common, LIBERROR_END, NULL); dtp->u.p.current_unit->current_record = 0; } }