projects / unix-history / blob
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
BSD 4 release
[unix-history] / usr / src / cmd / lisp / error.c
static char *sccsid = "@(#)error.c 34.3 11/7/80";
#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 "catchfram.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();
lispval contatm;
lispval handy2;
struct argent *savedlbot = lbot;
struct nament * savedbnp = bnp;
int curdep ; /* error depth */
typedef struct catchfr *cp;
extern long errp;
long myerrp = errp, what;
int pass,founduw;
int saveme[SAVSIZE];
snpand(2);
contatm = (contuab == TRUE ? tatom : nil);
/* if there is a catch every error handler */
if((handy = Verall->a.clb) != nil)
{
handy = Verall->a.clb;
Verall->a.clb = nil; /* turn off before calling */
handy = calhan(limit,work,type,uniqid,contatm,message,handy);
if(contuab && (TYPE(handy) == DTPR))
return(handy->d.car);
}
if((handy = type->a.clb) != nil) /* if there is an error handler */
{
handy = calhan(limit,work,type,uniqid,contatm,message,handy);
if(contuab && (TYPE(handy) == DTPR))
return(handy->d.car);
}
pass = 1;
/* search stack for error catcher */
ps2:
founduw = FALSE;
for (curp = (cp) errp ; curp != (cp) nil ; curp = curp->link)
{
if(curp->labl == Veruwpt) founduw = TRUE;
if(((pass == 2) && founduw)
|| (curp->labl == type)
|| ( (TYPE(curp->labl) == DTPR) && (curp->labl->d.car == Verall)))
{
if((pass == 1) && founduw)
{ pass = 2;
goto ps2;
}
if(founduw)
{ protect(handy2 = newdot());
handy2->d.car = Veruwpt;
handy = handy2->d.cdr = newdot();
handy->d.car = nil; /* indicates error */
handy = handy->d.cdr = newdot();
handy->d.car = type;
handy = handy->d.cdr = newdot();
handy->d.car = matom(message);
handy = handy->d.cdr = newdot();
handy->d.car = valret;
handy = handy->d.cdr = newdot();
handy->d.car = inewint(uniqid);
handy = handy->d.cdr = newdot();
handy->d.car = inewint(contuab);
while (limit-- > 0) /* put in optional args */
{ handy = handy->d.cdr = newdot();
handy->d.car = *work++;
}
valret = handy2; /* return this as value */
}
else 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);
}
if(!founduw && ((handy=Verrset->a.clb) != nil))
{
calhan(limit,work,type,uniqid,contatm,message,handy);
}
popnames(curp->svbnp); /* un shallow bind */
errp = (int) curp->link; /* set error to next frame */
/*
* return value goes into r7 until after movc3 instruction
* which clobbers r0
*/
asm(" movl 12(ap),r7"); /* set return value (valret)*/
asm(" addl3 $16,r11,sp"); /* skip link,flag,labl,svbnp */
asm(" movc3 $44,(sp),_setsav");/*restore (return) context*/
asm(" movab 44(sp),sp"); /* skip past "" "" */
asm(" popr $0x2540"); /* restore registers */
asm(" movl r7,r0");
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->a.clb != nil)
{
handy = calhan(limit,work,type,uniqid,contatm,message,Vertpl->a.clb);
if( contuab && (TYPE(handy) == DTPR))
return(handy->d.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);
}
/* If automatic-reset is set
we will now jump to top level, calling the reset function
if it exists, or using the c rest function if it does not
*/
if(Sautor)
{
if ((handy = reseta->a.fnbnd) != nil)
{ lbot = np;
protect(reseta);
protect(nil);
Lapply();
}
contval = 0;
reset(BRRETB);
}
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) {
depth = curdep; /* In case of freturn, reset this global */
fprintf(stdout,"\n%d:>",curdep);
dmpport(stdout);
vtemp = Lread();
if(vtemp == eofa) exit(0);
printr(eval(vtemp),stdout);
}
}
lispval
calhan(limit,work,type,uniqid,contuab,message,handler)
register lispval *work;
lispval handler,type,contuab;
register limit;
register char *message;
int uniqid;
{
register lispval handy;
register struct argent *lbot, *np;
lbot = np;
protect(handler); /* funcall the handler */
protect(handy = newdot()); /* with a list consisting of */
handy->d.car = type; /* type, */
handy = (handy->d.cdr = newdot());
handy->d.car = inewint(uniqid); /* identifying number, */
handy = (handy->d.cdr = newdot());
handy->d.car = contuab;
handy = (handy->d.cdr = newdot());
handy->d.car = matom(message); /* message to be typed out, */
while(limit-- > 0)
{ /* any other args. */
handy = handy->d.cdr = newdot();
handy->d.car = *work++;
}
handy->d.cdr = nil;
handy = Lfuncal();
np=lbot;
return(handy);
}
/* 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()
{
if((nplim = np + NAMINC) > orgnp + NAMESIZE)
{
printf("Unrecoverable Namestack Overflow, (reset) is forced\n");
fflush(stdout);
nplim = orgnp + NAMESIZE - 4*NAMINC;
lbot = np = nplim - NAMINC;
protect(matom("reset"));
Lfuncal();
}
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);
}
argerr(msg)
char *msg;
{
Lshostk();
errorh(Vermisc,"incorrect number of args to",
nil,FALSE,0,matom(msg));
}
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.