[unix-history] / usr / src / cmd / lisp / lam5.c

static char *sccsid = "@(#)lam5.c	34.1 10/3/80";

#include "global.h"
#include "chkrtab.h"

/*===========================================
-
-	explode functions: aexplode , aexplodec, aexploden
- The following function partially implement the explode functions for atoms.
-  The full explode functions are written in lisp and call these for atom args.
-
-===========================================*/

#include "chars.h"
lispval
Lexpldx(kind,slashify)
int kind, slashify; 	/* kind = 0 => explode to characters 
				= 1 => explode to fixnums (aexploden)
			   slashify = 0 => do not quote bizarre characters
				    = 1 => quote bizarre characters
			*/
{
	int typ, i;
	char ch, *strb, strbb[BUFSIZ];  /* temporary string buffer */
	register lispval last, handy;
	register char *cp;
	char Idqc = Xdqc;
	snpand(4); /* kludge register save mask */

	chkarg(1,"expldx");

	handy = Vreadtable->a.clb;
	chkrtab(handy);
	handy = lbot->val;
	*strbuf = 0;
	typ=TYPE(handy);	/* we only work for a few types */


	/* put the characters to return in the string buffer strb */

	switch(typ) {
	case STRNG:
		if(slashify && !Xsdc)
		    errorh(Vermisc,"Can't explode without string delimiter",nil
					  ,FALSE,0,handy);
		
		strb = strbb;
		if(slashify) *strb++ = Xsdc;
		/* copy string into buffer, escape only occurances of the 
		   double quoting character if in slashify mode
		*/
		for(cp = (char *) handy; *cp; cp++)
		{
		  if(slashify &&
		     (*cp == Xsdc || ctable[*cp]==VESC))
			 *strb++ = Xesc;
		  *strb++ = *cp;
		}
		if(slashify) *strb++ = Xsdc;
		*strb = NULL_CHAR ;
		strb = strbb;
		break;

	case ATOM:
		strb = handy->a.pname;
		if(strb[0]==0) {
			strb = strbb;
			strbb[0] = Xdqc;
			strbb[1] = Xdqc;
			strbb[2] = 0;
		} else
	common:
		if(slashify != 0)
		{
			register char *out = strbb;
			cp = strb;
			strb = strbb;
			if(ctable[(*cp)&0177]==VNUM)
				*out++ = Xesc;
			for(; *cp; cp++)
			{
				if(ctable[*cp]& QUTMASK)
					*out++ = Xesc;
				*out++ = *cp;
			}
			*out = 0;
		}
				
		break;
	case INT:
		strb = strbb;
		sprintf(strb, "%d", lbot->val->i);
		break;
	case DOUB:
		strb = strbb;
		lfltpr(strb, lbot->val->r);
		break;
	case SDOT:
	{
		struct _iobuf _strbuf;
		register count;
		for((handy = lbot->val), count = 12;
		    handy->s.CDR!=(lispval) 0;
		    (handy = handy->s.CDR), count += 12);
		strb = (char *) alloca(count);

		_strbuf._flag = _IOWRT+_IOSTRG;
		_strbuf._ptr = strb;
		_strbuf._cnt = count;
		pbignum(lbot->val,&_strbuf);
		putc(0,&_strbuf);
		break;
	}
	default:
			errorh(Vermisc,"EXPLODE ARG MUST BE STRING, SYMBOL, FIXNUM, OR FLONUM",nil,FALSE,0,handy);
			return(nil);
		}


	if( strb[0] != NULL_CHAR )	/* if there is something to do */
	{
	    register lispval prev;

	    protect(handy = last = newdot()); 
	    strbuf[1] = NULL_CHAR ;     /* set up for getatom */
	    atmlen = 2;

	    for(i=0; ch = strb[i++]; ) {
		switch(kind) {

		  case 0: strbuf[0] = hash = ch;   /* character explode */
			  last->d.car = (lispval) getatom(); /* look in oblist */
			  break;

		  case 1: 
			  last->d.car = inewint(ch);
			  break;
		}

		/* advance pointers */
		prev = last;
		last->d.cdr = newdot();
		last = last->d.cdr;
	    }

	    /* end list with a nil pointer */
	    prev->d.cdr = nil;
	    return(handy);
	}
	else return(nil);	/* return nil if no characters */
}

/*===========================
-
- (aexplodec 'atm) returns (a t m)
- (aexplodec 234) returns (\2 \3 \4)
-===========================*/

lispval
Lexpldc()
{ return(Lexpldx(0,0)); }


/*===========================
-
- (aexploden 'abc) returns (65 66 67)
- (aexploden 123)  returns (49 50 51)
-=============================*/


lispval
Lexpldn()
{ return(Lexpldx(1,0)); }

/*===========================
-
- (aexplode "123")  returns (\\ \1 \2 \3);
- (aexplode 123)  returns (\1 \2 \3);
-=============================*/

lispval
Lexplda()
{ return(Lexpldx(0,1)); }

/*
 * (argv) returns how many arguments where on the command line which invoked
 * lisp; (argv i) returns the i'th argument made into an atom;
 */

lispval
Largv()
{
	register lispval handy;
	register index;
	register char *base;
	char c;
	extern int Xargc;
	extern char **Xargv;
	snpand(3);

	if(lbot-np==0)protect(nil);
	handy = lbot->val;
	
	if(TYPE(handy)==INT && handy->i>=0 && handy->i<Xargc) {
		strcpy(strbuf,Xargv[handy->i]);
		return(getatom());
	} else { 
		return(inewint(Xargc));
	}
}
/*
 * (chdir <atom>) executes a chdir command
 * if successful, return t otherwise returns nil
 */
lispval Lchdir(){
	register char *filenm;

	chkarg(1,"chdir");
	filenm = (char *) verify(lbot->val,"chdir - non symbol or string arg");
	if(chdir(filenm)>=0)
		return(tatom);
	else
		return(nil);
}

/* ==========================================================
-
-	ascii   - convert from number to ascii character
-
- form:(ascii number)
-
-	the number is checked so that it is in the range 0-255
- then it is made a character and returned
- =========================================================*/

lispval
Lascii() 
{
	register lispval handy;

	handy = lbot->val;		/* get argument */

	if(TYPE(handy) != INT)		/* insure that it is an integer */
	{	error("argument not an integer",FALSE);
		return(nil);
	}

	if(handy->i < 0 || handy->i > 0377)	/* insure that it is in range*/
	{	error("argument is out of ascii range",FALSE);
		return(nil);
	}

	strbuf[0] = handy->i ;	/* ok value, make into a char */
	strbuf[1] = NULL_CHAR;

	/* lookup and possibly intern the atom given in strbuf */

	return( (lispval) getatom() );
}

/*
 *  boole - maclisp bitwise boolean function
 *  (boole k x y) where k determines which of 16 possible bitwise 
 *  truth tables may be applied.  Common values are 1 (and) 6 (xor) 7 (or)
 *  the result is mapped over each pair of bits on input
 */
lispval
Lboole(){
	register x, y;
	register lispval result;
	register struct argent *mynp;
	int k;

	if(np - lbot < 3)
		error("Boole demands at least 3 args",FALSE);
	mynp = lbot+AD;
	k = mynp->val->i & 15;
	x = (mynp+1)->val->i;
	for(mynp += 2; mynp < np; mynp++) {
		y = mynp->val->i;
		switch(k) {

		case 0: x = 0;
			break;
		case 1: x = x & y;
			break;
		case 2:	x = y & ~x;
			break;
		case 3:	x = y;
			break;
		case 4: x = x & ~y;
			break;
		/* case 5:	x = x; break; */
		case 6:	x = x ^ y;
			break;
		case 7:	x = x | y;
			break;
		case 8: x = ~(x | y);
			break;
		case 9: x = ~(x ^ y);
			break;
		case 10: x = ~x;
			break;
		case 11: x = ~x | y;
			break;
		case 12: x = ~y;
			break;
		case 13: x = x | ~y;
			break;
		case 14: x = ~x | ~y;
			break;
		case 15: x = -1;
		}
	}
	return(inewint(x));
}
lispval
Lfact()
{
	register lispval result, handy;
	register itemp;
	snpand(3); /* fixup entry mask */

	result = lbot->val;
	if(TYPE(result)!=INT) error("Factorial of Non-fixnum.  If you want me\
to calculate fact of > 2^30 We will be here till doomsday!.",FALSE);
	itemp = result->i;
	protect(result = newsdot());
	result->s.CDR=(lispval)0;
	result->i = 1;
	for(; itemp > 1; itemp--)
		dmlad(result,itemp,0);
	if(result->s.CDR) return(result);
	(handy = newint())->i = result->i;
	return(handy);
}
/*
 * fix -- maclisp floating to fixnum conversion
 * for the moment, mereley convert floats to ints.
 * eventual convert to bignum if too big to fit.
 */
 lispval Lfix() 
 {
	register lispval result, handy;

	chkarg(1,"fix");
	handy = lbot->val;
	switch(TYPE(handy)) {
	default:
		error("innaproriate arg to fix.",FALSE);
	case INT:
	case SDOT:
		return(handy);
	case DOUB:
		if(handy->r >= 0)
			return(inewint((int)handy->r));
		else
			return(inewint(((int)handy->r)-1));
	}
}
#define SIGFPE 8
#define B 1073741824.0
static double table[] = { 1.0, B, B*B, B*B*B, B*B*B*B, 0.0};

lispval
Lfloat()
{
	register lispval handy,result;
	register double sum = 0;
	register int count;
	chkarg(1,"float");
	handy = lbot->val;
	switch(TYPE(handy))
	{
	  case DOUB: return(handy);


	  case INT:  result = newdoub();
		     result->r = (double) handy->i;
		     return(result);
	  case SDOT: 
	  {
		for(handy = lbot->val, count = 0;
		    count < 5;
		    count++, handy = handy->s.CDR) {
			sum += handy->s.I * table[count];
			if(handy->s.CDR==(lispval)0) goto done;
		}
		kill(getpid(),SIGFPE);
	done:
		result = newdoub();
		result->r = sum;
		return(result);
	}
	  default: errorh(Vermisc,"Bad argument to float",nil,FALSE,0,handy);
	}
}


/* Lbreak ***************************************************************/
/* If first argument is not nil, this is evaluated and printed.  Then	*/
/* error is called with the "breaking" message.				*/
lispval Lbreak() {
	register lispval hold;

	if (np > lbot) {
		printr(lbot->val,poport);
		dmpport(poport);
	}
	return(error("",TRUE));
}


lispval LDivide() {
	register lispval result, work, temp;
	register struct argent *mynp;
	register struct argent *lbot, *np;
	int typ;
	lispval quo, rem; struct sdot dummy;

	chkarg(2,"Divide");
	mynp = lbot;
	result = mynp->val;
	work = (mynp+1)->val;

	if((typ=TYPE(result))==INT) {
		protect(temp=newsdot());
		temp->i	= result->i;
		result = temp;
	} else if (typ!=SDOT)
		error("First arg to divide neither a bignum nor int.",FALSE);
	typ = TYPE(work);
	if(typ != INT && typ != SDOT)
		error("second arg to Divide neither an sdot nor an int.",FALSE);
	if(typ == INT) {
		dummy.CDR = (lispval) 0;
		dummy.I = work->i;
		work = (lispval) &dummy;
	}
	divbig(result,work, &quo, &rem);
	protect(quo);
	if(rem==((lispval) &dummy))
		protect(rem = inewint(dummy.I));
	protect(result = work = newdot());
	work->d.car = quo;
	(work->d.cdr = newdot())->d.car = rem;
	return(result);
}

lispval LEmuldiv(){
	register struct argent * mynp = lbot+AD;
	register lispval work, result;
	int quo, rem;
	snpand(3); /* fix register mask */

	/* (Emuldiv mul1 mult2 add quo) => 
		temp = mul1 + mul2 + sext(add);
		result = (list temp/quo temp%quo);
		to mix C and lisp a bit */

	Imuldiv(mynp[0].val->i, mynp[1].val->i, mynp[2].val->i,
		mynp[3].val->i, &quo, &rem);
	protect(result=newdot());
	(result->d.car=inewint(quo));
	work = result->d.cdr = newdot();
	(work->d.car=inewint(rem));
	return(result);
}
static Imuldiv() {
asm("	emul	4(ap),8(ap),12(ap),r0");
asm("	ediv	16(ap),r0,*20(ap),*24(ap)");
}
Commit	Line	Data
31cef89c BJ	1	static char *sccsid = "@(#)lam5.c 34.1 10/3/80";
31cef89c BJ	2
654e6e2d JF	3	#include "global.h"
	4	#include "chkrtab.h"
	5
	6	/*===========================================
	7	-
31cef89c BJ	8	- explode functions: aexplode , aexplodec, aexploden
	9	- The following function partially implement the explode functions for atoms.
	10	- The full explode functions are written in lisp and call these for atom args.
654e6e2d JF	11	-
	12	-===========================================*/
	13
	14	#include "chars.h"
	15	lispval
	16	Lexpldx(kind,slashify)
31cef89c BJ	17	int kind, slashify; /* kind = 0 => explode to characters
	18	= 1 => explode to fixnums (aexploden)
	19	slashify = 0 => do not quote bizarre characters
	20	= 1 => quote bizarre characters
	21	*/
654e6e2d JF	22	{
	23	int typ, i;
	24	char ch, strb, strbb[BUFSIZ]; / temporary string buffer */
	25	register lispval last, handy;
31cef89c	26	register char *cp;
654e6e2d JF	27	char Idqc = Xdqc;
	28	snpand(4); /* kludge register save mask */
	29
31cef89c	30	chkarg(1,"expldx");
654e6e2d	31
31cef89c	32	handy = Vreadtable->a.clb;
654e6e2d JF	33	chkrtab(handy);
	34	handy = lbot->val;
	35	*strbuf = 0;
	36	typ=TYPE(handy); /* we only work for a few types */
	37
	38
	39	/* put the characters to return in the string buffer strb */
	40
	41	switch(typ) {
	42	case STRNG:
31cef89c BJ	43	if(slashify && !Xsdc)
	44	errorh(Vermisc,"Can't explode without string delimiter",nil
	45	,FALSE,0,handy);
	46
	47	strb = strbb;
	48	if(slashify) *strb++ = Xsdc;
	49	/* copy string into buffer, escape only occurances of the
	50	double quoting character if in slashify mode
	51	*/
	52	for(cp = (char ) handy; cp; cp++)
	53	{
	54	if(slashify &&
	55	(cp == Xsdc \|\| ctable[cp]==VESC))
	56	*strb++ = Xesc;
	57	strb++ = cp;
	58	}
	59	if(slashify) *strb++ = Xsdc;
	60	*strb = NULL_CHAR ;
	61	strb = strbb;
	62	break;
	63
654e6e2d	64	case ATOM:
31cef89c	65	strb = handy->a.pname;
654e6e2d JF	66	if(strb[0]==0) {
	67	strb = strbb;
	68	strbb[0] = Xdqc;
	69	strbb[1] = Xdqc;
	70	strbb[2] = 0;
	71	} else
	72	common:
	73	if(slashify != 0)
	74	{
31cef89c	75	register char *out = strbb;
654e6e2d JF	76	cp = strb;
	77	strb = strbb;
	78	if(ctable[(*cp)&0177]==VNUM)
	79	*out++ = Xesc;
	80	for(; *cp; cp++)
	81	{
	82	if(ctable[*cp]& QUTMASK)
	83	*out++ = Xesc;
	84	out++ = cp;
	85	}
	86	*out = 0;
	87	}
	88
	89	break;
	90	case INT:
	91	strb = strbb;
	92	sprintf(strb, "%d", lbot->val->i);
	93	break;
	94	case DOUB:
	95	strb = strbb;
31cef89c	96	lfltpr(strb, lbot->val->r);
654e6e2d JF	97	break;
	98	case SDOT:
	99	{
	100	struct _iobuf _strbuf;
	101	register count;
	102	for((handy = lbot->val), count = 12;
31cef89c BJ	103	handy->s.CDR!=(lispval) 0;
31cef89c BJ	104	(handy = handy->s.CDR), count += 12);
654e6e2d JF	105	strb = (char *) alloca(count);
	106
	107	_strbuf._flag = _IOWRT+_IOSTRG;
	108	_strbuf._ptr = strb;
	109	_strbuf._cnt = count;
	110	pbignum(lbot->val,&_strbuf);
654e6e2d JF	111	putc(0,&_strbuf);
	112	break;
	113	}
	114	default:
	115	errorh(Vermisc,"EXPLODE ARG MUST BE STRING, SYMBOL, FIXNUM, OR FLONUM",nil,FALSE,0,handy);
	116	return(nil);
	117	}
	118
	119
	120	if( strb[0] != NULL_CHAR ) /* if there is something to do */
	121	{
	122	register lispval prev;
	123
	124	protect(handy = last = newdot());
	125	strbuf[1] = NULL_CHAR ; /* set up for getatom */
	126	atmlen = 2;
	127
	128	for(i=0; ch = strb[i++]; ) {
	129	switch(kind) {
	130
	131	case 0: strbuf[0] = hash = ch; /* character explode */
31cef89c	132	last->d.car = (lispval) getatom(); /* look in oblist */
654e6e2d JF	133	break;
	134
	135	case 1:
31cef89c	136	last->d.car = inewint(ch);
654e6e2d JF	137	break;
	138	}
	139
	140	/* advance pointers */
	141	prev = last;
31cef89c BJ	142	last->d.cdr = newdot();
31cef89c BJ	143	last = last->d.cdr;
654e6e2d JF	144	}
	145
	146	/* end list with a nil pointer */
31cef89c	147	prev->d.cdr = nil;
654e6e2d JF	148	return(handy);
	149	}
	150	else return(nil); /* return nil if no characters */
	151	}
	152
	153	/*===========================
	154	-
31cef89c BJ	155	- (aexplodec 'atm) returns (a t m)
31cef89c BJ	156	- (aexplodec 234) returns (\2 \3 \4)
654e6e2d JF	157	-===========================*/
	158
	159	lispval
	160	Lexpldc()
	161	{ return(Lexpldx(0,0)); }
	162
	163
	164	/*===========================
	165	-
31cef89c BJ	166	- (aexploden 'abc) returns (65 66 67)
31cef89c BJ	167	- (aexploden 123) returns (49 50 51)
654e6e2d JF	168	-=============================*/
	169
	170
	171	lispval
	172	Lexpldn()
	173	{ return(Lexpldx(1,0)); }
	174
	175	/*===========================
	176	-
31cef89c BJ	177	- (aexplode "123") returns (\\ \1 \2 \3);
31cef89c BJ	178	- (aexplode 123) returns (\1 \2 \3);
654e6e2d JF	179	-=============================*/
	180
	181	lispval
	182	Lexplda()
	183	{ return(Lexpldx(0,1)); }
	184
	185	/*
	186	* (argv) returns how many arguments where on the command line which invoked
	187	* lisp; (argv i) returns the i'th argument made into an atom;
	188	*/
	189
	190	lispval
	191	Largv()
	192	{
	193	register lispval handy;
	194	register index;
31cef89c BJ	195	register char *base;
31cef89c BJ	196	char c;
654e6e2d JF	197	extern int Xargc;
654e6e2d JF	198	extern char **Xargv;
31cef89c	199	snpand(3);
654e6e2d	200
31cef89c	201	if(lbot-np==0)protect(nil);
654e6e2d JF	202	handy = lbot->val;
	203
	204	if(TYPE(handy)==INT && handy->i>=0 && handy->i<Xargc) {
	205	strcpy(strbuf,Xargv[handy->i]);
	206	return(getatom());
	207	} else {
	208	return(inewint(Xargc));
	209	}
	210	}
	211	/*
	212	* (chdir <atom>) executes a chdir command
	213	* if successful, return t otherwise returns nil
	214	*/
	215	lispval Lchdir(){
31cef89c	216	register char *filenm;
654e6e2d	217
31cef89c BJ	218	chkarg(1,"chdir");
	219	filenm = (char *) verify(lbot->val,"chdir - non symbol or string arg");
	220	if(chdir(filenm)>=0)
654e6e2d JF	221	return(tatom);
	222	else
	223	return(nil);
	224	}
	225
	226	/* ==========================================================
	227	-
	228	- ascii - convert from number to ascii character
	229	-
	230	- form:(ascii number)
	231	-
	232	- the number is checked so that it is in the range 0-255
	233	- then it is made a character and returned
	234	- =========================================================*/
	235
	236	lispval
	237	Lascii()
	238	{
	239	register lispval handy;
	240
	241	handy = lbot->val; /* get argument */
	242
	243	if(TYPE(handy) != INT) /* insure that it is an integer */
	244	{ error("argument not an integer",FALSE);
	245	return(nil);
	246	}
	247
	248	if(handy->i < 0 \|\| handy->i > 0377) /* insure that it is in range*/
	249	{ error("argument is out of ascii range",FALSE);
	250	return(nil);
	251	}
	252
	253	strbuf[0] = handy->i ; /* ok value, make into a char */
	254	strbuf[1] = NULL_CHAR;
	255
	256	/* lookup and possibly intern the atom given in strbuf */
	257
	258	return( (lispval) getatom() );
	259	}
	260
	261	/*
	262	* boole - maclisp bitwise boolean function
	263	* (boole k x y) where k determines which of 16 possible bitwise
	264	* truth tables may be applied. Common values are 1 (and) 6 (xor) 7 (or)
	265	* the result is mapped over each pair of bits on input
	266	*/
	267	lispval
	268	Lboole(){
	269	register x, y;
	270	register lispval result;
	271	register struct argent *mynp;
	272	int k;
	273
	274	if(np - lbot < 3)
	275	error("Boole demands at least 3 args",FALSE);
	276	mynp = lbot+AD;
	277	k = mynp->val->i & 15;
	278	x = (mynp+1)->val->i;
	279	for(mynp += 2; mynp < np; mynp++) {
	280	y = mynp->val->i;
	281	switch(k) {
	282
	283	case 0: x = 0;
	284	break;
285	case 1: x = x & y;
286	break;
287	case 2: x = y & ~x;
288	break;
289	case 3: x = y;
290	break;
291	case 4: x = x & ~y;
292	break;
293	/* case 5: x = x; break; */
294	case 6: x = x ^ y;
295	break;
296	case 7: x = x \| y;
297	break;
298	case 8: x = ~(x \| y);
299	break;
300	case 9: x = ~(x ^ y);
301	break;
302	case 10: x = ~x;
303	break;
304	case 11: x = ~x \| y;
305	break;
306	case 12: x = ~y;
307	break;
308	case 13: x = x \| ~y;
309	break;
310	case 14: x = ~x \| ~y;
311	break;
312	case 15: x = -1;
313	}
314	}
315	return(inewint(x));
316	}
317	lispval
318	Lfact()
319	{
320	register lispval result, handy;
321	register itemp;
322	snpand(3); /* fixup entry mask */
323
324	result = lbot->val;
325	if(TYPE(result)!=INT) error("Factorial of Non-fixnum. If you want me\
326	to calculate fact of > 2^30 We will be here till doomsday!.",FALSE);
327	itemp = result->i;
328	protect(result = newsdot());
31cef89c	329	result->s.CDR=(lispval)0;
654e6e2d JF	330	result->i = 1;
	331	for(; itemp > 1; itemp--)
	332	dmlad(result,itemp,0);
31cef89c	333	if(result->s.CDR) return(result);
654e6e2d JF	334	(handy = newint())->i = result->i;
	335	return(handy);
	336	}
	337	/*
	338	* fix -- maclisp floating to fixnum conversion
	339	* for the moment, mereley convert floats to ints.
	340	* eventual convert to bignum if too big to fit.
	341	*/
	342	lispval Lfix()
	343	{
	344	register lispval result, handy;
	345
31cef89c	346	chkarg(1,"fix");
654e6e2d JF	347	handy = lbot->val;
	348	switch(TYPE(handy)) {
	349	default:
	350	error("innaproriate arg to fix.",FALSE);
	351	case INT:
	352	case SDOT:
	353	return(handy);
	354	case DOUB:
	355	if(handy->r >= 0)
	356	return(inewint((int)handy->r));
	357	else
	358	return(inewint(((int)handy->r)-1));
	359	}
	360	}
31cef89c BJ	361	#define SIGFPE 8
	362	#define B 1073741824.0
	363	static double table[] = { 1.0, B, BB, BBB, BBBB, 0.0};
654e6e2d JF	364
	365	lispval
	366	Lfloat()
	367	{
	368	register lispval handy,result;
31cef89c BJ	369	register double sum = 0;
	370	register int count;
	371	chkarg(1,"float");
654e6e2d JF	372	handy = lbot->val;
	373	switch(TYPE(handy))
	374	{
	375	case DOUB: return(handy);
	376
	377
	378	case INT: result = newdoub();
	379	result->r = (double) handy->i;
	380	return(result);
31cef89c BJ	381	case SDOT:
	382	{
	383	for(handy = lbot->val, count = 0;
	384	count < 5;
	385	count++, handy = handy->s.CDR) {
	386	sum += handy->s.I * table[count];
	387	if(handy->s.CDR==(lispval)0) goto done;
	388	}
	389	kill(getpid(),SIGFPE);
	390	done:
	391	result = newdoub();
	392	result->r = sum;
	393	return(result);
	394	}
	395	default: errorh(Vermisc,"Bad argument to float",nil,FALSE,0,handy);
654e6e2d JF	396	}
	397	}
	398
31cef89c	399
654e6e2d JF	400	/* Lbreak ***************************************************************/
	401	/* If first argument is not nil, this is evaluated and printed. Then */
	402	/* error is called with the "breaking" message. */
	403	lispval Lbreak() {
	404	register lispval hold;
	405
	406	if (np > lbot) {
	407	printr(lbot->val,poport);
	408	dmpport(poport);
	409	}
	410	return(error("",TRUE));
	411	}
	412
	413
	414	lispval LDivide() {
	415	register lispval result, work, temp;
	416	register struct argent *mynp;
	417	register struct argent lbot, np;
	418	int typ;
	419	lispval quo, rem; struct sdot dummy;
	420
31cef89c	421	chkarg(2,"Divide");
654e6e2d JF	422	mynp = lbot;
	423	result = mynp->val;
	424	work = (mynp+1)->val;
	425
	426	if((typ=TYPE(result))==INT) {
	427	protect(temp=newsdot());
	428	temp->i = result->i;
	429	result = temp;
	430	} else if (typ!=SDOT)
	431	error("First arg to divide neither a bignum nor int.",FALSE);
	432	typ = TYPE(work);
	433	if(typ != INT && typ != SDOT)
	434	error("second arg to Divide neither an sdot nor an int.",FALSE);
	435	if(typ == INT) {
	436	dummy.CDR = (lispval) 0;
	437	dummy.I = work->i;
	438	work = (lispval) &dummy;
	439	}
	440	divbig(result,work, &quo, &rem);
	441	protect(quo);
	442	if(rem==((lispval) &dummy))
	443	protect(rem = inewint(dummy.I));
	444	protect(result = work = newdot());
31cef89c BJ	445	work->d.car = quo;
31cef89c BJ	446	(work->d.cdr = newdot())->d.car = rem;
654e6e2d JF	447	return(result);
654e6e2d JF	448	}
31cef89c	449
654e6e2d JF	450	lispval LEmuldiv(){
	451	register struct argent * mynp = lbot+AD;
	452	register lispval work, result;
	453	int quo, rem;
	454	snpand(3); /* fix register mask */
	455
	456	/* (Emuldiv mul1 mult2 add quo) =>
	457	temp = mul1 + mul2 + sext(add);
	458	result = (list temp/quo temp%quo);
	459	to mix C and lisp a bit */
	460
	461	Imuldiv(mynp[0].val->i, mynp[1].val->i, mynp[2].val->i,
	462	mynp[3].val->i, &quo, &rem);
	463	protect(result=newdot());
31cef89c BJ	464	(result->d.car=inewint(quo));
	465	work = result->d.cdr = newdot();
	466	(work->d.car=inewint(rem));
654e6e2d JF	467	return(result);
	468	}
	469	static Imuldiv() {
	470	asm(" emul 4(ap),8(ap),12(ap),r0");
	471	asm(" ediv 16(ap),r0,20(ap),24(ap)");
	472	}
	473
	474