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

# include "global.h"
lispval
Lalfalp()
{
	register lispval first, second;
	register struct argent *inp;
	snpand(3); /* clobber save mask */

	chkarg(2);
	inp = lbot;
	first = (inp)->val;
	second = (inp+1)->val;
	if( (TYPE(first))!=ATOM || (TYPE(second))!=ATOM)
		error("alphalessp expects atoms");
	if(strcmp(first->pname,second->pname) <= 0)
		return(tatom);
	else
		return(nil);
}

lispval
Lncons()
{
	register lispval handy;
	snpand(1); /* clobber save mask */

	chkarg(1);
	handy = newdot();
	handy -> cdr = nil;
	handy -> car = lbot->val;
	return(handy);
}
lispval
Lzerop()
{
	register lispval handy;
	snpand(1); /* clobber save mask */

	chkarg(1);
	handy = lbot->val;
	switch(TYPE(handy)) {
	case INT:
		return(handy->i==0?tatom:nil);
	case DOUB:
		return(handy->r==0.0?tatom:nil);
	}
	return(nil);
}
lispval
Lonep()
{
	register lispval handy; lispval Ladd();
	snpand(1); /* clobber save mask */

	chkarg(1);
	handy = lbot->val;
	switch(TYPE(handy)) {
	case INT:
		return(handy->i==1?tatom:nil);
	case DOUB:
		return(handy->r==1.0?tatom:nil);
	case SDOT:
		protect(inewint(0));
		handy = Ladd();
		if(TYPE(handy)!=INT || handy->i !=1)
			return(nil);
		else
			return(tatom);
	}
	return(nil);
}

lispval
cmpx(lssp)
{
	register struct argent *argp;
	register struct argent *outarg;
	register struct argent *handy;
	register count;
	register struct argent *lbot;
	register struct argent *np;
	struct argent *onp = np;


	argp = lbot + 1;
	outarg = np;
	while(argp < onp) {

		np = outarg + 2;
		lbot = outarg;
		if(lssp)
			*outarg = argp[-1], outarg[1]  = *argp++;
		else
			outarg[1]  = argp[-1], *outarg = *argp++;
		lbot->val = Lsub();
		np = lbot + 1;
		if(Lnegp()==nil) return(nil);
	}
	return(tatom);
}

lispval
Lgreaterp()
{
	return(cmpx(FALSE));
}

lispval
Llessp()
{
	return(cmpx(TRUE));
}

lispval
Ldiff()
{
	register lispval arg1,arg2; register handy = 0;
	snpand(3); /* clobber save mask */


	chkarg(2);
	arg1 = lbot->val;
	arg2 = (lbot+1)->val;
	if(TYPE(arg1)==INT && TYPE(arg2)==INT) {
		handy=arg1->i - arg2->i;
	}
	else error("non-numeric argument",FALSE);
	return(inewint(handy));
}

lispval
Lmod()
{
	register lispval arg1,arg2; lispval  handy;
	struct sdot fake1, fake2;
	fake2.CDR = 0;
	fake1.CDR = 0;
	snpand(2); /* clobber save mask */

	chkarg(2);
	handy = arg1 = lbot->val;
	arg2 = (lbot+1)->val;
	switch(TYPE(arg1)) {
	case SDOT:
		break;
	case INT:
		fake1.I = arg1->i;
		arg1 =(lispval) &fake1;
		break;
	default:
		error("non-numeric argument",FALSE);
	}
	switch(TYPE(arg2)) {
	case SDOT:
		break;
	case INT:
		fake2.I = arg2->i;
		arg2 =(lispval) &fake2;
		break;
	default:
		error("non-numeric argument",FALSE);
	}
		if(Lzerop()!=nil) return(handy);
		divbig(arg1,arg2,0,&handy);
		if(handy==((lispval)&fake1))
			handy = inewint(fake1.I);
		if(handy==((lispval)&fake2))
			handy = inewint(fake2.I);
		return(handy);

}


lispval
Ladd1()
{
	register lispval handy;
	lispval Ladd();
	snpand(1); /* fixup entry mask */

	handy = rdrint;
	handy->i = 1;
	protect(handy);
	return(Ladd());

}

lispval
Lsub1()
{
	register lispval handy;
	lispval Ladd();
	snpand(1); /* fixup entry mask */

	handy = rdrint;
	handy->i = - 1;
	protect(handy);
	return(Ladd());
}

lispval
Lminus()
{
	register lispval arg1, handy;
	register temp;
	lispval subbig();
	snpand(3); /* clobber save mask */

	chkarg(1);
	arg1 = lbot->val;
	handy = nil;
	switch(TYPE(arg1)) {
	case INT:
		handy= inewint(0 - arg1->i);
		break;
	case DOUB:
		handy = newdoub();
		handy->r = -arg1->r;
		break;
	case SDOT:
		handy = rdrsdot;
		handy->I = 0;
		handy->CDR = (lispval) 0;
		handy = subbig(handy,arg1);
		break;

	default:
		error("non-numeric argument",FALSE);
	}
	return(handy);
}

lispval
Lnegp()
{
	register lispval handy = np[-1].val, work;
	register flag = 0;
	snpand(3); /* clobber save mask */

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->CDR!=(lispval) 0; work = work->CDR);
		if(work->I < 0) flag = TRUE;
		break;
	default:
		handy = errorh(Vermisc,
				  "minusp: Non-(int,real,bignum) arg: ",
				  nil,
				  TRUE,
				  0,
				  handy);
		goto loop;
	}
	if(flag) return(tatom);
	return(nil);
}

lispval
Labsval()
{
	register lispval arg1, handy;
	register temp;
	snpand(3); /* clobber save mask */

	chkarg(1);
	arg1 = lbot->val;
	if(Lnegp()!=nil) return(Lminus());

	return(arg1);
}

#include "frame.h"
/* new version of showstack,
	We will set fp to point where the register fp points.
	Then fp+2 = saved ap
	     fp+4 = saved pc
	     fp+3 = saved fp
	     ap+1 = first arg
	If we find that the saved pc is somewhere in the routine eval,
   then we print the first argument to that eval frame. This is done
   by looking one beyond the saved ap.
*/
lispval
Lshostk()
{	lispval isho();
	return(isho(1));
}
static lispval
isho(f)
int f;
{
	register struct frame *myfp; register lispval handy;
	int **fp;	/* this must be the first local */
	int virgin=1;
	lispval _qfuncl(),tynames();	/* locations in qfuncl */

	if(f==1)
		printf("Forms in evaluation:\n");
	else
		printf("Backtrace:\n\n");

	myfp = (struct frame *) (&fp +1);	/* point to current frame */

	while(TRUE)
	{
	    if( (myfp->pc > eval  &&  		/* interpreted code */
		 myfp->pc < popnames)
		||
		(myfp->pc > _qfuncl &&		/* compiled code */
		 myfp->pc < tynames)  )
	    {
		handy = (myfp->ap[1]);
		if(f==1)
			printr(handy,stdout), putchar('\n');
		else {
			if(virgin)
				virgin = 0;
			else
				printf(" -- ");
			printr((TYPE(handy)==DTPR)?handy->car:handy,stdout);
		}

	    }

	    if(myfp > myfp->fp) break;	/* end of frames */
	    else myfp = myfp->fp;
	}
	putchar('\n');
	return(nil);
}
lispval
Lbaktrace()
{
	isho(0);
}
/* ===========================================================
-
**** baktrace ****	(moved back by kls)
-
- baktrace will print the names of all functions being evaluated
- from the current one (baktrace) down to the first one.
- currently it only prints the function name.  Planned is a
- list of local variables in all stack frames.
- written by jkf.
-
-============================================================*/

/*=============================================================
-
-***  oblist ****
-
- oblist returns a list of all symbols in the oblist
-
- written by jkf.
============================================================*/

lispval
Loblist()
{
    int indx;
    lispval headp, tailp ;
    struct atom *symb ;

    headp = tailp = newdot(); /* allocate first DTPR */
    protect(headp);		/*protect the list from garbage collection*/
				/*line added by kls			  */

    for( indx=0 ; indx <= HASHTOP-1 ; indx++ ) /* though oblist */
    {
	for( symb = hasht[indx] ;
	     symb != (struct atom *) CNIL ;
	     symb = symb-> hshlnk)
	{
	    tailp->car = (lispval) symb  ; /* remember this atom */
	    tailp = tailp->cdr = newdot() ; /* link to next DTPR */
	}
    }

    tailp->cdr = nil ; /* close the list unfortunately throwing away
			  the last DTPR
			  */
    return(headp);
}

/*
 * Maclisp setsyntax function:
 *    (setsyntax c s x)
 * c represents character either by fixnum or atom
 * s is the atom "macro" or the atom "splicing" (in which case x is the
 * macro to be invoked); or nil (meaning don't change syntax of c); or
 * (well thats enough for now) if s is a fixnum then we modify the bits
 * for c in the readtable.
 */
#define VMAC	0316
#define VSPL	0315
#define VDQ     0212
#define VESC	0217
#include "chkrtab.h"

lispval
Lsetsyn()
{
	register lispval s, c;
	register struct argent *mynp;
	register index;
	register struct argent *lbot, *np;
	lispval x;
	extern char *ctable;
	int value;

	chkarg(3);
	s = Vreadtable->clb;
	chkrtab(s);
	mynp = lbot;
	c = (mynp++)->val;
	s = (mynp++)->val;
	x = (mynp++)->val;

	switch(TYPE(c)) {
	default:
		error("neither fixnum nor atom as char to setsyntax",FALSE);

	case ATOM:
		index = *(c->pname);
		if((c->pname)[1])error("Only 1 char atoms to setsyntax",FALSE);
		break;

	case INT:
		index = c->i;
	}
	switch(TYPE(s)) {
	case INT:
		if(s->i == VESC) Xesc = (char) index;
		else if(s->i == VDQ) Xdqc = (char) index;

		if(ctable[index] == VESC   /* if we changed the current esc */
		  && s->i != VESC          /* to something else, pick current */
		  && Xesc == (char) index) {
	       		ctable[index] = s->i;
			rpltab(VESC,&Xesc);
		}
		else if(ctable[index] == VDQ   /*  likewise for double quote */
		       && s->i != VDQ
		       && Xdqc == (char) index)  {
			ctable[index] = s->i;
			rpltab(VDQ,&Xdqc);
		}
		else ctable[index] = s->i;

		break;
	case ATOM:
		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());
		}
		Iputprop(c,x,macro);
	}
	return(tatom);
}


/* this aux function is used by setsyntax to determine the new current
   escape or double quote character.  It scans the character table for
   the first character with the given class (either VESC or VDQ) and
   puts that character in Xesc or Xdqc (whichever is pointed to by
   addr).
*/
rpltab(cclass,addr)
char cclass;
char *addr;
{
	register int i;
	extern char *ctable;
	for(i=0; i<=127 && ctable[i] != cclass; i++);
	if(i<=127) *addr = (char) i;
	else *addr = '\0';
}


lispval
Lzapline()
{
	register FILE *port;
	extern FILE * rdrport;

	port = rdrport;
	while (!feof(port) && (getc(port)!='\n') );
	return(nil);
}
Commit	Line	Data
8cd657f4 JF	1	# include "global.h"
	2	lispval
	3	Lalfalp()
	4	{
	5	register lispval first, second;
	6	register struct argent *inp;
	7	snpand(3); /* clobber save mask */
	8
	9	chkarg(2);
	10	inp = lbot;
	11	first = (inp)->val;
	12	second = (inp+1)->val;
	13	if( (TYPE(first))!=ATOM \|\| (TYPE(second))!=ATOM)
	14	error("alphalessp expects atoms");
	15	if(strcmp(first->pname,second->pname) <= 0)
	16	return(tatom);
	17	else
	18	return(nil);
	19	}
	20
	21	lispval
	22	Lncons()
	23	{
	24	register lispval handy;
	25	snpand(1); /* clobber save mask */
	26
	27	chkarg(1);
	28	handy = newdot();
	29	handy -> cdr = nil;
	30	handy -> car = lbot->val;
	31	return(handy);
	32	}
	33	lispval
	34	Lzerop()
	35	{
	36	register lispval handy;
	37	snpand(1); /* clobber save mask */
	38
	39	chkarg(1);
	40	handy = lbot->val;
	41	switch(TYPE(handy)) {
	42	case INT:
	43	return(handy->i==0?tatom:nil);
	44	case DOUB:
	45	return(handy->r==0.0?tatom:nil);
	46	}
	47	return(nil);
	48	}
	49	lispval
	50	Lonep()
	51	{
	52	register lispval handy; lispval Ladd();
	53	snpand(1); /* clobber save mask */
	54
	55	chkarg(1);
	56	handy = lbot->val;
	57	switch(TYPE(handy)) {
	58	case INT:
	59	return(handy->i==1?tatom:nil);
	60	case DOUB:
	61	return(handy->r==1.0?tatom:nil);
	62	case SDOT:
	63	protect(inewint(0));
	64	handy = Ladd();
65	if(TYPE(handy)!=INT \|\| handy->i !=1)
66	return(nil);
67	else
68	return(tatom);
69	}
70	return(nil);
71	}
72
73	lispval
74	cmpx(lssp)
75	{
76	register struct argent *argp;
77	register struct argent *outarg;
78	register struct argent *handy;
79	register count;
80	register struct argent *lbot;
81	register struct argent *np;
82	struct argent *onp = np;
83
84
85	argp = lbot + 1;
86	outarg = np;
87	while(argp < onp) {
88
89	np = outarg + 2;
90	lbot = outarg;
91	if(lssp)
92	outarg = argp[-1], outarg[1] = argp++;
93	else
94	outarg[1] = argp[-1], outarg = argp++;
95	lbot->val = Lsub();
96	np = lbot + 1;
97	if(Lnegp()==nil) return(nil);
98	}
99	return(tatom);
100	}
101
102	lispval
103	Lgreaterp()
104	{
105	return(cmpx(FALSE));
106	}
107
108	lispval
109	Llessp()
110	{
111	return(cmpx(TRUE));
112	}
113
114	lispval
115	Ldiff()
116	{
117	register lispval arg1,arg2; register handy = 0;
118	snpand(3); /* clobber save mask */
119
120
121	chkarg(2);
122	arg1 = lbot->val;
123	arg2 = (lbot+1)->val;
124	if(TYPE(arg1)==INT && TYPE(arg2)==INT) {
125	handy=arg1->i - arg2->i;
126	}
127	else error("non-numeric argument",FALSE);
128	return(inewint(handy));
129	}
130
131	lispval
132	Lmod()
133	{
134	register lispval arg1,arg2; lispval handy;
135	struct sdot fake1, fake2;
136	fake2.CDR = 0;
137	fake1.CDR = 0;
138	snpand(2); /* clobber save mask */
139
140	chkarg(2);
141	handy = arg1 = lbot->val;
142	arg2 = (lbot+1)->val;
143	switch(TYPE(arg1)) {
144	case SDOT:
145	break;
146	case INT:
147	fake1.I = arg1->i;
148	arg1 =(lispval) &fake1;
149	break;
150	default:
151	error("non-numeric argument",FALSE);
152	}
153	switch(TYPE(arg2)) {
154	case SDOT:
155	break;
156	case INT:
157	fake2.I = arg2->i;
158	arg2 =(lispval) &fake2;
159	break;
160	default:
161	error("non-numeric argument",FALSE);
162	}
163	if(Lzerop()!=nil) return(handy);
164	divbig(arg1,arg2,0,&handy);
165	if(handy==((lispval)&fake1))
166	handy = inewint(fake1.I);
167	if(handy==((lispval)&fake2))
168	handy = inewint(fake2.I);
169	return(handy);
170
171	}
172
173
174	lispval
175	Ladd1()
176	{
177	register lispval handy;
178	lispval Ladd();
179	snpand(1); /* fixup entry mask */
180
181	handy = rdrint;
182	handy->i = 1;
183	protect(handy);
184	return(Ladd());
185
186	}
187
188	lispval
189	Lsub1()
190	{
191	register lispval handy;
192	lispval Ladd();
193	snpand(1); /* fixup entry mask */
194
195	handy = rdrint;
196	handy->i = - 1;
197	protect(handy);
198	return(Ladd());
199	}
200
201	lispval
202	Lminus()
203	{
204	register lispval arg1, handy;
205	register temp;
206	lispval subbig();
207	snpand(3); /* clobber save mask */
208
209	chkarg(1);
210	arg1 = lbot->val;
211	handy = nil;
212	switch(TYPE(arg1)) {
213	case INT:
214	handy= inewint(0 - arg1->i);
215	break;
216	case DOUB:
217	handy = newdoub();
218	handy->r = -arg1->r;
219	break;
220	case SDOT:
221	handy = rdrsdot;
222	handy->I = 0;
223	handy->CDR = (lispval) 0;
224	handy = subbig(handy,arg1);
225	break;
226
227	default:
228	error("non-numeric argument",FALSE);
229	}
230	return(handy);
231	}
232
233	lispval
234	Lnegp()
235	{
236	register lispval handy = np[-1].val, work;
237	register flag = 0;
238	snpand(3); /* clobber save mask */
239
240	loop:
241	switch(TYPE(handy)) {
242	case INT:
243	if(handy->i < 0) flag = TRUE;
244	break;
245	case DOUB:
246	if(handy->r < 0) flag = TRUE;
247	break;
248	case SDOT:
249	for(work = handy; work->CDR!=(lispval) 0; work = work->CDR);
250	if(work->I < 0) flag = TRUE;
251	break;
252	default:
253	handy = errorh(Vermisc,
254	"minusp: Non-(int,real,bignum) arg: ",
255	nil,
256	TRUE,
257	0,
258	handy);
259	goto loop;
260	}
261	if(flag) return(tatom);
262	return(nil);
263	}
264
265	lispval
266	Labsval()
267	{
268	register lispval arg1, handy;
269	register temp;
270	snpand(3); /* clobber save mask */
271
272	chkarg(1);
273	arg1 = lbot->val;
274	if(Lnegp()!=nil) return(Lminus());
275
276	return(arg1);
277	}
278
279	#include "frame.h"
280	/* new version of showstack,
281	We will set fp to point where the register fp points.
282	Then fp+2 = saved ap
283	fp+4 = saved pc
284	fp+3 = saved fp
285	ap+1 = first arg
286	If we find that the saved pc is somewhere in the routine eval,
287	then we print the first argument to that eval frame. This is done
288	by looking one beyond the saved ap.
289	*/
290	lispval
291	Lshostk()
292	{ lispval isho();
293	return(isho(1));
294	}
295	static lispval
296	isho(f)
297	int f;
298	{
299	register struct frame *myfp; register lispval handy;
300	int *fp; / this must be the first local */
301	int virgin=1;
302	lispval _qfuncl(),tynames(); /* locations in qfuncl */
303
304	if(f==1)
305	printf("Forms in evaluation:\n");
306	else
307	printf("Backtrace:\n\n");
308
309	myfp = (struct frame ) (&fp +1); / point to current frame */
310
311	while(TRUE)
312	{
313	if( (myfp->pc > eval && /* interpreted code */
314	myfp->pc < popnames)
315	\|\|
316	(myfp->pc > _qfuncl && /* compiled code */
317	myfp->pc < tynames) )
318	{
319	handy = (myfp->ap[1]);
320	if(f==1)
321	printr(handy,stdout), putchar('\n');
322	else {
323	if(virgin)
324	virgin = 0;
325	else
326	printf(" -- ");
327	printr((TYPE(handy)==DTPR)?handy->car:handy,stdout);
328	}
329
330	}
331
332	if(myfp > myfp->fp) break; /* end of frames */
333	else myfp = myfp->fp;
334	}
335	putchar('\n');
336	return(nil);
337	}
338	lispval
339	Lbaktrace()
340	{
341	isho(0);
342	}
343	/* ===========================================================
344	-
345	** baktrace ** (moved back by kls)
346	-
347	- baktrace will print the names of all functions being evaluated
348	- from the current one (baktrace) down to the first one.
349	- currently it only prints the function name. Planned is a
350	- list of local variables in all stack frames.
351	- written by jkf.
352	-
353	-============================================================*/
354
355	/*=============================================================
356	-
357	-* oblist **
358	-
359	- oblist returns a list of all symbols in the oblist
360	-
361	- written by jkf.
362	============================================================*/
363
364	lispval
365	Loblist()
366	{
367	int indx;
368	lispval headp, tailp ;
369	struct atom *symb ;
370
371	headp = tailp = newdot(); /* allocate first DTPR */
372	protect(headp); /protect the list from garbage collection/
373	/line added by kls /
374
375	for( indx=0 ; indx <= HASHTOP-1 ; indx++ ) /* though oblist */
376	{
377	for( symb = hasht[indx] ;
378	symb != (struct atom *) CNIL ;
379	symb = symb-> hshlnk)
380	{
381	tailp->car = (lispval) symb ; /* remember this atom */
382	tailp = tailp->cdr = newdot() ; /* link to next DTPR */
383	}
384	}
385
386	tailp->cdr = nil ; /* close the list unfortunately throwing away
387	the last DTPR
388	*/
389	return(headp);
390	}
391
392	/*
393	* Maclisp setsyntax function:
394	* (setsyntax c s x)
395	* c represents character either by fixnum or atom
396	* s is the atom "macro" or the atom "splicing" (in which case x is the
397	* macro to be invoked); or nil (meaning don't change syntax of c); or
398	* (well thats enough for now) if s is a fixnum then we modify the bits
399	* for c in the readtable.
400	*/
401	#define VMAC 0316
402	#define VSPL 0315
403	#define VDQ 0212
404	#define VESC 0217
405	#include "chkrtab.h"
406
407	lispval
408	Lsetsyn()
409	{
410	register lispval s, c;
411	register struct argent *mynp;
412	register index;
413	register struct argent lbot, np;
414	lispval x;
415	extern char *ctable;
416	int value;
417
418	chkarg(3);
419	s = Vreadtable->clb;
420	chkrtab(s);
421	mynp = lbot;
422	c = (mynp++)->val;
423	s = (mynp++)->val;
424	x = (mynp++)->val;
425
426	switch(TYPE(c)) {
427	default:
428	error("neither fixnum nor atom as char to setsyntax",FALSE);
429
430	case ATOM:
431	index = *(c->pname);
432	if((c->pname)[1])error("Only 1 char atoms to setsyntax",FALSE);
433	break;
434
435	case INT:
436	index = c->i;
437	}
438	switch(TYPE(s)) {
439	case INT:
440	if(s->i == VESC) Xesc = (char) index;
441	else if(s->i == VDQ) Xdqc = (char) index;
442
443	if(ctable[index] == VESC /* if we changed the current esc */
444	&& s->i != VESC /* to something else, pick current */
445	&& Xesc == (char) index) {
446	ctable[index] = s->i;
447	rpltab(VESC,&Xesc);
448	}
449	else if(ctable[index] == VDQ /* likewise for double quote */
450	&& s->i != VDQ
451	&& Xdqc == (char) index) {
452	ctable[index] = s->i;
453	rpltab(VDQ,&Xdqc);
454	}
455	else ctable[index] = s->i;
456
457	break;
458	case ATOM:
459	if(s==splice)
460	ctable[index] = VSPL;
461	else if(s==macro)
462	ctable[index] = VMAC;
463	if(TYPE(c)!=ATOM) {
464	strbuf[0] = index;
465	strbuf[1] = 0;
466	c = (getatom());
467	}
468	Iputprop(c,x,macro);
469	}
470	return(tatom);
471	}
472
473
474
475	/* this aux function is used by setsyntax to determine the new current
476	escape or double quote character. It scans the character table for
477	the first character with the given class (either VESC or VDQ) and
478	puts that character in Xesc or Xdqc (whichever is pointed to by
479	addr).
480	*/
481	rpltab(cclass,addr)
482	char cclass;
483	char *addr;
484	{
485	register int i;
486	extern char *ctable;
487	for(i=0; i<=127 && ctable[i] != cclass; i++);
488	if(i<=127) *addr = (char) i;
489	else *addr = '\0';
490	}
491
492
493
494	lispval
495	Lzapline()
496	{
497	register FILE *port;
498	extern FILE * rdrport;
499
500	port = rdrport;
501	while (!feof(port) && (getc(port)!='\n') );
502	return(nil);
503	}
504