4.4BSD/usr/src/old/lisp/franz/fex4.c
#ifndef lint
static char *rcsid =
"$Header: fex4.c,v 1.5 85/03/13 17:19:04 sklower Exp $";
#endif
/* -[Sat Jan 29 12:40:56 1983 by jkf]-
* fex4.c $Locker: $
* nlambda functions
*
* (c) copyright 1982, Regents of the University of California
*/
#include "global.h"
#include "lfuncs.h"
#include "chkrtab.h"
#include <signal.h>
#include <sys/types.h>
#if (os_4_2 || os_4_3)
#include <sys/time.h>
#else
#include <time.h>
#endif
/* this is now a lambda function instead of a nlambda.
the only reason that it wasn't a lambda to begin with is that
the person who wrote it didn't know how to write a lexpr
- jkf
*/
lispval
Lsyscall() {
register lispval temp;
register struct argent *aptr;
register int acount = 1;
extern syscall();
int args[50];
Savestack(3);
/* there must be at least one argument */
if (np==lbot) { chkarg(1,"syscall"); }
aptr = lbot;
temp = lbot->val;
if (TYPE(temp) != INT) {
Restorestack();
return(error("syscall: bad first argument ", FALSE));
}
args[acount++] = temp->i;
while( ++aptr < np && acount < 48) {
temp = aptr->val;
switch(TYPE(temp)) {
case ATOM:
args[acount++] = (int)temp->a.pname;
break;
case STRNG:
args[acount++] = (int) temp;
break;
case INT:
args[acount++] = (int)temp->i;
break;
default:
Restorestack();
return(error("syscall: arg not symbol, string or fixnum", FALSE));
}
}
Restorestack();
args[0] = acount - 1;
return(inewint(callg_(syscall,args)));
}
/* eval-when: this has the form (eval-when <list> <form1> <form2> ...)
where the list may contain any combination of `eval', `load', `compile'.
The interpreter (us) looks for the atom `eval', if it is present
we treat the rest of the forms as a progn.
*/
lispval
Nevwhen()
{
register lispval handy;
register lispval handy2;
Savestack(2);
for (handy=(lbot->val)->d.car ; handy != nil ; handy = handy->d.cdr) {
if (handy->d.car == (lispval) Veval) {
lbot=np;
protect(((lbot-1)->val)->d.cdr);
handy2 = Nprogn();
Restorestack();
return(handy2);
}
}
Restorestack();
return(nil); /* eval not seen */
}
/* Status functions.
* These operate on the statuslist stlist which has the form:
* ( status_elem_1 status_elem_2 status_elem_3 ...)
* where each status element has the form:
* ( name readcode setcode . readvalue)
* where
* name - name of the status feature (the first arg to the status
* function).
* readcode - fixnum which tells status how to read the value of
* this status name. The codes are #defined.
* setcode - fixnum which tells sstatus how to set the value of
* this status name
* readvalue - the value of the status feature is usually stored
* here.
*
* Readcodes:
*
* ST_READ - if no second arg, return readvalue.
* if the second arg is given, we return t if it is eq to
* the readvalue.
* ST_FEATR - used in (status feature xxx) where we test for xxx being
* in the status features list
* ST_SYNT - used in (status syntax c) where we return c's syntax code
* ST_INTB - read stattab entry
* ST_NFETR - used in (status nofeature xxx) where we test for xxx not
* being in the status features list
* ST_DMPR - read the dumpmode
* ST_UNDEF - return the undefined functions in the transfer table
*
* Setcodes:
* ST_NO - if not allowed to set this status through sstatus.
* ST_SET - if the second arg is made the readvalue.
* ST_FEATW - for (sstatus feature xxx), we add xxx to the
* (status features) list.
* ST_TOLC - if non nil, map upper case chars in atoms to lc.
* ST_CORE - if non nil, have bus errors and segmentation violations
* dump core, if nil have them produce a bad-mem err msg
* ST_INTB - set stattab table entry
* ST_NFETW - use in (sstatus nofeature xxx) where we wish to remove xxx
* from the status feature list.
* ST_DMPW - set the dumpmode
* ST_BCDTR - (ifdef RSET) if non nil, creat trace stack entries for
* calls from BCD functions to BCD functions
* ST_GCSTR - (ifdef GCSTRINGS) garbage collect strings
*/
lispval
Nstatus()
{
register lispval handy,curitm,valarg;
int indx,ctim;
int typ;
char *cp;
char *ctime();
struct tm *lctime,*localtime();
extern unsigned char *ctable;
extern int dmpmode;
extern lispval chktt();
lispval Istsrch();
Savestack(3);
if(lbot->val == nil) return(nil);
handy = lbot->val; /* arg list */
while(TYPE(handy) != DTPR) handy = error("status: bad arg list",TRUE);
curitm = Istsrch(handy->d.car); /* look for feature */
if( curitm == nil ) return(nil); /* non existant */
if( handy->d.cdr == nil ) valarg = (lispval) CNIL;
else valarg = handy->d.cdr->d.car;
/* now do the processing with curitm pointing to the requested
item in the status list
*/
switch( typ = curitm->d.cdr->d.car->i ) { /* look at readcode */
case ST_READ:
curitm = Istsrch(handy->d.car); /* look for name */
if(curitm == nil) return(nil);
if( valarg != (lispval) CNIL)
error("status: Second arg not allowed.",FALSE);
else return(curitm->d.cdr->d.cdr->d.cdr);
case ST_NFETR: /* look for feature present */
case ST_FEATR: /* look for feature */
curitm = Istsrch(matom("features"));
if( valarg == (lispval) CNIL)
error("status: need second arg",FALSE);
for( handy = curitm->d.cdr->d.cdr->d.cdr;
handy != nil;
handy = handy->d.cdr)
if(handy->d.car == valarg)
return(typ == ST_FEATR ? tatom : nil);
return(typ == ST_FEATR ? nil : tatom);
case ST_SYNT: /* want character syntax */
handy = Vreadtable->a.clb;
chkrtab(handy);
if( valarg == (lispval) CNIL)
error("status: need second arg",FALSE);
while (TYPE(valarg) != ATOM)
valarg = error("status: second arg must be atom",TRUE);
indx = valarg->a.pname[0]; /* get first char */
if(valarg->a.pname[1] != '\0')
error("status: only one character atom allowed",FALSE);
handy = inewint((long) ctable[indx]);
return(handy);
case ST_RINTB:
return(stattab[curitm->d.cdr->d.cdr->d.cdr->i]);
case ST_DMPR:
return(inewint(dmpmode));
case ST_CTIM:
ctim = time((time_t *)0);
cp = ctime(&ctim);
cp[24] = '\0';
return(matom(cp));
case ST_LOCT:
ctim = time((time_t *)0);
lctime = localtime(&ctim);
(handy = newdot())->d.car = inewint(lctime->tm_sec);
protect(handy);
handy->d.cdr = (valarg = newdot());
valarg->d.car = inewint(lctime->tm_min);
valarg->d.cdr = (curitm = newdot());
curitm->d.car = inewint(lctime->tm_hour);
curitm->d.cdr = (valarg = newdot());
valarg->d.car = inewint(lctime->tm_mday);
valarg->d.cdr = (curitm = newdot());
curitm->d.car = inewint(lctime->tm_mon);
curitm->d.cdr = (valarg = newdot());
valarg->d.car = inewint(lctime->tm_year);
valarg->d.cdr = (curitm = newdot());
curitm->d.car = inewint(lctime->tm_wday);
curitm->d.cdr = (valarg = newdot());
valarg->d.car = inewint(lctime->tm_yday);
valarg->d.cdr = (curitm = newdot());
curitm->d.car = inewint(lctime->tm_isdst);
Restorestack();
return(handy);
case ST_ISTTY:
return( (isatty(0) == TRUE ? tatom : nil));
case ST_UNDEF:
return(chktt());
}
error("Internal error in status: Couldn't figure out request",FALSE);
/* NOTREACHED */
}
lispval
Nsstatus()
{
register lispval handy;
lispval Isstatus();
handy = lbot->val;
while( TYPE(handy) != DTPR || TYPE(handy->d.cdr) != DTPR)
handy = error("sstatus: Bad args",TRUE);
return(Isstatus(handy->d.car,handy->d.cdr->d.car));
}
/* Isstatus - internal routine to do a set status. */
lispval
Isstatus(curnam,curval)
lispval curnam,curval;
{
register lispval curitm,head;
lispval Istsrch(),Iaddstat();
int badmr(),clrtt();
extern int uctolc, dmpmode, bcdtrsw, gcstrings;
curitm = Istsrch(curnam);
/* if doesnt exist, make one up */
if(curitm == nil) curitm = Iaddstat(curnam,ST_READ,ST_SET,nil);
switch (curitm->d.cdr->d.cdr->d.car->i) {
case ST_NO: error("sstatus: cannot set this status",FALSE);
case ST_SET: goto setit;
case ST_FEATW: curitm = Istsrch(matom("features"));
(curnam = newdot())->d.car = curval;
curnam->d.cdr = curitm->d.cdr->d.cdr->d.cdr; /* old val */
curitm->d.cdr->d.cdr->d.cdr = curnam;
return(curval);
case ST_NFETW: /* remove from features list */
curitm = Istsrch(matom("features"))->d.cdr->d.cdr;
for(head = curitm->d.cdr; head != nil; head = head->d.cdr)
{
if(head->d.car == curval) curitm->d.cdr = head->d.cdr;
else curitm = head;
}
return(nil);
case ST_TOLC: if(curval == nil) uctolc = FALSE;
else uctolc = TRUE;
goto setit;
case ST_CORE: if(curval == nil)
{
signal(SIGBUS,badmr); /* catch bus errors */
signal(SIGSEGV,badmr); /* and segmentation viols */
}
else {
signal(SIGBUS,SIG_DFL); /* let them core dump */
signal(SIGSEGV,SIG_DFL);
}
goto setit;
case ST_INTB:
stattab[curitm->d.cdr->d.cdr->d.cdr->i] = curval;
return(curval);
case ST_DMPW:
if(TYPE(curval) != INT ||
(curval->i != 413 &&
curval->i != 407 &&
curval->i != 410)) errorh1(Vermisc,"sstatus: bad dump mode:",
nil,FALSE,0,curval);
dmpmode= curval->i;
return(curval);
case ST_AUTR:
if(curval != nil) Sautor = (lispval) TRUE;
else Sautor = FALSE;
goto setit;
case ST_TRAN:
if(curval != nil)
{
Strans = (lispval) TRUE;
/* the atom `on' set to set up all table
* to their bcd fcn if possible
*/
if(curval == matom("on")) clrtt(1);
}
else {
Strans = (lispval) FALSE;
clrtt(0); /* clear all transfer tables */
}
goto setit;
case ST_BCDTR:
if(curval == nil) bcdtrsw = FALSE;
else bcdtrsw = TRUE;
goto setit;
case ST_GCSTR:
if(curval == nil) gcstrings = FALSE;
else gcstrings = TRUE;
goto setit;
}
setit: /* store value in status list */
curitm->d.cdr->d.cdr->d.cdr = curval;
return(curval);
}
/* Istsrch - utility routine to search the status list for the
name given as an argument. If such an entry is not found,
we return nil
*/
lispval Istsrch(nam)
lispval nam;
{
register lispval handy;
for(handy = stlist ; handy != nil ; handy = handy->d.cdr)
if(handy->d.car->d.car == nam) return(handy->d.car);
return(nil);
}
/* Iaddstat - add a status entry to the status list */
/* return new entry in status list */
lispval
Iaddstat(name,readcode,setcode,valu)
lispval name,valu;
int readcode,setcode;
{
register lispval handy,handy2;
Savestack(2);
protect(handy=newdot()); /* build status list here */
(handy2 = newdot())->d.car = name;
handy->d.car = handy2;
((handy2->d.cdr = newdot())->d.car = newint())->i = readcode;
handy2 = handy2->d.cdr;
((handy2->d.cdr = newdot())->d.car = newint())->i = setcode;
handy2->d.cdr->d.cdr = valu;
/* link this one in */
handy->d.cdr = stlist;
stlist = handy;
Restorestack();
return(handy->d.car); /* return new item in stlist */
}