BSD 3 development

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

#include "global.h"
/* error ****************************************************************/
/* this routine is always called on a non-fatal error.  The first argu-	*/
/* ment is printed out.  The second a boolean flag indicating if the	*/
/* error routine is permitted to return a pointer to a lisp value if	*/
/* the "cont" command is executed.					*/

/* error from lisp C code, this temporarily replaces the old error
 * allowing us to interface with the new errset scheme with minimum
 * difficulty.  We assume that an error which comes to this routine
 * is of an "undefined error type" ER%misc .  Soon all calls to this
 * routine will be removed.
 *
 */

lispval
error(mesg,contvl)
char *mesg;
lispval contvl;
{
    lispval errorh();

    return(errorh(Vermisc,mesg,nil,contvl,0));
}


/* new error handler, works with errset 
 * 
 * call is errorh(type,message,valret,contuab) where
 * type is an atom which classifys the error, and whose clb, if not nil
 * is the name of a function to call to handle the error.
 * message is a character string to print to describe the error
 * valret is the value to return to an errset if one is found,
 * and contuab is non nil if this error is continuable.
 */
 
#include "catchframe.h"

lispval
errorh(type,message,valret,contuab,uniqid)
lispval type,valret;
int uniqid,contuab;
char *message;
{
 	register struct catchfr *curp; /* must be first register decl */
	register lispval handy;
	lispval *work = 1 + (lispval *) &uniqid; int limit = nargs() - 5;
	lispval Lread(), calhan();
	struct argent *savedlbot = lbot;
	struct nament * savedbnp = bnp;
	int curdep ;	/* error depth */
	typedef struct catchfr *cp;
	extern int errp;
	int myerrp = errp, what;
	int saveme[SAVSIZE];
	snpand(2);

	if(type->clb != nil)	/* if there is an error handler */
	{
	    handy = calhan(limit,work,type->clb,uniqid,message);
	    if(contuab && (TYPE(handy) == DTPR))
		return(handy->car);
	}

	/* search stack for error catcher */

	for (curp = (cp) errp ; curp != (cp) nil ; curp = curp->link)
	{
	   if((curp->labl == type)  
	      || ( (TYPE(curp->labl) == DTPR) && (curp->labl->car == Verall)))
	   {
	       if((curp->flag != nil)
		  && (type != Vererr)) {
			/* print the full error message */
			printf("%s  ",message);
			while(limit-->0) {
				printr(*work++,stdout);
				fflush(stdout);
			}
			fputc('\n',stdout);
			fflush(stdout);
	       }
	       popnames(curp->svbnp);	/* un shallow bind */
	       errp = (int) curp->link;	/* set error to next frame */
	       asm("	addl3	$16,r11,sp");	/* skip link,flag,labl,svbnp */
	       asm("	movc3	$40,(sp),_setsav");/*restore (return) context*/
	       asm("	movab	40(sp),sp");	   /* skip past ""     "" */
	       asm("	popr	$0x2540");	/* restore registers */
	       asm("	movl	12(ap),r0");	/* set return value */
	       asm("	rsb");		/* return to errset */
	       /* NOT REACHED */
	   }
	}
	    
	/* no one will catch this error, we must see if there is an
	   error-goes-to-top-level catcher */
	
	if (Vertpl->clb != nil)
	{
	    
	    handy = calhan(limit,work,Vertpl,uniqid,message);
	    if( contuab  && (TYPE(handy) == DTPR))
		   return(handy->car);
	}

	/* at this point, print error mssage and break, just like
	   the current error scheme */
	printf("%s: ",message);
	while(limit-->0) {
		printr(*work++,stdout);
		fflush(stdout);
	}

  	curdep = ++depth;
	getexit(saveme);
	while(what = setexit()) {
		errp = myerrp;
		depth = curdep;
		switch(what) {
		case BRRETB:
			if (curdep == (int) contval) {
				popnames(savedbnp);
				lbot = savedlbot;
				continue;
			}
		default:
			resexit(saveme);
			reset(what);

		case	BRRETN:
			if (contuab)
			{
				popnames(savedbnp);
				lbot = savedlbot;
				depth = curdep -1;
				resexit(saveme);
				return(contval);
			}
			printf("CAN'T CONTINUE\n");
			
		}
	}
	lbot = np;
	np++->val = P(stdin);
	np++->val = eofa;
	while(TRUE) {
		
		fprintf(stdout,"\n%d:>",curdep);
		dmpport(stdout);
		vtemp = Lread();
		if(vtemp == eofa) exit(0);
		printr(eval(vtemp),stdout);
	}
}
static lispval
calhan(limit,work,handler,uniqid,message)
register lispval *work;
lispval handler;
register limit;
register char *message;
int uniqid;
{
	    register lispval handy;
	    register struct argent *lbot, *np;
	    lbot = np;
	    protect(handler->clb);		/* funcall the handler */
	    protect(handy = newdot());		/* with a list consisting of */
	    handy->car = inewint(uniqid);	/* identifying number, */
	    handy = handy->cdr = newdot();
	    handy->car = matom(message);	/* message to be typed out, */
	    while(limit-- > 0)
	    {					/* any other args. */
		    handy = handy->cdr = newdot();
		    handy->car = *work++;
	    }
	    handy->cdr = nil;

	    handy = Lfuncal();
	    np=lbot;
}

/* lispend **************************************************************/
/* Fatal errors come here, with their epitaph.				*/
lispend(mesg)
	char	mesg[];
	{
	dmpport(poport);
	fprintf(errport,"%s\n",mesg);
	dmpport(errport);
	exit(0);
	}

/* namerr ***************************************************************/
/* handles namestack overflow, at present by simply giving a message	*/

namerr()
{
	np -= 10;
	error("NAMESTACK OVERFLOW",FALSE);
	/* NOT REACHED */
}
binderr()
{
	bnp -= 10;
	error("Bindstack overflow.",FALSE);
}
rtaberr()
{
	bindfix(Vreadtable,strtab,nil);
	error("Illegal read table.",FALSE);
}
badmem()
{
	error("Attempt to allocate beyond static structures.",FALSE);
}