4.4BSD/usr/src/old/lisp/franz/lam4.c
#ifndef lint
static char *rcsid =
"$Header: lam4.c,v 1.5 83/12/28 16:21:08 sklower Exp $";
#endif
/* -[Sun Jun 19 22:25:48 1983 by jkf]-
* lam4.c $Locker: $
* lambda functions
*
* (c) copyright 1982, Regents of the University of California
*/
#include "global.h"
lispval adbig(),subbig(),mulbig();
double Ifloat();
lispval
Ladd()
{
register lispval work;
register struct argent *result, *mynp, *oldnp;
long restype,prunep,hi,lo=0;
struct sdot dummybig;
double flacc;
Savestack(4);
oldnp = result = np;
restype = INT; /* now start as integers */
protect(nil);
for(mynp = lbot; mynp < oldnp; mynp++)
{
work = mynp->val;
switch(TYPE(work)) {
case INT:
switch(restype) {
case SDOT:
dmlad(result->val,1L,work->i);
prunep = TRUE;
/* In adding the fixnum to the sdot we may make it
possible for the bignum to be represented as a fixnum */
break;
case INT:
if(exarith(lo,1L,work->i,&hi,&lo)) {
work = result->val = newsdot();
work->s.I = lo;
work = work->s.CDR = newdot();
work->s.I = hi;
work->s.CDR = 0;
restype = SDOT; prunep = FALSE;
}
break;
case DOUB:
result->val->r += work->i;
break;
default: goto urk;
}
break;
case SDOT:
switch(restype) {
case INT:
dummybig.I = lo;
dummybig.CDR = 0;
work=adbig(work,(lispval)&dummybig);
goto code1;
case SDOT:
work=adbig(work,result->val);
/* previous result is no longer needed */
pruneb(result->val);
code1:
restype = TYPE(work); /* SDOT or INT */
if(restype==INT) {
lo = work->i;
prunei(work);
} else {
prunep = FALSE; /* sdot is cannonical */
result->val = work;
} break;
case DOUB:
result->val->r += Ifloat(work);
break;
default: goto urk;
}
break;
case DOUB:
switch(restype) {
case SDOT:
if(prunep) {
lispval handy;
dummybig.I = 0;
dummybig.CDR = (lispval) 0;
handy = adbig((lispval)&dummybig,result->val);
pruneb(result->val);
result->val = handy;
}
flacc = Ifloat(result->val) + work->r;
pruneb(result->val);
scrimp:
(result->val = newdoub())->r = flacc;
restype = DOUB;
break;
case INT:
flacc = work->r + lo;
goto scrimp;
case DOUB:
result->val->r += work->r;
break;
default: goto urk;
}
break;
default:
errorh1(Vermisc,"Non-number to add",nil,0,FALSE,work);
}
}
work = result->val;
switch(restype){
case DOUB:
break;
case INT:
work=inewint(lo);
break;
case SDOT:
if(prunep) {
/* wouldn't (copy result->val) be faster ? -dhl */
/* It might, but isn't guaranteed to canonicalize */
dummybig.I = 0;
dummybig.CDR = (lispval) 0;
work = adbig((lispval)&dummybig,work);
}
break;
default:
urk:
error("Internal error in add ",FALSE);
}
Restorestack();
return(work);
}
/* exarith(a,b,c,lo,hi)
* int a,b,c;
* int *lo, *hi;
* Exact arithmetic.
* a,b and c are 32 bit 2's complement integers
* calculates x=a*b+c to twice the precision of an int.
* In the vax version, the 30 low bits only are returned
* in *lo,and the next 32 bits of precision are returned in * hi.
* this works since exarith is used either for calculating the sum of
* two 32 bit numbers, (which is at most 33 bits), or
* multiplying a 30 bit number by a 32 bit numbers,
* which has a maximum precision of 62 bits.
* If *phi is 0 or -1 then
* x doesn't need any more than 31 bits plus sign to describe, so we
* place the sign in the high two bits of *plo and return 0 from this
* routine. A non zero return indicates that x requires more than 31 bits
* to describe.
*
* The definition has been moved to vax.c.
*/
lispval
Lsub()
{
register lispval work;
register struct argent *result, *mynp, *oldnp;
long prunep,restype,hi,lo=0;
struct sdot dummybig;
double flacc;
lispval Lminus();
Savestack(4);
oldnp = result = np;
mynp = lbot + 1;
restype = INT;
prunep = TRUE;
if(oldnp==lbot)
goto out;
if(oldnp==mynp) {
work = Lminus();
Restorestack();
return(work);
}
protect(nil);
work = lbot->val;
/* examine the first argument and perhaps set restype to the
* correct type. If restype (result type) is INT, then the
* fixnum value is stored in lo. Otherwise, if restype is
* SDOT or DOUB, then the value is stored in result->val.
*/
switch(TYPE(work)) {
case INT:
lo = work->i;
restype = INT;
break;
case SDOT:
/* we want to copy the sdot we are given as an argument since
* the bignum arithmetic routine dmlad clobbers the values it
* is given.
*/
dummybig.I = 0; /* create a zero sdot */
dummybig.CDR = 0;
work = adbig(work,(lispval)&dummybig);
/* the resulting value may have been reduced from an
* sdot to a fixnum. This should never happen though
* but if it does, we simplify things.
*/
restype = TYPE(work);
if(restype==INT) {
lo = work->i; /* has turned into an fixnum */
prunei(work); /* return fixnum cell */
} else {
prunep = FALSE; /* sdot is cannonical */
result->val = work;
}
break;
case DOUB:
(result->val = newdoub())->r = work->r;
restype = DOUB;
}
/* now loop through the rest of the arguments subtracting them
* from the running result in result or lo
*/
for(; mynp < oldnp; mynp++)
{
work = mynp->val;
switch(TYPE(work)) {
case INT:
switch(restype) {
case SDOT:
/* subtracting a fixnum from an bignum
* use the distructive multiply (by 1)
* and add the negative of the work value.
* The result will still be pointed to
* by result->val
*/
dmlad(result->val,1L, -work->i);
prunep = TRUE; /* check up on exiting */
break; /* that it didn't collapse */
case INT:
/* subtracting a fixnum from a fixnum,
* the result could turn into a bignum
*/
if(exarith(lo,1L,-work->i,&hi,&lo)) {
work = result->val = newsdot();
work->s.I = lo;
work = work->s.CDR = newdot();
work->s.I = hi;
work->s.CDR = 0;
restype = SDOT; prunep = TRUE;
}
break;
case DOUB:
/* subtracting a fixnum from a flonum */
result->val->r -= work->i;
break;
default:
goto urk;
}
break;
case SDOT:
switch(restype) {
case INT:
/* subtracting a bignum from an integer
* first make a bignum of the integer and
* then fall into the next case
*/
dummybig.I = lo;
dummybig.CDR = (lispval) 0;
work = subbig((lispval)&dummybig,work);
goto on1;
case SDOT:
/* subtracting one bignum from another. The
* routine to do this ends up calling addbig
* and should probably be written specifically
* for subtraction.
*/
work = subbig(result->val,work);
pruneb(result->val);
on1:
/* check if the result has turned into a fixnum */
restype = TYPE(work);
if(restype==INT) {
lo = work->i; /* it has */
prunei(work);
} else {
prunep = FALSE; /* sdot is cannonical */
result->val = work;
}
break;
case DOUB: /* Subtract bignum from float */
/* Death on overflow */
result->val->r -= Ifloat(work);
break;
default:
goto urk;
}
break;
case DOUB:
switch(restype) {
case SDOT: /* subtracting a flonum from a bignum. */
if(prunep) {
lispval handy;
dummybig.I = 0;
dummybig.CDR = (lispval) 0;
handy = adbig((lispval)&dummybig,result->val);
pruneb(result->val);
result->val = handy;
}
flacc = Ifloat(result->val) - work->r;
pruneb(result->val);
scrimp: (result->val = newdoub())->r = flacc;
restype = DOUB;
break;
case INT:
/* subtracting a flonum from an fixnum.
* The result will be an flonum.
*/
flacc = lo - work->r;
goto scrimp;
case DOUB:
/* subtracting a flonum from a flonum, what
* could be easier?
*/
result->val->r -= work->r;
break;
default:
goto urk;
}
break;
default:
errorh1(Vermisc,"Non-number to minus",nil,FALSE,0,work);
}
}
out:
work = result->val;
switch(restype){
case DOUB:
break;
case INT:
work = inewint(lo);
break;
case SDOT:
if(prunep) {
dummybig.I = 0;
dummybig.CDR = (lispval) 0;
work = adbig((lispval)&dummybig,work);
}
break;
default:
urk:
error("Internal error in difference",FALSE);
}
Restorestack();
return(work);
}
lispval
Ltimes()
{
register lispval work;
register struct argent *result, *mynp, *oldnp;
long restype,prunep,hi,lo=1;
struct sdot dummybig;
double flacc;
Savestack(4);
oldnp = result = np;
restype = INT; /* now start as integers */
prunep = TRUE;
protect(nil);
for(mynp = lbot; mynp < oldnp; mynp++)
{
work = mynp->val;
switch(TYPE(work)) {
case INT:
switch(restype) {
case SDOT:
dmlad(result->val,work->i,0L);
prunep = TRUE;
/* In adding the fixnum to the sdot we may make it
possible for the bignum to be represented as a fixnum */
break;
case INT:
if(exarith(lo,work->i,0L,&hi,&lo)) {
work = result->val = newsdot();
work->s.I = lo;
work = work->s.CDR = newdot();
work->s.I = hi;
work->s.CDR = 0;
restype = SDOT; prunep = TRUE;
}
break;
case DOUB:
result->val->r *= work->i;
break;
default: goto urk;
}
break;
case SDOT:
switch(restype) {
case INT:
dummybig.I = lo;
dummybig.CDR = 0;
work=mulbig(work,(lispval)&dummybig);
goto code1;
case SDOT:
work=mulbig(work,result->val);
/* previous result is no longer needed */
pruneb(result->val);
code1:
restype = TYPE(work); /* SDOT or INT */
if(restype==INT) {
lo = work->i;
prunei(work);
} else {
prunep = FALSE; /* sdot is cannonical */
result->val = work;
} break;
case DOUB:
result->val->r *= Ifloat(work);
break;
default: goto urk;
}
break;
case DOUB:
switch(restype) {
case SDOT:
if(prunep) {
lispval handy;
dummybig.I = 0;
dummybig.CDR = (lispval) 0;
handy = adbig((lispval)&dummybig,result->val);
pruneb(result->val);
result->val = handy;
}
flacc = Ifloat(result->val) * work->r;
pruneb(result->val);
scrimp: (result->val = newdoub())->r = flacc;
restype = DOUB;
break;
case INT:
flacc = work->r * lo;
goto scrimp;
case DOUB:
result->val->r *= work->r;
break;
default: goto urk;
}
break;
default:
errorh1(Vermisc,"Non-number to add",nil,0,FALSE,work);
}
}
work = result->val;
switch(restype){
case DOUB:
break;
case INT:
work = inewint(lo);
break;
case SDOT:
if(prunep) {
dummybig.I = 0;
dummybig.CDR = (lispval) 0;
work = adbig((lispval)&dummybig,work);
}
break;
default:
urk:
error("Internal error in times",FALSE);
}
Restorestack();
return(work);
}
lispval
Lquo()
{
register lispval work;
register struct argent *result, *mynp, *oldnp;
int restype; lispval quotient; double flacc;
struct sdot dummybig;
Savestack(4);
oldnp = result = np;
protect(nil);
mynp = lbot + 1;
restype = INT;
dummybig.I = 1; dummybig.CDR = (lispval) 0;
if(oldnp==lbot) goto out;
if(oldnp==mynp) mynp = lbot;
else {
/* examine the first argument and perhaps set restype to the
* correct type. If restype (result type) is INT, then the
* fixnum value is stored in lo. Otherwise, if restype is
* SDOT or DOUB, then the value is stored in result->val.
*/
work = lbot->val;
switch(TYPE(work)) {
case INT:
dummybig.I = work->i;
break;
case SDOT:
/* we want to copy the sdot we are given as an argument since
* the bignum divide routine divbig expects an argument in
* canonical form.
*/
dummybig.I = 0; /* create a zero sdot */
work = adbig(work,(lispval)&dummybig);
restype = TYPE(work);
if(restype==INT) { /* Either INT or SDOT */
dummybig.I=work->i; /* has turned into an fixnum */
prunei(work); /* return fixnum cell */
} else {
result->val = work;
}
break;
case DOUB:
(result->val = newdoub())->r = work->r;
restype = DOUB;
break;
default:
errorh1(Vermisc,"Internal quotient error #1: ",nil,FALSE,0,
work);
goto urk;
}
}
/* now loop through the rest of the arguments dividing them
* into the running result in result or dummybig.I
*/
for(; mynp < oldnp; mynp++)
{
work = mynp->val;
switch(TYPE(work)) {
case INT:
if (work->i==0)
kill(getpid(),8);
switch(restype) {
case SDOT: /* there is no fast routine to destructively
divide a bignum by an int, so do it the
hard way. */
dummybig.I = work->i;
divbig(result->val,(lispval)&dummybig,"ient,(lispval *)0);
pruneb(result->val);
on1:
/* check if the result has turned into a fixnum */
restype = TYPE(quotient);
if(restype==INT) { /* Either INT or SDOT */
dummybig.I=quotient->i; /* has turned into an fixnum */
prunei(quotient); /* return fixnum cell */
} else
result->val = quotient;
break;
case INT: /* divide int by int */
dummybig.I /= work->i;
break;
case DOUB:
result->val->r /= work->i;
break;
default:
errorh1(Vermisc,"Internal quotient error #2: ",nil,FALSE,0,
result->val);
goto urk;
}
break;
case SDOT:
switch(restype) {
case INT:
/* Although it seems that dividing an int
* by a bignum can only lead to zero, it is
* concievable that the bignum is improperly boxed,
* i.e. actually an int.
*/
divbig((lispval)&dummybig,work,"ient,(lispval *)0);
goto on1;
case SDOT:
/* dividing one bignum by another. */
divbig(result->val,work,"ient,(lispval *)0);
pruneb(result->val);
goto on1;
case DOUB:
/* dividing a bignum into a flonum.
*/
result->val->r /= Ifloat(work);
break;
default:
errorh1(Vermisc,"Internal quotient error #3: ",nil,FALSE,0,
result->val);
goto urk;
}
break;
case DOUB:
switch(restype) {
case SDOT: /* Divide bignum by flonum converting to flonum
* May die due to overflow */
flacc = Ifloat(result->val) / work->r;
pruneb(result->val);
scrimp:
(result->val = newdoub())->r = flacc;
restype = DOUB;
break;
case INT: /* dividing a flonum into a fixnum.
* The result will be a flonum. */
flacc = ((double) dummybig.I) / work->r;
goto scrimp;
case DOUB: /* dividing a flonum into a flonum, what
* could be easier?
*/
result->val->r /= work->r;
break;
default:
errorh1(Vermisc,"Internal quotient error #4: ",nil,
FALSE,0, result->val);
goto urk;
}
break;
default:
errorh1(Vermisc,"Non-number to quotient ",nil,FALSE,0,work);
}
}
out:
work = result->val;
switch(restype){
case SDOT:
case DOUB:
break;
case INT:
work = inewint(dummybig.I);
break;
default:
urk:
errorh1(Vermisc,"Internal quotient error #5: ",nil,FALSE,0,
work);
}
Restorestack();
return(work);
}
lispval Lfp()
{
register temp = 0;
register struct argent *argp;
for(argp = lbot; argp < np; argp++)
if(TYPE(argp->val) != INT)
errorh1(Vermisc,"+: non fixnum argument ",
nil,FALSE,0,argp->val);
else
temp += argp->val->i;
return(inewint(temp));
}
lispval Lfm()
{
register temp;
register struct argent *argp;
if(lbot==np)return(inewint(0));
if(TYPE(lbot->val) != INT)
errorh1(Vermisc,"-: non fixnum argument ",
nil,FALSE,0,lbot->val);
else
temp = lbot->val->i;
if(lbot+1==np) return(inewint(-temp));
for(argp = lbot+1; argp < np; argp++)
if(TYPE(argp->val) != INT)
errorh1(Vermisc,"-: non fixnum argument ",
nil,FALSE,0,argp->val);
else
temp -= argp->val->i;
return(inewint(temp));
}
lispval Lft()
{
register temp = 1;
register struct argent *argp;
for(argp = lbot; argp < np; argp++)
if(TYPE(argp->val) != INT)
errorh1(Vermisc,"*: non fixnum argument ",
nil,FALSE,0,argp->val);
else
temp *= argp->val->i;
return(inewint(temp));
}
lispval Lflessp()
{
register struct argent *argp = lbot;
register old, new;
if(np < argp + 2) return(nil);
old = argp->val->i; argp++;
for(; argp < np; argp++)
if(TYPE(argp->val) != INT)
errorh1(Vermisc,"<: non fixnum argument ",
nil,FALSE,0,argp->val);
else {
new = argp->val->i;
if(!(old < new)) return(nil);
old = new;
}
return(tatom);
}
lispval Lfd()
{
register temp = 0;
register struct argent *argp;
if(lbot==np)return(inewint(1));
if(TYPE(lbot->val) != INT)
errorh1(Vermisc,"/: non fixnum argument ",
nil,FALSE,0,lbot->val);
temp = lbot->val->i;
if(lbot+1==np) return(inewint(1/temp));
for(argp = lbot+1; argp < np; argp++)
if(TYPE(argp->val) != INT)
errorh1(Vermisc,"/: non fixnum argument ",
nil,FALSE,0,argp->val);
else
temp /= argp->val->i;
return(inewint(temp));
}
lispval Lfadd1()
{
chkarg(1,"1+");
if(TYPE(lbot->val) != INT)
errorh1(Vermisc,"1+: non fixnum argument ",
nil,FALSE,0,lbot->val);
return(inewint(lbot->val->i + 1));
}
/*
* Lfexpt (^ 'x_a 'x_b)
* exponentiation of fixnums x_a and x_b returning a fixnum
* result
*/
lispval Lfexpt()
{
register int base;
register int exp;
register int res;
chkarg(2,"^");
if((TYPE(lbot[0].val) != INT ) || (TYPE(lbot[1].val) != INT))
errorh2(Vermisc,"^: non fixnum arguments", nil,0,
lbot[0].val,lbot[1].val);
base = lbot[0].val->i;
exp = lbot[1].val->i;
if(base == 0)
{
/* 0^0 == 1, 0 to any other power (even negative powers)
* is zero (according to Maclisp)
*/
if(exp == 0) return(inewint(1));
else return(inewint(0));
}
else if(base == 1)
/*
* 1 to any power is 1
*/
return(lbot[0].val); /* == 1 */
else if(exp == 0)
/*
* anything to the zero power is 1
*/
return(inewint(1));
else if(base == -1)
{
/*
* -1 to an even power is 1, to an odd is -1
*/
if(exp & 1) return(lbot[0].val);
else return(inewint(1));
}
else if(exp < 0)
/*
* anything not 0,-1,or 1 to a negative power is 0
*
*/
return(inewint(0));
/* compute exponentiation. This should check for overflows,
I suppose. --jkf
*/
res = 1;
while( exp > 0)
{
if( exp & 1 )
{ /* odd, just multiply by one */
res = res * base;
exp--;
}
else {
/* even, square base */
base = base * base;
exp = exp / 2;
}
}
return(inewint(res));
}
lispval Lfsub1()
{
chkarg(1,"1-");
if(TYPE(lbot->val) != INT)
errorh1(Vermisc,"1-: non fixnum argument ",
nil,FALSE,0,lbot->val);
return(inewint(lbot->val->i - 1));
}
lispval
Ldbtofl()
{
float x;
chkarg(1,"double-to-float");
if(TYPE(lbot->val) != DOUB)
errorh1(Vermisc,"double-to-float: non flonum argument ",
nil,FALSE,0,lbot->val);
x = lbot->val->r;
return(inewint(*(long *)&x));
}
lispval
Lfltodb()
{
register lispval handy;
chkarg(1,"float-to-double");
if(TYPE(lbot->val) != INT)
errorh1(Vermisc,"float-to-double: non fixnum argument ",
nil,FALSE,0,lbot->val);
handy = newdoub();
handy->r = *(float *)lbot->val;
return(handy);
}