/*
* _flushall - flush all connected Fortran units except 100, 101, 102.
*/
void
_flushall(void)
{
int ret;
register short errflag;
static short pass = 0; /* incremented when _flushall is called */
unit *uptr;
if (pass++ >= 1)
return;
errflag = 0;
/*
* Find all open Fortran units not connected by
* WOPEN/OPENMS/OPENDR/AQOPEN and flush them.
*/
uptr = _get_next_unit(NULL, 0, 0);
while (uptr != NULL) { /* while more open units */
#ifdef KEY /* Bug 6433 */
_f_int4 unum;
#else /* KEY Bug 6433 */
unum_t unum;
#endif /* KEY Bug 6433 */
unum = uptr->uid;
if (OPEN_UPTR(uptr) && uptr->ufs != FS_AUX) {
flush_( &unum );
}
uptr = _get_next_unit(uptr, 0, 0);
}
/*
* Flush C files on mips because the C cleanup routine will not
* be executed if the code is loaded using the f90 command. So
* Fortran fork_ processing must flush stdout and any user C
* files in addition to the Fortran files.
*/
(void) fflush(NULL);
return;
}
/*
* _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);
}
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;
}