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;
}
_f_int8
ftellf90_8_( _f_int8 *unump)
{
_f_int8 pos;
register unum_t unum;
unit *cup;
struct fiostate cfs;
unum = *unump;
/* lock the unit */
STMT_BEGIN(unum, 0, T_GETPOS, NULL, &cfs, cup);
/*
* If not connected, do implicit open. Abort if open fails.
*/
if (cup == NULL)
cup = _imp_open(&cfs, SEQ, UNF, unum, 0, NULL);
/* if direct access file */
if (cup->useq == 0)
_ferr(&cfs, FEBIONDA, "GETPOS");
/*
* Make the appropriate call depending on file structure to
* get the current file position. Postion routines are file
* structure dependent.
*
* Simulate the IPOS=GETPOS(IUN) call
*/
pos = 0;
switch( cup->ufs ) {
case FS_TEXT:
case STD:
pos = ftell(cup->ufp.std);
break;
case FS_FDC:
_ferr(&cfs, FDC_ERR_NOSUP);
break;
case FS_AUX:
_ferr(&cfs, FEMIXAUX);
break;
default:
_ferr(&cfs, FEINTFST);
}
getpos_done:
STMT_END(cup, T_GETPOS, NULL, &cfs);
return(pos);
}
void
SETPOS(
_f_int *unump,
_f_int *len,
_f_int *pa,
_f_int *stat)
{
register int errn;
register int narg;
register unum_t unum;
unit *cup;
struct fiostate cfs;
unum = *unump;
STMT_BEGIN(unum, 0, T_SETPOS, NULL, &cfs, cup); /* lock the unit */
/*
* If not connected, do an implicit open. Abort if the open fails.
*/
if (cup == NULL)
cup = _imp_open(&cfs, SEQ, UNF, unum, 0, NULL);
if (cup->useq == 0) /* If direct access file */
_ferr(&cfs, FEBIONDA, "SETPOS");
/*
* Do the setpos.
*/
narg = _numargs();
if ( narg == OLD ) {
errn = _setpos(&cfs, cup, len, 1);
}
else {
if (*len <= 0)
errn = FEBIOSNT;
else
errn = _setpos(&cfs, cup, pa, *len);
}
if (narg >= STAT)
*stat = errn;
else if (errn != OK)
_ferr(&cfs, errn);
STMT_END(cup, T_SETPOS, NULL, &cfs); /* unlock the unit */
}
/*
* unum logical unit number
* cfs I/O state used in locking the file
* return unit * corresponding to that logical unit, having performed
* an implicit open if need be and locked the file. errno is
* 0 unless an error occurred
*/
static unit *
setup(unum_t unum, struct fiostate *cfs) {
unit *cup = 0;
/* Lock the unit */
errno = 0;
STMT_BEGIN( unum, 0, T_RSF, NULL, cfs, cup);
if (cup == NULL) {
int stat;
int errf = 0;
cup = _imp_open(cfs, SEQ, FMT, unum, errf, &stat);
errno = (0 == cup) ? stat : 0;
}
if (unum < 0 || !cup) {
errno = FEIVUNIT;
}
return cup;
}
/*
* _BUFFERIN f90 BUFFER IN wrapper (also a headache remedy)
*/
void
_BUFFERIN(struct bio_spec_list *bisl)
{
register unum_t unum;
type_packet tip;
struct f90_type ts;
unit *cup;
struct fiostate cfs;
assert ( bisl->version == 0 );
unum = *bisl->unit;
ts = *bisl->tiptr;
STMT_BEGIN(unum, 0, T_BUFIN, NULL, &cfs, cup);
/*
* If not connected, do an implicit open. Abort if the open fails.
*/
if (cup == NULL)
cup = _imp_open(&cfs, SEQ, UNF, unum, 0, NULL);
tip.type77 = -1;
tip.type90 = ts.type;
tip.intlen = ts.int_len;
tip.extlen = ts.int_len;
tip.elsize = ts.int_len >> 3;
tip.stride = 1;
#if NUMERIC_DATA_CONVERSION_ENABLED
if (cup->unumcvrt || cup->ucharset) {
register int ret;
ret = _get_dc_param(&cfs, cup, ts, &tip);
if (ret != 0)
_ferr(&cfs, ret);
}
#endif
_PRAGMA_INLINE(_rb);
_rb( &cfs, cup, bisl->recmode, bisl->bloc, bisl->eloc, &tip);
return;
}
/* Don't pollute the Fortran namespace with library functions */
static
#endif /* KEY Bug 1683 */
_f_int
fputcf90_(_f_int *u, char *c, int clen)
{
_f_int res;
struct fiostate cfs; /* fiosp */
unit *cup; /* Unit table pointer */
unum_t unum;
long inpbuf;
unum = *u;
res = 0;
/* lock the unit */
STMT_BEGIN( unum, 0, T_WSF, NULL, &cfs, cup);
#ifdef KEY /* Bug 1683 */
/* Copied from rf90.c; list-directed uses SEQ, so we do too */
if (cup == NULL) { /* If not connected */
int stat;
int errf = 0;
cup= _imp_open(&cfs, SEQ, FMT, unum, errf, &stat);
if (0 == cup) {
return errno = stat;
}
}
#endif /* KEY Bug 1683 */
if (unum < 0 || !cup)
return((errno=FEIVUNIT));
/* move the character to a character per word for fwch */
inpbuf = (long) *c;
if (_fwch(cup, &inpbuf, 1, PARTIAL) == -1)
res = errno;
/* unlock the unit */
STMT_END( cup, TF_WRITE, NULL, &cfs);
return(res);
}
int
_FRU(ControlListType *cilist, iolist_header *iolist, void *stck)
{
register int errf; /* ERR processing flag */
register int errn; /* Error number */
register int endf; /* END processing flag */
register int iost; /* I/O statement type */
register int retval; /* _FRU Return value */
register recn_t errarg; /* Extra _ferr argument */
register unum_t unum; /* Unit number */
unit *cup; /* Unit table pointer */
FIOSPTR css; /* I/O statement state */
/*
* Assertions
*/
/* Validate that the size of *stck is large enough */
assert ( cilist->stksize >= sizeof(struct fiostate)/sizeof(long) );
css = stck;
errn = 0;
errarg = 0;
retval = IO_OKAY;
if (iolist->iolfirst == 0) {
cup = css->f_cu;
goto data_transfer;
}
/*******************************************************************************
*
* Statement Initialization Section
*
******************************************************************************/
errf = (cilist->errflag || cilist->iostatflg);
endf = (cilist->endflag || cilist->iostatflg);
unum = *cilist->unit.wa;
iost = cilist->dflag ? T_RDU : T_RSU;
STMT_BEGIN(unum, 0, iost, NULL, css, cup);
if (cup == NULL) { /* If not connected */
int stat; /* Status */
cup = _imp_open(css, (cilist->dflag ? DIR : SEQ), UNF,
unum, errf, &stat);
/*
* If the open failed, cup is NULL and stat contains
* the error number.
*/
if (cup == NULL) {
errn = stat;
goto handle_exception;
}
}
/* Record error processing options in the unit. (used in _rdunf()) */
cup->uflag = (cilist->errflag ? _UERRF : 0) |
(cilist->endflag ? _UENDF : 0) |
(cilist->iostat_spec != NULL ? _UIOSTF : 0);
/* If sequential and writing, disallow read after write */
if (cup->useq && cup->uwrt != 0) {
errn = FERDAFWR; /* Read after write */
goto handle_exception;
}
/* Preset fields in unit table */
cup->ueor_found = NO; /* Clear EOR */
cup->uwrt = 0;
cup->ulastyp = DVTYPE_TYPELESS;
if (cilist->dflag) { /* If direct access */
if (!cup->ok_rd_dir_unf)
errn = _get_mismatch_error(errf, iost, cup, css);
else {
register recn_t recn; /* Record number */
recn = (recn_t) *cilist->rec_spec;
errarg = recn;
errn = _unit_seek(cup, recn, iost);
}
}
else /* Else sequential access */
if (!cup->ok_rd_seq_unf)
errn = _get_mismatch_error(errf, iost, cup, css);
if (errn != 0)
goto handle_exception;
/*******************************************************************************
*
* Data Transfer Section
*
******************************************************************************/
data_transfer:
errn = _xfer_iolist(css, cup, iolist, _rdunf);
if (errn != 0)
goto handle_exception;
if (! iolist->iollast)
return(IO_OKAY);
/******************************************************************************
*
* Statement Finalization Section
*
******************************************************************************/
finalization:
if (cup != NULL) {
cup->ulrecl = cup->urecpos;
cup->urecpos = 0;
}
#ifdef _CRAYMPP
if (css->f_shrdput) {
css->f_shrdput = 0;
_remote_write_barrier();
}
#endif
if (errn == 0 && cup->useq) {
if (cup->ufs == FS_FDC) {
/*
* Do a full record read to advance to the
* end of the record for sequential access.
*/
if (cup->ublkd && !cup->ueor_found) {
char dummy; /* Unused data */
int ubc = 0; /* Unused bit count */
struct ffsw fst; /* FFIO status block */
(void) XRCALL(cup->ufp.fdc, readrtn)
cup->ufp.fdc,
CPTR2BP(&dummy), 0,
&fst, FULL, &ubc);
switch (fst.sw_stat) {
case FFERR:
errn = fst.sw_error;
break;
case FFEOF:
cup->uend = PHYSICAL_ENDFILE;
errn = FERDPEOF;
break;
case FFEOD:
if (cup->uend == BEFORE_ENDFILE) {
cup->uend = LOGICAL_ENDFILE;
errn = FERDPEOF;
}
else
errn = FERDENDR;
break;
} /* switch */
}
}
if (errn != 0)
goto handle_exception;
}
