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;
}
/* Don't pollute the Fortran namespace with library functions */
static
#endif /* KEY Bug 1683 */
_f_int4
putcf90_(char *c, int clen)
{
_f_int4 res;
struct fiostate cfs; /* fiosp */
unit *cup; /* Unit table pointer */
unum_t unum = 6;
res = 0;
/* lock the unit */
STMT_BEGIN( unum, 0, T_WSF, NULL, &cfs, cup);
if (!cup)
return((errno=FEIVUNIT));
if (_fwch(cup, (long *)c, 1, PARTIAL) == -1)
res = errno;
/* unlock the unit */
STMT_END( cup, TF_WRITE, NULL, &cfs);
return(res);
}
_f_int8
fputcf90_8_(_f_int8 *u, char *c, int clen)
{
_f_int8 res;
struct fiostate cfs; /* fiosp */
unit *cup; /* Unit table pointer */
unum_t unum;
unum = *u;
res = 0;
/* lock the unit */
STMT_BEGIN( unum, 0, T_WSF, NULL, &cfs, cup);
if (unum < 0 || !cup)
return((errno=FEIVUNIT));
if (_fwch(cup, (long *)c, 1, PARTIAL) == -1)
res = errno;
/* unlock the unit */
STMT_END( cup, TF_WRITE, NULL, &cfs);
return(res);
}
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
_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));
}
_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 */
}
/* 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);
}
/*
* Similar to C setlinebuf(3s)
* u logical unit
* return 0 if no error; else errno (system or Fortran)
*/
int
_Setlinebuf(_f_int *u) {
struct fiostate cfs;
unit *cup = setup(*u, &cfs);
int res = errno;
if (0 == res) {
switch (cup->ufs) {
case FS_TEXT:
case STD:
setlinebuf(cup->ufp.std);
res = errno;
break;
default:
res = errno = FESTIOER;
break;
}
}
STMT_END( cup, TF_READ, NULL, &cfs);
return res;
}
/*
* Similar to C setbuf(3s)
* u logical unit
* buf buffer to use: can pass %val(0) or a character(len=0)
* variable to disable buffering
* size character length which Fortran passes unbeknownst to user
* return 0 if no error; else errno (system or Fortran)
*/
int
_Setbuf(_f_int *u, char *buf, size_t size) {
struct fiostate cfs;
unit *cup = setup(*u, &cfs);
int res = errno;
if (0 == res) {
switch (cup->ufs) {
case FS_TEXT:
case STD:
if (buf && (0 == size)) {
buf = 0;
}
setbuffer(cup->ufp.std, buf, size);
res = errno;
break;
default:
res = errno = FESTIOER;
break;
}
}
STMT_END( cup, TF_READ, NULL, &cfs);
return res;
}
int
@WNL(
_f_int *unump, /* Unit number or dataset name */
Namelist *nl, /* Namelist structure */
int errf /* Nonzero if ERR specified */
)
{
unum_t unum;
int errn;
int n, ss;
void *vaddr; /* variable address */
unsigned elsize; /* size in bytes of the variable */
long recsize; /* number of characters to output per
* line. Used by REPFLUSH.*/
char c; /* needed by NLPUTS macro */
char *s; /* needed by NLPUTS macro */
unit *cup; /* unit pointer */
Nlentry *nlent;
FIOSPTR css;
struct BUFFERS wnlbuffers;
struct BUFFERS *bptr;
bptr = &wnlbuffers;
bptr->f_lbuf = NULL;
unum = *unump;
GET_FIOS_PTR(css);
STMT_BEGIN(unum, 0, T_WNL, NULL, css, cup);
if (cup == NULL) { /* if not connected */
cup = _imp_open77(css, SEQ, FMT, unum, errf, &errn);
/*
* If the open failed, cup is NULL and errn contains
* the error number.
*/
if (cup == NULL)
RERR(css, errn);
}
/* Set various unit table fields */
cup->uflag = (errf != 0 ? _UERRF : 0);
cup->ulineptr = cup->ulinebuf;
cup->uwrt = 1; /* Set write flag */
/* Set fields in the Fortran statement state structure */
css->u.fmt.nonl = 0; /* Clear no-newline flag */
if (cup->useq == 0) /* If direct access file */
RERR(css, FESEQTIV); /* Sequential attempted on direct access */
if (!cup->ufmt) /* If unformatted file */
RERR(css, FEFMTTIV); /* Formatted attempted on unformatted */
if ((cup->uaction & OS_WRITE) == 0)
RERR(css, FENOWRIT);
bptr = &wnlbuffers;
bptr->lcomma = 0;
/*
* Set up record size. The hierarchy for determining Namelist
* output record size is as follows:
* 1) RECL, if specified
* 2) WNLLONG(), if set and does not exceed cup->urecsize
* 3) list-directed output record size (cup->uldwsize)
*
* Note that while (1) and (3) are established at OPEN time, (2)
* can be changed ``on the fly''; therefore, this check has to
* be performed here.
*/
recsize = cup->uldwsize;
if (cup->urecl == 0 && _wnlrecsiz > 0) /* No RECL and WNLLONG() set */
recsize = MIN(cup->urecsize, _wnlrecsiz);
bptr->outcnt = recsize - 1; /* First char. for carriage control */
bptr->outbuff = cup->ulinebuf;
bptr->outptr = bptr->outbuff;
*bptr->outptr++ = OUT_ECHO; /* First character of first line */
bptr->f_lbuf = (long *) malloc((recsize + 1) * sizeof(long));
if (bptr->f_lbuf == NULL)
RERR(css, FENOMEMY); /* No memory */
/* NAMELIST delimiter to output line */
NLPUT(OUT_CHAR); /* output delimiter */
NLPUTS(nl->nlname); /* unpack group name to buffer */
NLPUT(' ');
NLPUT(' ');
NLINE(); /* Did user specify new line for each variable? */
nlent = nl->nlvnames;
do {
int ntype;
ntype = _old_namelist_to_f77_type_cnvt[nlent->na.type];
/*
* Always format output into f_lbufptr.
* After formatting, if it will fit, move it into outbuff.
* If it will not fit, write out what is already in outbuff,
* and then move in the newly formatted data.
*/
bptr->f_lbufptr = bptr->f_lbuf;
bptr->f_lbufcnt = 0;
LPUTS(nlent->varname); /* output variable name */
LPUT(' ');
LPUT(OUT_EQ); /* output the replacement
* character. '=' by default. */
n = (nlent->na.offdim) ? nlent->na.nels : 1;
if (ntype == DT_CHAR) {
_fcd f;
f = *(_fcd *)(((unsigned long) nlent->va.varaddr +
(long *)nl));
vaddr = _fcdtocp(f);
elsize = _fcdlen(f);
}
else {
vaddr = (void *)nlent->va.varaddr;
elsize = 0;
}
LPUT(' ');
/* Output value */
ss = l_write(css, cup, vaddr, elsize, n, 1, ntype, recsize,
errf, bptr);
if (ss != 0) {
RERR(css, ss);
}
NLINE();
nlent++; /* point to next variable description */
} while (nlent->varname[0]);
if (bptr->outcnt < 6) {
REPFLUSH(); /* Make sure there's room for " &END" */
bptr->outptr--; /* start in col. 2 */
bptr->outcnt++;
}
NLPUT(OUT_CHAR);
NLPUTS("END");
REPFLUSH();
ret:
STMT_END(cup, T_WNL, NULL, css); /* Unlock the unit */
if (bptr->f_lbuf != NULL) /* Free formatting buffer */
free(bptr->f_lbuf);
return(CFT77_RETVAL(ss));
}
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 _INQ(
_f_int *unitn,
_f_int *iostat,
int errf,
_f_log *exist,
_f_log *opened,
_f_int *number,
_f_log *named,
_fcd name,
_fcd access,
_fcd sequent,
_fcd direct,
_fcd form,
_fcd formatt,
_fcd unform,
_f_int *recl,
_f_int *nextrec,
_fcd blank,
_fcd file,
_fcd pos,
_fcd action,
_fcd red,
_fcd writ,
_fcd redwrit,
_fcd delim,
_fcd pad
)
#endif
{
inlist a; /* INQUIRE parameter list */
int errn; /* IOSTAT error number */
int error; /* Error flag */
unum_t unum; /* Unit number */
long stmt; /* Statement type */
unit *cup; /* Unit pointer if inquire by unit */
struct fiostate cfs;
#ifdef _CRAYMPP
va_list args;
_fcd name;
_fcd access;
_fcd sequent;
_fcd direct;
_fcd form;
_fcd formatt;
_fcd unform;
_f_int *recl;
_f_int *nextrec;
_fcd blank;
_fcd file;
_fcd pos;
_fcd action;
_fcd red;
_fcd writ;
_fcd redwrit;
_fcd delim;
_fcd pad;
va_start(args,named);
name = va_arg(args, _fcd);
access = va_arg(args, _fcd);
sequent = va_arg(args, _fcd);
direct = va_arg(args, _fcd);
form = va_arg(args, _fcd);
formatt = va_arg(args, _fcd);
unform = va_arg(args, _fcd);
recl = va_arg(args, _f_int *);
nextrec = va_arg(args, _f_int *);
blank = va_arg(args, _fcd);
file = va_arg(args, _fcd);
#endif
/* Initialize the inlist structure */
(void) memset(&a, 0, sizeof(inlist));
a.inunit = -1;
/* Determine type of INQUIRE */
if (_fcdtocp(file) != NULL) {
a.infile = _fcdtocp(file);
a.infilen = _fcdlen (file); /* CFT77 */
stmt = T_INQF; /* INQUIRE by FILE */
unum = -1;
}
else {
stmt = T_INQU; /* INQUIRE by UNIT */
unum = *unitn;
a.inunit = unum;
}
/*
* Here unum is -1 if this is an inquire by file. This will suppress
* any unit locking in STMT_BEGIN.
*/
STMT_BEGIN(unum, 0, stmt, NULL, &cfs, cup);
/* Process rest of parameters */
if (_fcdtocp(name) != NULL) {
a.inname = _fcdtocp(name);
a.innamlen = _fcdlen (name); /* CFT77 */
if (a.innamlen == 0)
a.innamlen = strlen(a.inname); /* CFT2 */
}
if (_fcdtocp(access) != NULL) {
a.inacc = _fcdtocp(access);
a.inacclen = _fcdlen (access);
}
if (_fcdtocp(sequent) != NULL) {
a.inseq = _fcdtocp(sequent);
a.inseqlen = _fcdlen (sequent);
}
if (_fcdtocp(direct) != NULL) {
a.indir = _fcdtocp(direct);
a.indirlen = _fcdlen (direct);
}
if (_fcdtocp(form) != NULL) {
a.inform = _fcdtocp(form);
a.informlen = _fcdlen (form);
}
if (_fcdtocp(formatt) != NULL) {
a.infmt = _fcdtocp(formatt);
a.infmtlen = _fcdlen (formatt);
}
if (_fcdtocp(unform) != NULL) {
a.inunf = _fcdtocp(unform);
a.inunflen = _fcdlen (unform);
}
if (_fcdtocp(blank) != NULL) {
a.inblank = _fcdtocp(blank);
a.inblanklen = _fcdlen (blank);
}
#ifdef _UNICOS
if (_numargs() <= (9 + 9*sizeof(_fcd)/sizeof(long)))
goto old_inq;
#endif
#ifdef _CRAYMPP
pos = va_arg(args, _fcd);
action = va_arg(args, _fcd);
red = va_arg(args, _fcd);
writ = va_arg(args, _fcd);
redwrit = va_arg(args, _fcd);
delim = va_arg(args, _fcd);
pad = va_arg(args, _fcd);
#endif
if (_fcdtocp(pos) != NULL) {
a.inposit = _fcdtocp(pos);
a.inpositlen = _fcdlen (pos);
}
if (_fcdtocp(action) != NULL) {
a.inaction = _fcdtocp(action);
a.inactonlen = _fcdlen (action);
}
if (_fcdtocp(red) != NULL) {
a.inread = _fcdtocp(red);
a.inreadlen = _fcdlen (red);
}
if (_fcdtocp(writ) != NULL) {
a.inwrite = _fcdtocp(writ);
a.inwritelen = _fcdlen (writ);
}
if (_fcdtocp(redwrit) != NULL) {
a.inredwrit = _fcdtocp(redwrit);
a.inrdwrtlen = _fcdlen (redwrit);
}
if (_fcdtocp(delim) != NULL) {
a.indelim = _fcdtocp(delim);
a.indelimlen = _fcdlen (delim);
}
if (_fcdtocp(pad) != NULL) {
a.inpad = _fcdtocp(pad);
a.inpadlen = _fcdlen (pad);
}
old_inq:
a.inerr = (errf || iostat) ? 1 : 0;
a.inex = exist;
a.inopen = opened;
a.innum = number;
a.innamed = named;
a.inrecl = recl;
a.innrec = nextrec;
errn = _f_inqu(&cfs, cup, &a);
error = (errn != 0) ? IO_ERR : IO_OKAY;
if (iostat != NULL)
*iostat = errn;
#ifdef _CRAYMPP
va_end(args);
#endif
STMT_END(NULL, 0, NULL, NULL);
return(CFT77_RETVAL(error));
}
