BSD 4_4 development

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

#ifndef lint
static char *rcsid =
   "$Header: lam5.c,v 1.8 87/12/14 18:47:45 sklower Exp $";
#endif

/*					-[Fri Aug  5 12:49:06 1983 by jkf]-
 * 	lam5.c				$Locker:  $
 * lambda functions
 *
 * (c) copyright 1982, Regents of the University of California
 */

#include "global.h"
#include "chkrtab.h"
#include <ctype.h>
char *strcpy();

/*===========================================
-
-	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], *alloca();  /* temporary string buffer */
	register lispval last, handy;
	extern int uctolc;
	register char *cp;
	Savestack(3); /* kludge register save mask */
#ifdef SPISFP
	Keepxs();
#endif

	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)
		    errorh1(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 || synclass(ctable[*cp])==CESC))
			 *strb++ = Xesc;
		  *strb++ = *cp;
		}
		if(slashify) *strb++ = Xsdc;
		*strb = NULL_CHAR ;
		strb = strbb;
		break;

	case ATOM:
		strb = handy->a.pname;
		if(slashify && (strb[0]==0)) {
			strb = strbb;
			strbb[0] = Xdqc;
			strbb[1] = Xdqc;
			strbb[2] = 0;
		} else
	/*common:*/
		if(slashify != 0)
		{
			char *out = strbb;
			unsigned char code;

			cp = strb;
			strb = strbb;
			code = ctable[(*cp)&0177];
			switch(synclass(code)) {
			case CNUM:
				*out++ = Xesc;
				break;
			case CCHAR:
				if(uctolc && isupper((*cp)&0177)) {
				    *out++ = Xesc;
				}
				break;
			default:
			    switch(code&QUTMASK) {
			    case QWNUNIQ:
				    if (cp[1]==0) *out++ = Xesc;
				    break;
			    case QALWAYS:
			    case QWNFRST:
				    *out++ = Xesc;
			    }
			}
			*out++ = *cp++;
			for(; *cp; cp++)
			{
				if(((ctable[*cp]&QUTMASK)==QALWAYS) ||
				   (uctolc && isupper(*cp)))
					*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;
		int count;
		for((handy = lbot->val), count = 12;
		    handy->s.CDR!=(lispval) 0;
		    (handy = handy->s.CDR), count += 12);
		strb = alloca(count);

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


	if( strb[0] != NULL_CHAR )	/* if there is something to do */
	{
	    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(TRUE); /* 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;
	    Freexs();
	    Restorestack();
	    return(handy);
	}
	Freexs();
	Restorestack();
	return(nil);	/* return nil if no characters */
}

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

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


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


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

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

lispval
Lxplda()
{ 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;
	extern int Xargc;
	extern char **Xargv;

	if(lbot-np==0)handy = nil;
	else handy = lbot->val;
	
	if(TYPE(handy)==INT && handy->i>=0 && handy->i<Xargc) {
		strcpy(strbuf,Xargv[handy->i]);
		return(getatom(FALSE));
	} 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(TRUE) );
}

/*
 *  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 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;
	Savestack(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,(long)itemp,0L);
	if(result->s.CDR) 
	{
	    Restorestack();
	    return(result);
	}
	handy = inewint(result->s.I);
	pruneb(result);
	Restorestack();
	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 handy;
	double floor();

	chkarg(1,"fix");
	handy = lbot->val;
	switch(TYPE(handy)) {
	default:
		error("innaproriate arg to fix.",FALSE);
	case INT:
	case SDOT:
		return(handy);
	case DOUB:
		return(inewint((int)floor(handy->r)));
	}
}
/*
 * (frexp <real no>)
 * returns a dotted pair (<exponent>. <bignum>)
 * such that bignum is 56 bits long, and if you think of the binary
 * point occuring after the high order bit, <real no> = 2^<exp> * <bignum>
 *
 * myfrexp is an assembly language routine found in bigmath.s to do exactly
 * what is necessary to accomplish this.
 * this routine is horribly vax specific.
 *
 * Lfix should probably be rewritten to take advantage of myfrexp
 */
lispval
Lfrexp()
{
	register lispval handy, result;
	int exp, hi, lo;

	Savestack(2);
	chkarg(1,"frexp");

	myfrexp(lbot->val->r, &exp, &hi, &lo);
	if(lo < 0) {
		/* normalize for bignum */
		lo &= ~ 0xC0000000;
		hi += 1;
	}
	result = handy = newdot(); 
	protect(handy);
	handy->d.car = inewint(exp);
	if(hi==0&&lo==0) {
		handy->d.cdr = inewint(0);
	} else {
		handy = handy->d.cdr = newsdot();
		handy->s.I = lo;
		handy = handy->s.CDR = newdot();
		handy->s.I = hi;
		handy->s.CDR = 0;
	}
	np--;
	Restorestack();
	return(result);
}

#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: errorh1(Vermisc,"Bad argument to float",nil,FALSE,0,handy);
	  /* NOTREACHED */
	}
}
double
Ifloat(handy)
register lispval handy;
{
	register double sum = 0.0; register int count=0;
	for(; 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:
	return(sum);
}

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

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


lispval
LDivide() {
	register lispval result, work;
	register struct argent *mynp;
	lispval quo, rem, arg1, arg2; struct sdot dummy, dum2;
	Savestack(3);

	chkarg(2,"Divide");
	mynp = lbot;
	work = mynp++->val;
	switch(TYPE(work)) {
	case INT:
		arg1 = (lispval) &dummy;
		dummy.I = work->i;
		dummy.CDR = (lispval) 0;
		break;
	case SDOT:
		arg1 = work;
		break;
	urk:
	default:
		error("First arg to divide neither a bignum nor int.",FALSE);
	}
	work = mynp->val;
	switch(TYPE(work)) {
	case INT:
		arg2 = (lispval) &dum2;
		dum2.I = work->i;
		dum2.CDR = (lispval) 0;
		break;
	case SDOT:
		arg2 = work;
		break;
	default:
		goto urk;
	}
	divbig(arg1,arg2, &quo, &rem);
	protect(quo);
	if(rem==((lispval)&dummy))
		rem = inewint(dummy.I);
	protect(rem);
	protect(result = work = newdot());
	work->d.car = quo;
	(work->d.cdr = newdot())->d.car = rem;
	Restorestack();
	return(result);
}

lispval LEmuldiv(){
	register struct argent * mynp = lbot+AD;
	register lispval work, result;
	int quo, rem;
	Savestack(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));
	Restorestack();
	return(result);
}