4.3BSD - /usr/src/ucb/lisp/franz/frame.c

   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: }

Defined functions

Defined variables