Пример #1
0
extern void
getlog_(char *name, int len)
{
	char *l = getlogin();

	b_char(l?l:" ", name, len);
}
Пример #2
0
extern void
getlog_(char *name, int len)

#endif /* KEY Bug 1683 */
{
	char *l = getlogin();

	b_char(l?l:" ", name, len);
}
Пример #3
0
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);
}
Пример #4
0
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);
}
Пример #5
0
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);
}
Пример #6
0
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
}
Пример #7
0
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);
}
Пример #8
0
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);
}
Пример #9
0
Файл: lread.c Проект: cran/rioja
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++;
	}
Пример #10
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);
}
Пример #11
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);
}
Пример #12
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);
}