1594 lines
34 KiB
C
1594 lines
34 KiB
C
|
|
/* 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 <assert.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.
|
|
*/
|
|
|
|
gfc_unit *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_TL:
|
|
case FMT_T:
|
|
if (f->format==FMT_TL)
|
|
{
|
|
pos = f->u.n ;
|
|
pos= current_unit->recl - current_unit->bytes_left - pos;
|
|
}
|
|
else // FMT==T
|
|
{
|
|
consume_data_flag = 0 ;
|
|
pos = f->u.n - 1;
|
|
}
|
|
|
|
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)
|
|
{
|
|
gfc_offset *p;
|
|
int n;
|
|
|
|
n = sizeof (gfc_offset);
|
|
p = (gfc_offset *) salloc_r (current_unit->s, &n);
|
|
|
|
if (p == NULL || n != sizeof (gfc_offset))
|
|
{
|
|
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)
|
|
{
|
|
gfc_offset *p;
|
|
int length;
|
|
|
|
length = sizeof (gfc_offset);
|
|
p = (gfc_offset *) 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);
|
|
|
|
/* for sequential unformatted, we write until we have more bytes than
|
|
can fit in the record markers. if disk space runs out first it will
|
|
error on the write */
|
|
current_unit->recl = g.max_offset;
|
|
|
|
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;
|
|
/* is it unformatted ?*/
|
|
if (ioparm.format == NULL && !ioparm.list_format)
|
|
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.status = STATUS_UNKNOWN;
|
|
new_unit(&u_flags);
|
|
current_unit = get_unit (read_flag);
|
|
}
|
|
|
|
if (current_unit == NULL)
|
|
return;
|
|
|
|
if (is_internal_unit())
|
|
{
|
|
current_unit->recl = file_length(current_unit->s);
|
|
if (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;
|
|
gfc_offset new;
|
|
char *p;
|
|
|
|
switch (current_mode ())
|
|
{
|
|
case UNFORMATTED_SEQUENTIAL:
|
|
current_unit->bytes_left += sizeof (gfc_offset); /* 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)
|
|
{
|
|
gfc_offset c, m;
|
|
int length;
|
|
char *p;
|
|
|
|
switch (current_mode ())
|
|
{
|
|
case FORMATTED_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_DIRECT:
|
|
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 (gfc_offset);
|
|
|
|
/* Write the length tail */
|
|
|
|
p = salloc_w (current_unit->s, &length);
|
|
if (p == NULL)
|
|
goto io_error;
|
|
|
|
*((gfc_offset *) 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);
|
|
|
|
*((gfc_offset *) 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 (gfc_offset)) == 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)
|
|
{
|
|
gfc_offset fp; /* file position */
|
|
|
|
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)
|
|
{
|
|
fp = file_position (current_unit->s);
|
|
/* Calculate next record, rounding up partial records. */
|
|
current_unit->last_record = (fp + curren_unit->recl - 1)
|
|
/ 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)
|
|
{
|
|
/* Most systems buffer lines, so force the partial record
|
|
to be written out. */
|
|
flush (current_unit->s);
|
|
return;
|
|
}
|
|
|
|
next_record (1);
|
|
current_unit->current_record = 0;
|
|
}
|
|
|
|
sfree (current_unit->s);
|
|
}
|
|
|
|
|
|
/* Transfer function for IOLENGTH. It doesn't actually do any
|
|
data transfer, it just updates the length counter. */
|
|
|
|
static void
|
|
iolength_transfer (bt type, void *dest, int len)
|
|
{
|
|
if (ioparm.iolength != NULL)
|
|
*ioparm.iolength += len;
|
|
}
|
|
|
|
|
|
/* 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 (void)
|
|
{
|
|
|
|
if (ioparm.iolength != NULL)
|
|
*ioparm.iolength = 0;
|
|
|
|
g.item_count = 0;
|
|
|
|
/* Set up the subroutine that will handle the transfers. */
|
|
|
|
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. */
|
|
|
|
void
|
|
st_iolength (void)
|
|
{
|
|
library_start ();
|
|
|
|
iolength_transfer_init ();
|
|
}
|
|
|
|
void
|
|
st_iolength_done (void)
|
|
{
|
|
library_end ();
|
|
}
|
|
|
|
|
|
/* 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, int string_length)
|
|
{
|
|
namelist_info *t1 = NULL, *t2 = NULL;
|
|
namelist_info *nml = (namelist_info *) get_mem (sizeof(
|
|
namelist_info ));
|
|
nml->mem_pos = var_addr;
|
|
if (var_name)
|
|
{
|
|
assert (var_name_len > 0);
|
|
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;
|
|
}
|
|
else
|
|
{
|
|
assert (var_name_len == 0);
|
|
nml->var_name = NULL;
|
|
}
|
|
|
|
nml->len = kind;
|
|
nml->type = type;
|
|
nml->string_length = string_length;
|
|
|
|
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, 0);
|
|
}
|
|
|
|
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, 0);
|
|
}
|
|
|
|
void
|
|
st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
|
|
int kind, gfc_strlen_type string_length)
|
|
{
|
|
st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER,
|
|
string_length);
|
|
}
|
|
|
|
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, 0);
|
|
}
|
|
|
|
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, 0);
|
|
}
|
|
|