/*
* This routine is like ffopen, except it expects all parameters
*/
ffopenf(const char *name, int flags, mode_t mode, long cbits, int cblks,
struct ffsw *pstat)
{
int narg;
_ffopen_t fd;
int retfd;
int aifound;
union spec_u *fdspec;
struct gl_o_inf gloinf;
assign_info ai;
struct fdinfo *nfio;
extern union spec_u *_g_fdc_spec();
aifound = _assign_asgcmd_info(name, -1, ASN_G_FF | ASN_G_ALL, &ai,
NULL, 1);
if (aifound == -1) {
ERETURN(pstat, errno, 0);
}
if (aifound == 1 && ai.F_filter_flg)
fdspec = &ai.F_filter[0];
else
fdspec = NULL;
(void) memset(&gloinf, 0, sizeof(gloinf));
gloinf.aip = aifound ? &ai : NULL;
fd = _ffopen(name, flags, mode, fdspec, pstat, cbits, cblks, NULL,
&gloinf);
#if defined(_CRAY1) || defined(__mips)
if (fd != _FFOPEN_ERR && MULTI_ON) {
nfio = NULL;
if (_ff_top_lock(fd, &nfio, pstat) < 0)
fd = _FFOPEN_ERR;
if (nfio != NULL)
fd = (_ffopen_t)nfio;
}
#endif
/*
* ffopen returns an int. Call a routine which associates an
* int with what is returned by _ffopen
*/
#if defined(__mips) || defined(_LITTLE_ENDIAN)
retfd = _ff_fdinfo_to_int(fd, pstat);
#else
retfd = (int)fd;
#endif
/* should check chain of layers here for sanity */
return(retfd);
}
void
OPENWA(
long *dn, /* pointer to null-terminated file name */
long *index,
long *eoi,
long **addr,
long *blocks,
long *sector,
long *ier /* optional error return. If this parameter is */
/* not present, we abort on error */
)
{
WAFIL *f;
assign_info ai;
int aifound;
char *nmstr;
unum_t unitnum;
unum_t unitid;
int rfd;
char c;
char *ptr;
struct ffc_info_s ffi;
struct fdinfo *fio;
struct ffsw iostat;
int errflg = 0;
long *erptr;
unitnum = -1; /* assume no unit number */
unitid = *(unum_t *) dn; /* unit ID is 'name' */
if (_numargs() > 6)
errflg = 1;
/*
* Check the assign environment for user requested changes to the
* default file characteristics.
*/
if (strncmp((char *)dn, "fort.", 5) == 0) {
register unum_t unum;
ptr = (char *)dn + 5;
unum = 0;
while (isdigit(c = *ptr++)) {
unum = unum * 10;
unum = unum + ((int) c - (int) '0');
}
if (c == '\0') {
unitnum = unum;
unitid = unum;
}
}
aifound = _assign_asgcmd_info((char *)dn, unitnum, ASN_G_ALL,
&ai, NULL, 1);
if (aifound == -1) {
if (errflg) {
*ier = -errno;
_errwa_msg(errno);
return;
}
else
_errwa_abort(errno);
}
if (aifound == 1 && ai.a_actfil_flg) /* if actual file assigned */
nmstr = ai.a_actfil;
else
nmstr = (char *)dn;
if (errflg)
erptr = ier;
else
erptr = NULL;
G@OPENWA(nmstr, index, eoi, addr, blocks, &aifound, &ai,
NULL, erptr, sector);
if (erptr && *erptr != 0) {
_errwa_msg(-(*erptr));
return;
}
f = wafils + (*index-1);
/*
* The file name is stored only if we're not being called from libf
* via the '-s bin' mechanism.
*/
(void) strncpy(f->wa_idn, (char*)dn, WA_NAMLEN);
fio = GETIOB(f->wa_fd);
if (f->wa_fdc == YES) {
if (XRCALL(fio, fcntlrtn)fio, FC_GETINFO, &ffi, &iostat) < 0) {
if (errflg) {
*ier = -iostat.sw_error;
_errwa_msg(iostat.sw_error);
return;
}
else
_errwa("OPENWA", "Fcntlrtn error on", f,
iostat.sw_error);
}
rfd = ffi.ffc_fd;
}
else
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;
}
ffopen(const char *name, int flags, ...)
{
int narg;
int cblks;
_ffopen_t fd;
int retfd;
int aifound;
mode_t mode;
long cbits;
va_list ap;
union spec_u *fdspec;
struct gl_o_inf gloinf;
assign_info ai;
struct fdinfo *nfio;
extern union spec_u *_g_fdc_spec();
struct ffsw *pstat, locstat;
#ifdef _CRAY
NUMARG(narg);
#elif defined(__mips) || defined(_LITTLE_ENDIAN)
/* mode is passed only when O_CREAT is set */
if (flags & O_CREAT)
narg = 3;
else
narg = 2;
#else
narg = 6;
#endif
mode = 0;
cbits = 0;
cblks = 0;
pstat = &locstat;
/*
* New usage only allows 5 params. (what does this mean ???)
*/
va_start(ap, flags);
if (narg >= 3)
#if defined(BUILD_OS_DARWIN)
mode = (mode_t) va_arg(ap, int);
#else /* defined(BUILD_OS_DARWIN) */
mode = va_arg(ap, mode_t);
#endif /* defined(BUILD_OS_DARWIN) */
if (narg >= 4)
cbits = va_arg(ap, long);
if (narg >= 5)
pstat = va_arg(ap, struct ffsw *);
if (narg >= 6)
cblks = va_arg(ap, int);
va_end(ap);
aifound = _assign_asgcmd_info(name, -1, ASN_G_FF | ASN_G_ALL, &ai,
NULL, 1);
if (aifound == -1) {
ERETURN(pstat, errno, 0);
}
if (aifound == 1 && ai.F_filter_flg)
fdspec = &ai.F_filter[0];
else
fdspec = NULL;
(void) memset(&gloinf, 0, sizeof(gloinf));
gloinf.aip = aifound ? &ai : NULL;
fd = _ffopen(name, flags, mode, fdspec, pstat, cbits, cblks, NULL,
&gloinf);
#if defined(_CRAY1) || defined(__mips)
if (fd != _FFOPEN_ERR && MULTI_ON) {
nfio = NULL;
if (_ff_top_lock(fd, &nfio, pstat) < 0)
fd = _FFOPEN_ERR;
if (nfio != NULL)
fd = (_ffopen_t)nfio;
}
#endif
/*
* ffopen returns an int. Call a routine which associates an
* int with what is returned by _ffopen
*/
#if defined(__mips) || defined(_LITTLE_ENDIAN)
retfd = _ff_fdinfo_to_int(fd, pstat);
#else
retfd = (int)fd;
#endif
/* should check chain of layers here for sanity */
if (narg < 4)
errno = locstat.sw_error;
return(retfd);
}
