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

#ifndef lint
static char *rcsid =
   "$Header: fex1.c,v 1.5 85/03/24 11:03:51 sklower Exp $";
#endif

/*					-[Sat Mar  5 19:50:28 1983 by layer]-
 * 	fex1.c				$Locker:  $
 * nlambda functions
 *
 * (c) copyright 1982, Regents of the University of California
 */


#include "global.h"
#include "frame.h"

/* Nprog ****************************************************************/
/* This first sets the local variables to nil while saving their old	*/
/* values on the name stack.  Then, pointers to various things are	*/
/* saved as this function may be returned to by an "Ngo" or by a	*/
/* "Lreturn".  At the end is the loop that cycles through the contents	*/
/* of the prog.								*/

lispval
Nprog() {
	register lispval where, temp;
	struct nament *savedbnp = bnp;
	extern struct frame *errp;
	pbuf pb;
	extern int retval;
	extern lispval lispretval;

	if((np-lbot) < 1) chkarg(1,"prog");

	/* shallow bind the local variables to nil */
	if(lbot->val->d.car != nil)
	{
	    for( where = lbot->val->d.car ; where != nil; where = where->d.cdr )
	    {
	        if(TYPE(where) != DTPR || TYPE(temp=where->d.car) != ATOM)
		    errorh1(Vermisc,
			   "Illegal local variable list in prog ",nil,FALSE,
			   1,where);
    	        PUSHDOWN(temp,nil);
	    }
	}

	/* put a frame on the stack which can be 'return'ed to or 'go'ed to */
	errp = Pushframe(F_PROG,nil,nil);

	where = lbot->val->d.cdr;	/* first thing in the prog body */

	switch (retval)	{
	case C_RET:	/*
			 * returning from this prog, value to return
			 * is in lispretval
			 */
			errp = Popframe();
			popnames(savedbnp);
			return(lispretval);

	case C_GO:	/*
			 * going to a certain label, label to go to in
			 * in lispretval
			 */
			where = (lbot->val)->d.cdr;
			while ((TYPE(where) == DTPR) 
			       && (where->d.car != lispretval))
				where = where->d.cdr;
			if (where->d.car == lispretval) {
				popnames(errp->svbnp);
				break;
			}
			/* label not found in this prog, must 
			 * go up to higher prog
			 */
			errp = Popframe();	/* go to next frame */
			Inonlocalgo(C_GO,lispretval,nil);

			/* NOT REACHED */

	case C_INITIAL: break;

	}

	while (TYPE(where) == DTPR)
		{
		temp = where->d.car;
		if((TYPE(temp))!=ATOM) eval(temp);
		where = where->d.cdr;
		}
	if((where != nil) && (TYPE(where) != DTPR)) 
	    errorh1(Vermisc,"Illegal form in prog body ", nil,FALSE,0,where);
	errp = Popframe();
	popnames(savedbnp);	/* pop off locals */
	return(nil);
}

lispval globtag;
/*
   Ncatch is now linked to the lisp symbol *catch , which has the form
     (*catch tag form)
    tag is evaluated and then the catch entry is set up.
      then form is evaluated
    finally the catch entry is removed.

  *catch is still an nlambda since its arguments should not be evaluated
   before this routine is called.

   (catch form [tag]) is translated to (*catch 'tag form) by a macro.
 */
lispval
Ncatch()
{
	register lispval tag;
	pbuf pb;
	Savestack(3);		/* save stack pointers */

	if((TYPE(lbot->val))!=DTPR) return(nil);
	protect(tag = eval(lbot->val->d.car));  /* protect tag from gc */

	errp = Pushframe(F_CATCH,tag,nil);

	switch(retval) {

	case C_THROW: 	/*
		       	 * value thrown is in lispretval
		       	 */
			break;

	case C_INITIAL: /*
			 * calculate value of expression
			 */
			 lispretval = eval(lbot->val->d.cdr->d.car);
	}
			
			
	errp = Popframe();
	Restorestack();
	return(lispretval);
}
/* (errset form [flag])  
   if present, flag determines if the error message will be printed
   if an error reaches the errset.
   if no error occurs, errset returns a list of one element, the 
    value returned from form.
   if an error occurs, nil is usually returned although it could
    be non nil if err threw a non nil value 
 */

lispval Nerrset()
{
	lispval temp,flag;
	pbuf pb;
	Savestack(0);

	if(TYPE(lbot->val) != DTPR) return(nil);	/* no form */

	/* evaluate and save flag first */
	flag = lbot->val->d.cdr;
	if(TYPE(flag) == DTPR) flag = eval(flag->d.car); 
	else flag = tatom; 	/* if not present , assume t */
	protect(flag);

	errp = Pushframe(F_CATCH,Verall,flag);

	switch(retval) {

	case C_THROW: 	/*
			 * error thrown to this routine, value thrown is
			 * in lispretval
			 */
			break;

	case C_INITIAL:	/*
			 * normally just evaluate expression and listify it.
			 */
			temp = eval(lbot->val->d.car);
			protect(temp);
			(lispretval = newdot())->d.car = temp;
			break;
	}

	errp = Popframe();
	Restorestack();
	return(lispretval);
}
	
/* this was changed from throw to *throw 21nov79
   it is now a lambda and really should be called Lthrow
*/
lispval
Nthrow()
{
	switch(np-lbot) {
	case 0:
		protect(nil);
	case 1:
		protect(nil);
	case 2: break;
	default:
		argerr("throw");
	}
	Inonlocalgo(C_THROW,lbot->val,(lbot+1)->val);
	/* NOT REACHED */
}


/* Ngo ******************************************************************/
/* First argument only is checked - and must be an atom or evaluate	*/
/* to one.								*/
lispval
Ngo() 
{
    register lispval temp;
    chkarg(1,"go");

    temp = (lbot->val)->d.car;
    if (TYPE(temp) != ATOM)
    {
	temp = eval(temp);
	while(TYPE(temp) != ATOM) 
	  temp = errorh1(Vermisc,"Illegal tag to go to",nil,TRUE, 0,lbot->val);
    }
    Inonlocalgo(C_GO,temp,nil);
    /* NOT REACHED */
}


/* Nreset ***************************************************************/
/* All arguments are ignored.  This just returns-from-break to depth 0.	*/
lispval
Nreset()
{
    Inonlocalgo(C_RESET,inewint(0),nil);
}


/* Nbreak ***************************************************************/
/* If first argument is not nil, this is evaluated and printed.  Then	*/
/* error is called with the "breaking" message.				*/

lispval
Nbreak()
{
	register lispval hold; register FILE *port;
	port = okport(Vpoport->a.clb,stdout);
	fprintf(port,"Breaking:");

	if ((hold = lbot->val) != nil && ((hold = hold->d.car) != nil))
	{
		printr(hold,port);
	}
	putc('\n',port);
	dmpport(port);
	return(errorh(Verbrk,"",nil,TRUE,0));
}


/* Nexit ****************************************************************/
/* Just calls lispend with no message.					*/
Nexit()
	{
	lispend("");
	}


/* Nsys *****************************************************************/
/* Just calls lispend with no message.					*/

lispval
Nsys()
	{
	lispend("");
	}


lispval
Ndef() {
	register lispval arglist, body, name, form;
	
	form = lbot->val;
	name = form->d.car;
	body = form->d.cdr->d.car;
	arglist = body->d.cdr->d.car;
	if((TYPE(arglist))!=DTPR && arglist != nil)
		error("Warning: defining function with nonlist of args",
			TRUE);
	name->a.fnbnd = body;
	return(name);
}


lispval
Nquote()
{
	return((lbot->val)->d.car);
}


lispval
Nsetq()
{	register lispval handy, where, value;
	register int lefttype;

	value = nil;
	
	for(where = lbot->val; where != nil; where = handy->d.cdr) {
		handy = where->d.cdr;
		if((TYPE(handy))!=DTPR)
			error("odd number of args to setq",FALSE);
		if((lefttype=TYPE(where->d.car))==ATOM) {
			if(where->d.car==nil)
				error("Attempt to set nil",FALSE);
			where->d.car->a.clb = value = eval(handy->d.car);
		 }else if(lefttype==VALUE)
			where->d.car->l = value = eval(handy->d.car);
		else errorh1(Vermisc,
			    "Can only setq atoms or values",nil,FALSE,0,
			    		where->d.car);
	}
	return(value);
}


lispval
Ncond()
{
	register lispval  where, last;

	where = lbot->val;
	last = nil;
	for(;;) {
		if ((TYPE(where))!=DTPR)
			break;
		if ((TYPE(where->d.car))!=DTPR)
			break;
		if ((last=eval((where->d.car)->d.car)) != nil)
			break;
		where = where->d.cdr;
	}

	if ((TYPE(where)) != DTPR)
			return(nil);
	where = (where->d.car)->d.cdr;
	while ((TYPE(where))==DTPR) {
			last = eval(where->d.car);
			where = where->d.cdr;
	}
	return(last);
}

lispval
Nand()
{
	register lispval current, temp;

	current = lbot->val;
	temp = tatom;
	while (current != nil)
		if ( (temp = current->d.car)!=nil && (temp = eval(temp))!=nil) 
			current = current->d.cdr;
		else {
			current = nil;
			temp = nil;
		}
	return(temp);
}


lispval
Nor()
{
	register lispval current, temp;

	current = lbot->val;
	temp = nil;
	while (current != nil)
		if ( (temp = eval(current->d.car)) == nil)
			current = current->d.cdr;
		else
			break;
	return(temp);
}
Commit	Line	Data
73350edc C	1	#ifndef lint
	2	static char *rcsid =
	3	"$Header: fex1.c,v 1.5 85/03/24 11:03:51 sklower Exp $";
	4	#endif
	5
	6	/* -[Sat Mar 5 19:50:28 1983 by layer]-
	7	* fex1.c $Locker: $
	8	* nlambda functions
	9	*
	10	* (c) copyright 1982, Regents of the University of California
	11	*/
	12
	13
	14	#include "global.h"
	15	#include "frame.h"
	16
	17	/* Nprog ****************************************************************/
	18	/* This first sets the local variables to nil while saving their old */
	19	/* values on the name stack. Then, pointers to various things are */
	20	/* saved as this function may be returned to by an "Ngo" or by a */
	21	/* "Lreturn". At the end is the loop that cycles through the contents */
	22	/* of the prog. */
	23
	24	lispval
	25	Nprog() {
	26	register lispval where, temp;
	27	struct nament *savedbnp = bnp;
	28	extern struct frame *errp;
	29	pbuf pb;
	30	extern int retval;
	31	extern lispval lispretval;
	32
	33	if((np-lbot) < 1) chkarg(1,"prog");
	34
	35	/* shallow bind the local variables to nil */
	36	if(lbot->val->d.car != nil)
	37	{
	38	for( where = lbot->val->d.car ; where != nil; where = where->d.cdr )
	39	{
	40	if(TYPE(where) != DTPR \|\| TYPE(temp=where->d.car) != ATOM)
	41	errorh1(Vermisc,
	42	"Illegal local variable list in prog ",nil,FALSE,
	43	1,where);
	44	PUSHDOWN(temp,nil);
	45	}
	46	}
	47
	48	/* put a frame on the stack which can be 'return'ed to or 'go'ed to */
	49	errp = Pushframe(F_PROG,nil,nil);
	50
	51	where = lbot->val->d.cdr; /* first thing in the prog body */
	52
	53	switch (retval) {
	54	case C_RET: /*
	55	* returning from this prog, value to return
	56	* is in lispretval
	57	*/
	58	errp = Popframe();
	59	popnames(savedbnp);
	60	return(lispretval);
	61
	62	case C_GO: /*
	63	* going to a certain label, label to go to in
	64	* in lispretval
65	*/
66	where = (lbot->val)->d.cdr;
67	while ((TYPE(where) == DTPR)
68	&& (where->d.car != lispretval))
69	where = where->d.cdr;
70	if (where->d.car == lispretval) {
71	popnames(errp->svbnp);
72	break;
73	}
74	/* label not found in this prog, must
75	* go up to higher prog
76	*/
77	errp = Popframe(); /* go to next frame */
78	Inonlocalgo(C_GO,lispretval,nil);
79
80	/* NOT REACHED */
81
82	case C_INITIAL: break;
83
84	}
85
86	while (TYPE(where) == DTPR)
87	{
88	temp = where->d.car;
89	if((TYPE(temp))!=ATOM) eval(temp);
90	where = where->d.cdr;
91	}
92	if((where != nil) && (TYPE(where) != DTPR))
93	errorh1(Vermisc,"Illegal form in prog body ", nil,FALSE,0,where);
94	errp = Popframe();
95	popnames(savedbnp); /* pop off locals */
96	return(nil);
97	}
98
99	lispval globtag;
100	/*
101	Ncatch is now linked to the lisp symbol *catch , which has the form
102	(*catch tag form)
103	tag is evaluated and then the catch entry is set up.
104	then form is evaluated
105	finally the catch entry is removed.
106
107	*catch is still an nlambda since its arguments should not be evaluated
108	before this routine is called.
109
110	(catch form [tag]) is translated to (*catch 'tag form) by a macro.
111	*/
112	lispval
113	Ncatch()
114	{
115	register lispval tag;
116	pbuf pb;
117	Savestack(3); /* save stack pointers */
118
119	if((TYPE(lbot->val))!=DTPR) return(nil);
120	protect(tag = eval(lbot->val->d.car)); /* protect tag from gc */
121
122	errp = Pushframe(F_CATCH,tag,nil);
123
124	switch(retval) {
125
126	case C_THROW: /*
127	* value thrown is in lispretval
128	*/
129	break;
130
131	case C_INITIAL: /*
132	* calculate value of expression
133	*/
134	lispretval = eval(lbot->val->d.cdr->d.car);
135	}
136
137
138	errp = Popframe();
139	Restorestack();
140	return(lispretval);
141	}
142	/* (errset form [flag])
143	if present, flag determines if the error message will be printed
144	if an error reaches the errset.
145	if no error occurs, errset returns a list of one element, the
146	value returned from form.
147	if an error occurs, nil is usually returned although it could
148	be non nil if err threw a non nil value
149	*/
150
151	lispval Nerrset()
152	{
153	lispval temp,flag;
154	pbuf pb;
155	Savestack(0);
156
157	if(TYPE(lbot->val) != DTPR) return(nil); /* no form */
158
159	/* evaluate and save flag first */
160	flag = lbot->val->d.cdr;
161	if(TYPE(flag) == DTPR) flag = eval(flag->d.car);
162	else flag = tatom; /* if not present , assume t */
163	protect(flag);
164
165	errp = Pushframe(F_CATCH,Verall,flag);
166
167	switch(retval) {
168
169	case C_THROW: /*
170	* error thrown to this routine, value thrown is
171	* in lispretval
172	*/
173	break;
174
175	case C_INITIAL: /*
176	* normally just evaluate expression and listify it.
177	*/
178	temp = eval(lbot->val->d.car);
179	protect(temp);
180	(lispretval = newdot())->d.car = temp;
181	break;
182	}
183
184	errp = Popframe();
185	Restorestack();
186	return(lispretval);
187	}
188
189	/* this was changed from throw to *throw 21nov79
190	it is now a lambda and really should be called Lthrow
191	*/
192	lispval
193	Nthrow()
194	{
195	switch(np-lbot) {
196	case 0:
197	protect(nil);
198	case 1:
199	protect(nil);
200	case 2: break;
201	default:
202	argerr("throw");
203	}
204	Inonlocalgo(C_THROW,lbot->val,(lbot+1)->val);
205	/* NOT REACHED */
206	}
207
208
209
210	/* Ngo ******************************************************************/
211	/* First argument only is checked - and must be an atom or evaluate */
212	/* to one. */
213	lispval
214	Ngo()
215	{
216	register lispval temp;
217	chkarg(1,"go");
218
219	temp = (lbot->val)->d.car;
220	if (TYPE(temp) != ATOM)
221	{
222	temp = eval(temp);
223	while(TYPE(temp) != ATOM)
224	temp = errorh1(Vermisc,"Illegal tag to go to",nil,TRUE, 0,lbot->val);
225	}
226	Inonlocalgo(C_GO,temp,nil);
227	/* NOT REACHED */
228	}
229
230
231	/* Nreset ***************************************************************/
232	/* All arguments are ignored. This just returns-from-break to depth 0. */
233	lispval
234	Nreset()
235	{
236	Inonlocalgo(C_RESET,inewint(0),nil);
237	}
238
239
240
241	/* Nbreak ***************************************************************/
242	/* If first argument is not nil, this is evaluated and printed. Then */
243	/* error is called with the "breaking" message. */
244
245	lispval
246	Nbreak()
247	{
248	register lispval hold; register FILE *port;
249	port = okport(Vpoport->a.clb,stdout);
250	fprintf(port,"Breaking:");
251
252	if ((hold = lbot->val) != nil && ((hold = hold->d.car) != nil))
253	{
254	printr(hold,port);
255	}
256	putc('\n',port);
257	dmpport(port);
258	return(errorh(Verbrk,"",nil,TRUE,0));
259	}
260
261
262	/* Nexit ****************************************************************/
263	/* Just calls lispend with no message. */
264	Nexit()
265	{
266	lispend("");
267	}
268
269
270	/* Nsys *****************************************************************/
271	/* Just calls lispend with no message. */
272
273	lispval
274	Nsys()
275	{
276	lispend("");
277	}
278
279
280
281
282	lispval
283	Ndef() {
284	register lispval arglist, body, name, form;
285
286	form = lbot->val;
287	name = form->d.car;
288	body = form->d.cdr->d.car;
289	arglist = body->d.cdr->d.car;
290	if((TYPE(arglist))!=DTPR && arglist != nil)
291	error("Warning: defining function with nonlist of args",
292	TRUE);
293	name->a.fnbnd = body;
294	return(name);
295	}
296
297
298	lispval
299	Nquote()
300	{
301	return((lbot->val)->d.car);
302	}
303
304
305	lispval
306	Nsetq()
307	{ register lispval handy, where, value;
308	register int lefttype;
309
310	value = nil;
311
312	for(where = lbot->val; where != nil; where = handy->d.cdr) {
313	handy = where->d.cdr;
314	if((TYPE(handy))!=DTPR)
315	error("odd number of args to setq",FALSE);
316	if((lefttype=TYPE(where->d.car))==ATOM) {
317	if(where->d.car==nil)
318	error("Attempt to set nil",FALSE);
319	where->d.car->a.clb = value = eval(handy->d.car);
320	}else if(lefttype==VALUE)
321	where->d.car->l = value = eval(handy->d.car);
322	else errorh1(Vermisc,
323	"Can only setq atoms or values",nil,FALSE,0,
324	where->d.car);
325	}
326	return(value);
327	}
328
329
330	lispval
331	Ncond()
332	{
333	register lispval where, last;
334
335	where = lbot->val;
336	last = nil;
337	for(;;) {
338	if ((TYPE(where))!=DTPR)
339	break;
340	if ((TYPE(where->d.car))!=DTPR)
341	break;
342	if ((last=eval((where->d.car)->d.car)) != nil)
343	break;
344	where = where->d.cdr;
345	}
346
347	if ((TYPE(where)) != DTPR)
348	return(nil);
349	where = (where->d.car)->d.cdr;
350	while ((TYPE(where))==DTPR) {
351	last = eval(where->d.car);
352	where = where->d.cdr;
353	}
354	return(last);
355	}
356
357	lispval
358	Nand()
359	{
360	register lispval current, temp;
361
362	current = lbot->val;
363	temp = tatom;
364	while (current != nil)
365	if ( (temp = current->d.car)!=nil && (temp = eval(temp))!=nil)
366	current = current->d.cdr;
367	else {
368	current = nil;
369	temp = nil;
370	}
371	return(temp);
372	}
373
374
375	lispval
376	Nor()
377	{
378	register lispval current, temp;
379
380	current = lbot->val;
381	temp = nil;
382	while (current != nil)
383	if ( (temp = eval(current->d.car)) == nil)
384	current = current->d.cdr;
385	else
386	break;
387	return(temp);
388	}