f_inqu0_com (inlist *a, int *mask, int lock)
#endif
{
flag byfile;
flag sysfile = 0; /* set this flag if the file name is
* "SYS$*" */
int i;
char buf[PATH_MAX], *abuf;
int x = 0;
ino_t inod;
unit *ftnunit;
if (a->infile != NULL) {
char *flname;
flname = a->infile;
byfile = 1;
if (flname[3] == '$' && _I90_uppercase(flname, buf) &&
(!strcmp (buf, "SYS$INPUT") || !strcmp (buf, "SYS$OUTPUT")
|| !strcmp (buf, "SYS$ERROR")))
sysfile = 1;
if (a->indefaultfile) {
g_char (a->indefaultfile, a->indefaultfilelen, buf);
abuf = buf + strlen (buf);
} else
abuf = buf;
g_char (a->infile, a->infilen, abuf);
/* bug fix 12983 */
x = f77inode (buf, &inod);
if (x < 0) {
mkidxname (buf, buf);
x = f77inode (buf, &inod);
}
if (strlen (buf) > PATH_MAX) {
/* can't use err() with inquire since f77curunit is never defined
by a call to map_luno
err (a->inerr, 145, "inquire");
*/
if (a->inerr) {
return(errno=F_ERFNAME);
} else {
fprintf(stderr, "Error in INQUIRE: file name too long: %s\n", buf);
_cleanup ();
exit(F_ERFNAME);
}
}
ftnunit = NULL;
if (x < 0)
goto setvar;
for (i = 0; i < mxunit; i++) /* sjc #1963 11Dec 87 */
if (f77units[i].uinode == inod && f77units[i].uconn > 0) {
ftnunit = &f77units[i];
/*
while (lock && test_and_set( &ftnunit->lock_unit, 1L ))
;
*/
break;
}
} else {
byfile = 0;
ftnunit = map_luno (a->inunit);
/*
while (lock && test_and_set( &ftnunit->lock_unit, 1L ))
;
*/
}
setvar:
if (a->inex)
/* Fix BN 11327 .
* If the file name is SYS$* then the file always exists. The sysfile
* flag gets set above and hence when a user does and inquire with EXIST, then
* the exist variable will be set .
*
* ---ravi---1/16/92
*/
set_var (a->inex, *mask, INEX,
(byfile && x > 0 || !byfile && ftnunit != NULL || sysfile) ? 1 : 0);
if (a->inopen)
set_var (a->inopen, *mask, INOPEN, byfile ? (ftnunit != NULL) : (ftnunit && ftnunit->uconn > 0));
if (a->innum)
set_var (a->innum, *mask, INNUM, ftnunit ? ftnunit->luno : 0);
if (a->innamed)
set_var (a->innamed, *mask, INNAMED,
(byfile || ftnunit != NULL && ftnunit->ufnm != NULL) ? 1 : 0);
if (a->inname != NULL)
if (byfile)
b_char (buf, a->inname, a->innamlen);
else if (ftnunit != NULL && ftnunit->ufnm != NULL)
b_char (ftnunit->ufnm, a->inname, a->innamlen);
else
b_char ("", a->inname, a->innamlen);
if (a->inacc)
if (ftnunit && ftnunit->uconn > 0)
switch (ftnunit->uacc) {
case SEQUENTIAL:
b_char ("SEQUENTIAL", a->inacc, a->inacclen);
break;
case DIRECT:
b_char ("DIRECT", a->inacc, a->inacclen);
break;
case KEYED:
b_char ("KEYED", a->inacc, a->inacclen);
break;
default:
b_char ("UNKNOWN", a->inacc, a->inacclen);
}
else
b_char ("UNKNOWN", a->inacc, a->inacclen);
if (a->inseq != NULL)
if (ftnunit)
b_char ((ftnunit->uacc == SEQUENTIAL) ? "YES" : "NO",
a->inseq, a->inseqlen);
else
b_char ("UNKNOWN", a->inseq, a->inseqlen);
if (a->indir != NULL)
if (ftnunit)
b_char ((ftnunit->uacc == DIRECT) ? "YES" : "NO",
a->indir, a->indirlen);
else
b_char ("UNKNOWN", a->indir, a->indirlen);
if (a->infmt != NULL)
if (ftnunit)
if (!ftnunit->ufmt)
b_char ("UNFORMATTED", a->infmt, a->infmtlen);
else if (ftnunit->ufmt == 1)
b_char ("FORMATTED", a->infmt, a->infmtlen);
else
b_char ("BINARY", a->infmt, a->infmtlen);
else
b_char ("UNKNOWN", a->infmt, a->infmtlen);
if (a->inform != NULL)
if (ftnunit)
b_char (ftnunit->ufmt > 0 ? "YES" : "NO", a->inform, a->informlen);
else
b_char ("UNKNOWN", a->inform, a->informlen);
if (a->inunf)
if (ftnunit)
b_char (ftnunit->ufmt > 0 ? "NO" : "YES", a->inunf, a->inunflen);
else
b_char ("UNKNOWN", a->inunf, a->inunflen);
if (a->inrecl)
set_var (a->inrecl, *mask, INRECL,
(int) (ftnunit ? (ftnunit->ufmt || f77vms_flag_[OLD_RL] ?
ftnunit->url : ftnunit->url / sizeof (int)) : 0));
if (a->innrec) {
/* CALVIN: need to determine if a->innrec points to a *4 or a *8 */
if (ftnunit && (ftnunit->uacc == DIRECT) && (ftnunit->ufmt == 0)) {
set_var (a->innrec, *mask, INNREC,
(ftnunit && ftnunit->uacc == DIRECT && ftnunit->url) ? ftnunit->uirec + 1 : 0);
} else {
set_var (a->innrec, *mask, INNREC,
(ftnunit && ftnunit->uacc == DIRECT && ftnunit->url) ? ftell (ftnunit->ufd) / ftnunit->url + 1 : 0);
}
}
if (a->inblank)
if (ftnunit && ftnunit->ufmt > 0)
b_char (ftnunit->ublnk ? "ZERO" : "NULL", a->inblank, a->inblanklen);
else
b_char ("UNKNOWN", a->inblank, a->inblanklen);
if (a->incc)
if (ftnunit && ftnunit->ufmt > 0)
switch (ftnunit->ucc) {
case CC_FORTRAN:
b_char ("FORTRAN", a->incc, a->incclen);
break;
case CC_LIST:
b_char ("LIST", a->incc, a->incclen);
break;
case CC_NONE:
b_char ("NONE", a->incc, a->incclen);
break;
default:
b_char ("UNKNOWN", a->incc, a->incclen);
}
else
b_char ("UNKNOWN", a->incc, a->incclen);
if (a->inkeyed)
if (ftnunit)
b_char (ftnunit->uacc == KEYED ? "YES" : "NO", a->inkeyed, a->inkeyedlen);
else
b_char ("UNKNOWN", a->inkeyed, a->inkeyedlen);
if (a->inorg)
if (ftnunit)
switch (ftnunit->uacc) {
case SEQUENTIAL:
b_char ("SEQUNTIAL", a->inorg, a->inorglen);
break;
case DIRECT:
b_char ("RELATIVE", a->inorg, a->inorglen);
break;
case KEYED:
b_char ("INDEXED", a->inorg, a->inorglen);
break;
default:
b_char ("UNKNOWN", a->inorg, a->inorglen);
}
else
b_char ("UNKNOWN", a->inorg, a->inorglen);
if (a->inrecordtype)
if (ftnunit)
switch (ftnunit->uacc) {
case SEQUENTIAL:
b_char (ftnunit->ufmt == 1 ? "STREAM_LF" : "VARIABLE",
a->inrecordtype, a->inrecordtypelen);
break;
case DIRECT:
case KEYED:
b_char ("FIXED", a->inrecordtype, a->inrecordtypelen);
break;
default:
b_char ("UNKNOWN", a->inrecordtype, a->inrecordtypelen);
}
else
b_char ("UNKNOWN", a->inrecordtype, a->inrecordtypelen);
/*
if (ftnunit) {
ftnunit->lock_unit = 0;
}
*/
return (0);
}
f_open_com (olist *a, ftnint *mask, char **mode_, char **buf_, unit **fu)
#endif
{
unit *b;
ino_t inod;
int n, org;
char *mode = "r";
char *abuf, c, *cbuf, errstr[80];
char buf[PATH_MAX]; /* temp buffer */
char ubuf[PATH_MAX]; /* temp buffer */
unsigned int need;
#if 00
cllist64 x;
#else
cllist x;
#endif
struct stat sbuf;
static char seed[] = "aa";
char *q = seed;
char ch;
unit *dupunit;
int dupopen;
int istty = 0; /* Flag to indicate whether file
* being opened is /dev/tty */
/*
extern FILE *debugfile;
*/
struct stat stat_struct;
unit *ftnunit;
/* bug fix 12787 : need to initialize to zero */
/* sjc #1827: The cretin who coded this originally assumed that an
* 80-byte temporary string would always be enough. We dynamically
* allocate it to be 80 bytes plus whatever we can easily find out
* about the length of the filename being passed to us. That may
* not be enough (the string gets passed all over creation, so
* it's hard to know) but it's better than before. Note that this
* relies on f_open continuing not to be recursive. */
if (a->ofnm)
istty = !strncmp ("/dev/tty", a->ofnm, 8);
need = a->odfnm ? a->odfnmlen : 0;
need += a->ofnm ? a->ofnmlen : 0;
need += 40;
if ((*fu = ftnunit = b = map_luno (a->ounit)) == NULL)
err(a->oerr, 101, "open");
while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L )) {
sginap(0);
}
/* obtain exclusive lock for special I/O operation, this should always
be done after the lock onthe unit has been done to avoid deadlock */
while (test_and_set( &io_lock, 1L ))
sginap(0);
* buf_ = buf;
/* Fix BN 9310 . If the the terminal is being opened do not test to see if this
* file is already connected to a fortran unit since the terminal should be
* able to be connected to various fortran units simultaneously
* ---ravi---1/7/91
*/
/* From the ANSI standard: to make this clear once and for all:
** If a unit is connnected to a file that exists, execution of an OPEN
** statement for that unit is permitted. If the FILE= specifier is not
** included in the OPEN statement, the file to be connected to the unit is
** the same as the file to which the unit is connected.
** If the file to be connected to the unit does not exist, but is the
** same as the file to which the unit is preconnected, the properties
** specifies by the OPEN statement become a part of the connection.
** If the file to be connected to the unit is not the same as the
** file to which the unit is conencted, the effect is as if a CLOSE
** statement without a STATUS= specifier had been executed for the unit
** immediately to the execution of the OPEN statement.
** If the file to be connected to the unit is the same as the file
** to which the unit is connected, only the BLANK= specifier may have a
** value different from the one currently in effect. The position of
** the file is unaffected.
** If a file is connected to a unit, execution of an OPEN statement
** on that file and a different unit is not permitted
*/
if (!istty) {
if (dupopen = f_duped (a, ftnunit, &dupunit))
if (!a->oshared)
return(dupopen);
}
else
dupopen = 0;
if (a->odfnm) {
g_char (a->odfnm, a->odfnmlen, buf);
abuf = &buf[strlen(buf)];
} else
abuf = buf;
if (b->uconn > 0 && (!a->osta || up_low (*a->osta) != 's')) {
if (a->ofnm == 0) {
same:if (a->oblnk != 0)
b->ublnk = up_low (*a->oblnk) == 'z' ? 1 : 0;
/* Ignore this open statement if it is not a preconnected unit
** otherwise redefine the unit characteristics
*/
if ((b->ufd == stdin || b->ufd == stdout || b->ufd == stderr)
&& b->ufnm == NULL)
dupopen = 1;
else
return (0);
}
if (a->ofnm) {
g_char (a->ofnm, a->ofnmlen, abuf);
if (b->uacc == KEYED)
mkidxname (buf, buf);
f77inode (buf, &inod);
if ((inod == b->uinode) && inod)
goto same;
buf[a->ofnmlen] = '\0';
}
x.cunit = a->ounit;
x.csta = 0;
x.cerr = a->oerr;
/* fix bug 6084 */
/* BN-8077 */
/* Leave the stdin, stdout, stderr alone without closing them,
* since if that is done a normal file will be opened which will
* have the ufd value of stdin, stdout, or stderr and mess up all
* the conditional testing for stdin, stdout, and stderr */
if (b->ufd == stdin || b->ufd == stdout || b->ufd == stderr) {
if (!dupopen) {
b->uconn = 0;
b->ufd = NULL;
}
#if 00
#define NAMEf_clos f_clos64
#else
#define NAMEf_clos f_clos
#endif
} else if ((n = NAMEf_clos (&x)) != 0)
return (n);
b->luno = a->ounit;
#undef NAMEf_clos
}
org = a->oorg ? up_low (*a->oorg) : 0;
b->umask = *mask;
if (a->oacc == 0)
switch (org) {
case 'r':
b->uacc = DIRECT;
break;
case 'i':
if (dupopen)
err(a->oerr, 186, "open")
b->uacc = KEYED;
break;
default:
b->uacc = SEQUENTIAL;
}
else
switch (up_low (*a->oacc)) {
case 'd':
b->uacc = DIRECT;
if (org == 'i')
err(a->oerr, 149, "open")
break;
case 'k':
b->uacc = KEYED;
if (org == 's')
err(a->oerr, 150, "open")
if (org == 'r')
err(a->oerr, 151, "open")
break;
case 'a':
b->uacc = APPEND;
if (org == 'i')
err(a->oerr, 152, "open")
break;
/* Fix BN 11769
* Currently if the access parameter is not a keywords, it
* sets it to the default ,sequential. Generate error instead.
* ---ravi---2/21/92
*
case 's':
default: b->uacc = org == 'i' ? KEYED : SEQUENTIAL;
*/
case 's':
b->uacc = org == 'i' ? KEYED : SEQUENTIAL;
break;
default:
err(a->oerr, 130, "open");
}
if (a->oassocv && b->uacc == DIRECT)
set_var ((ftnintu *)(b->uassocv = a->oassocv), b->umask, ASSOCV, 1);
else
b->uassocv = NULL;
if (a->omaxrec && b->uacc == DIRECT)
b->umaxrec = a->omaxrec;
else
b->umaxrec = 0;
if (cbuf = a->odisp)
switch (up_low (*cbuf++)) {
case 'd':
b->udisp = DELETE;
break;
case 'p':
b->udisp = PRINT;
goto checkdelete;
case 's':
if (up_low (*cbuf) == 'a')
goto keep;
b->udisp = SUBMIT;
checkdelete:
while (c = (*cbuf++))
if ((c == '/') && (c = (*cbuf)) && (up_low (c) == 'd'))
b->udisp |= DELETE;
break;
keep:
default:
b->udisp = KEEP;
}
else
b->udisp = KEEP;
b->ushared = a->oshared;
b->ureadonly = a->oreadonly;
if (a->oblnk && up_low (*a->oblnk) == 'z')
b->ublnk = 1;
else
b->ublnk = 0;
#ifdef I90
b->uaction = b->ureadonly ? READONLY : READWRITE;
b->unpad = 0;
b->udelim = DELIM_NONE;
#endif
b->url = a->orl;
if (a->ofm == 0) {
if (b->uacc == DIRECT || b->uacc == KEYED) {
b->ufmt = 0;
if (!f77vms_flag_[OLD_RL])
b->url *= sizeof (int);
} else
b->ufmt = 1;
} else if (up_low (*a->ofm) == 'f')
b->ufmt = 1;
else if (up_low (*a->ofm) == 'b')
b->ufmt = 2;
else if (up_low (*a->ofm) == 's') {
/* system file = direct unformatted file with record length = 1 */
b->ufmt = 0;
b->url = 1;
b->uacc = DIRECT;
} else {
b->ufmt = 0;
if (!f77vms_flag_[OLD_RL])
b->url *= sizeof (int);
/* all sequential unformatted must need a minimum of 1K buffer to
avoid fseek() operations when reading which causes data to be
read from the disk each time and cause a 12X performance loss.
*/
check_buflen( b, 1024 );
}
if (a->orectype)
switch (up_low (*a->orectype)) {
case 'f':
if (b->uacc != DIRECT && b->uacc != KEYED)
err(a->oerr, 156, "open")
break;
case 'v':
if (b->uacc == DIRECT || b->uacc == KEYED ||
b->ufmt == 1)
err(a->oerr, 157, "open")
break;
case 's':
if (b->uacc == DIRECT || b->uacc == KEYED ||
b->ufmt != 1)
err(a->oerr, 158, "open")
default:
break;
}
if (a->occ == 0)
b->ucc = (char) (b->ufmt ? ((b->luno == 6 && f77vms_flag_[VMS_CC]) ?
CC_FORTRAN : CC_LIST) : CC_NONE);
else
switch (up_low (*a->occ)) {
case 'l':
b->ucc = CC_LIST;
break;
case 'f':
b->ucc = CC_FORTRAN;
b->ucchar = '\0';
break;
case 'n':
b->ucc = CC_NONE;
break;
default:
b->ucc = (char) (b->ufmt ? ((b->luno == 6 && f77vms_flag_[VMS_CC]) ?
CC_FORTRAN : CC_LIST) : CC_NONE);
}
if (!b->ufmt && b->ucc != CC_NONE)
err(a->oerr, 162, "open");
if (a->ofnm == 0)
#ifdef SIZEOF_LUNO_IS_64
(void) sprintf (abuf, "fort.%lld", a->ounit);
#else
(void) sprintf (abuf, "fort.%d", a->ounit);
#endif
else
