integer
G77_link_0 (const char *path1, const char *path2, const ftnlen Lpath1,
const ftnlen Lpath2)
{
#if defined (HAVE_LINK)
char *buff1, *buff2;
int i;
buff1 = malloc (Lpath1 + 1);
if (buff1 == NULL)
return -1;
g_char (path1, Lpath1, buff1);
buff2 = malloc (Lpath2 + 1);
if (buff2 == NULL)
return -1;
g_char (path2, Lpath2, buff2);
i = link (buff1, buff2);
free (buff1);
free (buff2);
return i ? errno : 0;
#else /* ! HAVE_LINK */
errno = ENOSYS;
return -1;
#endif
}
integer
G77_rename_0 (const char *path1, const char *path2, const ftnlen Lpath1,
const ftnlen Lpath2)
{
char *buff1, *buff2;
int i;
buff1 = malloc (Lpath1 + 1);
if (buff1 == NULL)
return -1;
g_char (path1, Lpath1, buff1);
buff2 = malloc (Lpath2 + 1);
if (buff2 == NULL)
return -1;
g_char (path2, Lpath2, buff2);
i = rename (buff1, buff2);
free (buff1);
free (buff2);
return i ? errno : 0;
}
int32
unlink_(char *fname, int32 namlen)
{
if (!bufarg && !(bufarg=malloc(bufarglen=namlen+1)))
return((errno=F_ERSPACE));
else if (bufarglen <= namlen && !(bufarg=realloc(bufarg, bufarglen=namlen+1)))
return((int32)(errno=F_ERSPACE));
g_char(fname, namlen, bufarg);
return( (int32) unlink(bufarg) );
}
static void
opn_err (int m, char *s, olist * a)
{
if (a->ofnm)
{
/* supply file name to error message */
if (a->ofnmlen >= f__buflen)
f__bufadj ((int) a->ofnmlen, 0);
g_char (a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf);
}
f__fatal (m, s);
}
integer G77_unlink_0 (const char *str, const ftnlen Lstr)
#endif
{
char *buff;
char *bp, *blast;
int i;
buff = malloc (Lstr+1);
if (buff == NULL) return -1;
g_char (str, Lstr, buff);
i = unlink (buff);
free (buff);
return i ? errno : 0; /* SGI version returns -1 on failure. */
}
pathf90_i4
pathf90_chmod(char *name, char *mode, pathf90_i4 *status, int namlen,
int modlen)
{
pathf90_i4 junk;
char *modbuf;
__int32_t retcode;
status = (0 == status) ? (&junk) : status;
if (!bufarg && !(bufarg=malloc(bufarglen=namlen+modlen+2)))
return(*status = errno=F_ERSPACE);
else if (bufarglen <= namlen+modlen+1 && !(bufarg=realloc(bufarg, bufarglen=namlen+modlen+2)))
return(*status = errno=F_ERSPACE);
modbuf = &bufarg[namlen+1];
g_char(name, namlen, bufarg);
g_char(mode, modlen, modbuf);
if (bufarg[0] == '\0')
return(*status = errno=ENOENT);
if (modbuf[0] == '\0')
return(*status = errno=F_ERARG);
if (fork())
{
if (wait(&retcode) == -1)
return(*status = errno);
return(*status = retcode);
}
else
/* child */
#ifdef KEY /* Bug 1683 */
/* make error messages vanish if possible, since
* we'll use return status to tell caller about errors
*/
dup2(open("/dev/null", O_WRONLY, 0666), 2);
#endif /* KEY Bug 1683 */
execl("/bin/chmod", "chmod", modbuf, bufarg, (char *)0);
/* NOTREACHED */
}
pathf90_i4
pathf90_chdir(char *dname, pathf90_i4 *status, int dnamlen)
{
pathf90_i4 junk;
status = (0 == status) ? &junk : status;
if (!bufarg && !(bufarg=malloc(bufarglen=dnamlen+1)))
return((*status = errno=F_ERSPACE));
else if (bufarglen <= dnamlen && !(bufarg=realloc(bufarg, bufarglen=dnamlen+1)))
return(*status = (errno=F_ERSPACE));
g_char(dname, dnamlen, bufarg);
if (chdir(bufarg) != 0) {
return(*status = errno);
}
return(*status = 0);
}
pathf90_i4
pathf90_unlink(char *fname, pathf90_i4 *status, int namlen)
{
pathf90_i4 junk;
status = (0 == status) ? (&junk) : status;
if (!bufarg && !(bufarg=malloc(bufarglen=namlen+1)))
return(*status = (errno=F_ERSPACE));
else if (bufarglen <= namlen && !(bufarg=realloc(bufarg, bufarglen=namlen+1)))
return(*status = (errno=F_ERSPACE));
g_char(fname, namlen, bufarg);
if (0 != unlink(bufarg)) {
return *status = errno;
}
return *status = 0;
}
integer
G77_lstat_0 (const char *name, integer statb[13], const ftnlen Lname)
{
#if HAVE_LSTAT
char *buff;
int err;
struct stat buf;
buff = malloc (Lname + 1);
if (buff == NULL)
return -1;
g_char (name, Lname, buff);
err = lstat (buff, &buf);
free (buff);
statb[0] = buf.st_dev;
statb[1] = buf.st_ino;
statb[2] = buf.st_mode;
statb[3] = buf.st_nlink;
statb[4] = buf.st_uid;
statb[5] = buf.st_gid;
#if HAVE_ST_RDEV
statb[6] = buf.st_rdev;
#else
statb[6] = 0;
#endif
statb[7] = buf.st_size;
statb[8] = buf.st_atime;
statb[9] = buf.st_mtime;
statb[10] = buf.st_ctime;
#if HAVE_ST_BLKSIZE
statb[11] = buf.st_blksize;
#else
statb[11] = -1;
#endif
#if HAVE_ST_BLOCKS
statb[12] = buf.st_blocks;
#else
statb[12] = -1;
#endif
return err;
#else /* !HAVE_LSTAT */
return errno = ENOSYS;
#endif /* !HAVE_LSTAT */
}
integer G77_stat_0 (const char *name, integer statb[13], const ftnlen Lname)
#endif
{
char *buff;
char *bp, *blast;
int err;
struct stat buf;
buff = malloc (Lname+1);
if (buff == NULL) return -1;
g_char (name, Lname, buff);
err = stat (buff, &buf);
free (buff);
statb[0] = buf.st_dev;
statb[1] = buf.st_ino;
statb[2] = buf.st_mode;
statb[3] = buf.st_nlink;
statb[4] = buf.st_uid;
statb[5] = buf.st_gid;
#if HAVE_ST_RDEV
statb[6] = buf.st_rdev; /* not posix */
#else
statb[6] = 0;
#endif
statb[7] = buf.st_size;
statb[8] = buf.st_atime;
statb[9] = buf.st_mtime;
statb[10] = buf.st_ctime;
#if HAVE_ST_BLKSIZE
statb[11] = buf.st_blksize; /* not posix */
#else
statb[11] = -1;
#endif
#if HAVE_ST_BLOCKS
statb[12] = buf.st_blocks; /* not posix */
#else
statb[12] = -1;
#endif
return err;
}
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);
}
integer f_inqu(inlist *a)
#endif
{ flag byfile;
int i, n;
unit *p;
char buf[256];
long x;
if(a->infile!=NULL)
{ byfile=1;
g_char(a->infile,a->infilen,buf);
#ifdef NON_UNIX_STDIO
x = access(buf,0) ? -1 : 0;
for(i=0,p=NULL;i<MXUNIT;i++)
if(f__units[i].ufd != NULL
&& f__units[i].ufnm != NULL
&& !strcmp(f__units[i].ufnm,buf)) {
p = &f__units[i];
break;
}
#else
x=f__inode(buf, &n);
for(i=0,p=NULL;i<MXUNIT;i++)
if(f__units[i].uinode==x
&& f__units[i].ufd!=NULL
&& f__units[i].udev == n) {
p = &f__units[i];
break;
}
#endif
}
else
{
byfile=0;
if(a->inunit<MXUNIT && a->inunit>=0)
{
p= &f__units[a->inunit];
}
else
{
p=NULL;
}
}
if(a->inex!=NULL)
if(byfile && x != -1 || !byfile && p!=NULL)
*a->inex=1;
else *a->inex=0;
if(a->inopen!=NULL)
if(byfile) *a->inopen=(p!=NULL);
else *a->inopen=(p!=NULL && p->ufd!=NULL);
if(a->innum!=NULL) *a->innum= p-f__units;
if(a->innamed!=NULL)
if(byfile || p!=NULL && p->ufnm!=NULL)
*a->innamed=1;
else *a->innamed=0;
if(a->inname!=NULL)
if(byfile)
b_char(buf,a->inname,a->innamlen);
else if(p!=NULL && p->ufnm!=NULL)
b_char(p->ufnm,a->inname,a->innamlen);
if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL)
if(p->url)
b_char("DIRECT",a->inacc,a->inacclen);
else b_char("SEQUENTIAL",a->inacc,a->inacclen);
if(a->inseq!=NULL)
if(p!=NULL && p->url)
b_char("NO",a->inseq,a->inseqlen);
else b_char("YES",a->inseq,a->inseqlen);
if(a->indir!=NULL)
if(p==NULL || p->url)
b_char("YES",a->indir,a->indirlen);
else b_char("NO",a->indir,a->indirlen);
if(a->infmt!=NULL)
if(p!=NULL && p->ufmt==0)
b_char("UNFORMATTED",a->infmt,a->infmtlen);
else b_char("FORMATTED",a->infmt,a->infmtlen);
if(a->inform!=NULL)
if(p!=NULL && p->ufmt==0)
b_char("NO",a->inform,a->informlen);
else b_char("YES",a->inform,a->informlen);
if(a->inunf)
if(p!=NULL && p->ufmt==0)
b_char("YES",a->inunf,a->inunflen);
else if (p!=NULL) b_char("NO",a->inunf,a->inunflen);
else b_char("UNKNOWN",a->inunf,a->inunflen);
if(a->inrecl!=NULL && p!=NULL)
*a->inrecl=p->url;
if(a->innrec!=NULL && p!=NULL && p->url>0)
*a->innrec=ftell(p->ufd)/p->url+1;
if(a->inblank && p!=NULL && p->ufmt)
if(p->ublnk)
b_char("ZERO",a->inblank,a->inblanklen);
else b_char("NULL",a->inblank,a->inblanklen);
return(0);
}
int
f_inqu(inlist *a)
{
flag byfile,legal;
int i;
unit *p;
char buf[256];
long x;
x = 0; /* XXX - check correctness */
if(a->infile!=NULL) {
byfile=1;
g_char(a->infile,a->infilen,buf);
x=inode(buf);
for(i=0,p=NULL;i<MXUNIT;i++)
if(units[i].uinode==x && units[i].ufd!=NULL)
p = &units[i];
} else {
byfile=0;
if(a->inunit<MXUNIT && a->inunit>=0) {
legal=1;
p= &units[a->inunit];
} else {
legal=0;
p=NULL;
}
}
if(a->inex!=NULL) {
if((byfile && x>0) || (!byfile && p!=NULL))
*a->inex=1;
else *a->inex=0;
}
if(a->inopen!=NULL) {
if(byfile) *a->inopen=(p!=NULL);
else *a->inopen=(p!=NULL && p->ufd!=NULL);
}
if(a->innum!=NULL) *a->innum= p-units;
if(a->innamed!=NULL) {
if(byfile || (p!=NULL && p->ufnm!=NULL))
*a->innamed=1;
else *a->innamed=0;
}
if(a->inname!=NULL) {
if(byfile)
b_char(buf,a->inname,a->innamlen);
else if(p!=NULL && p->ufnm!=NULL)
b_char(p->ufnm,a->inname,a->innamlen);
}
if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) {
if(p->url)
b_char("direct",a->inacc,a->inacclen);
else b_char("sequential",a->inacc,a->inacclen);
}
if(a->inseq!=NULL) {
if(byfile || (p!=NULL && p->useek))
b_char("yes",a->inseq,a->inseqlen);
else b_char("no",a->inseq,a->inseqlen);
}
if(a->indir!=NULL) {
if(byfile || (p!=NULL && p->useek))
b_char("yes",a->indir,a->indirlen);
else b_char("no",a->indir,a->indirlen);
}
if(a->infmt!=NULL) {
if(p!=NULL && p->ufmt)
b_char("formatted",a->infmt,a->infmtlen);
else if(p!=NULL)
b_char("unformatted",a->infmt,a->infmtlen);
}
if(a->inform!=NULL)
b_char("yes",a->inform,a->informlen);
if(a->inunf) {
if(byfile || (p!=NULL && p->useek))
b_char("yes",a->inunf,a->inunflen);
else b_char("unknown",a->inunf,a->inunflen);
}
if(a->inrecl!=NULL && p!=NULL)
*a->inrecl=p->url;
if(a->innrec!=NULL && p!=NULL && p->url>0)
*a->innrec=ftell(p->ufd)/p->url+1;
if(a->inblank && p!=NULL && p->ufmt) {
if(p->ublnk)
b_char("zero",a->inblank,a->inblanklen);
else b_char("blank",a->inblank,a->inblanklen);
}
return(0);
}
integer
f_open (olist * a)
{
unit *b;
integer rv;
char buf[256], *s, *env;
cllist x;
int ufmt;
FILE *tf;
int fd, len;
#ifndef NON_UNIX_STDIO
int n;
#endif
if (f__init != 1)
f_init ();
f__external = 1;
if (a->ounit >= MXUNIT || a->ounit < 0)
err (a->oerr, 101, "open");
f__curunit = b = &f__units[a->ounit];
if (b->ufd)
{
if (a->ofnm == 0)
{
same:if (a->oblnk)
b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z';
return (0);
}
#ifdef NON_UNIX_STDIO
if (b->ufnm
&& strlen (b->ufnm) == a->ofnmlen
&& !strncmp (b->ufnm, a->ofnm, (unsigned) a->ofnmlen))
goto same;
#else
g_char (a->ofnm, a->ofnmlen, buf);
if (f__inode (buf, &n) == b->uinode && n == b->udev)
goto same;
#endif
x.cunit = a->ounit;
x.csta = 0;
x.cerr = a->oerr;
if ((rv = f_clos (&x)) != 0)
return rv;
}
b->url = (int) a->orl;
b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z');
if (a->ofm == 0)
if ((a->oacc) && (*a->oacc == 'D' || *a->oacc == 'd'))
b->ufmt = 0;
else
b->ufmt = 1;
else if (*a->ofm == 'f' || *a->ofm == 'F')
b->ufmt = 1;
else
b->ufmt = 0;
ufmt = b->ufmt;
#ifdef url_Adjust
if (b->url && !ufmt)
url_Adjust (b->url);
#endif
if (a->ofnm)
{
g_char (a->ofnm, a->ofnmlen, buf);
if (!buf[0])
opnerr (a->oerr, 107, "open");
}
else
sprintf (buf, "fort.%ld", (long) a->ounit);
b->uscrtch = 0;
b->uend = 0;
b->uwrt = 0;
b->ufd = 0;
b->urw = 3;
switch (a->osta ? *a->osta : 'u')
{
case 'o':
case 'O':
#ifdef NON_POSIX_STDIO
if (!(tf = fopen (buf, "r")))
opnerr (a->oerr, errno, "open");
fclose (tf);
#else
if (access (buf, 0))
opnerr (a->oerr, errno, "open");
#endif
break;
case 's':
case 'S':
b->uscrtch = 1;
#ifdef HAVE_MKSTEMP /* Allow use of TMPDIR preferentially. */
env = getenv ("TMPDIR");
if (!env)
env = getenv ("TEMP");
if (!env)
env = "/tmp";
len = strlen (env);
if (len > 256 - (int) sizeof ("/tmp.FXXXXXX"))
err (a->oerr, 132, "open");
strcpy (buf, env);
strcat (buf, "/tmp.FXXXXXX");
fd = mkstemp (buf);
if (fd == -1 || close (fd))
err (a->oerr, 132, "open");
#else /* ! defined (HAVE_MKSTEMP) */
#ifdef HAVE_TEMPNAM /* Allow use of TMPDIR preferentially. */
s = tempnam (0, buf);
if (strlen (s) >= sizeof (buf))
err (a->oerr, 132, "open");
(void) strcpy (buf, s);
free (s);
#else /* ! defined (HAVE_TEMPNAM) */
#ifdef HAVE_TMPNAM
tmpnam (buf);
#else
(void) strcpy (buf, "tmp.FXXXXXX");
(void) mktemp (buf);
#endif
#endif /* ! defined (HAVE_TEMPNAM) */
#endif /* ! defined (HAVE_MKSTEMP) */
goto replace;
case 'n':
case 'N':
#ifdef NON_POSIX_STDIO
if ((tf = fopen (buf, "r")) || (tf = fopen (buf, "a")))
{
fclose (tf);
opnerr (a->oerr, 128, "open");
}
#else
if (!access (buf, 0))
opnerr (a->oerr, 128, "open");
#endif
/* no break */
case 'r': /* Fortran 90 replace option */
case 'R':
replace:
if ((tf = fopen (buf, f__w_mode[0])))
fclose (tf);
}
b->ufnm = (char *) malloc ((unsigned int) (strlen (buf) + 1));
if (b->ufnm == NULL)
opnerr (a->oerr, 113, "no space");
(void) strcpy (b->ufnm, buf);
if ((s = a->oacc) && b->url)
ufmt = 0;
if (!(tf = fopen (buf, f__w_mode[ufmt | 2])))
{
if ((tf = fopen (buf, f__r_mode[ufmt])))
b->urw = 1;
else if ((tf = fopen (buf, f__w_mode[ufmt])))
{
b->uwrt = 1;
b->urw = 2;
}
else
err (a->oerr, errno, "open");
}
b->useek = f__canseek (b->ufd = tf);
#ifndef NON_UNIX_STDIO
if ((b->uinode = f__inode (buf, &b->udev)) == -1)
opnerr (a->oerr, 108, "open");
#endif
if (b->useek)
{
if (a->orl)
FSEEK (b->ufd, 0, SEEK_SET);
else if ((s = a->oacc) && (*s == 'a' || *s == 'A')
&& FSEEK (b->ufd, 0, SEEK_END))
opnerr (a->oerr, 129, "open");
}
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
