_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
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;
}
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 */
}
int
$RFI(
_fcd funit, /* Address of unit number or FCD */
_fcd format, /* Address of format (FCD or hollerith) */
long *err, /* Address of error processing address */
long *end, /* Address of end processing address */
_f_int *iostat, /* Address of IOSTAT variable */
_f_int *rec, /* Address of direct access record no. */
fmt_type **pform, /* Address of address of parsed format */
long *inumelt, /* Address of int. array element count */
long *inumcfe /* Address of number of format elements */
)
#endif
{
register int endf; /* END processing flag */
register int errf; /* ERR processing flag */
register int errn; /* Error number */
register int iost; /* I/O statement type */
register int iotp; /* I/O type */
register recn_t recn; /* Record number */
register unum_t unum; /* Unit number */
fmt_type **prsfmt; /* Parsed format info. */
unit *cup; /* Unit table pointer */
FIOSPTR css; /* I/O statement state */
#ifdef _CRAYMPP
va_list args;
_fcd format; /* Address of format (FCD or hollerith) */
long *err; /* Address of error processing address */
long *end; /* Address of end processing address */
_f_int *iostat; /* Address of IOSTAT variable */
_f_int *rec; /* Address of direct access record no. */
fmt_type **pform; /* Address of address of parsed format */
long *inumelt; /* Address of int. array element count */
long *inumcfe; /* Address of number of format elements */
#endif
GET_FIOS_PTR(css);
/* Check if recursive triple-call I/O */
if (css->f_iostmt != 0)
_ferr(css, FEIOACTV);
#ifdef _CRAYMPP
va_start(args, funit);
format = va_arg(args, _fcd);
err = va_arg(args, long *);
end = va_arg(args, long *);
iostat = va_arg(args, _f_int *);
rec = va_arg(args, _f_int *);
if (_numargs() > ARGS_6) {
pform = va_arg(args, fmt_type **);
if (_numargs() > ARGS_7) {
inumelt = va_arg(args, long *);
if (_numargs() > ARGS_8) {
inumcfe = va_arg(args, long *);
}
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
$DFI(
long *len, /* Address of length (in characters) */
_fcd format, /* Address of format (FCD or hollerith) */
_fcd fwa, /* Address of output character string */
fmt_type **_arg4, /* Unused (old pform arugment) */
long *_arg5, /* Unused */
long *_arg6, /* Unused */
fmt_type **pform, /* Address of address of parsed format */
long *inumelt, /* Address of int. array element count */
long *inumcfe /* Address of number of format elements */
)
#endif
{
long mone = -1L;
_fcd fch;
int nargs;
#ifdef _CRAYMPP
va_list args;
_fcd format; /* Address of format (FCD or hollerith) */
_fcd fwa; /* Address of output character string */
fmt_type **_arg4; /* Unused (old pform arugment) */
long *_arg5; /* Unused */
long *_arg6; /* Unused */
fmt_type **pform; /* Address of address of parsed format */
long *inumelt; /* Address of int. array element count */
long *inumcfe; /* Address of number of format elements */
va_start(args, len);
format = va_arg(args, _fcd);
fwa = va_arg(args, _fcd);
#endif
if (*len <= 0) /* If length is zero or negative */
_ferr(NULL, FEDECDRL); /* Invalid DECODE record length */
/* Insert length in character descriptor */
fch = _cptofcd(_fcdtocp(fwa), *len);
nargs = _numargs();
#ifdef _CRAYMPP
if (nargs >= ARGS_7) {
_arg4 = va_arg(args, fmt_type **);
_arg5 = va_arg(args, long *);
_arg6 = va_arg(args, long *);
pform = va_arg(args, fmt_type **);
if (nargs >= ARGS_9) {
inumelt = va_arg(args, long *);
inumcfe = va_arg(args, long *);
}
void
$RB$(
_f_int *biunit, /* Unit */
_f_int *recmode, /* Mode */
gfptr_t bloc, /* Beginning location */
gfptr_t eloc, /* Ending location */
int *type) /* Data type */
{
register short type77;
register unum_t unum;
type_packet tip;
struct f90_type ts;
unit *cup;
struct fiostate cfs;
unum = *biunit;
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_open77(&cfs, SEQ, UNF, unum, 0, NULL);
type77 = *type & 017;
CREATE_F90_INFO(ts, tip, type77);
#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, recmode, bloc, eloc, &tip);
return;
}
/*
* _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;
}
void
TSYNC(_f_int *unump, _f_int *istat)
{
register int ret;
unit *cup; /* Unit table pointer */
FIOSPTR css; /* I/O statement state */
GET_FIOS_PTR(css);
STMT_BEGIN(*unump, 0, T_TAPE, NULL, css, cup);
if (cup == NULL)
_ferr(css, FENOTOPN);
*istat = 0;
if (cup->ufs == FS_FDC) {
ret = XRCALL(cup->ufp.fdc, fcntlrtn) cup->ufp.fdc,
FC_TSYNC, 0, &cup->uffsw);
if (ret < 0)
*istat = cup->uffsw.sw_error;
}
void
ENDSP(_f_int *unump, _f_int *istat)
{
register int ret;
unit *cup;
FIOSPTR css;
GET_FIOS_PTR(css);
STMT_BEGIN(*unump, 0, T_TAPE, NULL, css, cup);
if (cup == NULL)
_ferr(css, FENOTOPN);
*istat = 0;
if (cup->ufs == FS_FDC) {
ret = XRCALL(cup->ufp.fdc, fcntlrtn) cup->ufp.fdc,
FC_ENDSP, 0, &cup->uffsw);
if (ret < 0)
*istat = cup->uffsw.sw_error;
else
cup->uspcproc = 0;
}
/*
* _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));
}
int
_RUI(
_fcd _Unitid, /* Pointer to unit identifier */
_fcd _arg2, /* Unused */
long *err, /* Address of error processing address */
long *end, /* Address of end processing address */
_f_int *iostat, /* Address of IOSTAT variable */
_f_int *rec /* Address of direct access record no. */
#ifndef _UNICOS
,FIOSPTR cssa /* Statement state structure */
#endif
)
#endif
{
register int errf; /* Error processing flag */
register int errn; /* Error number */
register int iost; /* I/O statement type */
register int iotp; /* I/O type */
register recn_t recn; /* Direct access record number */
register unum_t unum; /* Actual unit number */
unit *cup; /* Pointer to unit table entry */
FIOSPTR css; /* Statement state structure */
#ifdef _CRAYMPP
va_list args;
_fcd _arg2; /* Unused */
long *err; /* Address of error processing address*/
long *end; /* Address of end processing address */
_f_int *iostat; /* Address of IOSTAT variable */
_f_int *rec; /* Address of direct access record no.*/
#endif
#ifdef _UNICOS
GET_FIOS_PTR(css);
/* Check if recursive triple-call I/O */
if (css->f_iostmt != 0)
_ferr(css, FEIOACTV);
#else
css = cssa;
#endif
#ifdef _CRAYMPP
va_start(args, _Unitid);
_arg2 = va_arg(args, _fcd);
err = va_arg(args, long *);
end = va_arg(args, long *);
iostat = va_arg(args, _f_int *);
rec = va_arg(args, _f_int *);
va_end(args);
#endif
errn = 0;
/* Establish error processing options */
if (iostat != NULL)
*iostat = 0; /* Clear IOSTAT variable, if extant */
errf = ((err != NULL) || (iostat != NULL));
iost = T_RSU;
iotp = SEQ; /* Assume sequential */
unum = **(_f_int **)&_Unitid;
if (rec != NULL) { /* If direct access */
iost = T_RDU; /* Set direct unformatted read */
iotp = DIR;
recn = *rec;
}
STMT_BEGIN(unum, 0, iost, NULL, css, cup);
if (cup == NULL) { /* if not connected */
int stat;
cup = _imp_open77(css, iotp, UNF, unum, errf, &stat);
if (cup == NULL) {
errn = stat;
goto error;
}
}
/* Record error processing options in the unit */
cup->uiostat = iostat;
cup->uflag = (err != NULL ? _UERRF : 0) |
(end != NULL ? _UENDF : 0) |
(iostat != NULL ? _UIOSTF : 0);
/* Perform error checking */
if (cup->ufs == FS_AUX) {
errn = FEMIXAUX; /* Can't mix auxiliary and Fortran I/O */
ERROR0(errf, errn);
}
if ((cup->uaction & OS_READ) == 0) {
errn = FENOREAD; /* No read permission */
ERROR0(errf, errn);
}
if (cup->ufmt) { /* If unformatted attempted on formatted file */
errn = FEUNFMIV; /* Unformatted not allowed */
ERROR0(errf, errn);
}
/* If sequential and writing, disallow read after write */
if (cup->useq && cup->uwrt != 0) {
errn = FERDAFWR; /* Read after write */
ERROR0(errf, errn);
}
/* Preset fields in unit table */
cup->ueor_found = NO; /* Clear EOR */
cup->uwrt = 0;
cup->ulastyp = DVTYPE_TYPELESS;
if (iotp == DIR) { /* If direct access */
if (cup->useq) /* If direct attempted on seq. file */
errn = FEDIRTIV; /* Direct access not allowed */
else
errn = _unit_seek(cup, recn, iost);
if (errn != 0) {
ERROR1(errf, errn, recn);
}
}
else { /* Else sequential access */
if (cup->useq == 0) { /* If seq. attempted on direct file */
errn = FESEQTIV; /* Sequential not allowed */
ERROR0(errf, errn);
}
#if PURE_ENABLED
if (cup->upure && cup->upuretype != P_RDWR) {
/*
* Set the upuretype field to P_RDWR mode unless it has
* previously been set to P_BUFIO by a BUFFER IN/OUT
* statement. This check prevents the intermixing of
* READ/WRITE I/O with BUFFER IN/BUFFER OUT I/O when
* '-s pure' is assigned.
*/
if (cup->upuretype == P_BUFIO) {
errn = FEMIXBUF;
ERROR0(errf, errn);
}
cup->upuretype = P_RDWR;
}
#endif
}
if (errn != 0)
ERROR0(errf, errn);
return(CFT77_RETVAL(IO_OKAY));
error:
if (iostat != NULL)
*iostat = errn; /* Set IOSTAT variable to error */
if (cup != NULL) /* If we have a unit */
cup->uflag |= (errn > 0) ? _UERRC : _UENDC;/* Set status */
#ifdef _UNICOS
return(CFT77_RETVAL(_RUF()));
#else
return(CFT77_RETVAL(_RUF(css)));
#endif
}
static void
_rb(
FIOSPTR css, /* Current Fortran I/O state */
unit *cup, /* Unit pointer */
_f_int *recmode, /* Mode */
gfptr_t bloc, /* Beginning location */
gfptr_t eloc, /* Ending location */
type_packet *tip) /* Type information packet */
{
register int bytshft;
register int mode;
register long bytes;
register long elsize;
register long itemlen;
register long items;
register long stat;
register ftype_t type90;
int state;
char *uda, *udax;
#ifdef _CRAYT3D
register short shared;
register long ntot;
register long numleft;
long shrd[MAXSH];
#endif
if (cup->useq == 0) /* If direct access file */
_ferr(css, FEBIONDA, "BUFFER IN");
if (cup->ufmt) /* If formatted file */
_ferr(css, FEBIONFM, "BUFFER IN");
if (cup->uerr && !cup->unitchk)
_ferr(css, cup->uffsw.sw_error);
/*
* This check taken out temporarily because we'd like to be able to
* follow an ENDFILE statement or a READ which encounters an endfile
* record with a BUFFER IN statement. The sticky EOF principle should
* permit such a BUFFER IN to simply return an EOF status. But what
* really happens is the preceding ENDFILE or READ statement sets
* cup->uend, triggering an error here. We really need a flag to
* store the status of the previous BUFFER IN/OUT statement which is
* separate from cup->uend.
*
* if (cup->uend && !cup->unitchk)
* _ferr(css, FERDPEOF);
*/
cup->unitchk = 0;
cup->uerr = 0;
elsize = tip->elsize; /* Data size in bytes */
type90 = tip->type90;
/*
* Adjust the word count depending on the type.
*/
bytshft = ((sizeof(elsize) << 3) - 1) - _leadz(elsize); /* log2(elsize) */
if (type90 == DVTYPE_ASCII) { /* If character item */
uda = _fcdtocp(bloc.fcd);
udax = _fcdtocp(eloc.fcd);
itemlen = _fcdlen (eloc.fcd);
}
else {
#ifdef _CRAYT3D
shared = 0;
if (_issddptr(bloc.v)) {
int *tmpptr;
/* Shared data */
if (!_issddptr(eloc.v)) {
_ferr(css, FEINTUNK);
}
shared = 1;
ntot = 0;
if ((cup->ufs == FS_FDC) &&
(cup->uflagword & FFC_ASYNC)) {
/* When we can do I/O from shared memory */
/* we can support this. */
_ferr(css, FESHRSUP);
}
/*
* When compiler spr 76429 (on T3D) is closed, we can try replacing
* the lines that use tmpptr with this.
* items = _sdd_read_offset((void *)eloc.v) -
* _sdd_read_offset((void *)bloc.v) + 1;
*/
uda = bloc.v; /* temporary */
udax = eloc.v;
tmpptr = (int *)((int)udax & 0x7fffffffffffffff);
items = *(tmpptr + 1);
tmpptr = (int *)((int)uda & 0x7fffffffffffffff);
items = items - *(tmpptr + 1) + 1;
}
else
#endif /* _CRAYT3D */
{
uda = bloc.v;
udax = eloc.v;
}
itemlen = elsize;
}
#ifdef _CRAYT3D
if (shared) {
bytes = items << bytshft;
}
else
#endif
{
bytes = (udax - uda) + itemlen;
items = bytes >> bytshft;
}
if (bytes < 0)
_ferr(css, FEBIOFWA, "BUFFER IN");
mode = (*recmode < 0) ? PARTIAL : FULL;
cup->urecmode = mode;
cup->uwrt = 0;
state = CNT;
if ((items << bytshft) != bytes)
_ferr(css, FEBIOFWD);
#ifdef _CRAYT3D
if ( !shared && cup->uasync ) {
#else
if (cup->uasync) {
#endif
int ubc = 0;
WAITIO(cup, _ferr(css, cup->uffsw.sw_error));
#if defined(_UNICOS) || defined(NUMERIC_DATA_CONVERSION_ENABLED)
/*
* Pad word-aligned numeric data on word boundaries within
* the record for CRI and some foreign data formats.
*/
if ((cup->urecpos & cup->ualignmask) != 0 &&
type90 != DVTYPE_ASCII &&
elsize > 4 ) {
int padubc;
register int pbytes;
int padval;
COMPADD(cup, pbytes, padubc, padval);
if (pbytes != 0) {
stat = XRCALL(cup->ufp.fdc, readrtn)
cup->ufp.fdc,
WPTR2BP(&padval),
pbytes,
&cup->uffsw,
PARTIAL,
&padubc);
if (stat != pbytes ||
FFSTAT(cup->uffsw) != FFCNT) {
cup->uerr = 1;
goto badpart;
}
cup->urecpos += (stat << 3) - padubc;
}
}
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;
}
int
_rdunf(
#endif
FIOSPTR css, /* Current Fortran I/O statement state */
unit *cup, /* Unit pointer */
void *ptr, /* Pointer to data */
type_packet *tip, /* Type information packet */
int _Unused /* Unused by this routine */
)
{
register short shared; /* 1 iff ptr points to shared data */
register int errn; /* Error number */
register int64 fillen; /* bit size of each element, on disk */
register long count; /* Number of data items */
register long elsize; /* element size in bytes */
register long i;
register long incb; /* inc (in units of bytes) */
register long items;
int status;
long lbuf[LOCBUFLN];
void *frwdbuf; /* ptr to buffer passed to _frwd */
#ifdef _CRAYT3D
register long elwords; /* element size in words */
#endif
errn = 0; /* Clear error number */
shared = 0; /* Assume data is not shared */
count = tip->count;
elsize = tip->elsize;
fillen = tip->extlen;
if (count == 0)
return(0);
if (tip->type90 == DVTYPE_ASCII)
fillen = fillen * elsize;
incb = tip->stride * elsize; /* Stride in bytes */
if ( cup->ueor_found ) {
errn = FERDPEOR;
goto done;
}
if (cup->useq == 0) { /* If direct access file */
register int64 newpos;
register int64 recl;
newpos = cup->urecpos + count * fillen; /* in bits */
recl = (int64) (cup->urecl);
if ((recl << 3) < newpos) {
/*
* The user is asking for more data than can fit in a
* RECL-sized record, so we abort here.
*/
errn = FERDPEOR;
goto done;
}
}
#ifdef _CRAYT3D
if (_issddptr(ptr)) {
/* ptr points to shared data descriptor. */
/* If we have a layer that handles sdds someday, we */
/* could check for that here and not set shared. */
/* We'd also probably want to make sure that we are */
/* not doing foreign data conversion */
css->f_shrdput = 1;
shared = 1;
elwords = elsize / sizeof(long);
}
#endif
/*
* If contiguous memory, transfer all data at once.
*/
if ((shared == 0) && ((count == 1) || (incb == elsize))) {
register long ret;
ret = _frwd(cup, ptr, tip, PARTIAL, (int *) NULL,
(long *) NULL, &status);
if ( ret == IOERR ) {
errn = errno;
goto done;
}
if ( status == EOR ) {
cup->ueor_found = YES;
cup->uend = BEFORE_ENDFILE;
}
else if ( status == CNT )
cup->uend = BEFORE_ENDFILE;
if ( ret < count ) {
if (status == EOF || status == EOD)
goto endfile_record;
errn = FERDPEOR;
goto done;
}
return(0);
}
/*
* Stride is such that memory is not contiguous, break the request
* into chunks and do a scatter on the items when read.
*/
items = (LOCBUFLN * sizeof(long)) / elsize; /* chop it into chunks */
assert( ! (shared && items == 0) ); /* don't support shared char */
if (items == 0)
items = 1; /* must be character*BIG array*/
frwdbuf = lbuf;
for ( i = 0; i < count; i += items ) {
register long ret;
/* trim the item count if not a full buffer's worth */
if (items > count - i)
items = count - i;
tip->count = items;
/*
* Read data into lbuf, scatter items from lbuf into the
* user array, and then write out a chunk. If items == 1,
* we suppress the extra data copy for performance and because
* it might not fit in the lbuf if it is character*BIG data.
*
* We don't have to worry about shared data not fitting in
* lbuf since character data is never shared.
*/
if ((items == 1) && (shared == 0))
frwdbuf = ptr; /* read directly to user array */
ret = _frwd(cup, frwdbuf, tip, PARTIAL, (int *) NULL,
(long *) NULL, &status);
#ifdef _CRAYT3D
if (shared)
_cpytosdd(ptr, lbuf, items, elwords, tip->stride, i);
else
#endif
if (items > 1)
_scatter_data (ptr, items, incb, elsize, lbuf);
if ( ret == IOERR ) {
errn = errno;
goto done;
}
if ( status == EOR ) {
cup->ueor_found = YES;
/* If not last iteration, this is an error */
if ((i + ret) < count) {
errn = FERDPEOR;
goto done;
}
}
if (i == 0)
if (status == EOR || status == CNT)
cup->uend = BEFORE_ENDFILE;
/*
* We know that items > 0
*/
if ( ret < items ) {
if (status == EOF || status == EOD)
goto endfile_record;
errn = FERDPEOR;
goto done;
}
if (!shared)
ptr = (char *) ptr + (ret * incb);
}
done:
/* Process any error which occurred */
if (errn > 0) {
if ((cup->uflag & (_UERRF | _UIOSTF)) == 0)
_ferr(css, errn); /* Run-time error */
}
else if (errn < 0) {
if ((cup->uflag & (_UENDF | _UIOSTF)) == 0)
_ferr(css, errn); /* EOF-type error */
}
return(errn);
endfile_record:
/*
* EOF/EOD is an error on direct access, an end
* condition on sequential access.
*/
if (status == EOF) {
cup->uend = PHYSICAL_ENDFILE;
errn = FERDPEOF;
}
else { /* End of data */
if (cup->uend == 0) {
cup->uend = LOGICAL_ENDFILE;
errn = FERDPEOF;
}
else
errn = FERDENDR;
}
if (!(cup->useq)) /* If direct access */
errn = FENORECN; /* Record does not exist */
goto done;
}
int
_wrunf(
#endif
FIOSPTR css, /* Current Fortran I/O statement state */
unit *cup, /* Unit pointer */
void *ptr, /* Pointer to data */
type_packet *tip, /* Type information packet */
int mode /* Mode argument to _fwwd() */
)
{
register short shared; /* 1 iff ptr points to sdd */
register int errn; /* Error number */
register int64 fillen; /* bit size of each element, on disk */
register long count; /* Number of data items */
register long elsize; /* element size in bytes */
register long i;
register long incb; /* inc (in units of bytes) */
register long items;
long lbuf[LOCBUFLN];
void *fwwdbuf; /* ptr to buffer passed to _fwwd */
#ifdef _CRAYT3D
register long elwords; /* element size in words */
#endif
errn = 0;
shared = 0;
count = tip->count;
elsize = tip->elsize;
fillen = tip->extlen;
if (count == 0)
return(0);
if (tip->type90 == DVTYPE_ASCII)
fillen = fillen * elsize;
incb = tip->stride * elsize; /* Stride in bytes */
if (cup->useq == 0) { /* If direct access file */
register int64 newpos;
register int64 recl;
newpos = cup->urecpos + count * fillen; /* in bits */
recl = (int64) (cup->urecl);
if ((recl << 3) < newpos) {
errn = FEWRLONG; /* output record too long */
goto done;
}
}
#ifdef _CRAYT3D
if (_issddptr(ptr)) {
/* ptr points to a shared data descriptor */
/* If we have a layer that handles sdds someday, we */
/* could check for that here and not set shared to one. */
/* We'd also probably want to make sure that we're not */
/* doing foreign data converion */
shared = 1;
elwords = elsize / sizeof(long);
}
#endif
/*
* If only one item, or stride is such that data is contiguous,
* do it all at once
*/
if ((shared == 0) && ((count == 1) || (incb == elsize))) {
register long ret;
int status;
if (mode == FULL)
cup->f_lastwritten = 1;
ret = _fwwd(cup, ptr, tip, mode, (int *) NULL,
(long *) NULL, &status);
if ( ret == IOERR ) {
errn = errno;
goto done;
}
return(0);
}
/*
* Stride is such that memory is not contiguous, break the request
* into chunks and do a gaterh on the items before writing.
*/
items = (LOCBUFLN * sizeof(long)) / elsize; /* chop it in chunks */
assert( ! (shared && items == 0) ); /* don't support shared char */
if (items == 0)
items = 1; /* must be character*BIG array*/
fwwdbuf = lbuf;
for ( i = 0; i < count; i = i + items ) {
register long ret;
int status;
/* trim the item count if not a full buffer's worth */
if (items > count - i)
items = count - i;
tip->count = items;
/*
* Gather items from user array into lbuf, and then write
* out a chunk. If items == 1, we suppress the extra data
* copy for performance and because it might not fit in the
* lbuf if it is character*BIG data.
*
* We don't have to worry about shared data not fitting
* in lbuf since character data is never shared.
*/
#ifdef _CRAYT3D
if (shared)
_cpyfrmsdd(ptr, lbuf, items, elwords, tip->stride, i);
else
#endif
{
if (items > 1)
_gather_data (lbuf, items, incb, elsize, ptr);
else
fwwdbuf = ptr;
}
if ( mode == FULL && (i+items >= count)) {
cup->f_lastwritten = 1;
ret = _fwwd(cup, fwwdbuf, tip, FULL, (int *) NULL,
(long *) NULL, &status);
}
else
ret = _fwwd(cup, fwwdbuf, tip, PARTIAL,
(int *) NULL, (long *) NULL, &status);
if ( ret == IOERR ) {
errn = errno;
goto done;
}
if (!shared)
ptr = (char *)ptr + (ret * incb);
}
done:
if (errn > 0) {
if ((cup->uflag & (_UERRF | _UIOSTF)) == 0)
_ferr(css, errn); /* Run-time error */
}
return(errn);
}
int
$RUA$(
_fcd fwa, /* Address of first word of data */
long *count, /* Address of count of data items */
long *stride, /* Address of stride between data items */
long *type /* Address of data type */
)
{
register short type77; /* Fortran 77 data type */
register int errn; /* Error number */
type_packet tip; /* Type information packet */
struct f90_type ts; /* F90 type structure */
void *dptr;
unit *cup; /* Pointer to unit table entry */
FIOSPTR css;
GET_FIOS_PTR(css);
cup = css->f_cu;
type77 = *type & 017;
CREATE_F90_INFO(ts, tip, type77);
tip.count = *count;
tip.stride = *stride;
if (type77 == DT_CHAR) {
dptr = (void *) _fcdtocp(fwa);
tip.elsize = tip.elsize * _fcdlen(fwa);
}
else
dptr = *(void **)&fwa;
#if NUMERIC_DATA_CONVERSION_ENABLED
if (cup->unumcvrt || cup->ucharset) {
errn = _get_dc_param(css, cup, ts, &tip);
if (errn != 0)
goto error;
}
#endif
#pragma _CRI inline _inline_rdunf
errn = _inline_rdunf(css, cup, dptr, &tip, 0);
if (errn == 0)
return(CFT77_RETVAL(IO_OKAY));
error:
if (cup->uiostat != NULL)
*(cup->uiostat) = errn;
cup->uflag |= (errn > 0) ? _UERRC : _UENDC; /* Set status */
if (cup->uflag & (_UIOSTF | _UERRF | _UENDF))
return(CFT77_RETVAL(_RUF()));
_ferr(css, FEINTUNK); /* Deep weeds */
}
