Return to frame.c CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz

Annotation of 43BSD/ucb/lisp/franz/frame.c, revision 1.1

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: frame.c,v 1.2 83/05/07 23:46:38 jkf Exp $";
        !             4: #endif
        !             5: 
        !             6: /*                                     -[Sat May  7 22:27:57 1983 by jkf]-
        !             7:  *     frame.c                         $Locker: sklower $
        !             8:  * non local goto handlers
        !             9:  *
        !            10:  * (c) copyright 1982, Regents of the University of California
        !            11:  */
        !            12: 
        !            13: 
        !            14: #include "global.h"
        !            15: #include "frame.h"
        !            16: 
        !            17: /* 
        !            18:  * This is a collection of routines for manipulating evaluation frames.
        !            19:  * Such frames are generated to mark the state of execution at a certain
        !            20:  * spot.  They are created upon entry to prog, do, catch, errset and
        !            21:  * other misc. functions (such as eval when in *rset mode).
        !            22:  *
        !            23:  * As described in h/frame.h, each frame is identified by a class, which
        !            24:  * says who created the frame.  The global variable errp points to the
        !            25:  * first (newest) frame on the stack.  
        !            26:  * The standard way to create a frame is to say
        !            27:  *
        !            28:  *   errp = Pushframe(class,arg1,arg2);         /* create and link in new 
        !            29:  *                                         frame of give class * /
        !            30:  *
        !            31:  * poping the frame must be done explicity if the routine was not exited by
        !            32:  * a non-local goto.  This is done by 
        !            33:  *   errp = Popframe();
        !            34:  *
        !            35:  * When a frame is created, it marks the current state on the runtime stack.
        !            36:  * Execution will continues after the Pushframe call with the value of the
        !            37:  * global variable 'retval' set to 0.  Some time later control may be thrown
        !            38:  * up the stack and it will seem that Pushframe returned again.  This time
        !            39:  * retval will contain a non-zero value indicating what caused the non-local
        !            40:  * jump.  retval will have one of the values from C_???? in h/frame.h . 
        !            41:  * It will not have just of the C_???? values, it will only have a value
        !            42:  * which makes sense. For example, coming out of a Pushframe(F_CATCH,tag,nil);
        !            43:  * retval will either be 0 (initially) or C_THROW, [and in addition it will
        !            44:  * already have been determined that the tag of the catch matches the tag
        !            45:  * being thrown, [[ this does not apply to GO's and PROG tags]] ].
        !            46:  *
        !            47:  * In doing throws, goto's, returns, or errors up the stack we are always
        !            48:  * conscious of the possiblity of unwind-protect sitting between where 
        !            49:  * control starts and where it wants to get.  Thus it may be necessary
        !            50:  * to save the state of the non-local jump, give control to the unwind-protect
        !            51:  * and have it continue the non-local jump. 
        !            52:  */
        !            53: 
        !            54:  /*
        !            55:   * Inonlocalgo(class, arg1, arg2) :: do a general non-local goto.
        !            56:   *            class - one of the C_???? in h/frame.h
        !            57:   *    arg1 - tag in C_THROW, C_GO; value in C_RETURN
        !            58:   *    arg2 - value in C_THROW;
        !            59:   *  this handles GO's, THROW's, RETURN's  but not errors, which have more
        !            60:   * state to throw and a lot of different things to do if there is no one
        !            61:   * to catch the error.
        !            62:   * 
        !            63:   * This routine never returns.
        !            64:   */
        !            65: 
        !            66: Inonlocalgo(class, arg1, arg2)
        !            67: lispval arg1,arg2;
        !            68: {
        !            69:     struct frame *uwpframe, *Inlthrow();
        !            70:     lispval handy;
        !            71: 
        !            72:     /* 
        !            73:      * scan for something to match 'class', return if nothing found, or
        !            74:      * if we must first handle an unwind protect.
        !            75:      */
        !            76:     while( uwpframe = Inlthrow(class,arg1,arg2) )
        !            77:     {
        !            78:        /* build error frame description to be use to continue this throw */
        !            79:        protect(lispretval = handy = newdot());
        !            80:        handy->d.car = Veruwpt;
        !            81:        handy = handy->d.cdr = newdot();
        !            82:        handy->d.car = inewint(class);          /* remember type */
        !            83:        handy = handy->d.cdr = newdot();
        !            84:        handy->d.car = arg1;
        !            85:        handy = handy->d.cdr = newdot();
        !            86:        handy->d.car = arg2;
        !            87:        retval = C_THROW;
        !            88:        Iretfromfr(uwpframe);
        !            89:        /* NOT REACHED */
        !            90:     }
        !            91: 
        !            92:     /*
        !            93:      * nothing to go to, signal the appropriate error
        !            94:      */
        !            95: 
        !            96:     switch(class)
        !            97:     {
        !            98:     case C_GO: errorh1(Vermisc, "No prog to go to with this tag ",
        !            99:                               nil,FALSE,0,arg1);
        !           100:                /* NOT REACHED */
        !           101: 
        !           102:     case C_RET: errorh(Vermisc, "No prog to return from", nil, FALSE, 0);
        !           103:                /* NOT REACHED */
        !           104: 
        !           105:     case C_THROW: errorh1(Vermisc, "No catch for this tag ", nil, FALSE , 0,
        !           106:                                  arg1);
        !           107:                /* NOT REACHED */
        !           108:     default: error("Internal  Inonlocalgoto error" ,FALSE);
        !           109:                /* NOT REACHED */
        !           110:     }
        !           111: }
        !           112: 
        !           113: /*
        !           114:  * Inlthrow(class,arg1,arg2) :: look up the stack for a form to handle
        !           115:  * a value of 'class' being thrown.  If found, do the throw.  If an
        !           116:  * unwind-protect must be done, then return a pointer to that frame
        !           117:  * first.  If there is nothing to catch this throw, we return 0.
        !           118:  */
        !           119: 
        !           120: struct frame *
        !           121: Inlthrow(class, arg1, arg2)
        !           122: lispval arg1, arg2;
        !           123: {
        !           124:     struct frame *uwpframe = (struct frame *)0;
        !           125:     struct frame *curp;
        !           126:     int pass = 1;
        !           127: 
        !           128:     restart:
        !           129:        for(curp = errp; curp != (struct frame *) 0; curp = curp->olderrp)
        !           130:        {
        !           131:            switch(curp->class)
        !           132:            {
        !           133:            case F_PROG: if(class == C_RET || class == C_GO)
        !           134:                         {
        !           135:                            if(pass == 2) return(uwpframe);
        !           136:                            else 
        !           137:                            {
        !           138:                                lispretval = arg1;
        !           139:                                retval = class;
        !           140:                                Iretfromfr(curp);
        !           141:                                /* NOT REACHED */
        !           142:                            }
        !           143:                          }
        !           144:                          break;
        !           145: 
        !           146:            case F_CATCH: if((pass == 1) && (curp->larg1 == Veruwpt))
        !           147:                          {
        !           148:                                uwpframe = curp;
        !           149:                                pass = 2;
        !           150:                                goto restart;
        !           151:                          }
        !           152:                          else if(class == C_THROW 
        !           153:                                        && matchtags(arg1,curp->larg1))
        !           154:                          {
        !           155:                            if(pass == 2) return(uwpframe);
        !           156:                            else 
        !           157:                            {
        !           158:                                lispretval = arg2;      /* value thrown */
        !           159:                                retval = class;
        !           160:                                Iretfromfr(curp);
        !           161:                                /* NOT REACHED */
        !           162:                            }
        !           163:                           }
        !           164:                           break;
        !           165:            
        !           166:            case F_RESET:  if(class == C_RESET)
        !           167:                           {
        !           168:                                if(pass == 2) return(uwpframe);
        !           169:                                else
        !           170:                                {
        !           171:                                    retval = class;
        !           172:                                    Iretfromfr(curp);
        !           173:                                    /* NOT REACHED */
        !           174:                                }
        !           175:                            }
        !           176:                            break;
        !           177: 
        !           178:            }
        !           179:        }
        !           180:        return((struct frame *)0);   /* nobody wants it */
        !           181: }
        !           182: 
        !           183: 
        !           184: Iretfromfr(fram)
        !           185: register struct frame *fram;
        !           186: {
        !           187:     xpopnames(fram->svbnp);
        !           188:     qretfromfr();      /* modified in sed script to point to real function */
        !           189:     /* NOT REACHED */
        !           190: }
        !           191: 
        !           192: /* matchtags :: return TRUE if there is any atom in common between the
        !           193:  * two tags.  Either tag may be an atom or an list of atoms.
        !           194:  */
        !           195: matchtags(tag1,tag2)
        !           196: lispval tag1, tag2;
        !           197: {
        !           198:     int repeat1 = FALSE;
        !           199:     int repeat2 = FALSE;
        !           200:     lispval temp1 = tag1;
        !           201:     lispval temp2 = tag2;
        !           202:     lispval t1,t2;
        !           203: 
        !           204:     if(TYPE(tag1) == ATOM) 
        !           205:     {
        !           206:        t1 = tag1;
        !           207:     }
        !           208:     else {
        !           209:        t1 = tag1->d.car;
        !           210:        repeat1 = TRUE;
        !           211:     }
        !           212: 
        !           213:     if(TYPE(tag2) == ATOM)
        !           214:     {
        !           215:        t2 = tag2;
        !           216:     }
        !           217:     else {
        !           218:        t2 = tag2->d.car;
        !           219:        repeat2 = TRUE;
        !           220:     }
        !           221: 
        !           222: loop:
        !           223:     if(t1 == t2) return(TRUE);
        !           224:     if(repeat2) 
        !           225:     {
        !           226:        if((temp2 = temp2->d.cdr) != nil)
        !           227:        {
        !           228:            t2 = temp2->d.car;
        !           229:            goto loop;
        !           230:        }
        !           231:     }
        !           232: 
        !           233:     if(repeat1)
        !           234:     {
        !           235:         if((temp1 = temp1->d.cdr) != nil)
        !           236:        {
        !           237:            t1 = temp1->d.car;
        !           238:            if(repeat2) 
        !           239:            {
        !           240:                temp2 = tag2;
        !           241:                t2 = temp2->d.car;
        !           242:                goto loop;
        !           243:            }
        !           244:            else t2 = tag2;
        !           245:            goto loop;
        !           246:         }
        !           247:     }
        !           248:     return(FALSE);
        !           249: }
        !           250: 
        !           251: /*
        !           252:  * framedump :: debugging routine to print the contents of the error 
        !           253:  * frame
        !           254:  *
        !           255:  */
        !           256: lispval
        !           257: Lframedump()
        !           258: {
        !           259:     struct frame *curp;
        !           260: 
        !           261:     printf("Frame dump\n");
        !           262:     for(curp = errp ; curp != (struct frame *)0 ; curp=curp->olderrp)
        !           263:     {
        !           264:        printf("at %x is ",curp);
        !           265: 
        !           266:        switch(curp->class) {
        !           267:        case F_PROG: printf(" prog\n");
        !           268:                     break;
        !           269: 
        !           270:        case F_CATCH:printf(" catching ");
        !           271:                     printr(curp->larg1,stdout);
        !           272:                     putchar('\n');
        !           273:                     break;
        !           274: 
        !           275:        case F_RESET:printf(" reset \n");
        !           276:                     break;
        !           277: 
        !           278:        case F_EVAL: printf(" eval: ");
        !           279:                     printr(curp->larg1,stdout);
        !           280:                     putchar('\n');
        !           281:                     break;
        !           282: 
        !           283:        case F_FUNCALL: printf(" funcall: ");
        !           284:                     printr(curp->larg1,stdout);
        !           285:                     putchar('\n');
        !           286:                     break;
        !           287: 
        !           288:        case F_TO_FORT: printf(" calling fortran:\n");
        !           289:                     break;
        !           290: 
        !           291:        case F_TO_LISP: printf(" fortran calling lisp:\n");
        !           292:                     break;
        !           293: 
        !           294:                
        !           295:        default:
        !           296:                     printf(" unknown: %d \n",curp->class);
        !           297:        }
        !           298:        fflush(stdout);
        !           299:     }
        !           300:     printf("End of stack\n");
        !           301:     return(nil);
        !           302: }
        !           303: 

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