diff options
Diffstat (limited to 'libgfortran/io/transfer.c')
| -rw-r--r-- | libgfortran/io/transfer.c | 1498 |
1 files changed, 1498 insertions, 0 deletions
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c new file mode 100644 index 00000000000..b1f0ef10598 --- /dev/null +++ b/libgfortran/io/transfer.c @@ -0,0 +1,1498 @@ + +/* Copyright (C) 2002-2003 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 2, 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. + +You should have received a copy of the GNU General Public License +along with Libgfortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +/* transfer.c -- Top level handling of data transfer statements. */ + +#include "config.h" +#include <string.h> +#include "libgfortran.h" +#include "io.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. + * + * transfer_integer + * transfer_logical + * transfer_character + * transfer_real + * transfer_complex + * + * These subroutines do not return status. + * + * 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. + */ + +unit_t *current_unit; +static int sf_seen_eor = 0; + +char scratch[SCRATCH_SIZE]; +static char *line_buffer = NULL; + +static unit_advance advance_status; + +static st_option advance_opt[] = { + {"yes", ADVANCE_YES}, + {"no", ADVANCE_NO}, + {NULL} +}; + + +static void (*transfer) (bt, void *, int); + + +typedef enum +{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL, + FORMATTED_DIRECT, UNFORMATTED_DIRECT +} +file_mode; + + +static file_mode +current_mode (void) +{ + file_mode m; + + if (current_unit->flags.access == ACCESS_DIRECT) + { + m = current_unit->flags.form == FORM_FORMATTED ? + FORMATTED_DIRECT : UNFORMATTED_DIRECT; + } + else + { + m = current_unit->flags.form == FORM_FORMATTED ? + FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL; + } + + return m; +} + + +/* Mid level data transfer statements. These subroutines do reading + * and writing in the style of salloc_r()/salloc_w() within the + * current record. */ + +/* read_sf()-- 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 locations, we use a static buffer. + * For larger allocations, we are forced to allocate memory on the + * heap. Hopefully this won't happen very often. */ + +static char * +read_sf (int *length) +{ + static char data[SCRATCH_SIZE]; + char *base, *p, *q; + int n, unity; + + if (*length > SCRATCH_SIZE) + p = base = line_buffer = get_mem (*length); + else + p = base = data; + + memset(base,'\0',*length); + + current_unit->bytes_left = options.default_recl; + unity = 1; + n = 0; + + do + { + if (is_internal_unit()) + { + /* unity may be modified inside salloc_r if is_internal_unit() is true */ + unity = 1; + } + + q = salloc_r (current_unit->s, &unity); + if (q == NULL) + break; + + if (*q == '\n') + { + if (current_unit->unit_number == options.stdin_unit) + { + if (n <= 0) + continue; + } + /* Unexpected end of line */ + if (current_unit->flags.pad == PAD_NO) + { + generate_error (ERROR_EOR, NULL); + return NULL; + } + + current_unit->bytes_left = 0; + *length = n; + sf_seen_eor = 1; + break; + } + + n++; + *p++ = *q; + sf_seen_eor = 0; + } + while (n < *length); + + return base; +} + + +/* read_block()-- Function for reading the next couple of bytes from + * the current file, advancing the current position. We return a + * pointer to a buffer containing the bytes. We return NULL on end of + * record or end of file. + * + * 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 (int *length) +{ + char *source; + int nread; + + if (current_unit->flags.form == FORM_FORMATTED && + current_unit->flags.access == ACCESS_SEQUENTIAL) + return read_sf (length); /* Special case */ + + if (current_unit->bytes_left < *length) + { + if (current_unit->flags.pad == PAD_NO) + { + generate_error (ERROR_EOR, NULL); /* Not enough data left */ + return NULL; + } + + *length = current_unit->bytes_left; + } + + current_unit->bytes_left -= *length; + + nread = *length; + source = salloc_r (current_unit->s, &nread); + + if (ioparm.size != NULL) + *ioparm.size += nread; + + if (nread != *length) + { /* Short read, this shouldn't happen */ + if (current_unit->flags.pad == PAD_YES) + *length = nread; + else + { + generate_error (ERROR_EOR, NULL); + source = NULL; + } + } + + return source; +} + + +/* write_block()-- 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 (int length) +{ + char *dest; + + if (!is_internal_unit() && current_unit->bytes_left < length) + { + generate_error (ERROR_EOR, NULL); + return NULL; + } + + current_unit->bytes_left -= length; + dest = salloc_w (current_unit->s, &length); + + if (ioparm.size != NULL) + *ioparm.size += length; + + return dest; +} + + +/* unformatted_read()-- Master function for unformatted reads. */ + +static void +unformatted_read (bt type, void *dest, int length) +{ + void *source; + int w; + w = length; + source = read_block (&w); + + if (source != NULL) + { + memcpy (dest, source, w); + if (length != w) + memset (((char *) dest) + w, ' ', length - w); + } +} + +static void +unformatted_write (bt type, void *source, int length) +{ + void *dest; + dest = write_block (length); + if (dest != NULL) + memcpy (dest, source, length); +} + + +/* type_name()-- 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 ("type_name(): Bad type"); + } + + return p; +} + + +/* write_constant_string()-- 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 (fnode * f) +{ + char c, delimiter, *p, *q; + int length; + + length = f->u.string.length; + if (length == 0) + return; + + p = write_block (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') + q++; /* Skip the doubled delimiter */ + } +} + + +/* require_type()-- 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 (bt expected, bt actual, fnode * f) +{ + char buffer[100]; + + if (actual == expected) + return 0; + + st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s", + type_name (expected), g.item_count, type_name (actual)); + + format_error (f, buffer); + return 1; +} + + +/* formatted_transfer()-- This subroutine is 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, processesing format elements. When we + * actually have to transfer data instead of just setting flags, we + * return control to the user program which calls a subroutine that + * supplies the address and type of the next element, then comes back + * here to process it. */ + +static void +formatted_transfer (bt type, void *p, int len) +{ + int pos ,m ; + fnode *f; + int i, 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; + + /* If reversion has occurred and there is another real data item, + * then we have to move to the next record */ + + if (g.reversion_flag && n > 0) + { + g.reversion_flag = 0; + next_record (0); + } + for (;;) + { + consume_data_flag = 1 ; + if (ioparm.library_return != LIBRARY_OK) + break; + + f = next_format (); + if (f == NULL) + return; /* No data descriptors left (already raised) */ + + switch (f->format) + { + case FMT_I: + if (n == 0) + goto need_data; + if (require_type (BT_INTEGER, type, f)) + return; + + if (g.mode == READING) + read_decimal (f, p, len); + else + write_i (f, p, len); + + break; + + case FMT_B: + if (n == 0) + goto need_data; + if (require_type (BT_INTEGER, type, f)) + return; + + if (g.mode == READING) + read_radix (f, p, len, 2); + else + write_b (f, p, len); + + break; + + case FMT_O: + if (n == 0) + goto need_data; + + if (g.mode == READING) + read_radix (f, p, len, 8); + else + write_o (f, p, len); + + break; + + case FMT_Z: + if (n == 0) + goto need_data; + + if (g.mode == READING) + read_radix (f, p, len, 16); + else + write_z (f, p, len); + + break; + + case FMT_A: + if (n == 0) + goto need_data; + if (require_type (BT_CHARACTER, type, f)) + return; + + if (g.mode == READING) + read_a (f, p, len); + else + write_a (f, p, len); + + break; + + case FMT_L: + if (n == 0) + goto need_data; + + if (g.mode == READING) + read_l (f, p, len); + else + write_l (f, p, len); + + break; + + case FMT_D: + if (n == 0) + goto need_data; + if (require_type (BT_REAL, type, f)) + return; + + if (g.mode == READING) + read_f (f, p, len); + else + write_d (f, p, len); + + break; + + case FMT_E: + if (n == 0) + goto need_data; + if (require_type (BT_REAL, type, f)) + return; + + if (g.mode == READING) + read_f (f, p, len); + else + write_e (f, p, len); + break; + + case FMT_EN: + if (n == 0) + goto need_data; + if (require_type (BT_REAL, type, f)) + return; + + if (g.mode == READING) + read_f (f, p, len); + else + write_en (f, p, len); + + break; + + case FMT_ES: + if (n == 0) + goto need_data; + if (require_type (BT_REAL, type, f)) + return; + + if (g.mode == READING) + read_f (f, p, len); + else + write_es (f, p, len); + + break; + + case FMT_F: + if (n == 0) + goto need_data; + if (require_type (BT_REAL, type, f)) + return; + + if (g.mode == READING) + read_f (f, p, len); + else + write_f (f, p, len); + + break; + + case FMT_G: + if (n == 0) + goto need_data; + if (g.mode == READING) + switch (type) + { + case BT_INTEGER: + read_decimal (f, p, len); + break; + case BT_LOGICAL: + read_l (f, p, len); + break; + case BT_CHARACTER: + read_a (f, p, len); + break; + case BT_REAL: + read_f (f, p, len); + break; + default: + goto bad_type; + } + else + switch (type) + { + case BT_INTEGER: + write_i (f, p, len); + break; + case BT_LOGICAL: + write_l (f, p, len); + break; + case BT_CHARACTER: + write_a (f, p, len); + break; + case BT_REAL: + write_d (f, p, len); + break; + default: + bad_type: + internal_error ("formatted_transfer(): Bad type"); + } + + break; + + case FMT_STRING: + consume_data_flag = 0 ; + if (g.mode == READING) + { + format_error (f, "Constant string in input format"); + return; + } + write_constant_string (f); + break; + + /* Format codes that don't transfer data */ + case FMT_X: + case FMT_TR: + consume_data_flag = 0 ; + if (g.mode == READING) + read_x (f); + else + write_x (f); + + break; + + case FMT_T: + pos = f->u.n ; + pos= current_unit->recl - current_unit->bytes_left - pos; + /* fall through */ + + case FMT_TL: + consume_data_flag = 0 ; + pos = f->u.n ; + + if (pos < 0 || pos >= current_unit->recl ) + { + generate_error (ERROR_EOR, "T Or TL edit position error"); + break ; + } + m = pos - (current_unit->recl - current_unit->bytes_left); + + if (m == 0) + break; + + if (m > 0) + { + f->u.n = m; + if (g.mode == READING) + read_x (f); + else + write_x (f); + } + if (m < 0) + { + move_pos_offset (current_unit->s,m); + } + + break; + + case FMT_S: + consume_data_flag = 0 ; + g.sign_status = SIGN_S; + break; + + case FMT_SS: + consume_data_flag = 0 ; + g.sign_status = SIGN_SS; + break; + + case FMT_SP: + consume_data_flag = 0 ; + g.sign_status = SIGN_SP; + break; + + case FMT_BN: + consume_data_flag = 0 ; + g.blank_status = BLANK_NULL; + break; + + case FMT_BZ: + consume_data_flag = 0 ; + g.blank_status = BLANK_ZERO; + break; + + case FMT_P: + consume_data_flag = 0 ; + g.scale_factor = f->u.k; + break; + + case FMT_DOLLAR: + consume_data_flag = 0 ; + g.seen_dollar = 1; + break; + + case FMT_SLASH: + consume_data_flag = 0 ; + for (i = 0; i < f->repeat; i++) + next_record (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 ("Bad format node"); + } + + /* Free a buffer that we had to allocate during a sequential + * formatted read of a block that was larger than the static + * buffer. */ + + if (line_buffer != NULL) + { + free_mem (line_buffer); + line_buffer = NULL; + } + + /* Adjust the item count and data pointer */ + + if ((consume_data_flag > 0) && (n > 0)) + { + n--; + p = ((char *) p) + len; + } + } + + 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 (f); +} + + + +/* 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 (void *p, int kind) +{ + + g.item_count++; + if (ioparm.library_return != LIBRARY_OK) + return; + transfer (BT_INTEGER, p, kind); +} + + +void +transfer_real (void *p, int kind) +{ + + g.item_count++; + if (ioparm.library_return != LIBRARY_OK) + return; + transfer (BT_REAL, p, kind); +} + + +void +transfer_logical (void *p, int kind) +{ + + g.item_count++; + if (ioparm.library_return != LIBRARY_OK) + return; + transfer (BT_LOGICAL, p, kind); +} + + +void +transfer_character (void *p, int len) +{ + + g.item_count++; + if (ioparm.library_return != LIBRARY_OK) + return; + transfer (BT_CHARACTER, p, len); +} + + +void +transfer_complex (void *p, int kind) +{ + + g.item_count++; + if (ioparm.library_return != LIBRARY_OK) + return; + transfer (BT_COMPLEX, p, kind); +} + + +/* us_read()-- Preposition a sequential unformatted file while reading. */ + +static void +us_read (void) +{ + offset_t *p; + int n; + + n = sizeof (offset_t); + p = (offset_t *) salloc_r (current_unit->s, &n); + + if (p == NULL || n != sizeof (offset_t)) + { + generate_error (ERROR_BAD_US, NULL); + return; + } + + current_unit->bytes_left = *p; +} + + +/* us_write()-- Preposition a sequential unformatted file while + * writing. This amount to writing a bogus length that will be filled + * in later. */ + +static void +us_write (void) +{ + offset_t *p; + int length; + + length = sizeof (offset_t); + p = (offset_t *) salloc_w (current_unit->s, &length); + + if (p == NULL) + { + generate_error (ERROR_OS, NULL); + return; + } + + *p = 0; /* Bogus value for now */ + if (sfree (current_unit->s) == FAILURE) + generate_error (ERROR_OS, NULL); + + current_unit->bytes_left = current_unit->recl; +} + + +/* pre_position()-- 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 (void) +{ + + if (current_unit->current_record) + return; /* Already positioned */ + + switch (current_mode ()) + { + case UNFORMATTED_SEQUENTIAL: + if (g.mode == READING) + us_read (); + else + us_write (); + + break; + + case FORMATTED_SEQUENTIAL: + case FORMATTED_DIRECT: + case UNFORMATTED_DIRECT: + current_unit->bytes_left = current_unit->recl; + break; + } + + current_unit->current_record = 1; +} + + +/* data_transfer_init()-- Initialize things for a data transfer. This + * code is common for both reading and writing. */ + +static void +data_transfer_init (int read_flag) +{ + unit_flags u_flags; /* used for creating a unit if needed */ + + g.mode = read_flag ? READING : WRITING; + + if (ioparm.size != NULL) + *ioparm.size = 0; /* Initialize the count */ + + current_unit = get_unit (read_flag); + if (current_unit == NULL) + { /* open the unit with some default flags */ + memset (&u_flags, '\0', sizeof (u_flags)); + u_flags.access = ACCESS_SEQUENTIAL; + u_flags.action = ACTION_READWRITE; + u_flags.form = FORM_UNSPECIFIED; + u_flags.delim = DELIM_UNSPECIFIED; + u_flags.blank = BLANK_UNSPECIFIED; + u_flags.pad = PAD_UNSPECIFIED; + u_flags.status = STATUS_UNKNOWN; + new_unit(&u_flags); + current_unit = get_unit (read_flag); + } + + if (current_unit == NULL) + return; + + if (is_internal_unit() && g.mode==WRITING) + empty_internal_buffer (current_unit->s); + + /* Check the action */ + + if (read_flag && current_unit->flags.action == ACTION_WRITE) + generate_error (ERROR_BAD_ACTION, + "Cannot read from file opened for WRITE"); + + if (!read_flag && current_unit->flags.action == ACTION_READ) + generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ"); + + if (ioparm.library_return != LIBRARY_OK) + return; + + /* Check the format */ + + if (ioparm.format) + parse_format (); + + if (ioparm.library_return != LIBRARY_OK) + return; + + if (current_unit->flags.form == FORM_UNFORMATTED + && (ioparm.format != NULL || ioparm.list_format)) + generate_error (ERROR_OPTION_CONFLICT, + "Format present for UNFORMATTED data transfer"); + + if (ioparm.namelist_name != NULL && ionml != NULL) + { + if(ioparm.format != NULL) + generate_error (ERROR_OPTION_CONFLICT, + "A format cannot be specified with a namelist"); + } + else if (current_unit->flags.form == FORM_FORMATTED && + ioparm.format == NULL && !ioparm.list_format) + generate_error (ERROR_OPTION_CONFLICT, + "Missing format for FORMATTED data transfer"); + + + if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED) + generate_error (ERROR_OPTION_CONFLICT, + "Internal file cannot be accessed by UNFORMATTED data transfer"); + + /* Check the record number */ + + if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0) + { + generate_error (ERROR_MISSING_OPTION, + "Direct access data transfer requires record number"); + return; + } + + if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0) + { + generate_error (ERROR_OPTION_CONFLICT, + "Record number not allowed for sequential access data transfer"); + return; + } + + /* Process the ADVANCE option */ + + advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED : + find_option (ioparm.advance, ioparm.advance_len, advance_opt, + "Bad ADVANCE parameter in data transfer statement"); + + if (advance_status != ADVANCE_UNSPECIFIED) + { + if (current_unit->flags.access == ACCESS_DIRECT) + generate_error (ERROR_OPTION_CONFLICT, + "ADVANCE specification conflicts with sequential access"); + + if (is_internal_unit ()) + generate_error (ERROR_OPTION_CONFLICT, + "ADVANCE specification conflicts with internal file"); + + if (ioparm.format == NULL || ioparm.list_format) + generate_error (ERROR_OPTION_CONFLICT, + "ADVANCE specification requires an explicit format"); + } + + if (read_flag) + { + if (ioparm.eor != 0 && advance_status == ADVANCE_NO) + generate_error (ERROR_MISSING_OPTION, + "EOR specification requires an ADVANCE specification of NO"); + + if (ioparm.size != NULL && advance_status != ADVANCE_NO) + generate_error (ERROR_MISSING_OPTION, + "SIZE specification requires an ADVANCE specification of NO"); + + } + else + { /* Write constraints */ + + if (ioparm.end != 0) + generate_error (ERROR_OPTION_CONFLICT, + "END specification cannot appear in a write statement"); + + if (ioparm.eor != 0) + generate_error (ERROR_OPTION_CONFLICT, + "EOR specification cannot appear in a write statement"); + + if (ioparm.size != 0) + generate_error (ERROR_OPTION_CONFLICT, + "SIZE specification cannot appear in a write statement"); + } + + if (advance_status == ADVANCE_UNSPECIFIED) + advance_status = ADVANCE_YES; + if (ioparm.library_return != LIBRARY_OK) + return; + + /* Sanity checks on the record number */ + + if (ioparm.rec) + { + if (ioparm.rec <= 0) + { + generate_error (ERROR_BAD_OPTION, "Record number must be positive"); + return; + } + + if (ioparm.rec >= current_unit->maxrec) + { + generate_error (ERROR_BAD_OPTION, "Record number too large"); + return; + } + + /* Position the file */ + + if (sseek (current_unit->s, + (ioparm.rec - 1) * current_unit->recl) == FAILURE) + generate_error (ERROR_OS, NULL); + } + + /* Set the initial value of flags */ + + g.blank_status = current_unit->flags.blank; + g.sign_status = SIGN_S; + g.scale_factor = 0; + g.seen_dollar = 0; + g.first_item = 1; + g.item_count = 0; + + pre_position (); + + /* Set up the subroutine that will handle the transfers */ + + if (read_flag) + { + if (current_unit->flags.form == FORM_UNFORMATTED) + transfer = unformatted_read; + else + { + if (ioparm.list_format) + { + transfer = list_formatted_read; + init_at_eol(); + } + else + transfer = formatted_transfer; + } + } + else + { + if (current_unit->flags.form == FORM_UNFORMATTED) + transfer = unformatted_write; + else + { + if (ioparm.list_format) + transfer = list_formatted_write; + else + transfer = formatted_transfer; + } + } + + /* Make sure that we don't do a read after a nonadvancing write */ + + if (read_flag) + { + if (current_unit->read_bad) + { + generate_error (ERROR_BAD_OPTION, + "Cannot READ after a nonadvancing WRITE"); + return; + } + } + else + { + if (advance_status == ADVANCE_YES) + current_unit->read_bad = 1; + } + + /* Start the data transfer if we are doing a formatted transfer */ + if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format + && ioparm.namelist_name == NULL && ionml == NULL) + + formatted_transfer (0, NULL, 0); + +} + + +/* next_record_r()-- Space to the next record for read mode. If the + * file is not seekable, we read MAX_READ chunks until we get to the + * right position. */ + +#define MAX_READ 4096 + +static void +next_record_r (int done) +{ + int rlength, length; + offset_t new; + char *p; + + switch (current_mode ()) + { + case UNFORMATTED_SEQUENTIAL: + current_unit->bytes_left += sizeof (offset_t); /* Skip over tail */ + + /* Fall through */ + + case FORMATTED_DIRECT: + case UNFORMATTED_DIRECT: + if (current_unit->bytes_left == 0) + break; + + if (is_seekable (current_unit->s)) + { + new = file_position (current_unit->s) + current_unit->bytes_left; + + /* Direct access files do not generate END conditions, only I/O errors */ + + if (sseek (current_unit->s, new) == FAILURE) + generate_error (ERROR_OS, NULL); + + } + else + { /* Seek by reading data */ + while (current_unit->bytes_left > 0) + { + rlength = length = (MAX_READ > current_unit->bytes_left) ? + MAX_READ : current_unit->bytes_left; + + p = salloc_r (current_unit->s, &rlength); + if (p == NULL) + { + generate_error (ERROR_OS, NULL); + break; + } + + current_unit->bytes_left -= length; + } + } + + break; + + case FORMATTED_SEQUENTIAL: + length = 1; + if (sf_seen_eor && done) + break; + + do + { + p = salloc_r (current_unit->s, &length); + + /*In case of internal file, there may not be any '\n'.*/ + if (is_internal_unit() && p == NULL) + { + break; + } + + if (p == NULL) + { + generate_error (ERROR_OS, NULL); + break; + } + + if (length == 0) + { + current_unit->endfile = AT_ENDFILE; + break; + } + } + while (*p != '\n'); + + break; + } + + if (current_unit->flags.access == ACCESS_SEQUENTIAL) + test_endfile (current_unit); +} + + +/* next_record_w()-- Position to the next record in write mode */ + +static void +next_record_w (int done) +{ + offset_t c, m; + int length; + char *p; + + switch (current_mode ()) + { + case FORMATTED_DIRECT: + case UNFORMATTED_DIRECT: + if (current_unit->bytes_left == 0) + break; + + length = current_unit->bytes_left; + + p = salloc_w (current_unit->s, &length); + if (p == NULL) + goto io_error; + + memset (p, ' ', current_unit->bytes_left); + if (sfree (current_unit->s) == FAILURE) + goto io_error; + + break; + + case UNFORMATTED_SEQUENTIAL: + m = current_unit->recl - current_unit->bytes_left; /* Bytes written */ + c = file_position (current_unit->s); + + length = sizeof (offset_t); + + /* Write the length tail */ + + p = salloc_w (current_unit->s, &length); + if (p == NULL) + goto io_error; + + *((offset_t *) p) = m; + if (sfree (current_unit->s) == FAILURE) + goto io_error; + + /* Seek to the head and overwrite the bogus length with the real length */ + + p = salloc_w_at (current_unit->s, &length, c - m - length); + if (p == NULL) + generate_error (ERROR_OS, NULL); + + *((offset_t *) p) = m; + if (sfree (current_unit->s) == FAILURE) + goto io_error; + + /* Seek past the end of the current record */ + + if (sseek (current_unit->s, c + sizeof (offset_t)) == FAILURE) + goto io_error; + + break; + + case FORMATTED_SEQUENTIAL: + length = 1; + p = salloc_w (current_unit->s, &length); + + if (!is_internal_unit()) + { + if (p) + *p = '\n'; /* no CR for internal writes */ + else + goto io_error; + } + + if (sfree (current_unit->s) == FAILURE) + goto io_error; + + break; + + io_error: + generate_error (ERROR_OS, NULL); + break; + } +} + + +/* next_record()-- 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 (int done) +{ + + current_unit->read_bad = 0; + + if (g.mode == READING) + next_record_r (done); + else + next_record_w (done); + + current_unit->current_record = 0; + if (current_unit->flags.access == ACCESS_DIRECT) + current_unit->last_record = file_position (current_unit->s) + / current_unit->recl; + else + current_unit->last_record++; + + if (!done) + pre_position (); +} + + +/* Finalize the current data transfer. For a nonadvancing transfer, + * this means advancing to the next record. */ + +static void +finalize_transfer (void) +{ + + if (setjmp (g.eof_jump)) + { + generate_error (ERROR_END, NULL); + return; + } + + if ((ionml != NULL) && (ioparm.namelist_name != NULL)) + { + if (ioparm.namelist_read_mode) + namelist_read(); + else + namelist_write(); + } + + transfer = NULL; + if (current_unit == NULL) + return; + + if (ioparm.list_format && g.mode == READING) + finish_list_read (); + else + { + free_fnodes (); + + if (advance_status == ADVANCE_NO) + return; + next_record (1); + current_unit->current_record = 0; + } + + sfree (current_unit->s); +} + + +/* The READ statement */ + +void +st_read (void) +{ + + library_start (); + + data_transfer_init (1); + + /* Handle complications dealing with the endfile record. It is + * significant that this is the only place where ERROR_END is + * generated. Reading an end of file elsewhere is either end of + * record or an I/O error. */ + + if (current_unit->flags.access == ACCESS_SEQUENTIAL) + switch (current_unit->endfile) + { + case NO_ENDFILE: + break; + + case AT_ENDFILE: + if (!is_internal_unit()) + { + generate_error (ERROR_END, NULL); + current_unit->endfile = AFTER_ENDFILE; + } + break; + + case AFTER_ENDFILE: + generate_error (ERROR_ENDFILE, NULL); + break; + } +} + + +void +st_read_done (void) +{ + finalize_transfer (); + + library_end (); +} + + +void +st_write (void) +{ + + library_start (); + data_transfer_init (0); +} + + +void +st_write_done (void) +{ + + finalize_transfer (); + + /* Deal with endfile conditions associated with sequential files */ + + if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL) + switch (current_unit->endfile) + { + case AT_ENDFILE: /* Remain at the endfile record */ + break; + + case AFTER_ENDFILE: + current_unit->endfile = AT_ENDFILE; /* Just at it now */ + break; + + case NO_ENDFILE: /* Get rid of whatever is after this record */ + if (struncate (current_unit->s) == FAILURE) + generate_error (ERROR_OS, NULL); + + current_unit->endfile = AT_ENDFILE; + break; + } + + library_end (); +} + + +static void +st_set_nml_var (void * var_addr, char * var_name, int var_name_len, + int kind, bt type) +{ + namelist_info *t1 = NULL, *t2 = NULL; + namelist_info *nml = (namelist_info *) get_mem (sizeof( + namelist_info )); + nml->mem_pos = var_addr; + nml->var_name = (char*) get_mem (var_name_len+1); + strncpy (nml->var_name,var_name,var_name_len); + nml->var_name[var_name_len] = 0; + nml->len = kind; + nml->type = type; + + nml->next = NULL; + + if (ionml == NULL) + ionml = nml; + else + { + t1 = ionml; + while (t1 != NULL) + { + t2 = t1; + t1 = t1->next; + } + t2->next = nml; + } +} + +void +st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len, + int kind) +{ + st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER); +} + +void +st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len, + int kind) +{ + st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_REAL); +} + +void +st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len, + int kind) +{ + st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER); +} + +void +st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len, + int kind) +{ + st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_COMPLEX); +} + +void +st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len, + int kind) +{ + st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_LOGICAL); +} + |