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

   1: 
   2: #ifndef lint
   3: static char *rcsid =
   4:    "$Header: fex2.c,v 1.3 83/09/07 17:55:38 sklower Exp $";
   5: #endif
   6: 
   7: /*					-[Mon Jan 31 21:54:52 1983 by layer]-
   8:  * 	fex2.c				$Locker:  $
   9:  * nlambda functions
  10:  *
  11:  * (c) copyright 1982, Regents of the University of California
  12:  */
  13: 
  14: #include "global.h"
  15: #define NDOVARS 30
  16: #include "frame.h"
  17: 
  18: /*
  19:  * Ndo  maclisp do function.
  20:  */
  21: lispval
  22: Ndo()
  23: {
  24:     register lispval current, where, handy;
  25:     register struct nament *mybnp;
  26:     lispval temp, atom;
  27:     lispval body, endtest, endform, varstuff, renewals[NDOVARS] ;
  28:     struct argent *getem, *startnp;
  29:     struct nament *savedbnp = bnp;
  30:     int count, repeatdo, index;
  31:     extern struct frame *errp;
  32:     pbuf pb;
  33:     Savestack(3);
  34: 
  35:     current = lbot->val;
  36:     varstuff = current->d.car;
  37: 
  38:     switch( TYPE(varstuff) ) {
  39: 
  40:     case ATOM:          /* This is old style maclisp do;
  41: 					   atom is var, cadr(current) = init;
  42: 					   caddr(current) = repeat etc. */
  43:         if(varstuff==nil) goto newstyle;
  44:         current = current->d.cdr;   /* car(current) is now init */
  45:         PUSHDOWN(varstuff,eval(current->d.car));
  46:                     /* Init var.	    */
  47:         *renewals = (current = current->d.cdr)->d.car;
  48:                     /* get repeat form  */
  49:         endtest = (current = current->d.cdr)->d.car;
  50:         body = current->d.cdr;
  51: 
  52:         errp = Pushframe(F_PROG,nil,nil);
  53: 
  54:         switch (retval) {
  55:             case C_RET: /*
  56: 				 * returning from this prog, value to return
  57: 				 * is in lispretval
  58: 				 */
  59:                 errp = Popframe();
  60:                 popnames(savedbnp);
  61:                 return(lispretval);
  62: 
  63:             case C_GO:  /*
  64: 				 * going to a certain label, label to go to in
  65: 				 * in lispretval
  66: 				 */
  67:                 where = body;
  68:                 while ((TYPE(where) == DTPR)
  69:                     & (where->d.car != lispretval))
  70:                 where = where->d.cdr;
  71:                 if (where->d.car == lispretval) {
  72:                     popnames(errp->svbnp);
  73:                     where = where->d.cdr;
  74:                     goto singbody;
  75:                 }
  76:                 /* label not found in this prog, must
  77: 				 * go up to higher prog
  78: 				 */
  79:                 Inonlocalgo(C_GO,lispretval,nil);
  80: 
  81:                 /* NOT REACHED */
  82: 
  83:             case C_INITIAL: break;      /* fall through */
  84: 
  85:         }
  86: 
  87:         singtop:
  88:             if(eval(endtest)!=nil) {
  89:             errp = Popframe();
  90:             popnames(savedbnp);
  91:             return(nil);
  92:             }
  93:             where = body;
  94: 
  95:         singbody:
  96:             while (TYPE(where) == DTPR)
  97:             {
  98:             temp = where->d.car;
  99:             if((TYPE(temp))!=ATOM) eval(temp);
 100:             where = where->d.cdr;
 101:             }
 102:             varstuff->a.clb = eval(*renewals);
 103:             goto singtop;
 104: 
 105: 
 106:     newstyle:
 107:     case DTPR:          /* New style maclisp do; atom is
 108: 					   list of things of the form
 109: 					   (var init repeat)		*/
 110:         count = 0;
 111:         startnp = np;
 112:         for(where = varstuff; where != nil; where = where->d.cdr) {
 113:                     /* do inits and count do vars. */
 114:                     /* requires "simultaneous" eval
 115: 					   of all inits			*/
 116:                 while (TYPE(where->d.car) != DTPR)
 117:               where->d.car =
 118:                  errorh1(Vermisc,"do: variable forms must be lists ",
 119:                  nil,TRUE,0,where->d.car);
 120:             handy = where->d.car->d.cdr;
 121:             temp = nil;
 122:             if(handy !=nil)
 123:                 temp = eval(handy->d.car);
 124:             protect(temp);
 125:             count++;
 126:         }
 127:         if(count > NDOVARS)
 128:             error("More than 15 do vars",FALSE);
 129:         where = varstuff;
 130:         getem = startnp;    /* base of stack of init forms */
 131:         for(index = 0; index < count; index++) {
 132: 
 133:             handy = where->d.car;
 134:                     /* get var name from group	*/
 135: 
 136:             atom = handy->d.car;
 137:             while((TYPE(atom) != ATOM) || (atom == nil))
 138:               atom = errorh1(Vermisc,"do variable must be a non nil symbol ",
 139:                             nil,TRUE,0,atom);
 140:             PUSHDOWN(atom,getem->val);
 141:             getem++;
 142:             handy = handy->d.cdr->d.cdr;
 143:             if(handy==nil)
 144:                 handy = CNIL;  /* be sure not to rebind later */
 145:             else
 146:                 handy = handy->d.car;
 147:             renewals[index] = handy;
 148: 
 149:                     /* more loop "increments" */
 150:             where = where->d.cdr;
 151:         }
 152:         np = startnp;       /* pop off all init forms */
 153:                     /* Examine End test and End form */
 154:         current = current->d.cdr;
 155:         handy = current->d.car;
 156:         body = current->d.cdr;
 157: 
 158:         /*
 159: 		 * a do form with a test of nil just does the body once
 160: 		 * and returns nil
 161: 		 */
 162:         if (handy == nil) repeatdo = 1; /* just do it once */
 163:         else repeatdo = -1;     /* do it forever   */
 164: 
 165:         endtest = handy->d.car;
 166:         endform = handy->d.cdr;
 167: 
 168:         where = body;
 169: 
 170:         errp = Pushframe(F_PROG,nil,nil);
 171:         while(TRUE) {
 172: 
 173:             switch (retval) {
 174:             case C_RET: /*
 175: 				 * returning from this prog, value to return
 176: 				 * is in lispretval
 177: 				 */
 178:                 errp = Popframe();
 179:                 popnames(savedbnp);
 180:                 Restorestack();
 181:                 return(lispretval);
 182: 
 183:             case C_GO:  /*
 184: 				 * going to a certain label, label to go to in
 185: 				 * in lispretval
 186: 				 */
 187:                 where = body;
 188:                 while ((TYPE(where) == DTPR)
 189:                     & (where->d.car != lispretval))
 190:                 where = where->d.cdr;
 191:                 if (where->d.car == lispretval) {
 192:                     popnames(errp->svbnp);
 193:                     where = where->d.cdr;
 194:                     goto bodystart;
 195:                 }
 196:                 /* label not found in this prog, must
 197: 				 * go up to higher prog
 198: 				 */
 199:                 Inonlocalgo(C_GO,lispretval,nil);
 200: 
 201:                 /* NOT REACHED */
 202: 
 203:             case C_INITIAL: break;      /* fall through */
 204: 
 205:             }
 206: 
 207:         loop:
 208:                 np = startnp;   /* is bumped when doing repeat forms */
 209: 
 210:             if((repeatdo-- == 0) || (eval(endtest) !=nil)) {
 211:             for(handy = nil; endform!=nil; endform = endform->d.cdr)
 212:             {
 213:                 handy = eval(endform->d.car);
 214:             }
 215:             errp = Popframe();
 216:             popnames(savedbnp);
 217:             Restorestack();
 218:             return(handy);
 219:             }
 220: 
 221:         bodystart:
 222:             while (TYPE(where) == DTPR)
 223:             {
 224:             temp = where->d.car;
 225:             if((TYPE(temp))!=ATOM) eval(temp);
 226:             where = where->d.cdr;
 227:             }
 228:             where = body;
 229:             getem = np = startnp;
 230:                     /* Simultaneously eval repeat forms */
 231:             for(index = 0; index < count; index++) {
 232:             temp = renewals[index];
 233:             if (temp == nil || temp == CNIL)
 234:                 protect(temp);
 235:             else
 236:                 protect(eval(temp));
 237:             }
 238:                     /* now simult. rebind all the atoms */
 239:             mybnp = savedbnp;
 240:             for(index = 0; index < count; index++)
 241:             {
 242:                if( getem->val != CNIL )  /* if this atom has a repeat */
 243:             mybnp->atm->a.clb = (getem)->val;  /* rebind */
 244:             mybnp++;
 245:             getem++;
 246:             }
 247:             goto loop;
 248:         }
 249:         default:
 250:         error("do: neither list nor atom follows do", FALSE);
 251:         }
 252:         /* NOTREACHED */
 253: }
 254: 
 255: lispval
 256: Nprogv()
 257: {
 258:     register lispval where, handy;
 259:     register struct nament *namptr;
 260:     register struct argent *vars;
 261:     struct nament *oldbnp = bnp;
 262:     Savestack(4);
 263: 
 264:     where = lbot->val;
 265:     protect(eval(where->d.car));        /* list of vars = lbot[1].val */
 266:     protect(eval((where = where->d.cdr)->d.car));
 267:                         /* list of vals */
 268:     handy = lbot[2].val;
 269:     namptr = oldbnp;
 270:                         /* simultaneous eval of all
 271: 						   args */
 272:     for(;handy!=nil; handy = handy->d.cdr) {
 273:         (np++)->val = (handy->d.car);
 274:         /*  Note, each element should not be reevaluated like it
 275: 		 *  was  before.  - dhl */
 276:         /* Before: (np++)->val = eval(handy->d.car);*/
 277:         TNP;
 278:     }
 279:     /*asm("# Here is where rebinding is done");	 /* very cute */
 280:     for(handy=lbot[1].val,vars=lbot+3; handy!=nil; handy=handy->d.cdr) {
 281:         namptr->atm = handy->d.car;
 282:         ++namptr;               /* protect against interrupts
 283: 						   while re-lambda binding */
 284:         bnp = namptr;
 285:         namptr[-1].atm = handy->d.car;
 286:         namptr[-1].val = handy->d.car->a.clb;
 287:         if(vars < np)
 288:         handy->d.car->a.clb = vars++->val;
 289:         else
 290:         handy->d.car->a.clb = nil;
 291:     }
 292: 
 293:     handy = nil;
 294:     for(where = where->d.cdr; where != nil; where = where->d.cdr)
 295:         handy = eval(where->d.car);
 296:     popnames(oldbnp);
 297:     Restorestack();
 298:     return(handy);
 299: }
 300: 
 301: lispval
 302: Nprogn()
 303: {
 304:     register lispval result, where;
 305: 
 306:     result = nil;
 307:     for(where = lbot->val; where != nil; where = where->d.cdr)
 308:         result = eval(where->d.car);
 309:     return(result);
 310: 
 311: 
 312: }
 313: lispval
 314: Nprog2()
 315: {
 316:     register lispval result, where;
 317: 
 318:     where = lbot->val;
 319:     eval(where->d.car);
 320:     result = eval((where = where->d.cdr)->d.car);
 321:     protect(result);
 322:     for(where = where->d.cdr; where != nil; where = where->d.cdr)
 323:         eval(where->d.car);
 324:     np--;
 325:     return(result);
 326: }
 327: lispval
 328: typred(typ,ptr)
 329: int     typ;
 330: lispval ptr;
 331: 
 332: {   int tx;
 333:     if ((tx = TYPE(ptr)) == typ) return(tatom);
 334:     if ((tx == INT) && (typ == ATOM)) return(tatom);
 335:     return(nil);
 336: }
 337: 
 338: /*
 339:  * function
 340:  * In the interpreter, function is the same as quote
 341:  */
 342: lispval
 343: Nfunction()
 344: {
 345:     if((lbot->val == nil) || (lbot->val->d.cdr != nil))
 346:         argerr("function");
 347:     return(lbot->val->d.car);
 348: }

Defined functions

Defined variables

Defined macros