lispval
Lflatsi()
{
register lispval current;
Savestack(1); /* fixup entry mask */
fmax = 0x7fffffff; /* biggest integer by default */
switch(np-lbot)
{
case 2: current = lbot[1].val;
while(TYPE(current) != INT)
current = errorh1(Vermisc,
"flatsize: second arg not integer",
nil,TRUE,0,current);
fmax = current->i;
case 1: break;
default: argerr("flatsize");
}
flen = 0;
current = lbot->val;
protect(nil); /*create space for argument to pntlen*/
Iflatsi(current);
Restorestack();
return(inewint(flen));
}
lispval
Lnegp()
{
register lispval handy = np[-1].val, work;
register flag = 0;
loop:
switch(TYPE(handy)) {
case INT:
if(handy->i < 0) flag = TRUE;
break;
case DOUB:
if(handy->r < 0) flag = TRUE;
break;
case SDOT:
for(work = handy;
work->s.CDR!=(lispval) 0;
work = work->s.CDR) {;}
if(work->s.I < 0) flag = TRUE;
break;
default:
handy = errorh1(Vermisc,
"minusp: Non-(int,real,bignum) arg: ",
nil,
TRUE,
0,
handy);
goto loop;
}
if(flag) return(tatom);
return(nil);
}
lispval
Lgetaddress(){
register struct argent *mlbot = lbot;
register lispval work;
register int numberofargs, i;
char ostabf[128];
struct nlist NTABLE[100];
lispval dispget();
Savestack(4);
if(np-lbot == 2) protect(nil); /* allow 2 args */
numberofargs = (np - lbot)/3;
if(numberofargs * 3 != np-lbot)
error("getaddress: arguments must come in triples ",FALSE);
for ( i=0; i<numberofargs; i++,mlbot += 3) {
NTABLE[i].n_value = 0;
mlbot[0].val = verify(mlbot[0].val,"Incorrect entry specification for binding");
STASSGN(i,(char *) mlbot[0].val);
while(TYPE(mlbot[1].val) != ATOM)
mlbot[1].val = errorh1(Vermisc,
"Bad associated atom name for binding",
nil,TRUE,0,mlbot[1].val);
mlbot[2].val = dispget(mlbot[2].val,"getaddress: Incorrect discipline specification ",(lispval)Vsubrou->a.pname);
}
STASSGN(numberofargs,"");
strncpy(ostabf,gstab(),128);
if ( nlist(ostabf,NTABLE) == -1 ) {
errorh1(Vermisc,"Getaddress: Bad file",nil,FALSE,0,inewstr(ostabf));
} else
for (i=0,mlbot=lbot+1; i<numberofargs; i++,mlbot+=3) {
if ( NTABLE[i].n_value == 0 )
fprintf(stderr,"Undefined symbol: %s\n",
NTABLE[i].N_name);
else {
work= newfunct();
work->bcd.start = (lispval (*) ())NTABLE[i].n_value;
work->bcd.discipline = mlbot[1].val;
mlbot->val->a.fnbnd = work;
}
};
Restorestack();
return(lbot[1].val->a.fnbnd);
};
lispval
Lfunhook()
{
register lispval handy;
register lispval evalhval = CNIL;
Savestack(2);
switch (np-lbot)
{
case 2: break;
case 3: evalhval = (lbot+2)->val;
break;
default: argerr("funcallhook");
}
/* Don't do this check any longer
* if (evalhsw == 0)
* error("funcallhook called before doing sstatus-evalhook", TRUE);
*if (rsetsw == 0 || rsetatom->a.clb == nil)
* error("funcallhook called while not in *rset mode", TRUE);
*/
handy = lbot->val;
while (TYPE(handy) != DTPR)
handy = errorh1(Vermisc,"funcallhook: first arg must be a list",nil,TRUE,
0,handy);
if(evalhval != CNIL) { PUSHDOWN(evalhatom,evalhval); }
PUSHDOWN(funhatom,(lispval)(lbot+1)->val);
/* funcall checks funcallhcall to see if this is a LISP call to evalhook
in which case it avoids call to evalhook function, but clobbers
value to nil so recursive calls will check. */
funhcallsw = TRUE;
/*
* the first argument to funhook is a list of already evaluated expressions
* which we just stack can call funcall on
*/
lbot = np; /* base of new args */
for ( ; handy != nil ; handy = handy->d.cdr)
{
protect(handy->d.car);
}
handy = Lfuncal();
POP;
if(evalhval != CNIL) { POP; }
Restorestack();
return(handy);
}
/* to one. */
lispval
Ngo()
{
register lispval temp;
chkarg(1,"go");
temp = (lbot->val)->d.car;
if (TYPE(temp) != ATOM)
{
temp = eval(temp);
while(TYPE(temp) != ATOM)
temp = errorh1(Vermisc,"Illegal tag to go to",nil,TRUE, 0,lbot->val);
}
Inonlocalgo(C_GO,temp,nil);
/* NOT REACHED */
}
lispval
Lxcdr()
{ register int typ;
register lispval temp;
chkarg(1,"xcdr");
temp = lbot->val;
if(temp==nil) return (nil);
if (((typ = TYPE(temp)) == DTPR) || HUNKP(temp))
return(temp->d.cdr);
else if(typ==SDOT) {
if(temp->s.CDR==0) return(nil);
temp = temp->s.CDR;
if(TYPE(temp)==DTPR)
errorh1(Vermisc,"Fell off the end of a bignum",nil,FALSE,5,lbot->val);
return(temp);
} else if(Schainp!=nil && typ==ATOM)
return(nil);
else
return(error("Bad arg to cdr", FALSE));
}
lispval
Nsetq()
{ register lispval handy, where, value;
register int lefttype;
value = nil;
for(where = lbot->val; where != nil; where = handy->d.cdr) {
handy = where->d.cdr;
if((TYPE(handy))!=DTPR)
error("odd number of args to setq",FALSE);
if((lefttype=TYPE(where->d.car))==ATOM) {
if(where->d.car==nil)
error("Attempt to set nil",FALSE);
where->d.car->a.clb = value = eval(handy->d.car);
}else if(lefttype==VALUE)
where->d.car->l = value = eval(handy->d.car);
else errorh1(Vermisc,
"Can only setq atoms or values",nil,FALSE,0,
where->d.car);
}
return(value);
}
lispval
Nprog() {
register lispval where, temp;
struct nament *savedbnp = bnp;
extern struct frame *errp;
pbuf pb;
extern int retval;
extern lispval lispretval;
if((np-lbot) < 1) chkarg(1,"prog");
/* shallow bind the local variables to nil */
if(lbot->val->d.car != nil)
{
for( where = lbot->val->d.car ; where != nil; where = where->d.cdr )
{
if(TYPE(where) != DTPR || TYPE(temp=where->d.car) != ATOM)
errorh1(Vermisc,
"Illegal local variable list in prog ",nil,FALSE,
1,where);
PUSHDOWN(temp,nil);
}
}
/* put a frame on the stack which can be 'return'ed to or 'go'ed to */
errp = Pushframe(F_PROG,nil,nil);
where = lbot->val->d.cdr; /* first thing in the prog body */
switch (retval) {
case C_RET: /*
* returning from this prog, value to return
* is in lispretval
*/
errp = Popframe();
popnames(savedbnp);
return(lispretval);
case C_GO: /*
* going to a certain label, label to go to in
* in lispretval
*/
where = (lbot->val)->d.cdr;
while ((TYPE(where) == DTPR)
&& (where->d.car != lispretval))
where = where->d.cdr;
if (where->d.car == lispretval) {
popnames(errp->svbnp);
break;
}
/* label not found in this prog, must
* go up to higher prog
*/
errp = Popframe(); /* go to next frame */
Inonlocalgo(C_GO,lispretval,nil);
/* NOT REACHED */
case C_INITIAL: break;
}
while (TYPE(where) == DTPR)
{
temp = where->d.car;
if((TYPE(temp))!=ATOM) eval(temp);
where = where->d.cdr;
}
if((where != nil) && (TYPE(where) != DTPR))
errorh1(Vermisc,"Illegal form in prog body ", nil,FALSE,0,where);
errp = Popframe();
popnames(savedbnp); /* pop off locals */
return(nil);
}
lispval
Lsetsyn()
{
register lispval s, c;
register struct argent *mynp;
register index;
lispval x /* ,debugmode */;
extern unsigned char *ctable;
extern lispval Istsrch();
switch(np-lbot) {
case 2:
x= nil; /* only 2 args given */
case 3:
x = lbot[2].val; /* all three args given */
break;
default:
argerr("setsyntax");
}
s = Vreadtable->a.clb;
chkrtab(s);
/* debugging code
debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr;
if(debugmode) printf("Readtable addr: %x\n",ctable);
end debugging code */
mynp = lbot;
c = (mynp++)->val;
s = (mynp++)->val;
switch(TYPE(c)) {
default:
error("neither fixnum, atom or string as char to setsyntax",FALSE);
case ATOM:
index = *(c->a.pname);
if((c->a.pname)[1])
errorh1(Vermisc,"Only 1 char atoms to setsyntax",
nil,FALSE,0,c);
break;
case INT:
index = c->i;
break;
case STRNG:
index = (int) *((char *) c);
}
switch(TYPE(s)) {
case ATOM:
if(s==splice || s==macro) {
if(s==splice)
ctable[index] = VSPL;
else if(s==macro)
ctable[index] = VMAC;
if(TYPE(c)!=ATOM) {
strbuf[0] = index;
strbuf[1] = 0;
c = (getatom(TRUE));
}
Iputprop(c,x,lastrtab);
return(tatom);
}
/* ... fall into */
default: errorh1(Vermisc,"int:setsyntax : illegal second argument ",
nil,FALSE,0,s);
/* not reached */
case INT:
switch(synclass(s->i)) {
case CESC: Xesc = (char) index; break;
case CDQ: Xdqc = (char) index; break;
case CSD: Xsdc = (char) index; /* string */
}
if(synclass(ctable[index])==CESC /* if we changed the current esc */
&& (synclass(s->i)!=CESC) /* to something else, pick current */
&& Xesc == (char) index) {
ctable[index] = s->i;
rpltab(CESC,&Xesc);
}
else if(synclass(ctable[index])==CDQ /* likewise for double quote */
&& synclass(s->i) != CDQ
&& Xdqc == (char) index) {
ctable[index] = s->i;
rpltab(CDQ,&Xdqc);
}
else if(synclass(ctable[index]) == CSD /* and for string delimiter */
&& synclass(s->i) != CSD
&& Xsdc == (char) index) {
ctable[index] = s->i;
rpltab(CSD,&Xsdc);
}
else ctable[index] = s->i;
break;
}
return(tatom);
}
