Return to error.c CVS log

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

Annotation of 43BSDReno/pgrm/lisp/franz/error.c, revision 1.1

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: error.c,v 1.6 87/12/14 14:40:57 sklower Exp $";
        !             4: #endif
        !             5: 
        !             6: /*
        !             7:  *     error.c                         $Locker:  $
        !             8:  * error handler
        !             9:  *
        !            10:  * (c) copyright 1982, Regents of the University of California
        !            11:  */
        !            12: 
        !            13: 
        !            14: #include "global.h"
        !            15: #include "frame.h"
        !            16: #include "catchfram.h"
        !            17: 
        !            18: static lispval IEargs[5];
        !            19: static int     IElimit;
        !            20: 
        !            21: /* error
        !            22:  * this routine is always called on a non-fatal error.  The first argu-
        !            23:  * ment is printed out.  The second a boolean flag indicating if the
        !            24:  * error routine is permitted to return a pointer to a lisp value if
        !            25:  * the "cont" command is executed.
        !            26:  */
        !            27:  
        !            28: /* error from lisp C code, this temporarily replaces the old error
        !            29:  * allowing us to interface with the new errset scheme with minimum
        !            30:  * difficulty.  We assume that an error which comes to this routine
        !            31:  * is of an "undefined error type" ER%misc .  Soon all calls to this
        !            32:  * routine will be removed.
        !            33:  *
        !            34:  */
        !            35: 
        !            36: lispval
        !            37: error(mesg,contvl)
        !            38: char *mesg;
        !            39: int contvl;
        !            40: {
        !            41:     lispval errorh();
        !            42: 
        !            43:     return(errorh(Vermisc,mesg,nil,contvl,0));
        !            44: }
        !            45: 
        !            46: 
        !            47: /* new error handler, works with errset 
        !            48:  * 
        !            49:  * call is errorh(type,message,valret,contuab) where
        !            50:  * type is an atom which classifys the error, and whose clb, if not nil
        !            51:  * is the name of a function to call to handle the error.
        !            52:  * message is a character string to print to describe the error
        !            53:  * valret is the value to return to an errset if one is found,
        !            54:  * and contuab is non nil if this error is continuable.
        !            55:  */
        !            56:  
        !            57: 
        !            58: /* VARARGS5 */
        !            59: static lispval
        !            60: Ierrorh(type,message,valret,contuab,uniqid)
        !            61: lispval type,valret;
        !            62: int uniqid,contuab;
        !            63: char *message;
        !            64: {
        !            65:        register struct frame *curp, *uwpframe = (struct frame *)0; 
        !            66:        register lispval handy;
        !            67:        lispval *work = IEargs; 
        !            68:        int limit = IElimit;
        !            69:        int pass, curdepth;
        !            70:        lispval Lread(), calhan();
        !            71:        lispval contatm;
        !            72:        lispval handy2;
        !            73:        extern struct frame *errp;
        !            74:        pbuf pb;
        !            75:        Savestack(2);
        !            76: 
        !            77:        contatm = (contuab == TRUE ? tatom : nil);
        !            78: 
        !            79:        /* if there is a catch every error handler */
        !            80:        if((handy = Verall->a.clb) != nil)      
        !            81:        {
        !            82:            handy = Verall->a.clb;
        !            83:            Verall->a.clb = nil;                /* turn off before calling */
        !            84:            handy = calhan(limit,work,type,uniqid,contatm,message,handy);
        !            85:            if(contuab && (TYPE(handy) == DTPR))
        !            86:                return(handy->d.car);
        !            87:        }
        !            88: 
        !            89:        if((handy = type->a.clb) != nil)        /* if there is an error handler */
        !            90:        {
        !            91:            handy = calhan(limit,work,type,uniqid,contatm,message,handy);
        !            92:            if(contuab && (TYPE(handy) == DTPR))
        !            93:                return(handy->d.car);
        !            94:        }
        !            95: 
        !            96:        pass = 1;
        !            97:        /* search stack for error catcher */
        !            98:   ps2:
        !            99: 
        !           100:        for (curp = errp ; curp != (struct frame *) 0 ; curp = curp->olderrp)
        !           101:        {
        !           102:           if(curp->class == F_CATCH) 
        !           103:           {
        !           104:                /* 
        !           105:                 * interesting catch tags are ER%unwind-protect, generated
        !           106:                 * by unwind-protect and ER%all, generated by errset
        !           107:                 */
        !           108:                if((pass == 1) && (curp->larg1 == Veruwpt))
        !           109:                {
        !           110:                    uwpframe = curp;
        !           111:                    pass = 2;
        !           112:                    goto ps2;
        !           113:                }
        !           114:                else if(curp->larg1 == Verall)
        !           115:                {
        !           116:                    /* 
        !           117:                     * have found an errset to jump to. If there is an
        !           118:                     * errset handler, first call that.
        !           119:                     */
        !           120:                    if((handy=Verrset->a.clb) != nil)
        !           121:                    {
        !           122:                        calhan(limit,work,type,uniqid,contatm,message,handy);
        !           123:                    }
        !           124: 
        !           125:                    /*
        !           126:                     * if there is an unwind-protect then go to that first.
        !           127:                     * The unwind protect will return to errorh after
        !           128:                     * it has processed its cleanup forms.
        !           129:                     * assert: if pass == 2 
        !           130:                     *          then there is a pending unwind-protect
        !           131:                     */
        !           132:                     if(uwpframe != (struct frame *)0)
        !           133:                     {
        !           134:                        /*
        !           135:                         * generate form to return to unwind-protect 
        !           136:                         */
        !           137:                        protect(handy2 = newdot());
        !           138:                        handy2->d.car = Veruwpt;
        !           139:                        handy = handy2->d.cdr = newdot();
        !           140:                        handy->d.car = nil;             /* indicates error */
        !           141:                        handy = handy->d.cdr = newdot();
        !           142:                        handy->d.car = type;
        !           143:                        handy = handy->d.cdr = newdot();
        !           144:                        handy->d.car = matom(message);
        !           145:                        handy = handy->d.cdr = newdot();
        !           146:                        handy->d.car = valret;
        !           147:                        handy = handy->d.cdr = newdot();
        !           148:                        handy->d.car = inewint(uniqid);
        !           149:                        handy = handy->d.cdr = newdot();
        !           150:                        handy->d.car = inewint(contuab);
        !           151:                        while (limit-- > 0)     /* put in optional args */
        !           152:                        {  handy = handy->d.cdr = newdot();
        !           153:                           handy->d.car = *work++;
        !           154:                        }
        !           155:                        lispretval = handy2;            /* return this as value */
        !           156:                        retval = C_THROW;
        !           157:                        Iretfromfr(uwpframe);
        !           158:                        /* NOTREACHED */
        !           159:                    }
        !           160:                    /*
        !           161:                     * Will return to errset
        !           162:                     * print message if flag on this frame is non nil
        !           163:                     */
        !           164:                    if(curp->larg2 != nil)
        !           165:                    {
        !           166:                        printf("%s  ",message);
        !           167:                        while(limit-->0) {
        !           168:                            printr(*work++,stdout);
        !           169:                            fflush(stdout);
        !           170:                        }
        !           171:                        fputc('\n',stdout);
        !           172:                        fflush(stdout);
        !           173:                    }
        !           174: 
        !           175:                    lispretval = valret;
        !           176:                    retval = C_THROW;           /* looks like a throw */
        !           177:                    Iretfromfr(curp);
        !           178:                }
        !           179:            }
        !           180:        }
        !           181:            
        !           182:        /* no one will catch this error, we must see if there is an
        !           183:           error-goes-to-top-level catcher */
        !           184:        
        !           185:        if (Vertpl->a.clb != nil)
        !           186:        {
        !           187:            
        !           188:            handy = calhan(limit,work,type,uniqid,contatm,message,Vertpl->a.clb);
        !           189:            if( contuab  && (TYPE(handy) == DTPR))
        !           190:                   return(handy->d.car);
        !           191:        }
        !           192: 
        !           193:        /* at this point, print error message and break, just like
        !           194:           the current error scheme */
        !           195:        printf("%s ",message);
        !           196:        while(limit-->0) {
        !           197:                printr(*work++,stdout);
        !           198:                fflush(stdout);
        !           199:        }
        !           200: 
        !           201: 
        !           202:        /* If automatic-reset is set
        !           203:         * we will now jump to top level, calling the reset function
        !           204:         * if it exists, or using the c rest function if it does not 
        !           205:         */
        !           206: 
        !           207:        if(Sautor)
        !           208:        {
        !           209:                if ((handy = reseta->a.fnbnd) != nil)
        !           210:                {
        !           211:                        lispval Lapply();
        !           212:                        lbot = np;
        !           213:                        protect(reseta);
        !           214:                        protect(nil);
        !           215:                        Lapply();
        !           216:                }
        !           217:                Inonlocalgo(C_RESET,inewint(0),nil);
        !           218:                /* NOTREACHED */
        !           219:        }
        !           220:        
        !           221:        /*
        !           222:         * no one wants the error.  We set up another read-eval-print
        !           223:         * loop. The user can get out of this error by typing (return 'val)
        !           224:         * if the error is continuable.  Normally this code be replaced
        !           225:         * by more clever lisp code, when the full lisp is built
        !           226:         */
        !           227: 
        !           228:        errp = Pushframe(F_PROG,nil,nil);
        !           229: 
        !           230:        if(TYPE(Verdepth->a.clb) != INT)
        !           231:        {
        !           232:                curdepth = 1;
        !           233:        }
        !           234:        else curdepth = 1 + Verdepth->a.clb->i;
        !           235:        PUSHDOWN(Verdepth,inewint(curdepth));
        !           236: 
        !           237:        switch(retval) {
        !           238:        case C_RET:     /* 
        !           239:                         * attempt to return from error
        !           240:                         */
        !           241:                        if(!contuab) error("Can't continue from this error",
        !           242:                                                  FALSE);
        !           243:                        popnames(errp->svbnp);
        !           244:                        errp = Popframe();
        !           245:                        Restorestack();
        !           246:                        return(lispretval);
        !           247: 
        !           248:        case C_GO:      /*
        !           249:                         * this may look like a valid prog, but it really
        !           250:                         * isn't, since go's are not allowed.  Let the
        !           251:                         * user know.
        !           252:                         */
        !           253:                        error("Can't 'go' through an error break",FALSE);
        !           254:                        /* NOT REACHED */
        !           255: 
        !           256:        case C_INITIAL: /*
        !           257:                          * normal case, just fall through into read-eval-print
        !           258:                          * loop
        !           259:                          */
        !           260:                        break;
        !           261:        }
        !           262:        lbot = np;
        !           263:        protect(P(stdin));
        !           264:        protect(eofa);
        !           265: 
        !           266:        while(TRUE) {
        !           267:                
        !           268:                fprintf(stdout,"\n%d:>",curdepth);
        !           269:                dmpport(stdout);
        !           270:                vtemp = Lread();
        !           271:                if(vtemp == eofa) franzexit(0);
        !           272:                printr(eval(vtemp),stdout);
        !           273:        }
        !           274:        /* NOTREACHED */
        !           275: }
        !           276: 
        !           277: lispval
        !           278: errorh(type,message,valret,contuab,uniqid)
        !           279: lispval type,valret;
        !           280: int uniqid,contuab;
        !           281: char *message;
        !           282: {
        !           283:        IElimit = 0;
        !           284:        Ierrorh(type,message,valret,contuab,uniqid);
        !           285:        /* NOTREACHED */
        !           286: }
        !           287: 
        !           288: lispval
        !           289: errorh1(type,message,valret,contuab,uniqid,arg1)
        !           290: lispval type,valret,arg1;
        !           291: int uniqid,contuab;
        !           292: char *message;
        !           293: {
        !           294:        IElimit = 1;
        !           295:        IEargs[0] = arg1;
        !           296:        Ierrorh(type,message,valret,contuab,uniqid);
        !           297:        /* NOTREACHED */
        !           298: }
        !           299: 
        !           300: lispval
        !           301: errorh2(type,message,valret,contuab,uniqid,arg1,arg2)
        !           302: lispval type,valret,arg1,arg2;
        !           303: int uniqid,contuab;
        !           304: char *message;
        !           305: {
        !           306:        IElimit = 2;
        !           307:        IEargs[0] = arg1;
        !           308:        IEargs[1] = arg2;
        !           309:        Ierrorh(type,message,valret,contuab,uniqid);
        !           310:        /* NOTREACHED */
        !           311: }
        !           312: 
        !           313: lispval
        !           314: calhan(limit,work,type,uniqid,contuab,message,handler)
        !           315: register lispval *work;
        !           316: lispval handler,type,contuab;
        !           317: register limit;
        !           318: register char *message;
        !           319: int uniqid;
        !           320: {
        !           321:            register lispval handy;
        !           322:            Savestack(4);
        !           323:            lbot = np;
        !           324:            protect(handler);           /* funcall the handler */
        !           325:            protect(handy = newdot());          /* with a list consisting of */
        !           326:            handy->d.car = type;                        /* type, */
        !           327:            handy = (handy->d.cdr = newdot());
        !           328:            handy->d.car = inewint(uniqid);     /* identifying number, */
        !           329:            handy = (handy->d.cdr = newdot());
        !           330:            handy->d.car = contuab;
        !           331:            handy = (handy->d.cdr = newdot());
        !           332:            handy->d.car = matom(message);      /* message to be typed out, */
        !           333:            while(limit-- > 0)
        !           334:            {                                   /* any other args. */
        !           335:                    handy = handy->d.cdr = newdot();
        !           336:                    handy->d.car = *work++;
        !           337:            }
        !           338:            handy->d.cdr = nil;
        !           339: 
        !           340:            handy = Lfuncal();
        !           341:            Restorestack();
        !           342:            return(handy);
        !           343: }
        !           344: 
        !           345: /* lispend **************************************************************/
        !           346: /* Fatal errors come here, with their epitaph.                         */
        !           347: lispend(mesg)
        !           348:        char    mesg[];
        !           349:        {
        !           350:        dmpport(poport);
        !           351:        fprintf(errport,"%s\n",mesg);
        !           352:        dmpport(errport);
        !           353:        franzexit(0);
        !           354:        /* NOT REACHED */
        !           355:        }
        !           356: 
        !           357: /* namerr ***************************************************************/
        !           358: /* handles namestack overflow, at present by simply giving a message   */
        !           359: 
        !           360: namerr()
        !           361: {
        !           362:        if((nplim = np + NAMINC) > orgnp + NAMESIZE) 
        !           363:        {  
        !           364:          printf("Unrecoverable Namestack Overflow, (reset) is forced\n");
        !           365:          fflush(stdout);
        !           366:          nplim = orgnp + NAMESIZE - 4*NAMINC;
        !           367:          lbot = np = nplim - NAMINC;
        !           368:          protect(matom("reset"));
        !           369:          Lfuncal();
        !           370:        }
        !           371:        error("NAMESTACK OVERFLOW",FALSE);
        !           372:        /* NOT REACHED */
        !           373: }
        !           374: 
        !           375: binderr()
        !           376: {
        !           377:        bnp -= 10;
        !           378:        error("Bindstack overflow.",FALSE);
        !           379:        /* NOT REACHED */
        !           380: }
        !           381: 
        !           382: rtaberr()
        !           383: {
        !           384:        bindfix(Vreadtable,strtab,nil);
        !           385:        error("Illegal read table.",FALSE);
        !           386:        /* NOT REACHED */
        !           387: }
        !           388: xserr()
        !           389: {
        !           390:        error("Ran out of alternate stack",FALSE);
        !           391: }
        !           392: badmem(n)
        !           393: {
        !           394:        char errbuf[256];
        !           395: 
        !           396:        sprintf(errbuf,"Attempt to allocate beyond static structures (%d).",n);
        !           397:        error(errbuf,FALSE);
        !           398:        /* NOT REACHED */
        !           399: }
        !           400: argerr(msg)
        !           401: char *msg;
        !           402: {
        !           403:        errorh1(Vermisc,"incorrect number of args to",
        !           404:                                  nil,FALSE,0,matom(msg));
        !           405:        /* NOT REACHED */
        !           406: }
        !           407: 
        !           408: lispval Vinterrfcn = nil;
        !           409: 
        !           410: /*
        !           411:  * wnaerr - wrong number of arguments to a compiled function hander
        !           412:  * called with the function name (symbol) and a descriptor of the
        !           413:  * number of arguments that were expected.  The form of the descriptor
        !           414:  * is (considered as a decimal number) xxyy where xx is the minumum
        !           415:  * and yy-1 is the maximum.  A maximum of -1 means that there is no
        !           416:  * maximum.
        !           417:  *
        !           418:  */
        !           419: wnaerr(fcn,wantargs)
        !           420: lispval fcn;
        !           421: {
        !           422:     if (Vinterrfcn == nil)
        !           423:     {
        !           424:        Vinterrfcn = matom("int:wrong-number-of-args-error");
        !           425:     }
        !           426:     if (Vinterrfcn->a.fnbnd != nil)
        !           427:     {
        !           428:        protect(fcn);
        !           429:        protect(inewint(wantargs / 1000));        /* min */
        !           430:        protect(inewint((wantargs % 1000) - 1));  /* max */
        !           431:        Ifuncal(Vinterrfcn);
        !           432:        error("wrong number of args function should never return ", FALSE);
        !           433:     }
        !           434: 
        !           435:     errorh1(Vermisc,"wrong number of arguments to ",nil,FALSE,0,fcn);
        !           436: }
        !           437: 
        !           438:        
        !           439:     

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