4.1cBSD/usr/src/ucb/lisp/franz/lam6.c
#ifndef lint
static char *rcsid =
"$Header: /na/franz/franz/RCS/lam6.c,v 1.1 83/01/29 13:04:34 jkf Exp $";
#endif
/* -[Sat Jan 29 13:03:13 1983 by jkf]-
* lam6.c $Locker: $
* lambda functions
*
* (c) copyright 1982, Regents of the University of California
*/
#include "global.h"
#include "frame.h"
#include <signal.h>
#include <sys/types.h>
#include <sys/times.h>
#include "chkrtab.h"
#include "chars.h"
FILE *
mkstFI(base,count,flag)
char *base;
char flag;
{
register FILE *p = stderr;
/* find free file descriptor */
for( ;(p < &_iob[_NFILE]) && p->_flag&(_IOREAD|_IOWRT);p++);
if(p >= &_iob[_NFILE])
error("Too many open files to do readlist",FALSE);
p->_flag = _IOSTRG | flag;
p->_cnt = count;
p->_base = base;
p->_ptr = base;
p->_file = -1;
return(p);
}
lispval
Lreadli()
{
register lispval work, handy;
register FILE *p;
register char *string; char *alloca();
lispval Lread();
int count;
Savestack(4);
if(lbot->val==nil) { /*effectively, return(matom(""));*/
strbuf[0] = 0;
return(getatom());
}
chkarg(1,"readlist");
count = 1;
/* compute length of list */
for(work = lbot->val; TYPE(work)==DTPR; work=work->d.cdr)
count++;
string = alloca(count);
p = mkstFI(string, count - 1, _IOREAD);
for(work = lbot->val; TYPE(work)==DTPR; work=work->d.cdr) {
handy = work->d.car;
switch(TYPE(handy)) {
case SDOT:
case INT:
*string++=handy->i;
break;
case ATOM:
*string++ = *(handy->a.pname);
break;
case STRNG:
*string++ = *(char *)handy;
break;
default:
frstFI(p);
error("Non atom or int to readlist",FALSE);
}
}
*string = 0;
errp = Pushframe(F_CATCH,Veruwpt,nil); /* must unwind protect
so can deallocate p
*/
switch(retval) { lispval Lctcherr();
case C_THROW:
/* an error has occured and we are given a chance
to unwind before the control goes higher
lispretval contains the error descriptor in
it's cdr
*/
frstFI(p); /* free port */
errp = Popframe();
lbot = np;
protect(lispretval->d.cdr); /* error descriptor */
return(Lctcherr()); /* do a I-do-throw */
case C_INITIAL:
lbot = np;
protect(P(p));
work = Lread(); /* error could occur here */
frstFI(p); /* whew.. no errors */
errp = Popframe(); /* remove unwind-protect */
Restorestack();
return(work);
}
/* NOTREACHED */
}
frstFI(p)
register FILE *p;
{
p->_flag=0;
p->_base=0;
p->_cnt = 0;
p->_ptr = 0;
p->_file = 0;
}
lispval
Lgetenv()
{
char *getenv(), *strcpy();
char *res;
chkarg(1,"getenv");
if((TYPE(lbot->val))!=ATOM)
error("argument to getenv must be atom",FALSE);
res = getenv(lbot->val->a.pname);
if(res) strcpy(strbuf,res);
else strbuf[0] = '\0';
return(getatom());
}
lispval
Lboundp()
{
register lispval result, handy;
chkarg(1,"boundp");
if((TYPE(lbot->val))!=ATOM)
error("argument to boundp must be symbol",FALSE);
if( (handy = lbot->val)->a.clb==CNIL)
result = nil;
else
(result = newdot())->d.cdr = handy->a.clb;
return(result);
}
lispval
Lplist()
{
register lispval atm;
/* get property list of an atom or disembodied property list */
chkarg(1,"plist");
atm = lbot->val;
switch(TYPE(atm)) {
case ATOM:
case DTPR:
break;
default:
error("Only Atoms and disembodied property lists allowed for plist",FALSE);
}
if(atm==nil) return(nilplist);
return(atm->a.plist);
}
lispval
Lsetpli()
{ /* set the property list of the given atom to the given list */
register lispval atm, vall;
chkarg(2,"setplist");
atm = lbot->val;
if (TYPE(atm) != ATOM)
error("setplist: First argument must be an symbol",FALSE);
vall = (np-1)->val;
if (TYPE(vall)!= DTPR && vall !=nil)
error("setplist: Second argument must be a list",FALSE);
if (atm==nil)
nilplist = vall;
else
atm->a.plist = vall;
return(vall);
}
lispval
Lsignal()
{
register lispval handy, old, routine;
int i;
int siginth();
switch(np-lbot) {
case 1: routine = nil; /* second arg defaults to nil */
break;
case 2: routine = lbot[1].val;
break; /* both args given */
default: argerr("signal");
}
handy = lbot->val;
if(TYPE(handy)!=INT)
error("First arg to signal must be an int",FALSE);
i = handy->i & 15;
if(TYPE(routine)!=ATOM)
error("Second arg to signal must be an atom",FALSE);
old = sigacts[i];
if(old==0) old = nil;
if(routine==nil)
sigacts[i]=((lispval) 0);
else
sigacts[i]=routine;
if(routine == nil)
signal(i,SIG_IGN); /* ignore this signals */
else if (old == nil)
signal(i,siginth); /* look for this signal */
if(i == SIGINT) sigintcnt = 0; /* clear memory */
return(old);
}
lispval
Lassq()
{
register lispval work, handy;
chkarg(2,"assq");
for(work = lbot[1].val, handy = lbot[0].val;
(work->d.car->d.car != handy) && (work != nil);
work = work->d.cdr);
return(work->d.car);
}
lispval
Lkilcopy()
{
if(fork()==0) {
abort();
}
}
lispval
Larg()
{
register lispval handy; register offset, count;
handy = lexpr_atom->a.clb;
if(handy==CNIL || TYPE(handy)!=DTPR)
error("Arg: not in context of Lexpr.",FALSE);
count = ((long *)handy->d.cdr) -1 - (long *)handy->d.car;
if(np==lbot || lbot->val==nil)
return(inewint(count+1));
if(TYPE(lbot->val)!=INT || (offset = lbot->val->i - 1) > count || offset < 0 )
error("Out of bounds: arg to \"Arg\"",FALSE);
return( ((struct argent *)handy->d.car)[offset].val);
}
lispval
Lsetarg()
{
register lispval handy, work;
register limit, index;
chkarg(2,"setarg");
handy = lexpr_atom->a.clb;
if(handy==CNIL || TYPE(handy)!=DTPR)
error("Arg: not in context of Lexpr.",FALSE);
limit = ((long *)handy->d.cdr) - 1 - (long *)(work = handy->d.car);
handy = lbot->val;
if(TYPE(handy)!=INT)
error("setarg: first argument not integer",FALSE);
if((index = handy->i - 1) < 0 || index > limit)
error("setarg: index out of range",FALSE);
return(((struct argent *) work)[index].val = lbot[1].val);
}
lispval
Lptime(){
extern int gctime;
int lgctime = gctime;
struct tms current;
register lispval result, handy;
Savestack(2);
times(¤t);
result = newdot();
handy = result;
protect(result);
result->d.cdr = newdot();
result->d.car = inewint(current.tms_utime);
handy = result->d.cdr;
handy->d.car = inewint(lgctime);
handy->d.cdr = nil;
if(gctime==0)
gctime = 1;
Restorestack();
return(result);
}
/* (err [value] [flag])
where if value is present, it is the value to throw to the errset.
flag if present must evaluate to nil, as we always evaluate value
before unwinding stack
*/
lispval Lerr()
{
lispval errorh();
char *mesg = "call to err"; /* default message */
Savestack(0);
if(np==lbot) protect(nil);
if ((np >= lbot + 2) && ((lbot+1)->val != nil))
error("Second arg to err must be nil",FALSE);
if ((lbot->val != nil) && (TYPE(lbot->val) == ATOM))
mesg = lbot->val->a.pname; /* new message if atom */
return(errorh(Vererr,mesg,lbot->val,FALSE,1));
}
/*
* (tyi ['p_port ['g_eofval]])
* normally -1 is return on eof, but g_eofval will be returned if given.
*/
lispval
Ltyi()
{
register FILE *port;
register lispval handy;
lispval eofval;
int val; /* really char but getc returns int on eof */
int eofvalgiven;
handy = nil; /* default port */
eofvalgiven = FALSE; /* assume no eof value given */
switch(np-lbot)
{
case 2: eofval = lbot[1].val;
eofvalgiven = TRUE;
case 1: handy = lbot[0].val; /* port to read */
case 0:
break;
default: argerr("tyi");
}
port = okport(handy,okport(Vpiport->a.clb,stdin));
fflush(stdout); /* flush any pending output characters */
val = getc(port);
if(val==EOF)
{
clearerr(port);
if(sigintcnt > 0) sigcall(SIGINT); /* eof might mean int */
if(eofvalgiven) return(eofval);
else return(inewint(-1));
}
return(inewint(val));
}
/* Untyi (added by DNC Feb. '80) - (untyi number port) puts the
character with ascii code number in the front of the input buffer of
port. Note that this buffer is limited to 1 character. That buffer is
also written by tyipeek, so a peek followed by an untyi will result in
the loss of the peeked char.
*/
lispval
Luntyi()
{
lispval port,ch;
port = nil;
switch(np-lbot) {
case 2: port = lbot[1].val;
case 1: ch = lbot[0].val;
break;
default:
argerr("untyi");
}
if(TYPE(ch) != INT) {
errorh1(Vermisc, "untyi: expects fixnum character ",
nil,FALSE,0,ch);
}
ungetc((int) ch->i,okport(port,okport(Vpiport->a.clb,stdin)));
return(ch);
}
lispval
Ltyipeek()
{
register FILE *port;
register lispval handy;
int val;
switch(np-lbot)
{
case 0: handy = nil; /* default port */
break;
case 1: handy = lbot->val;
break;
default: argerr("tyipeek");
}
port = okport(handy,okport(Vpiport->a.clb,stdin));
fflush(stdout); /* flush any pending output characters */
val = getc(port);
if(val==EOF)
clearerr(port);
ungetc(val,port);
return(inewint(val));
}
lispval
Ltyo()
{
register FILE *port;
register lispval handy, where;
char val;
switch(np-lbot)
{
case 1: where = nil; /* default port */
break;
case 2: where = lbot[1].val;
break;
default: argerr("tyo");
}
handy = lbot->val;
if(TYPE(handy)!=INT)
error("Tyo demands number for 1st arg",FALSE);
val = handy->i;
port = (FILE *) okport(where,okport(Vpoport->a.clb,stdout));
putc(val,port);
return(handy);
}
lispval
Imkrtab(current)
{
extern struct rtab {
unsigned char ctable[132];
} initread;
register lispval handy; extern lispval lastrtab;
static int cycle = 0;
static char *nextfree;
Savestack(3);
if((cycle++)%3==0) {
nextfree = (char *) csegment(STRNG,1,FALSE);
mrtabspace = (lispval) nextfree;
/* need to protect partially allocated read tables
from garbage collection. */
}
handy = newarray();
protect(handy);
handy->ar.data = nextfree;
if(current == 0)
*(struct rtab *)nextfree = initread;
else
{
register index = 0; register char *cp = nextfree;
lispval c;
*(struct rtab *)cp = *(struct rtab *)ctable;
for(; index < 128; index++) {
switch(synclass(cp[index])) {
case CSPL: case CSSPL: case CMAC: case CSMAC:
case CINF: case CSINF:
strbuf[0] = index;
strbuf[1] = 0;
c = (getatom());
Iputprop(c,Iget(c,lastrtab),handy);
}
}
}
handy->ar.delta = inewint(4);
handy->ar.length = inewint(sizeof(struct rtab)/sizeof(int));
handy->ar.accfun = handy->ar.aux = nil;
nextfree += sizeof(struct rtab);
Restorestack();
return(handy);
}
/* makereadtable - arg : t or nil
returns a readtable, t means return a copy of the initial readtable
nil means return a copy of the current readtable
*/
lispval
Lmakertbl()
{
lispval handy = Vreadtable->a.clb;
lispval value;
chkrtab(handy);
if(lbot==np) value = nil;
else if(TYPE(value=(lbot->val)) != ATOM)
error("makereadtable: arg must be atom",FALSE);
if(value == nil) return(Imkrtab(1));
else return(Imkrtab(0));
}
lispval
Lcpy1()
{
register lispval handy = lbot->val, result = handy;
top:
switch(TYPE(handy))
{
case INT:
result = inewint(handy->i);
break;
case VALUE:
(result = newval())->l = handy->l;
break;
case DOUB:
(result = newdoub())->r = handy->r;
break;
default:
lbot->val =
errorh1(Vermisc,"Bad arg to cpy1",nil,TRUE,67,handy);
goto top;
}
return(result);
}
/* copyint* . This returns a copy of its integer argument. The copy will
* be a fresh integer cell, and will not point into the read only
* small integer table.
*/
lispval
Lcopyint()
{
register lispval handy = lbot->val;
register lispval ret;
while (TYPE(handy) != INT)
{ handy=errorh1(Vermisc,"copyint* : non integer arg",nil,TRUE,0,handy);}
(ret = newint())->i = handy->i;
return(ret);
}