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

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

/*===========================================
-
-	explode functions
- The following function partially implement two explode functions,
- explodec and exploden.  They only work for atom arguments.
-
-===========================================*/

#include "chars.h"
lispval
Lexpldx(kind,slashify)
int kind, slashify; 	/* 0=explodec   1=exploden  */
{
	int typ, i;
	char ch, *strb, strbb[BUFSIZ];  /* temporary string buffer */
	register lispval last, handy;
	char Idqc = Xdqc;
	snpand(4); /* kludge register save mask */

	chkarg(1);

	handy = Vreadtable->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:
		strb = (char *) handy;
		if(Xsdc)Idqc = Xsdc;
		goto common;
	case ATOM:
		strb = handy->pname;
		if(strb[0]==0) {
			strb = strbb;
			strbb[0] = Xdqc;
			strbb[1] = Xdqc;
			strbb[2] = 0;
		} else
	common:
		if(slashify != 0)
		{
			register char *cp, *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;
		sprintf(strb, "%0.16G", lbot->val->r);
		break;
	case SDOT:
	{
		struct _iobuf _strbuf;
		register count;
		for((handy = lbot->val), count = 12;
		    handy->CDR!=(lispval) 0;
		    (handy = handy->CDR), count += 12);
		strb = (char *) alloca(count);

		_strbuf._flag = _IOWRT+_IOSTRG;
		_strbuf._ptr = strb;
		_strbuf._cnt = count;
		pbignum(lbot->val,&_strbuf);
		putc('.',&_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 */
			  hash = 177 & hash;	/* cut 1st bit off if any */
			  last->car = (lispval) getatom(); /* look in oblist */
			  break;

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

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

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

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

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


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


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

/*===========================
-
- (explodea "123")  returns (\\ \1 \2 \3);
- (explodea 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 c, *base;
	extern int Xargc;
	extern char **Xargv;

	chkarg(1);
	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 lispval handy;

	chkarg(1);
	handy=lbot->val;
	if(TYPE(handy)==ATOM && (chdir(handy->pname)>=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->CDR=(lispval)0;
	result->i = 1;
	for(; itemp > 1; itemp--)
		dmlad(result,itemp,0);
	if(result->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);
	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));
	}
}

lispval
Lfloat()
{
	register lispval handy,result;
	chkarg(1);
	handy = lbot->val;
	switch(TYPE(handy))
	{
	  case DOUB: return(handy);


	  case INT:  result = newdoub();
		     result->r = (double) handy->i;
		     return(result);
		     

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