Return to fex1.c CVS log

Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / franz

BSD 4.3reno

#ifndef lint
static char *rcsid =
   "$Header: /var/lib/cvsd/repos/CSRG/43BSDReno/pgrm/lisp/franz/fex1.c,v 1.1.1.1 2018/04/24 16:12:57 root 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);
}

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.