/*
* _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));
}