-/* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
the Free Software Foundation; either version 2, or (at your option)
any later version.
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
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
st_write(), an error inhibits any data from actually being
transferred. */
-gfc_unit *current_unit;
+extern void transfer_integer (void *, int);
+export_proto(transfer_integer);
+
+extern void transfer_real (void *, int);
+export_proto(transfer_real);
+
+extern void transfer_logical (void *, int);
+export_proto(transfer_logical);
+
+extern void transfer_character (void *, int);
+export_proto(transfer_character);
+
+extern void transfer_complex (void *, int);
+export_proto(transfer_complex);
+
+gfc_unit *current_unit = NULL;
static int sf_seen_eor = 0;
-char scratch[SCRATCH_SIZE];
+char scratch[SCRATCH_SIZE] = { };
static char *line_buffer = NULL;
static unit_advance advance_status;
{
static char data[SCRATCH_SIZE];
char *base, *p, *q;
- int n, unity;
+ int n, readlen;
if (*length > SCRATCH_SIZE)
p = base = line_buffer = get_mem (*length);
memset(base,'\0',*length);
current_unit->bytes_left = options.default_recl;
- unity = 1;
+ readlen = 1;
n = 0;
do
{
if (is_internal_unit())
{
- /* unity may be modified inside salloc_r if
+ /* readlen may be modified inside salloc_r if
is_internal_unit() is true. */
- unity = 1;
+ readlen = 1;
}
- q = salloc_r (current_unit->s, &unity);
+ q = salloc_r (current_unit->s, &readlen);
if (q == NULL)
break;
- if (*q == '\n')
+ /* If we have a line without a terminating \n, drop through to
+ EOR below. */
+ if (readlen < 1 && n == 0)
+ {
+ generate_error (ERROR_END, NULL);
+ return NULL;
+ }
+
+ if (readlen < 1 || *q == '\n' || *q == '\r')
{
+ /* ??? What is this for? */
if (current_unit->unit_number == options.stdin_unit)
{
if (n <= 0)
{
void *source;
int w;
+
+ /* Transfer functions get passed the kind of the entity, so we have
+ to fix this for COMPLEX data which are twice the size of their
+ kind. */
+ if (type == BT_COMPLEX)
+ length *= 2;
+
w = length;
source = read_block (&w);
unformatted_write (bt type, void *source, int length)
{
void *dest;
- dest = write_block (length);
- if (dest != NULL)
- memcpy (dest, source, length);
+
+ /* Correction for kind vs. length as in unformatted_read. */
+ if (type == BT_COMPLEX)
+ length *= 2;
+
+ dest = write_block (length);
+ if (dest != NULL)
+ memcpy (dest, source, length);
}
for (; length > 0; length--)
{
c = *p++ = *q++;
- if (c == delimiter && c != 'H')
+ if (c == delimiter && c != 'H' && c != 'h')
q++; /* Skip the doubled delimiter. */
}
}
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 (;;)
{
+ /* 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);
+ }
+
consume_data_flag = 1 ;
if (ioparm.library_return != LIBRARY_OK)
break;
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:
+ /* 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;
void
transfer_real (void *p, int kind)
{
-
g.item_count++;
if (ioparm.library_return != LIBRARY_OK)
return;
void
transfer_logical (void *p, int kind)
{
-
g.item_count++;
if (ioparm.library_return != LIBRARY_OK)
return;
void
transfer_character (void *p, int len)
{
-
g.item_count++;
if (ioparm.library_return != LIBRARY_OK)
return;
void
transfer_complex (void *p, int kind)
{
-
g.item_count++;
if (ioparm.library_return != LIBRARY_OK)
return;
static void
us_read (void)
{
- gfc_offset *p;
+ char *p;
int n;
+ gfc_offset i;
n = sizeof (gfc_offset);
- p = (gfc_offset *) salloc_r (current_unit->s, &n);
+ p = salloc_r (current_unit->s, &n);
+
+ if (n == 0)
+ return; /* end of file */
if (p == NULL || n != sizeof (gfc_offset))
{
return;
}
- current_unit->bytes_left = *p;
+ memcpy (&i, p, sizeof (gfc_offset));
+ current_unit->bytes_left = i;
}
static void
us_write (void)
{
- gfc_offset *p;
+ char *p;
int length;
length = sizeof (gfc_offset);
- p = (gfc_offset *) salloc_w (current_unit->s, &length);
+ p = salloc_w (current_unit->s, &length);
if (p == NULL)
{
return;
}
- *p = 0; /* Bogus value for now. */
+ memset (p, '\0', sizeof (gfc_offset)); /* Bogus value for now. */
if (sfree (current_unit->s) == FAILURE)
generate_error (ERROR_OS, NULL);
static void
pre_position (void)
{
-
if (current_unit->current_record)
return; /* Already positioned. */
current_unit = get_unit (read_flag);
if (current_unit == NULL)
{ /* Open the unit with some default flags. */
+ if (ioparm.unit < 0)
+ {
+ generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
+ library_end ();
+ return;
+ }
memset (&u_flags, '\0', sizeof (u_flags));
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
if (read_flag)
{
- if (ioparm.eor != 0 && advance_status == ADVANCE_NO)
+ if (ioparm.eor != 0 && advance_status != ADVANCE_NO)
generate_error (ERROR_MISSING_OPTION,
"EOR specification requires an ADVANCE specification of NO");
generate_error (ERROR_OS, NULL);
}
+ /* Overwriting an existing sequential file ?
+ it is always safe to truncate the file on the first write */
+ if (g.mode == WRITING
+ && current_unit->flags.access == ACCESS_SEQUENTIAL
+ && current_unit->current_record == 0)
+ struncate(current_unit->s);
+
current_unit->mode = g.mode;
/* Set the initial value of flags. */
g.seen_dollar = 0;
g.first_item = 1;
g.item_count = 0;
+ sf_seen_eor = 0;
pre_position ();
/* 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);
-
+ formatted_transfer (0, NULL, 0);
}
current_unit->bytes_left -= length;
}
}
-
break;
case FORMATTED_SEQUENTIAL:
length = 1;
- if (sf_seen_eor && done)
+ /* sf_read has already terminated input because of an '\n' */
+ if (sf_seen_eor)
break;
do
if (p == NULL)
goto io_error;
- *((gfc_offset *) p) = m;
+ memcpy (p, &m, sizeof (gfc_offset));
if (sfree (current_unit->s) == FAILURE)
goto io_error;
if (p == NULL)
generate_error (ERROR_OS, NULL);
- *((gfc_offset *) p) = m;
+ memcpy (p, &m, sizeof (gfc_offset));
if (sfree (current_unit->s) == FAILURE)
goto io_error;
else
next_record_w (done);
+ /* keep position up to date for INQUIRE */
+ current_unit->flags.position = POSITION_ASIS;
+
current_unit->current_record = 0;
if (current_unit->flags.access == ACCESS_DIRECT)
{
/* Finalize the current data transfer. For a nonadvancing transfer,
- this means advancing to the next record. */
+ this means advancing to the next record. For internal units close the
+ steam associated with the unit. */
static void
finalize_transfer (void)
{
-
- if (setjmp (g.eof_jump))
- {
- generate_error (ERROR_END, NULL);
- return;
- }
+ if (ioparm.library_return != LIBRARY_OK)
+ return;
if ((ionml != NULL) && (ioparm.namelist_name != NULL))
{
if (current_unit == NULL)
return;
+ if (setjmp (g.eof_jump))
+ {
+ generate_error (ERROR_END, NULL);
+ return;
+ }
+
if (ioparm.list_format && g.mode == READING)
finish_list_read ();
else
}
sfree (current_unit->s);
+
+ if (is_internal_unit ())
+ sclose (current_unit->s);
}
static void
iolength_transfer_init (void)
{
-
if (ioparm.iolength != NULL)
*ioparm.iolength = 0;
/* Set up the subroutine that will handle the transfers. */
transfer = iolength_transfer;
-
}
it must still be a runtime library call so that we can determine
the iolength for dynamic arrays and such. */
+extern void st_iolength (void);
+export_proto(st_iolength);
+
void
st_iolength (void)
{
library_start ();
-
iolength_transfer_init ();
}
+extern void st_iolength_done (void);
+export_proto(st_iolength_done);
+
void
st_iolength_done (void)
{
/* The READ statement. */
+extern void st_read (void);
+export_proto(st_read);
+
void
st_read (void)
{
-
library_start ();
data_transfer_init (1);
}
}
+extern void st_read_done (void);
+export_proto(st_read_done);
void
st_read_done (void)
{
finalize_transfer ();
-
library_end ();
}
+extern void st_write (void);
+export_proto(st_write);
void
st_write (void)
{
-
library_start ();
data_transfer_init (0);
}
+extern void st_write_done (void);
+export_proto(st_write_done);
void
st_write_done (void)
{
-
finalize_transfer ();
/* Deal with endfile conditions associated with sequential files. */
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);
+ case NO_ENDFILE:
+ if (current_unit->current_record > current_unit->last_record)
+ {
+ /* 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;
}
}
+extern void st_set_nml_var_int (void *, char *, int, int);
+export_proto(st_set_nml_var_int);
+
+extern void st_set_nml_var_float (void *, char *, int, int);
+export_proto(st_set_nml_var_float);
+
+extern void st_set_nml_var_char (void *, char *, int, int, gfc_charlen_type);
+export_proto(st_set_nml_var_char);
+
+extern void st_set_nml_var_complex (void *, char *, int, int);
+export_proto(st_set_nml_var_complex);
+
+extern void st_set_nml_var_log (void *, char *, int, int);
+export_proto(st_set_nml_var_log);
+
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);
}
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);
}
st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
int kind, gfc_charlen_type string_length)
{
-
st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER,
string_length);
}
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);
}
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);
}
-
OSDN Git Service
