extern void
getlog_(char *name, int len)
{
char *l = getlogin();
b_char(l?l:" ", name, len);
}
extern void
getlog_(char *name, int len)
#endif /* KEY Bug 1683 */
{
char *l = getlogin();
b_char(l?l:" ", name, len);
}
void
pathf90_getlog(char *name, int len)
{
char *l = alloca(len + 1);
#ifdef __sun
char *res = getlogin_r(l, len + 1);
int err = res == NULL;
#else
int err = getlogin_r(l, len + 1);
#endif
b_char((err == 0) ?l:" ", name, len);
}
extern int
gethostname_ (char *name, int *len, int ftnlen)
{
char buf[64];
int blen = sizeof buf;
if (gethostname (buf, blen) == 0)
{
b_char (buf, name, *len);
return (0);
}
else
return(-1);
}
pathf90_i4
pathf90_getcwd(char *path, pathf90_i4 *status, int len)
{
char *p;
char pathname[MAXPATHLEN];
pathf90_i4 junk;
status = (0 == status) ? (&junk) : status;
/*
* Bug 3349: ensure that getcwd is used.
* Never use getwd as fallback.
*/
p = getcwd(pathname, sizeof(pathname));
b_char(pathname, path, len);
if (p)
return(*status = 0);
else
return(*status = errno);
}
extern long
getcwd_(char *path, int len)
{
char *p;
char pathname[MAXPATHLEN];
#ifdef KEY
/* Bug 3349: Modern Unix should have 2-arg getcwd; if the target OS is
* unexpected, the code should fail instead of silently compiling with
* neither getwd nor getcwd .
*/
# ifdef __linux
p = getcwd(pathname,MAXPATHLEN);
# else
# error "Check function getwd/getcwd signature"
# endif
#else
#ifdef _BSD
extern char *getwd(); /* sjc #nit 27Jan88 */
p = getwd(pathname);
#endif /* _BSD */
#if defined(_SYSV) || defined(_SYSTYPE_SVR4)
p = getcwd(pathname,MAXPATHLEN); /* AGC #710 2/17/87 */
#endif /* _SYSV */
#endif /* KEY */
b_char(pathname, path, len);
#ifdef __sgi
return((long)p);
#else
if (p)
return(0);
else
return(errno);
#endif
}
pathf90_i4
pathf90_getcwd(char *path, pathf90_i4 *status, int len)
{
char *p;
char pathname[MAXPATHLEN];
pathf90_i4 junk;
status = (0 == status) ? (&junk) : status;
/* Bug 3349: Modern Unix should have 2-arg getcwd; if the target OS is
* unexpected, the code should fail instead of silently compiling with
* neither getwd nor getcwd .
*/
# if defined(__linux) || defined(BUILD_OS_DARWIN)
p = getcwd(pathname,MAXPATHLEN);
# else
# error "Check function getwd/getcwd signature"
# endif
b_char(pathname, path, len);
if (p)
return(*status = 0);
else
return(*status = errno);
}
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);
}
l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
#endif
{
#define Ptr ((flex *)ptr)
int i,n,ch;
doublereal *yy;
real *xx;
for(i=0;i<*number;i++)
{
if(f__lquit) return(0);
if(l_eof)
err(f__elist->ciend, EOF, "list in")
if(f__lcount == 0) {
f__ltype = 0;
for(;;) {
GETC(ch);
switch(ch) {
case EOF:
err(f__elist->ciend,(EOF),"list in")
case ' ':
case '\t':
case '\n':
continue;
case '/':
f__lquit = 1;
goto loopend;
case ',':
f__lcount = 1;
goto loopend;
default:
(void) Ungetc(ch, f__cf);
goto rddata;
}
}
}
rddata:
switch((int)type)
{
case TYINT1:
case TYSHORT:
case TYLONG:
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
ERR(l_R(0,1));
break;
#endif
case TYREAL:
case TYDREAL:
ERR(l_R(0,0));
break;
#ifdef TYQUAD
case TYQUAD:
n = l_R(0,2);
if (n)
return n;
break;
#endif
case TYCOMPLEX:
case TYDCOMPLEX:
ERR(l_C());
break;
case TYLOGICAL1:
case TYLOGICAL2:
case TYLOGICAL:
ERR(l_L());
break;
case TYCHAR:
ERR(l_CHAR());
break;
}
while (GETC(ch) == ' ' || ch == '\t');
if (ch != ',' || f__lcount > 1)
Ungetc(ch,f__cf);
loopend:
if(f__lquit) return(0);
if(f__cf && ferror(f__cf)) {
clearerr(f__cf);
errfl(f__elist->cierr,errno,"list in");
}
if(f__ltype==0) goto bump;
switch((int)type)
{
case TYINT1:
case TYLOGICAL1:
Ptr->flchar = (char)f__lx;
break;
case TYLOGICAL2:
case TYSHORT:
Ptr->flshort = (short)f__lx;
break;
case TYLOGICAL:
case TYLONG:
Ptr->flint = (ftnint)f__lx;
break;
#ifdef Allow_TYQUAD
case TYQUAD:
if (!(Ptr->fllongint = f__llx))
Ptr->fllongint = f__lx;
break;
#endif
case TYREAL:
Ptr->flreal=f__lx;
break;
case TYDREAL:
Ptr->fldouble=f__lx;
break;
case TYCOMPLEX:
xx=(real *)ptr;
*xx++ = f__lx;
*xx = f__ly;
break;
case TYDCOMPLEX:
yy=(doublereal *)ptr;
*yy++ = f__lx;
*yy = f__ly;
break;
case TYCHAR:
b_char(f__lchar,ptr,len);
break;
}
bump:
if(f__lcount>0) f__lcount--;
ptr += len;
if (nml_read)
nml_read++;
}
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);
}
static int
l_read(ftnint *number,flex *ptr,ftnlen len,ftnint type)
{ int i,n,ch;
double *yy;
float *xx;
for(i=0;i<*number;i++)
{
if(curunit->uend) err(elist->ciend, EOF, "list in")
if(l_first)
{ l_first=0;
for(GETC(ch);isblnk(ch);GETC(ch));
ungetc(ch,cf);
}
else if(lcount==0)
{ ERR(t_sep());
if(lquit) return(0);
}
switch((int)type)
{
case TYSHORT:
case TYLONG:
case TYREAL:
case TYDREAL:
ERR(l_R());
break;
case TYCOMPLEX:
case TYDCOMPLEX:
ERR(l_C());
break;
case TYLOGICAL:
ERR(l_L());
break;
case TYCHAR:
ERR(l_CHAR());
break;
}
if(lquit) return(0);
if(feof(cf)) err(elist->ciend,(EOF),"list in")
else if(ferror(cf))
{ clearerr(cf);
err(elist->cierr,errno,"list in")
}
if(ltype==0) goto bump;
switch((int)type)
{
case TYSHORT:
ptr->flshort=lx;
break;
case TYLOGICAL:
case TYLONG:
ptr->flint=lx;
break;
case TYREAL:
ptr->flreal=lx;
break;
case TYDREAL:
ptr->fldouble=lx;
break;
case TYCOMPLEX:
xx=(float *)ptr;
*xx++ = lx;
*xx = ly;
break;
case TYDCOMPLEX:
yy=(double *)ptr;
*yy++ = lx;
*yy = ly;
break;
case TYCHAR:
b_char(lchar,(char *)ptr,len);
break;
}
bump:
if(lcount>0) lcount--;
ptr = (flex *)((char *)ptr + len);
}
return(0);
}
