static void
already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
{
if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
{
edit_modes (opp, u, flags);
return;
}
/* If the file is connected to something else, close it and open a
new unit. */
if (!compare_file_filename (u, opp->file, opp->file_len))
{
#if !HAVE_UNLINK_OPEN_FILE
char *path = NULL;
if (u->file && u->flags.status == STATUS_SCRATCH)
{
path = (char *) gfc_alloca (u->file_len + 1);
unpack_filename (path, u->file, u->file_len);
}
#endif
if (sclose (u->s) == FAILURE)
{
unlock_unit (u);
generate_error (&opp->common, LIBERROR_OS,
"Error closing file in OPEN statement");
return;
}
u->s = NULL;
if (u->file)
free_mem (u->file);
u->file = NULL;
u->file_len = 0;
#if !HAVE_UNLINK_OPEN_FILE
if (path != NULL)
unlink (path);
#endif
u = new_unit (opp, u, flags);
if (u != NULL)
unlock_unit (u);
return;
}
edit_modes (opp, u, flags);
}
int
PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
{
int ret;
gfc_unit * u = find_unit (*unit);
if (u == NULL)
return -1;
fbuf_reset (u);
if (u->mode == WRITING)
{
sflush (u->s);
u->mode = READING;
}
memset (c, ' ', c_len);
ret = sread (u->s, c, 1);
unlock_unit (u);
if (ret < 0)
return ret;
if (ret != 1)
return -1;
else
return 0;
}
void
st_inquire (st_parameter_inquire *iqp)
{
gfc_unit *u;
library_start (&iqp->common);
if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
{
u = find_unit (iqp->common.unit);
inquire_via_unit (iqp, u);
}
else
{
u = find_file (iqp->file, iqp->file_len);
if (u == NULL)
inquire_via_filename (iqp);
else
inquire_via_unit (iqp, u);
}
if (u != NULL)
unlock_unit (u);
library_end ();
}
void
st_rewind (st_parameter_filepos *fpp)
{
gfc_unit *u;
library_start (&fpp->common);
u = find_unit (fpp->common.unit);
if (u != NULL)
{
if (u->flags.access == ACCESS_DIRECT)
generate_error (&fpp->common, LIBERROR_BAD_OPTION,
"Cannot REWIND a file opened for DIRECT access");
else
{
/* If there are previously written bytes from a write with ADVANCE="no",
add a record marker before performing the ENDFILE. */
if (u->previous_nonadvancing_write)
finish_last_advance_record (u);
u->previous_nonadvancing_write = 0;
fbuf_reset (u);
u->last_record = 0;
if (sseek (u->s, 0, SEEK_SET) < 0)
generate_error (&fpp->common, LIBERROR_OS, NULL);
/* Handle special files like /dev/null differently. */
if (!is_special (u->s))
{
/* We are rewinding so we are not at the end. */
u->endfile = NO_ENDFILE;
}
else
{
/* Set this for compatibilty with g77 for /dev/null. */
if (file_length (u->s) == 0 && stell (u->s) == 0)
u->endfile = AT_ENDFILE;
/* Future refinements on special files can go here. */
}
u->current_record = 0;
u->strm_pos = 1;
u->read_bad = 0;
}
/* Update position for INQUIRE. */
u->flags.position = POSITION_REWIND;
unlock_unit (u);
}
library_end ();
}
static gfc_offset
gf_ftell (int unit)
{
gfc_unit * u = find_unit (unit);
if (u == NULL)
return -1;
int pos = fbuf_reset (u);
if (pos != 0)
sseek (u->s, pos, SEEK_CUR);
gfc_offset ret = stell (u->s);
unlock_unit (u);
return ret;
}
static void
already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
{
if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
{
edit_modes (opp, u, flags);
return;
}
/* If the file is connected to something else, close it and open a
new unit. */
if (!compare_file_filename (u, opp->file, opp->file_len))
{
if (sclose (u->s) == -1)
{
unlock_unit (u);
generate_error (&opp->common, LIBERROR_OS,
"Error closing file in OPEN statement");
return;
}
u->s = NULL;
#if !HAVE_UNLINK_OPEN_FILE
if (u->filename && u->flags.status == STATUS_SCRATCH)
remove (u->filename);
#endif
free (u->filename);
u->filename = NULL;
u = new_unit (opp, u, flags);
if (u != NULL)
unlock_unit (u);
return;
}
edit_modes (opp, u, flags);
}
GFC_LOGICAL_8
isatty_l8 (int *unit)
{
gfc_unit *u;
GFC_LOGICAL_8 ret = 0;
u = find_unit (*unit);
if (u != NULL)
{
ret = (GFC_LOGICAL_8) stream_isatty (u->s);
unlock_unit (u);
}
return ret;
}
void
ttynam (char ** name, gfc_charlen_type * name_len, int unit)
{
gfc_unit *u;
u = find_unit (unit);
if (u != NULL)
{
*name = xmalloc (TTY_NAME_MAX);
int err = stream_ttyname (u->s, *name, TTY_NAME_MAX);
if (err == 0)
{
*name_len = strlen (*name);
unlock_unit (u);
return;
}
free (*name);
unlock_unit (u);
}
*name_len = 0;
*name = NULL;
}
void
fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
{
gfc_unit * u = find_unit (*unit);
ssize_t result = -1;
if (u != NULL)
{
result = sseek(u->s, *offset, *whence);
unlock_unit (u);
}
if (status)
*status = (result < 0 ? -1 : 0);
}
void
st_endfile (st_parameter_filepos *fpp)
{
gfc_unit *u;
library_start (&fpp->common);
u = find_unit (fpp->common.unit);
if (u != NULL)
{
if (u->flags.access == ACCESS_DIRECT)
{
generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
"Cannot perform ENDFILE on a file opened"
" for DIRECT access");
goto done;
}
/* If there are previously written bytes from a write with ADVANCE="no",
add a record marker before performing the ENDFILE. */
if (u->previous_nonadvancing_write)
finish_last_advance_record (u);
u->previous_nonadvancing_write = 0;
if (u->current_record)
{
st_parameter_dt dtp;
dtp.common = fpp->common;
memset (&dtp.u.p, 0, sizeof (dtp.u.p));
dtp.u.p.current_unit = u;
next_record (&dtp, 1);
}
unit_truncate (u, stell (u->s), &fpp->common);
u->endfile = AFTER_ENDFILE;
if (0 == stell (u->s))
u->flags.position = POSITION_REWIND;
done:
unlock_unit (u);
}
library_end ();
}
void
flush_i8 (GFC_INTEGER_8 *unit)
{
gfc_unit *us;
/* flush all streams */
if (unit == NULL)
flush_all_units ();
else
{
us = find_unit (*unit);
if (us != NULL)
{
sflush (us->s);
unlock_unit (us);
}
}
}
void
ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
{
gfc_unit *u;
int nlen;
int err = 1;
u = find_unit (*unit);
if (u != NULL)
{
err = stream_ttyname (u->s, name, name_len);
if (err == 0)
{
nlen = strlen (name);
memset (&name[nlen], ' ', name_len - nlen);
}
unlock_unit (u);
}
if (err != 0)
memset (name, ' ', name_len);
}
int
PREFIX(fputc) (const int * unit, char * c,
gfc_charlen_type c_len __attribute__((unused)))
{
ssize_t s;
gfc_unit * u = find_unit (*unit);
if (u == NULL)
return -1;
fbuf_reset (u);
if (u->mode == READING)
{
sflush (u->s);
u->mode = WRITING;
}
s = swrite (u->s, c, 1);
unlock_unit (u);
if (s < 0)
return -1;
return 0;
}
void
st_flush (st_parameter_filepos *fpp)
{
gfc_unit *u;
library_start (&fpp->common);
u = find_unit (fpp->common.unit);
if (u != NULL)
{
/* Make sure format buffer is flushed. */
if (u->flags.form == FORM_FORMATTED)
fbuf_flush (u, u->mode);
sflush (u->s);
unlock_unit (u);
}
else
/* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
generate_error (&fpp->common, LIBERROR_BAD_OPTION,
"Specified UNIT in FLUSH is not connected");
library_end ();
}
void
st_endfile (st_parameter_filepos *fpp)
{
gfc_unit *u;
library_start (&fpp->common);
u = find_unit (fpp->common.unit);
if (u != NULL)
{
if (u->flags.access == ACCESS_DIRECT)
{
generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
"Cannot perform ENDFILE on a file opened "
"for DIRECT access");
goto done;
}
if (u->flags.access == ACCESS_SEQUENTIAL
&& u->endfile == AFTER_ENDFILE)
{
generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
"Cannot perform ENDFILE on a file already "
"positioned after the EOF marker");
goto done;
}
/* If there are previously written bytes from a write with ADVANCE="no",
add a record marker before performing the ENDFILE. */
if (u->previous_nonadvancing_write)
finish_last_advance_record (u);
u->previous_nonadvancing_write = 0;
if (u->current_record)
{
st_parameter_dt dtp;
dtp.common = fpp->common;
memset (&dtp.u.p, 0, sizeof (dtp.u.p));
dtp.u.p.current_unit = u;
next_record (&dtp, 1);
}
unit_truncate (u, stell (u->s), &fpp->common);
u->endfile = AFTER_ENDFILE;
if (0 == stell (u->s))
u->flags.position = POSITION_REWIND;
}
else
{
if (fpp->common.unit < 0)
{
generate_error (&fpp->common, LIBERROR_BAD_OPTION,
"Bad unit number in statement");
return;
}
u = find_or_create_unit (fpp->common.unit);
if (u->s == NULL)
{
/* Open the unit with some default flags. */
st_parameter_open opp;
unit_flags u_flags;
memset (&u_flags, '\0', sizeof (u_flags));
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
/* Is it unformatted? */
if (!(fpp->common.flags & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
| IOPARM_DT_IONML_SET)))
u_flags.form = FORM_UNFORMATTED;
else
u_flags.form = FORM_UNSPECIFIED;
u_flags.delim = DELIM_UNSPECIFIED;
u_flags.blank = BLANK_UNSPECIFIED;
u_flags.pad = PAD_UNSPECIFIED;
u_flags.decimal = DECIMAL_UNSPECIFIED;
u_flags.encoding = ENCODING_UNSPECIFIED;
u_flags.async = ASYNC_UNSPECIFIED;
u_flags.round = ROUND_UNSPECIFIED;
u_flags.sign = SIGN_UNSPECIFIED;
u_flags.status = STATUS_UNKNOWN;
u_flags.convert = GFC_CONVERT_NATIVE;
opp.common = fpp->common;
opp.common.flags &= IOPARM_COMMON_MASK;
u = new_unit (&opp, u, &u_flags);
if (u == NULL)
return;
u->endfile = AFTER_ENDFILE;
}
}
done:
unlock_unit (u);
library_end ();
}
void
st_open (st_parameter_open *opp)
{
unit_flags flags;
gfc_unit *u = NULL;
GFC_INTEGER_4 cf = opp->common.flags;
unit_convert conv;
library_start (&opp->common);
/* Decode options. */
flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
find_option (&opp->common, opp->access, opp->access_len,
access_opt, "Bad ACCESS parameter in OPEN statement");
flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
find_option (&opp->common, opp->action, opp->action_len,
action_opt, "Bad ACTION parameter in OPEN statement");
flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
find_option (&opp->common, opp->blank, opp->blank_len,
blank_opt, "Bad BLANK parameter in OPEN statement");
flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
find_option (&opp->common, opp->delim, opp->delim_len,
delim_opt, "Bad DELIM parameter in OPEN statement");
flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
find_option (&opp->common, opp->pad, opp->pad_len,
pad_opt, "Bad PAD parameter in OPEN statement");
flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
find_option (&opp->common, opp->decimal, opp->decimal_len,
decimal_opt, "Bad DECIMAL parameter in OPEN statement");
flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
find_option (&opp->common, opp->encoding, opp->encoding_len,
encoding_opt, "Bad ENCODING parameter in OPEN statement");
flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
find_option (&opp->common, opp->round, opp->round_len,
round_opt, "Bad ROUND parameter in OPEN statement");
flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
find_option (&opp->common, opp->sign, opp->sign_len,
sign_opt, "Bad SIGN parameter in OPEN statement");
flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
find_option (&opp->common, opp->form, opp->form_len,
form_opt, "Bad FORM parameter in OPEN statement");
flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
find_option (&opp->common, opp->position, opp->position_len,
position_opt, "Bad POSITION parameter in OPEN statement");
flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
find_option (&opp->common, opp->status, opp->status_len,
status_opt, "Bad STATUS parameter in OPEN statement");
/* First, we check wether the convert flag has been set via environment
variable. This overrides the convert tag in the open statement. */
conv = get_unformatted_convert (opp->common.unit);
if (conv == GFC_CONVERT_NONE)
{
/* Nothing has been set by environment variable, check the convert tag. */
if (cf & IOPARM_OPEN_HAS_CONVERT)
conv = find_option (&opp->common, opp->convert, opp->convert_len,
convert_opt,
"Bad CONVERT parameter in OPEN statement");
else
conv = compile_options.convert;
}
/* We use big_endian, which is 0 on little-endian machines
and 1 on big-endian machines. */
switch (conv)
{
case GFC_CONVERT_NATIVE:
case GFC_CONVERT_SWAP:
break;
case GFC_CONVERT_BIG:
conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break;
case GFC_CONVERT_LITTLE:
conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break;
default:
internal_error (&opp->common, "Illegal value for CONVERT");
break;
}
flags.convert = conv;
if (flags.position != POSITION_UNSPECIFIED
&& flags.access == ACCESS_DIRECT)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot use POSITION with direct access files");
if (flags.access == ACCESS_APPEND)
{
if (flags.position != POSITION_UNSPECIFIED
&& flags.position != POSITION_APPEND)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Conflicting ACCESS and POSITION flags in"
" OPEN statement");
notify_std (&opp->common, GFC_STD_GNU,
"Extension: APPEND as a value for ACCESS in OPEN statement");
flags.access = ACCESS_SEQUENTIAL;
flags.position = POSITION_APPEND;
}
if (flags.position == POSITION_UNSPECIFIED)
flags.position = POSITION_ASIS;
if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
{
if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
opp->common.unit = get_unique_unit_number(opp);
else if (opp->common.unit < 0)
{
u = find_unit (opp->common.unit);
if (u == NULL) /* Negative unit and no NEWUNIT-created unit found. */
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Bad unit number in OPEN statement");
}
if (u == NULL)
u = find_or_create_unit (opp->common.unit);
if (u->s == NULL)
{
u = new_unit (opp, u, &flags);
if (u != NULL)
unlock_unit (u);
}
else
already_open (opp, u, &flags);
}
if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)
&& (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
*opp->newunit = opp->common.unit;
library_end ();
}
gfc_unit *
new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
{
gfc_unit *u2;
stream *s;
char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
/* Change unspecifieds to defaults. Leave (flags->action ==
ACTION_UNSPECIFIED) alone so open_external() can set it based on
what type of open actually works. */
if (flags->access == ACCESS_UNSPECIFIED)
flags->access = ACCESS_SEQUENTIAL;
if (flags->form == FORM_UNSPECIFIED)
flags->form = (flags->access == ACCESS_SEQUENTIAL)
? FORM_FORMATTED : FORM_UNFORMATTED;
if (flags->async == ASYNC_UNSPECIFIED)
flags->async = ASYNC_NO;
if (flags->status == STATUS_UNSPECIFIED)
flags->status = STATUS_UNKNOWN;
/* Checks. */
if (flags->delim == DELIM_UNSPECIFIED)
flags->delim = DELIM_NONE;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DELIM parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->blank == BLANK_UNSPECIFIED)
flags->blank = BLANK_NULL;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"BLANK parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->pad == PAD_UNSPECIFIED)
flags->pad = PAD_YES;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"PAD parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->decimal == DECIMAL_UNSPECIFIED)
flags->decimal = DECIMAL_POINT;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DECIMAL parameter conflicts with UNFORMATTED form "
"in OPEN statement");
goto fail;
}
}
if (flags->encoding == ENCODING_UNSPECIFIED)
flags->encoding = ENCODING_DEFAULT;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ENCODING parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
/* NB: the value for ROUND when it's not specified by the user does not
have to be PROCESSOR_DEFINED; the standard says that it is
processor dependent, and requires that it is one of the
possible value (see F2003, 9.4.5.13). */
if (flags->round == ROUND_UNSPECIFIED)
flags->round = ROUND_PROCDEFINED;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ROUND parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->sign == SIGN_UNSPECIFIED)
flags->sign = SIGN_PROCDEFINED;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"SIGN parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ACCESS parameter conflicts with SEQUENTIAL access in "
"OPEN statement");
goto fail;
}
else
if (flags->position == POSITION_UNSPECIFIED)
flags->position = POSITION_ASIS;
if (flags->access == ACCESS_DIRECT
&& (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
{
generate_error (&opp->common, LIBERROR_MISSING_OPTION,
"Missing RECL parameter in OPEN statement");
goto fail;
}
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
{
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"RECL parameter is non-positive in OPEN statement");
goto fail;
}
switch (flags->status)
{
case STATUS_SCRATCH:
if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
{
opp->file = NULL;
break;
}
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"FILE parameter must not be present in OPEN statement");
goto fail;
case STATUS_OLD:
case STATUS_NEW:
case STATUS_REPLACE:
case STATUS_UNKNOWN:
if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
break;
opp->file = tmpname;
opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d",
(int) opp->common.unit);
break;
default:
internal_error (&opp->common, "new_unit(): Bad status");
}
/* Make sure the file isn't already open someplace else.
Do not error if opening file preconnected to stdin, stdout, stderr. */
u2 = NULL;
if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
u2 = find_file (opp->file, opp->file_len);
if (u2 != NULL
&& (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
&& (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
&& (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
{
unlock_unit (u2);
generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL);
goto cleanup;
}
if (u2 != NULL)
unlock_unit (u2);
/* Open file. */
s = open_external (opp, flags);
if (s == NULL)
{
char *path, *msg;
size_t msglen;
path = (char *) gfc_alloca (opp->file_len + 1);
msglen = opp->file_len + 51;
msg = (char *) gfc_alloca (msglen);
unpack_filename (path, opp->file, opp->file_len);
switch (errno)
{
case ENOENT:
snprintf (msg, msglen, "File '%s' does not exist", path);
break;
case EEXIST:
snprintf (msg, msglen, "File '%s' already exists", path);
break;
case EACCES:
snprintf (msg, msglen,
"Permission denied trying to open file '%s'", path);
break;
case EISDIR:
snprintf (msg, msglen, "'%s' is a directory", path);
break;
default:
msg = NULL;
}
generate_error (&opp->common, LIBERROR_OS, msg);
goto cleanup;
}
if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
flags->status = STATUS_OLD;
/* Create the unit structure. */
u->file = xmalloc (opp->file_len);
if (u->unit_number != opp->common.unit)
internal_error (&opp->common, "Unit number changed");
u->s = s;
u->flags = *flags;
u->read_bad = 0;
u->endfile = NO_ENDFILE;
u->last_record = 0;
u->current_record = 0;
u->mode = READING;
u->maxrec = 0;
u->bytes_left = 0;
u->saved_pos = 0;
if (flags->position == POSITION_APPEND)
{
if (sseek (u->s, 0, SEEK_END) < 0)
generate_error (&opp->common, LIBERROR_OS, NULL);
u->endfile = AT_ENDFILE;
}
/* Unspecified recl ends up with a processor dependent value. */
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
{
u->flags.has_recl = 1;
u->recl = opp->recl_in;
u->recl_subrecord = u->recl;
u->bytes_left = u->recl;
}
else
{
u->flags.has_recl = 0;
u->recl = max_offset;
if (compile_options.max_subrecord_length)
{
u->recl_subrecord = compile_options.max_subrecord_length;
}
else
{
switch (compile_options.record_marker)
{
case 0:
/* Fall through */
case sizeof (GFC_INTEGER_4):
u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
break;
case sizeof (GFC_INTEGER_8):
u->recl_subrecord = max_offset - 16;
break;
default:
runtime_error ("Illegal value for record marker");
break;
}
}
}
/* If the file is direct access, calculate the maximum record number
via a division now instead of letting the multiplication overflow
later. */
if (flags->access == ACCESS_DIRECT)
u->maxrec = max_offset / u->recl;
if (flags->access == ACCESS_STREAM)
{
u->maxrec = max_offset;
u->recl = 1;
u->bytes_left = 1;
u->strm_pos = stell (u->s) + 1;
}
memmove (u->file, opp->file, opp->file_len);
u->file_len = opp->file_len;
/* Curiously, the standard requires that the
position specifier be ignored for new files so a newly connected
file starts out at the initial point. We still need to figure
out if the file is at the end or not. */
test_endfile (u);
if (flags->status == STATUS_SCRATCH && opp->file != NULL)
free (opp->file);
if (flags->form == FORM_FORMATTED)
{
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
fbuf_init (u, u->recl);
else
fbuf_init (u, 0);
}
else
u->fbuf = NULL;
return u;
cleanup:
/* Free memory associated with a temporary filename. */
if (flags->status == STATUS_SCRATCH && opp->file != NULL)
free (opp->file);
fail:
close_unit (u);
return NULL;
}
static void
edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
{
/* Complain about attempts to change the unchangeable. */
if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
u->flags.status != flags->status)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change STATUS parameter in OPEN statement");
if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change ACCESS parameter in OPEN statement");
if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change FORM parameter in OPEN statement");
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
&& opp->recl_in != u->recl)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change RECL parameter in OPEN statement");
if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change ACTION parameter in OPEN statement");
/* Status must be OLD if present. */
if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
flags->status != STATUS_UNKNOWN)
{
if (flags->status == STATUS_SCRATCH)
notify_std (&opp->common, GFC_STD_GNU,
"OPEN statement must have a STATUS of OLD or UNKNOWN");
else
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"OPEN statement must have a STATUS of OLD or UNKNOWN");
}
if (u->flags.form == FORM_UNFORMATTED)
{
if (flags->delim != DELIM_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DELIM parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->blank != BLANK_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"BLANK parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->pad != PAD_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"PAD parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->decimal != DECIMAL_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DECIMAL parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->encoding != ENCODING_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ENCODING parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->round != ROUND_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ROUND parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->sign != SIGN_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"SIGN parameter conflicts with UNFORMATTED form in "
"OPEN statement");
}
if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
{
/* Change the changeable: */
if (flags->blank != BLANK_UNSPECIFIED)
u->flags.blank = flags->blank;
if (flags->delim != DELIM_UNSPECIFIED)
u->flags.delim = flags->delim;
if (flags->pad != PAD_UNSPECIFIED)
u->flags.pad = flags->pad;
if (flags->decimal != DECIMAL_UNSPECIFIED)
u->flags.decimal = flags->decimal;
if (flags->encoding != ENCODING_UNSPECIFIED)
u->flags.encoding = flags->encoding;
if (flags->async != ASYNC_UNSPECIFIED)
u->flags.async = flags->async;
if (flags->round != ROUND_UNSPECIFIED)
u->flags.round = flags->round;
if (flags->sign != SIGN_UNSPECIFIED)
u->flags.sign = flags->sign;
}
/* Reposition the file if necessary. */
switch (flags->position)
{
case POSITION_UNSPECIFIED:
case POSITION_ASIS:
break;
case POSITION_REWIND:
if (sseek (u->s, 0, SEEK_SET) != 0)
goto seek_error;
u->current_record = 0;
u->last_record = 0;
test_endfile (u);
break;
case POSITION_APPEND:
if (sseek (u->s, 0, SEEK_END) < 0)
goto seek_error;
if (flags->access != ACCESS_STREAM)
u->current_record = 0;
u->endfile = AT_ENDFILE; /* We are at the end. */
break;
seek_error:
generate_error (&opp->common, LIBERROR_OS, NULL);
break;
}
unlock_unit (u);
}
void
st_backspace (st_parameter_filepos *fpp)
{
gfc_unit *u;
library_start (&fpp->common);
u = find_unit (fpp->common.unit);
if (u == NULL)
{
generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
goto done;
}
/* Direct access is prohibited, and so is unformatted stream access. */
if (u->flags.access == ACCESS_DIRECT)
{
generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
"Cannot BACKSPACE a file opened for DIRECT access");
goto done;
}
if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
{
generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
"Cannot BACKSPACE an unformatted stream file");
goto done;
}
/* Make sure format buffer is flushed and reset. */
if (u->flags.form == FORM_FORMATTED)
{
int pos = fbuf_reset (u);
if (pos != 0)
sseek (u->s, pos, SEEK_CUR);
}
/* Check for special cases involving the ENDFILE record first. */
if (u->endfile == AFTER_ENDFILE)
{
u->endfile = AT_ENDFILE;
u->flags.position = POSITION_APPEND;
sflush (u->s);
}
else
{
if (stell (u->s) == 0)
{
u->flags.position = POSITION_REWIND;
goto done; /* Common special case */
}
if (u->mode == WRITING)
{
/* If there are previously written bytes from a write with
ADVANCE="no", add a record marker before performing the
BACKSPACE. */
if (u->previous_nonadvancing_write)
finish_last_advance_record (u);
u->previous_nonadvancing_write = 0;
unit_truncate (u, stell (u->s), &fpp->common);
u->mode = READING;
}
if (u->flags.form == FORM_FORMATTED)
formatted_backspace (fpp, u);
else
unformatted_backspace (fpp, u);
u->flags.position = POSITION_UNSPECIFIED;
u->endfile = NO_ENDFILE;
u->current_record = 0;
u->bytes_left = 0;
}
done:
if (u != NULL)
unlock_unit (u);
library_end ();
}
