void
ttynamf90_(char *name, int strlen, int *u)
{
int rtrn, errval;
unum_t unum;
unit *cup;
struct fiostate cfs;
char *t = NULL;
#if defined(_LITTLE_ENDIAN)
char *ttyname(int);
#endif
unum = *u;
STMT_BEGIN(unum, 0, T_INQU, NULL, &cfs, cup);
errval = 0;
if (cup == NULL && !GOOD_UNUM(unum))
_ferr(&cfs, FEIVUNIT, unum); /* invalid unit number */
if (cup == NULL)
errval = FEIVUNIT; /* unit is not open */
else if (cup->usysfd == -1)
errval = FEIVUNIT; /* file is not disk-resident */
else {
t = ttyname(cup->usysfd);
}
STMT_END(cup, T_INQU, NULL, &cfs); /* unlock the unit */
if (t==NULL)
t="";
_b_char(t, name, strlen);
return;
}
int fnum_(int *u)
#endif /* KEY Bug 1683 */
{
int n, retval;
unum_t unum;
unit *cup;
struct stat buf;
struct fiostate cfs;
int stat;
register int errf; /* ERR processing flag */
unum = *u;
retval = -1;
if (unum != 0 && unum != 5 && unum != 6)
return retval;
STMT_BEGIN(unum, 0, T_INQU, NULL, &cfs, cup);
if (cup == NULL && !GOOD_UNUM(unum))
_ferr(&cfs, FEIVUNIT, unum); /* invalid unit number */
if (cup == NULL)
cup = _imp_open( &cfs,
SEQ,
FMT,
unum,
errf,
&stat);
retval = fileno ( cup->ufp.std );
STMT_END(cup, T_INQU, NULL, &cfs); /* unlock the unit */
return retval;
}
int
_BACK(
_f_int *unump, /* Fortran unit number */
_f_int *iostat, /* IOSTAT= variable address, or NULL */
int errf) /* 1 if ERR= specifier is present */
{
register int errn; /* nonzero when error is encountered */
register unum_t unum;
unit *cup;
struct fiostate cfs;
errn = 0;
unum = *unump;
STMT_BEGIN(unum, 0, T_BACKSPACE, NULL, &cfs, cup); /* lock the unit */
if (!GOOD_UNUM(unum)) {
errn = FEIVUNIT; /* Invalid unit number */
goto backspace_done;
}
/*
* BACKSPACE on unopened unit is OK, and does nothing. For opened units,
* call the low level backspace routine.
*/
if (cup == NULL)
goto backspace_done;
if (cup->pnonadv) { /* There is a current record */
if (cup->uwrt) {
errn = _nonadv_endrec(&cfs, cup);
if (errn != 0)
goto backspace_done;
}
cup->pnonadv = 0; /* Flag no current record */
}
errn = _unit_bksp(cup);
backspace_done:
if (iostat != NULL)
*iostat = errn;
else
if (errn != 0 && (errf == 0))
_ferr(&cfs, errn, unum); /* Pass unum to _ferr
* in case of FEIVUNIT error */
STMT_END(cup, T_BACKSPACE, NULL, &cfs); /* unlock the unit */
errn = (errn != 0) ? IO_ERR : IO_OKAY;/* 1 if error; 0 if no error */
return(CFT77_RETVAL(errn));
}
int
_REWF(
_f_int *unump, /* Fortran unit number */
_f_int *iostat, /* IOSTAT= variable address, or NULL */
int errf) /* 1 if ERR= specifier is present */
{
register int errn; /* Error status */
register unum_t unum;
unit *cup;
struct ffsw fst;
struct fiostate cfs;
errn = 0;
unum = *unump;
STMT_BEGIN(unum, 0, T_REWIND, NULL, &cfs, cup); /* lock the unit */
if (!GOOD_UNUM(unum)) {
errn = FEIVUNIT; /* Invalid unit number */
goto rewind_done;
}
/*
* REWIND on unopened unit is OK, and does nothing.
*/
if (cup == NULL)
goto rewind_done;
if (cup->useq == 0) { /* If file opened for direct access */
errn = FERWNDIV; /* REWIND invalid on dir. acc.*/
goto rewind_done;
}
/*
* Wait for completion of a preceding asynchronous BUFFER IN/OUT.
*/
WAITIO(cup, {errn = cup->uffsw.sw_error;});
/*
* _f_inqu - process INQUIRE statement.
*
* Return value
* Returns 0 on success, positive error code if an error
* is encountered and ERR= or IOSTAT= are unspecified.
* This routine aborts on error conditions if no ERR=
* or IOSTAT= are specified.
*/
int _f_inqu(
FIOSPTR css, /* statement state */
unit *cup, /* locked unit pointer if INQUIRE by
* unit and unit is connected. */
inlist *a) /* list of INQUIRE specifiers */
{
int aifound; /* Assign info found flag */
int byfile; /* INQUIRE by file/unit flag */
int exists; /* File exists flag */
int opened; /* File opened flag */
int valunit; /* Valid unit number flag */
int errn;
char *buf, *fn, *s;
struct stat st; /* Stat system call packet */
assign_info ai; /* Assign information packet */
unit *p;
p = cup;
errn = 0;
/*
* Lock _openlock to ensure that no other task opens or closes units
* during the unit table scan for inquire-by-file processing.
*/
OPENLOCK();
if (a->infile != NULL) /* if INQUIRE by file */
byfile = 1;
else { /* else INQUIRE by unit */
byfile = 0;
valunit = GOOD_UNUM(a->inunit) &&
!RSVD_UNUM(a->inunit); /* Valid Unit Number? */
}
if ((buf = malloc(MAX(a->infilen + 1, MXUNITSZ + 1))) == NULL) {
errn = FENOMEMY;
if (a->inerr)
goto out_of_here;
_ferr(css, errn);
}
*buf = '\0'; /* Assume no name */
opened = 0; /* Assume not opened */
fn = buf;
if (byfile) { /* If INQUIRE by file */
_copy_n_trim(a->infile, a->infilen, buf);
if ((aifound = _get_a_options(0, buf, -1, 0, &ai, NULL,
_LELVL_RETURN)) == -1) {
errn = errno;
if (a->inerr) {
free(buf);
goto out_of_here;
}
_ferr(css, errn);
}
if (aifound && ai.a_actfil_flg) /* If assign alias */
s = ai.a_actfil; /* Use -a attribute as file name */
else
s = buf;
exists = (stat(s, &st) != -1);
if (exists) {
p = _get_next_unit(NULL, 1, 1);
while (p != NULL) { /* while more open units */
unum_t unum;
unum = p->uid;
if (! RSVD_UNUM(unum) &&
(p->uinode == st.st_ino) &&
(p->udevice == st.st_dev)) {
fn = p->ufnm;
opened = 1;
break;
}
p = _get_next_unit(p, 1, 1);
}
/*
* If p is non-null here, it points to a locked unit.
* The unit is locked to ensure a consistent set of
* INQUIRE'd attributes is returned.
*/
}
}
else { /* Else INQUIRE by unit */
if (valunit) {
opened = (cup != NULL);
if (opened) { /* If opened, get name */
p = cup;
fn = p->ufnm;
}
}
}
if (fn == NULL) /* If no name available, return blanks */
fn = "";
/* EXIST specifier */
if (a->inex != NULL)
if (byfile) /* If INQUIRE by file */
*a->inex = _btol(exists);
else /* INQUIRE by unit */
*a->inex = _btol(valunit);
/* OPENED specifier */
if (a->inopen != NULL)
*a->inopen = _btol(opened);
/* NAMED specifier */
if (a->innamed != NULL)
if (byfile) /* If INQUIRE by file */
*a->innamed = _btol(1); /* .TRUE. */
else /* INQUIRE by unit */
*a->innamed = _btol(opened && p->ufnm != NULL);
/* NUMBER specifier */
if (a->innum != NULL) {
if (opened) {
if (byfile) /* If INQUIRE by file */
*a->innum = (opened) ? p->uid : -1;
else /* INQUIRE by unit */
*a->innum = a->inunit; /* The law of identity */
}
else
*a->innum = -1;
}
/* RECL specifier */
if (a->inrecl != NULL)
if (opened) {
if (p->urecl > 0) /* If recl was specified */
*a->inrecl = p->urecl;
else /* Recl not specified (i.e., sequential) */
*a->inrecl = (p->ufmt) ? p->urecsize : LONG_MAX;
}
else
*a->inrecl = -1;
/* NEXTREC specifier */
if (a->innrec != NULL)
if (opened && p->useq == 0) /* If opened & direct access */
*a->innrec = p->udalast + 1;
else
*a->innrec = -1;
/* NAME specifier */
if (a->inname != NULL)
_b_char(fn, a->inname, a->innamlen);
/* ACCESS specifier */
if (a->inacc != NULL) {
if (opened)
s = (p->useq) ? "SEQUENTIAL" : "DIRECT";
else
s = "UNDEFINED";
_b_char(s, a->inacc, a->inacclen);
}
/* SEQUENTIAL specifier */
if (a->inseq != NULL) {
if (opened)
s = (p->useq) ? "YES" : "NO";
else
s = "UNKNOWN";
_b_char(s, a->inseq, a->inseqlen);
}
/* DIRECT specifier */
if (a->indir != NULL) {
if (opened)
s = (p->useq) ? "NO" : "YES";
else
s = "UNKNOWN";
_b_char(s, a->indir, a->indirlen);
}
/* FORM specifier */
if (a->inform != NULL) {
if (opened)
s = (p->ufmt) ? "FORMATTED" : "UNFORMATTED";
else
s = "UNDEFINED";
_b_char(s, a->inform, (ftnlen)a->informlen);
}
/* FORMATTED specifier */
if (a->infmt != NULL) {
if (opened)
s = (p->ufmt) ? "YES" : "NO";
else
s = "UNKNOWN";
_b_char(s, a->infmt, a->infmtlen);
}
/* UNFORMATTED specifier */
if (a->inunf != NULL) {
if (opened)
s = (p->ufmt) ? "NO" : "YES";
else
s = "UNKNOWN";
_b_char(s, a->inunf, a->inunflen);
}
/* BLANK specifier */
if (a->inblank != NULL) {
if (opened && p->ufmt)
s = (p->ublnk) ? "ZERO" : "NULL";
else
s = "UNDEFINED";
_b_char(s, a->inblank, a->inblanklen);
}
/* POSITION specifier */
if (a->inposit != NULL) { /* Fortran 90 position control */
if (opened && p->useq) {
switch (p->uposition) {
case OS_REWIND:
s = "REWIND";
break;
case OS_ASIS:
s = "ASIS";
break;
case OS_APPEND:
s = "APPEND";
break;
case 0:
s = "UNKNOWN";
break;
default:
_ferr(css, FEINTUNK);
}
}
else
s = "UNDEFINED";
_b_char(s, a->inposit, a->inpositlen);
}
/* ACTION specifier */
if (a->inaction != NULL) { /* Fortran 90 action control */
if (opened) {
switch (p->uaction) {
case OS_READWRITE:
s = "READWRITE";
break;
case OS_READ:
s = "READ";
break;
case OS_WRITE:
s = "WRITE";
break;
default:
_ferr(css, FEINTUNK);
}
}
else /* for an unconnected file */
s = "UNDEFINED";
_b_char(s, a->inaction, a->inactonlen);
}
/* READ specifier */
if (a->inread != NULL) { /* Fortran 90 read action control */
if (opened) {
if ((p->uaction == OS_READ) ||
(p->uaction == OS_READWRITE))
s = "YES";
else
s = "NO";
}
else
s = "UNKNOWN";
_b_char(s, a->inread, a->inreadlen);
}
/* WRITE specifier */
if (a->inwrite != NULL) { /* Fortran 90 write action control */
if (opened) {
if ((p->uaction == OS_WRITE) ||
(p->uaction == OS_READWRITE))
s = "YES";
else
s = "NO";
}
else
s = "UNKNOWN";
_b_char(s, a->inwrite, a->inwritelen);
}
/* READWRITE specifier */
if (a->inredwrit != NULL) { /* Fortran 90 read/write action control */
if (opened) {
if (p->uaction == OS_READWRITE)
s = "YES";
else
s = "NO";
}
else
s = "UNKNOWN";
_b_char(s, a->inredwrit, a->inrdwrtlen);
}
/* DELIM specifier */
if (a->indelim != NULL) { /* Fortran 90 delim control */
if (opened && p->ufmt) { /* if formatted */
switch (p->udelim) {
case OS_NONE:
s = "NONE";
break;
case OS_QUOTE:
s = "QUOTE";
break;
case OS_APOSTROPHE:
s = "APOSTROPHE";
break;
default:
_ferr(css, FEINTUNK);
}
}
else /* UNDEFINED for unformatted or unconnected file */
s = "UNDEFINED";
_b_char(s, a->indelim, a->indelimlen);
}
/* PAD specifier */
if (a->inpad != NULL) { /* Fortran 90 pad control */
if(opened && p->ufmt) { /* if formatted */
switch (p->upad) {
case OS_YES:
s = "YES";
break;
case OS_NO:
s = "NO";
break;
default:
_ferr(css, FEINTUNK);
}
}
else /* Fortran 90 missed UNDEFINED if unformatted or unconnected */
s = "YES"; /* set to YES instead of UNDEFINED */
_b_char(s, a->inpad, a->inpadlen);
}
/*
* Unlock the unit if we have a pointer to an open unit. Note that
* $INQ/_INQUIRE never unlocks the unit.
*/
out_of_here:
OPENUNLOCK();
if (p != NULL)
_release_cup(p); /* unlock the unit */
free(buf);
return(errn);
}
int __OPN(
_f_int *unitn,
_f_int *iostat,
int *errf,
_fcd file,
_fcd status,
_fcd access,
_fcd form,
_f_int *recl,
_fcd blank,
_fcd position,
_fcd action_arg,
_fcd delim_arg,
_fcd pad_arg,
int unused1, /* for a future CFT77 open specifier */
int unused2, /* for a future CFT77 open specifier */
int isf90_arg) /* =1 iff Fortran-90 OPEN */
#endif
{
olist a; /* OPEN specifier list */
long fstrlen; /* Length of Fortran string */
int errn; /* IOSTAT error number */
int error; /* Error flag */
unum_t unum; /* Fortran unit number */
_fcd action;
_fcd delim;
_fcd pad;
int isf90;
unit *cup; /* Pointer to unit table entry */
enum form_spec formdef;
struct fiostate cfs;
#ifdef _CRAYMPP
va_list args;
_fcd file;
_fcd status;
_fcd access;
_fcd form;
_f_int *recl;
_fcd blank;
_fcd position;
int unused1; /* for a future CFT77 open specifier */
int unused2; /* for a future CFT77 open specifier */
int isf90_arg; /* =1 iff Fortran-90 OPEN */
#endif
/*
* The ACTION, DELIM, and PAD specifiers are supported by CFT77
* release 5.0 and later on CX/CEA systems, and by CFT77 release 6.0 and
* later on CRAY-2 systems.
*/
action = _cptofcd(NULL, 0);
delim = _cptofcd(NULL, 0);
pad = _cptofcd(NULL, 0);
#ifdef _CRAYMPP
va_start(args,errf);
file = va_arg(args, _fcd);
status = va_arg(args, _fcd);
access = va_arg(args, _fcd);
form = va_arg(args, _fcd);
recl = va_arg(args, _f_int *);
blank = va_arg(args, _fcd);
position = va_arg(args, _fcd);
#endif
if (PASSED_ARG(ARGS_11)) {
#ifdef _CRAYMPP
action = va_arg(args, _fcd);
#else
action = action_arg;
#endif
}
if (PASSED_ARG(ARGS_12)) {
#ifdef _CRAYMPP
delim = va_arg(args, _fcd);
#else
delim = delim_arg;
#endif
}
if (PASSED_ARG(ARGS_13)) {
#ifdef _CRAYMPP
pad = va_arg(args, _fcd);
#else
pad = pad_arg;
#endif
}
/*
* The isf90 argument is not passed from CFT77.
*/
isf90 = 0;
if (PASSED_ARG(ARGS_16)) {
#ifdef _CRAYMPP
unused1 = va_arg(args, int);
unused2 = va_arg(args, int);
isf90 = va_arg(args, int);
#else
isf90 = isf90_arg;
#endif
}
#ifdef _CRAYMPP
va_end(args);
#endif
errn = 0;
OPENLOCK(); /* prevent other OPENs or CLOSEs right now */
#ifdef KEY /* Bug 4260 */
/* Before we open the first file in the course of execution, we must
* set byte-swapping based on __io_byteswap_value defined by Fortran
* main in response to command-line options like -byteswapio */
__io_byteswap();
#endif /* KEY Bug 4260 */
unum = *unitn; /* UNIT= is required by compiler */
a.ounit = unum;
STMT_BEGIN(unum, 0, T_OPEN, NULL, &cfs, cup); /* lock unit if open */
if (!GOOD_UNUM(unum) || RSVD_UNUM(unum))
OPNERR(FEIVUNTO);
a.oerr = (errf || iostat) ? 1 : 0; /* Catch errs if ERR | IOSTAT */
/*
* Process FILE= and RECL= specifiers.
*/
if (_fcdtocp(file) != NULL) {
a.ofile = _fcdtocp(file);
a.ofilelen = _fcdlen (file);
}
else {
a.ofile = NULL;
a.ofilelen = 0;
}
if (recl != NULL)
a.orecl = *recl;
else
a.orecl = 0; /* 0 means unspecified */
/*
* Process remaining specifiers.
*
* Specifier Default Error Code
* Value List
*/
SETSPEC(status, OS_UNKNOWN, FEOPSTAT, 5,
S(OLD) S(NEW) S(SCRATCH) S(UNKNOWN) S(REPLACE));
#if !defined(__mips) && !defined(_LITTLE_ENDIAN)
SETSPEC(access, OS_SEQUENTIAL, FEOPACCS, 2,
S(DIRECT) S(SEQUENTIAL));
SETSPEC(position, OS_ASIS, FEOPPOSN, 3,
S(APPEND) S(ASIS) S(REWIND));
#else /* not __mips and not little endian */
SETSPEC(access, OS_SEQUENTIAL, FEOPACCS, 4,
S(DIRECT) S(SEQUENTIAL) S(KEYED) S(APPEND));
if ((_fcdtocp(access) != NULL) && (a.oaccess == OS_OAPPEND)) {
if (_fcdtocp(position) != NULL) {
OPNERR(FEOPACCS); /* Invalid ACCESS */
}
#ifdef KEY /* Bug 86 */
/* The Fortran 90 standard does not place a constraint
* on the value of 'access=', so there's no need to
* issue an error message in normal or -ansi mode (and
* "isf90" seems always to be set anyway). */
#else
else if (isf90) {
OPNERR(FEOPACCS); /* Invalid ACCESS */
}
#endif /* KEY */
else {
a.oposition = OS_APPEND;
a.oaccess = OS_SEQUENTIAL;
}
}
else {
/* use POSITION= if ACCESS='APPEND' is not provided */
SETSPEC(position, OS_ASIS, FEOPPOSN, 3,
S(APPEND) S(ASIS) S(REWIND));
}
#endif /* not __mips and not little endian */
formdef = (a.oaccess == OS_SEQUENTIAL) ? OS_FORMATTED : OS_UNFORMATTED;
SETSPEC(form, formdef, FEOPFORM, 4,
S(UNFORMATTED) S(FORMATTED) S(BINARY) S(SYSTEM));
SETSPEC(blank, OS_NULL, FEOPBLNK, 2,
S(ZERO) S(NULL));
SETSPEC(action, OS_ACTION_UNSPECIFIED, FEOPACTB, 3,
S(READ) S(WRITE) S(READWRITE));
SETSPEC(delim, OS_NONE, FEOPDLMB, 3,
S(APOSTROPHE) S(QUOTE) S(NONE));
SETSPEC(pad, OS_YES, FEOPPADB, 2,
S(YES) S(NO));
/*
* Diagnose errors.
*/
if (recl != NULL && a.orecl <= 0)
OPNERR(FEOPRECL); /* Invalid RECL */
if (recl == NULL && a.oaccess == OS_DIRECT)
OPNERR(FEOPRCRQ); /* RECL required for direct */
if (_fcdtocp(blank) != NULL && (a.oform == OS_UNFORMATTED ||
a.oform == OS_BINARY || a.oform == OS_SYSTEM))
OPNERR(FEOPBKIV); /* BLANK= invalid if unform. */
if (_fcdtocp(delim) != NULL && (a.oform == OS_UNFORMATTED ||
a.oform == OS_BINARY || a.oform == OS_SYSTEM))
OPNERR(FEOPDLMI); /* DELIM invalid if unform. */
if (_fcdtocp(pad) != NULL && (a.oform == OS_UNFORMATTED ||
a.oform == OS_BINARY || a.oform == OS_SYSTEM))
OPNERR(FEOPPDIV); /* PAD= invalid if unformatted*/
if (_fcdtocp(position) != NULL && a.oaccess == OS_DIRECT)
OPNERR(FEOPPSIV); /* POSITION invalid on direct */
/*
* Done with OPEN specifiers.
*/
if (OPEN_UPTR(cup) && cup->ufs == FS_AUX)
OPNERR(FEOPAUXT); /* Unit is opened by AQ/MS/DR/WA IO */
if (OPEN_UPTR(cup) &&
(_fcdtocp(file) == NULL || (cup->ufnm != NULL &&
strncmp(cup->ufnm, a.ofile, a.ofilelen) == 0))) {
/*
* A re-open of the same file occurs when the FILE= specifier
* is present and matches the name with which the file was
* originally opened, or if the FILE= specifier is absent
* (these are re-opens of the same file by definition).
*
* In this case, only a subset of the OPEN specifiers
* (the BLANK=, PAD=, and DELIM= specifiers) may be provided
* with values which are different from those currently in
* effect. Any new value passed with the BLANK=, PAD=, or
* DELIM= specifier will go into effect.
*
* An attempt to change the other OPEN specifers is an error.
*/
if (_fcdtocp(status) != NULL && a.ostatus != cup->uostatus) {
if (a.ostatus == OS_NEW && cup->uostatus == OS_OLD) {
OPNERR(FEOPNNEW); /* STATUS=NEW became OLD */
}
else
OPNERR(FEOPCBNK); /* Can't change STATUS */
}
if (_fcdtocp(access) != NULL &&
((a.oaccess == OS_SEQUENTIAL && cup->useq == 0 ) ||
(a.oaccess == OS_DIRECT && cup->useq == 1) ))
OPNERR(FEOPCBNK); /* Can't change ACCESS */
if (_fcdtocp(form) != NULL &&
((a.oform == OS_FORMATTED && cup->ufmt == 0) ||
(a.oform == OS_UNFORMATTED && cup->ufmt == 1) ))
OPNERR(FEOPCBNK); /* Can't change FORM */
if (recl != NULL && a.orecl != cup->urecl)
OPNERR(FEOPCBNK); /* Can't change RECL */
if (_fcdtocp(position) != NULL && a.oposition != cup->uposition)
OPNERR(FEOPCBNK); /* Can't change POSITION */
if (_fcdtocp(action) != NULL && a.oaction != cup->uaction)
OPNERR(FEOPCBNK); /* Can't change ACTION */
/*
* Place into effect any new BLANK=, DELIM=, or PAD= specifier
* provided on the OPEN statement.
*/
if (_fcdtocp(blank) != NULL)
cup->ublnk = (a.oblank == OS_ZERO);
if (_fcdtocp(delim) != NULL)
cup->udelim = a.odelim;
if (_fcdtocp(pad) != NULL)
cup->upad = a.opad;
}
else {
/*
* Open the unit. If the unit is currently connected, it
* will be closed and then reopened for the new file.
*/
/* KEY: we do want this check */
#if (!defined(__mips) && !defined(_LITTLE_ENDIAN)) || defined(KEY)
/*
* SGI's F77 and old F90 allowed open with status=NEW,
* OLD, or REPLACE without FILE specifier, so we continue
* to allow it on MIPS systems.
*/
if (a.ostatus == OS_REPLACE && a.ofile == NULL)
OPNERR(FEOPFNRQ); /* FILE= required for 'REPLACE' */
if (a.ostatus == OS_OLD && a.ofile == NULL)
OPNERR(FEOPFNRQ); /* FILE= required for 'OLD' */
if (a.ostatus == OS_NEW && a.ofile == NULL)
OPNERR(FEOPFNRQ); /* FILE= required for 'NEW' */
#endif
#ifdef _CRAYMPP
/*
* This check should be added for CX/CEA someday.
*/
if (a.ostatus == OS_SCRATCH && a.ofile != NULL)
OPNERR(FEOPFNIV); /* FILE= should not be specified */
#endif
/*
* We assume that _f_open does not change cfs.f_cu if
* the unit was already open.
*/
errn = _f_open(&cfs, &cup, &a, isf90);
}
/*
* Process results
*/
opn_done:
error = (errn != 0) ? IO_ERR : IO_OKAY;
if (iostat != NULL)
*iostat = errn;
else
if (error != IO_OKAY && errf == 0)
if (errn == FEIVUNTO)
_ferr(&cfs, errn, unum);
else
_ferr(&cfs, errn);
STMT_END(cup, T_OPEN, NULL, NULL); /* unlock unit */
OPENUNLOCK();
return(CFT77_RETVAL(error));
}
flush_(
#endif
const unum_t *unump, /* Fortran unit number */
_f_int *istat /* Optional error status parameter */
)
{
register short statp; /* 1 if istat parameter passed */
int *rstat; /* Pointer to return status word */
int errn; /* Error status */
register unum_t unum; /* unit number */
unit *cup;
struct fiostate cfs;
#ifdef KEY /* Bug 1683 */
/* G77 says that if unit is missing, flush all units */
if (0 == unump) {
/* Find all open Fortran units not connected by
* WOPEN/OPENMS/OPENDR/AQOPEN */
unit *uptr;
for (uptr = _get_next_unit(NULL, 0, 0); uptr != NULL;
uptr = _get_next_unit(uptr, 0, 0)) {
unum_t unum = uptr->uid;
if (OPEN_UPTR(uptr) && uptr->ufs != FS_AUX) {
__flush_f90(&unum, 0);
}
}
return;
}
#endif /* KEY Bug 1683 */
unum = *unump;
statp =
#ifdef _UNICOS
(_numargs() >= 2)
#else
(istat != NULL)
#endif
? 1 : 0;
rstat = statp ? istat : &errn;
*rstat = FLUSH_OK; /* Assume FLUSH works */
STMT_BEGIN(unum, 0, T_FLUSH, NULL, &cfs, cup); /* lock the unit */
if (cup == NULL) {
if (!GOOD_UNUM(unum))
errn = FEIVUNIT;
else {
#ifdef KEY /* Bug 6433 */
/* G77 ignores flush on an unopened unit, so we do likewise. The test for
* RSVD_UNUM is useless because we no longer have any (we automatically open
* units 5 and 6 on stdin and stdout, but we do not "reserve" them: the
* user can explicitly open them on named files.)
*/
goto flush_done;
#else /* KEY Bug 6433 */
/*
* Ignore FLUSH on unopened reserved unit.
*/
if (RSVD_UNUM(unum))
goto flush_done;
errn = FENOTOPN;
#endif /* KEY Bug 6433 */
}
FLUSH_ERROR1(errn, unum);
}
if (cup->useq == 0) { /* If file opened for direct access */
*rstat = NOT_SUPPORTED;
goto flush_done;
}
if ( ! cup->uwrt) /* If not writing, do nothing */
goto flush_done;
switch (cup->ufs) {
struct ffsw fstat; /* ffflush() status */
case FS_FDC:
if (__ffflush(cup->ufp.fdc, &fstat) < 0)
FLUSH_ERROR(fstat.sw_error);
break;
case FS_TEXT:
#ifdef KEY
#if defined(__CYGWIN__) || defined(__APPLE__)
#define _IO_NO_WRITES 8
#endif
if (!(cup->ufp.std->_flags & _IO_NO_WRITES))
if (fflush(cup->ufp.std) == EOF)
FLUSH_ERROR(errno);
break;
#endif
case STD:
#if !defined(_LITTLE_ENDIAN)
if (FILE_FLAG(cup->ufp.std) & _IOWRT)
if (fflush(cup->ufp.std) == EOF)
FLUSH_ERROR(errno);
#endif
break;
default:
*rstat = NOT_SUPPORTED;
} /* switch */
flush_done:
STMT_END(cup, T_FLUSH, NULL, &cfs); /* unlock the unit */
return;
}
int
_f_open(
FIOSPTR css, /* Fortran statement state */
unit **cup_p,/* input: pointer to currently open unit. output: */
/* pointer to new unit. */
olist *olptr, /* OPEN information */
int isf90) /* 1 if being opened from CF90, 0 if CF77 */
{
register short is_bin; /* 1 if binary; else 0 */
register short is_fmt; /* 1 if formatted; 0 if unformatted */
register short is_seq; /* 1 if sequential; 0 if direct */
register short is_sys; /* 1 if system; else 0 */
register short no_mem; /* 1 if malloc() fails */
register int aifound; /* 1 if assign/asgcmd info found */
register int errn; /* Error code */
register int gamask; /* Global assign mask */
register int oflags; /* O_EXCL/O_CREAT */
register int P_value; /* -P option value */
register int stdfn; /* 1 if std file stdin/stdout/stderr */
register int stdfnum; /* standard file descriptor number */
register int stat_ok; /* 1 if statbuf is valid */
register int tufs; /* requested file structure (default) */
register int uscope; /* File scope */
register unum_t unum; /* unit number */
char namebuf[MXUNITSZ]; /* buffer to construct file name */
char *fname; /* FILE= specifier or default filename*/
char *aname; /* actual file name */
char *atstr; /* assign attributes string */
unit *cup;
assign_info ai;
struct stat statbuf;
unum = olptr->ounit;
if (! GOOD_UNUM(unum))
FERROR1(olptr->oerr, FEIVUNIT, unum);
/*
* Check for a re-open before initializing any unit table fields.
*/
if (OPEN_UPTR(*cup_p)) {
/*
* The unit is connected, but we have already checked in
* $OPN for reconnection to the same file with unchanged
* attributes. Thus, we know that we may disconnect the unit
* here before continuing the set up of the new connection.
*
* We unlock it so that _alloc_unit may find it again and
* lock it.
*/
errn = _unit_close(*cup_p, CLST_UNSPEC, NULL);
if (errn != 0)
FERROR(olptr->oerr, errn);
_release_cup(*cup_p); /* unlock the unit */
}
/*
* "aname" receives the actual name to be opened by the system.
* It starts out the same as fname, but might later be reassigned
* by assign.
*/
aname = NULL;
fname = NULL;
stdfn = 0;
no_mem = 0;
if (olptr->ofile == NULL) { /* If no name specified */
if (olptr->ostatus == OS_SCRATCH) { /* If SCRATCH */
int scratchfd;
/*
* Scratch files have no name (see INQUIRE).
*/
fname = NULL;
aname = strdup("FXXXXXX");
scratchfd = mkstemp(aname);
close(scratchfd); /* because mkstemp opens the file */
}
else if (unum == 0 || unum == 5 || unum == 6 ||
RSVD_UNUM(unum)) {
stdfn = 1; /* Possible standard file */
stdfnum = -1;
switch (unum) {
case 5: /* Connect 5 and 100 to stdin */
case 100:
stdfnum = STDIN_FILENO;
break;
case 6: /* Connect 6 and 101 to stdout */
case 101:
stdfnum = STDOUT_FILENO;
break;
case 0: /* Connect 0 and 102 to stderr/errfile */
case 102: /* (see finit.c) */
stdfnum = fileno(errfile);
break;
default:
_ferr(css, FEINTUNK); /* deep weeds */
}
}
else { /* not scratch nor standard file */
(void) _fortname(namebuf, unum); /* Make default name */
fname = strdup(namebuf);
aname = strdup(namebuf);
no_mem = (aname == NULL) || (fname == NULL);
}
}
else { /* Copy user supplied name */
if ((fname = malloc(olptr->ofilelen + 1)) != NULL) {
_copy_n_trim(olptr->ofile, olptr->ofilelen, fname);
aname = strdup(fname);
}
no_mem = (aname == NULL) || (fname == NULL);
}
if (no_mem) { /* If malloc() failed */
freeit(aname);
freeit(fname);
FERROR(olptr->oerr, FENOMEMY); /* No memory */
}
is_bin = (olptr->oform == OS_BINARY) ? 1 : 0;
is_fmt = (olptr->oform == OS_FORMATTED) ? 1 : 0;
is_seq = (olptr->oaccess == OS_SEQUENTIAL ? 1 : 0);
is_sys = (olptr->oform == OS_SYSTEM) ? 1 : 0;
/*
* The ASN_G_SF/SU/DF/DU masks map to the ACCESS/FORM specifiers on OPEN.
*/
switch ((is_seq << 3) | is_fmt) {
case 011: /* Sequential Formatted */
gamask = ASN_G_SF;
break;
case 010: /* Sequential Unformatted */
gamask = ASN_G_SU;
break;
case 001: /* Direct Formatted */
gamask = ASN_G_DF;
break;
case 000: /* Direct Unformatted */
gamask = ASN_G_DU;
break;
}
gamask = gamask | ASN_G_ALL;
atstr = NULL;
aifound = _assign_asgcmd_info(fname, unum, gamask, &ai, &atstr,
olptr->oerr);
#ifdef KEY /* Bug 4924 */
/* Ignore "-F f77.mips" if the file is not sequential and thus has no
* headers. Otherwise, we would select an ffio layer which gives a
* runtime error on non-sequential files. Today f77.mips is the only
* value we support; if we supported some other value which permitted
* non-sequential access, this test would need to be made more precise.
*/
if (!is_seq) {
ai.F_filter_flg = 0;
}
#endif /* KEY Bug 4924 */
if (aifound == -1) {
freeit(fname);
freeit(aname);
freeit(atstr);
FERROR(olptr->oerr, errno);
}
/*
* Set up the scoping of this unit. -P process is default.
*/
uscope = AS_PROCESS; /* actual scope */
P_value = AS_PROCESS; /* -P option value, if any */
if (aifound == 1 && ai.P_ioscop_flg) {
uscope = ai.P_ioscop;
P_value = ai.P_ioscop;
/* Map -P private and -P global to the new spelling */
#ifdef _CRAYMPP
if (ai.P_ioscop == AS_PRIVATE)
uscope = AS_PROCESS;
#else
if (ai.P_ioscop == AS_PRIVATE)
uscope = AS_THREAD;
if (ai.P_ioscop == AS_GLOBAL)
uscope = AS_PROCESS;
#endif
}
#ifdef _CRAYMPP
if (uscope == AS_GLOBAL)
FERROR(olptr->oerr, FENOGLOB);
if (uscope == AS_THREAD)
FERROR(olptr->oerr, FENOTHRD);
if (uscope == AS_TEAM)
FERROR(olptr->oerr, FENOTEAM);
#else
if (uscope == AS_TEAM)
FERROR(olptr->oerr, FENOTEAM);
#endif
/*
* Now that we know the unit number and scope we can get a pointer to the
* unit table.
*/
#ifdef _CRAYMPP
cup = _alloc_unit(unum, 1); /* TEMPORARY */
#else
cup = _alloc_unit(unum, (uscope == AS_THREAD));
#endif
if (cup == NULL)
FERROR1(olptr->oerr, errno, unum);
*cup_p = cup;
/*
* Record OPEN specifiers in unit table
*/
cup->ubinary = is_bin;
cup->ufmt = is_fmt;
cup->useq = is_seq;
cup->usystem = is_sys;
cup->ublnk = (olptr->oblank == OS_ZERO ? 1 : 0);
cup->uposition = olptr->oposition;
cup->uaction = olptr->oaction;
cup->udelim = olptr->odelim;
cup->upad = olptr->opad;
cup->urecl = olptr->orecl;
/*
* Initialize the cf77/f90 mode. It might be changed in f_asgn() later.
*/
cup->uft90 = isf90;
if (aifound == 1 && ai.a_actfil_flg) {
stdfn = 0; /* standard file overridden */
freeit(aname);
aname = strdup(ai.a_actfil);
if (aname == NULL) {
freeit(atstr);
freeit(fname);
FERROR(olptr->oerr, FENOMEMY);
}
}
if (aifound == 1 && ai.D_fildes_flg) {
stdfn = 1; /* indicate standard file */
stdfnum = ai.D_fildes;
freeit(aname);
aname = NULL;
}
/*
* Units connected to stdin, stdout, or stderr may not have thread scope
* on PVP systems.
*/
#ifdef _CRAYMPP
if (stdfn && uscope == AS_TEAM) {
freeit(fname);
freeit(aname);
freeit(atstr);
FERROR(olptr->oerr, FENOTEAM);
}
#else
if (stdfn && uscope == AS_THREAD) {
freeit(fname);
freeit(aname);
freeit(atstr);
FERROR(olptr->oerr, (P_value==AS_PRIVATE)? FENOPRIV: FENOTHRD);
}
#endif
/*
* Set up cup->urecsize, the maximum record size. If RECL was
* specified (it's required on direct access files; optional
* on sequential access files), then RECL becomes the maximum
* record size for all formatted I/O on this unit. Otherwise
* we use default values for the maximum record size for both
* regular I/O and list-directed/namelist output.
*/
if (cup->ufmt) { /* If formatted file */
if (cup->urecl > 0) { /* If RECL specified */
cup->urecsize = cup->urecl;
cup->uldwsize = cup->urecl;
}
else { /* Else set defaults */
cup->urecsize = _f_rcsz;
cup->uldwsize = _f_ldsz;
}
/* Allocate line buffer for formatted files */
cup->ulinebuf = (long *) malloc(sizeof(long) *
(cup->urecsize + 1));
if (cup->ulinebuf == NULL) {
freeit(fname);
freeit(aname);
freeit(atstr);
FERROR(olptr->oerr, FENOMEMY);
}
}
/*
* See if the file exists. We don't know the filename for sure if FFIO
* is being used though.
*/
errn = 0;
stat_ok = 0;
if (stdfn) {
errn = fstat(stdfnum, &statbuf);
stat_ok = 1;
}
else if (aifound == 0 || ai.F_filter_flg == 0) {
errn = stat(aname, &statbuf);
stat_ok = 1;
}
/*
* ENOENT means the file doesn't exist. EINTR means the request
* was interrupted. If we got an EINTR error, retry the stat
* request a few times. A persistent EINTR error or any other
* stat error besides ENOENT is fatal.
*
* On UNICOS and UNICOS/mk systems, a EINTR error should never
* occur on a stat request... but we've seen some on UNICOS/mk
* for a reason the kernel developers do not understand.
*/
if (stat_ok && errn == -1) { /* If we did a stat and it failed */
register short retry = 0;
while (errn == -1 && errno == EINTR && retry++ < 10) {
if (stdfn)
errn = fstat(stdfnum, &statbuf);
else
errn = stat(aname, &statbuf);
}
if (errn == -1) { /* We have a hard failure */
stat_ok = 0;
if (errno != ENOENT) { /* If not ENOENT, abort */
freeit(fname);
freeit(aname);
freeit(atstr);
freeit(cup->ulinebuf);
FERROR(olptr->oerr, errno);
}
}
}
/* Select the file structure */
if (aifound == 1 && (ai.s_fstrct_flg || ai.F_filter_flg)) {
if (ai.F_filter_flg)
tufs = FS_FDC;
else
tufs = ai.s_fstrct;
}
else {
/* Select default file structure */
if ( cup->ufmt ) /* if formatted */
#if defined(__mips) || defined(_LITTLE_ENDIAN)
tufs = (cup->useq) ? FS_TEXT : FS_UNBLOCKED;
#else
tufs = FS_TEXT;
#endif
else { /* else unformatted */
#ifdef _UNICOS
tufs = (cup->useq) ? FS_COS : FS_UNBLOCKED;
#else /* else NOT _UNICOS */
tufs = (cup->useq) ? FS_F77 : FS_UNBLOCKED;
#endif /* END _UNICOS */
if (is_bin || is_sys) {
/*
* Use UNBLOCKED layer for direct or
* sequential unformatted IO that does
* not contain record control images.
* Formatted IO is not allowed (i.e., a)
*/
tufs = FS_UNBLOCKED;
}
}
/* See if the device is a tape and handle it accordingly */
if (stat_ok && _gsys_qtape(&statbuf) != 0)
tufs = FS_TAPE;
}
void
_fcontext(FIOSPTR css)
{
register short is_int; /* 1 if internal file I/O */
register int utindex;
char *file, *fstruct, *idir, *oprn, *sepr;
register unum_t unum; /* Fortran unit number */
long stmt; /* I/O statement type */
unit *cup; /* Pointer to unit table entry */
/* Just return if no Fortran statement info is available */
if (css == NULL)
return;
/* Retrieve global data */
cup = css->f_cu;
unum = css->f_curun;
stmt = css->f_iostmt;
is_int = css->f_intflg;
file = (!OPEN_UPTR(cup) || cup->alfnm == NULL) ? NULL : cup->alfnm;
if (stmt & TF_READ)
idir = " READ from";
else
if (stmt & TF_WRITE)
idir = " WRITE to";
else
idir = "";
/* Determine the type of error */
switch (stmt) {
case T_RSF: /* Sequential formatted READ */
case T_WSF: /* Sequential formatted WRITE */
oprn = " sequential formatted";
break;
case T_RSU: /* Sequential unformatted READ */
case T_WSU: /* Sequential unformatted WRITE */
oprn = " sequential unformatted";
break;
case T_RDF: /* Direct formatted READ */
case T_WDF: /* Direct formatted WRITE */
oprn = " direct access formatted";
break;
case T_RDU: /* Direct unformatted READ */
case T_WDU: /* Direct unformatted WRITE */
oprn = " direct access unformatted";
break;
case T_RLIST: /* List-directed READ */
case T_WLIST: /* List-directed WRITE */
oprn = " list-directed";
break;
case T_RNL: /* Namelist READ */
case T_WNL: /* Namelist WRITE */
oprn = " namelist";
break;
case T_BUFOUT: /* BUFFER OUT */
oprn = " BUFFER OUT on";
idir = "";
break;
case T_BUFIN: /* BUFFER IN */
oprn = " BUFFER IN from";
idir = "";
break;
case T_OPEN: /* OPEN */
oprn = "n OPEN of";
idir = "";
break;
case T_REWIND: /* REWIND */
oprn = " REWIND on";
idir = "";
break;
case T_BACKSPACE:/* BACKSPACE */
oprn = " BACKSPACE on";
idir = "";
break;
case T_ENDFILE: /* ENDFILE */
oprn = "n ENDFILE on";
idir = "";
break;
case T_CLOSE: /* CLOSE */
oprn = " CLOSE of";
idir = "";
break;
case T_INQF: /* INQUIRE */
oprn = "n INQUIRE by file on";
unum = -1;
idir = "";
break;
case T_INQU: /* INQUIRE */
oprn = "n INQUIRE by unit on";
idir = "";
break;
case T_GETPOS: /* GETPOS */
oprn = " GETPOS on";
idir = "";
break;
case T_SETPOS: /* SETPOS */
oprn = " SETPOS on";
idir = "";
break;
case T_LENGTH: /* LENGTH */
oprn = " LENGTH function on";
idir = "";
break;
case T_UNIT: /* UNIT */
oprn = " UNIT function on";
idir = "";
break;
case T_TAPE: /* TAPE */
oprn = " tape operation on";
idir = "";
break;
default:
oprn = "n I/O operation on";
break;
} /* switch */
(void) fprintf(errfile, "\nEncountered during a%s%s", oprn, idir);
if (is_int)
(void) fprintf(errfile,
" an internal file (character variable)\n");
else {
if (unum != -1) {
(void) fprintf(errfile, " unit %lld\n", unum);
(void) fprintf(errfile, "Fortran unit %lld is ",
unum);
if (!OPEN_UPTR(cup)) {
if (GOOD_UNUM(unum))
(void) fprintf(errfile,
"not connected\n");
else
(void) fprintf(errfile,
"not a valid unit number\n");
}
else {
(void) fprintf(errfile, "connected to ");
utindex = IO_TYPE(cup);
fstruct = FIO_STRUCT(_deduce_fstruct(
cup->ufs,
(struct fdinfo*)cup->ufp.fdc,
cup->ufmt));
if (fstruct == NULL)
fstruct = "";
(void) fprintf(errfile, "a %s %s file",
FIO_METHOD(utindex), fstruct);
if (file == NULL && cup->ufs != FS_FDC) {
if (cup->ufp.std == stdin)
file = "standard input";
else if (cup->ufp.std == stdout)
file = "standard output";
else if (cup->ufp.std == stderr)
file = "standard error";
else
file = "unnamed";
(void) fprintf(errfile,
"\n (%s).\n", file);
}
else { /* Format to under 80 chars. per line */
if ((int)strlen(file) > 8)
sepr = ":\n ";
else
sepr = ": ";
(void) fprintf(errfile, "%s\"%s\"\n",
sepr, file);
}
/*
* If the connection is formatted and there's
* a format, print the format and point to
* the current position therein.
*/
if ((stmt & TF_FMT) &&
css->u.fmt.u.fe.fmtbuf != NULL) {
int i, offset;
offset = css->u.fmt.u.fe.fmtcol - 2 +
fprintf(errfile,
" Current format: ");
if (css->u.fmt.u.fe.fmtnum > 0)
/* If format label, print it */
offset = offset +
fprintf(errfile,
"%5d FORMAT",
css->u.fmt.u.fe.fmtnum);
(void) fprintf(errfile, "%.*s\n",
css->u.fmt.u.fe.fmtlen,
css->u.fmt.u.fe.fmtbuf);
for (i = 0; i <= offset; i++)
(void) fprintf(errfile, " ");
(void) fprintf(errfile, "^\n");
}
}
}
else /* Unknown state */
if (file == NULL)
(void) fprintf(errfile,
" an indeterminate file\n");
else
(void) fprintf(errfile, " file \"%s\"\n", file);
}
/*
* Print name of the routine which called _ferr() which called us.
*/
#ifdef _UNICOS
{
int len, lineno;
char name[MAX_ENT_LEN];
len = _who_called_me(&lineno, name, MAX_ENT_LEN, 2);
if (len > 0) { /* If no error */
name[len] = '\0';
(void) fprintf(errfile,
"Error initiated at line %d in routine '%s'.\n",
lineno, name);
}
}
#endif
#ifdef _CRAY2
/*
* Print traceback
*
* On CX/CEA systems, the traceback is printed by the abort() call.
*/
(void) _tracebk(25, errfile);
#endif
return;
}
