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

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: eval2.c,v 1.8 85/03/24 11:03:02 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Sat May  7 23:38:37 1983 by jkf]-
   7:  * 	eval2.c				$Locker:  $
   8:  * more of the evaluator
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: 
  14: #include "global.h"
  15: #include "frame.h"
  16: 
  17: /* Iarray - handle array call.
  18:  *  fun - array object
  19:  *  args - arguments to the array call , most likely subscripts.
  20:  *  evalp - flag, if TRUE then the arguments should be evaluated when they
  21:  *	are stacked.
  22:  */
  23: lispval
  24: Iarray(fun,args,evalp)
  25: register lispval fun,args;
  26: {
  27:     Savestack(2);
  28: 
  29:     lbot = np;
  30:     protect(fun->ar.accfun);
  31:     for ( ; args != nil ; args = args->d.cdr)  /* stack subscripts */
  32:       if(evalp) protect(eval(args->d.car));
  33:       else protect(args->d.car);
  34:     protect(fun);
  35:     vtemp = Lfuncal();
  36:     Restorestack();
  37:     return(vtemp);
  38: }
  39: 
  40: 
  41: dumpmydata(thing)
  42: int thing;
  43: {
  44:     register int *ip = &thing;
  45:     register int *lim = ip + nargs();
  46: 
  47:     printf("Dumpdata got %d args:\n",nargs());
  48:     while(ip < lim) printf("%x\n",*ip++);
  49:     return(0);
  50: }
  51: /* Ifcall :: call foreign function/subroutine
  52:  *   Ifcall is handed a binary object which is the function to call.
  53:  * This function has already been determined to be a foreign function
  54:  * by noticing that its discipline field is a string.
  55:  * The arguments to pass have already been evaluated and stacked.  We
  56:  * create on the stack a 'callg' type argument list to give to the
  57:  * function.  What is passed to the foreign function depends on the
  58:  * type of argument.  Certain args are passes directly, others must be
  59:  * copied since the foreign function my want to change them.
  60:  * When the foreign function returns, we may have to box the result,
  61:  * depending on the type of foreign function.
  62:  */
  63: lispval
  64: Ifcall(a)
  65: lispval a;
  66: {
  67:     char *alloca();
  68:     long callg_();
  69:     register int *arglist;
  70:     register int index;
  71:     register struct argent *mynp;
  72:     register lispval ltemp;
  73:     pbuf pb;
  74:     int nargs = np - lbot, kind, mysize, *ap;
  75:     Keepxs();
  76: 
  77:     /* put a frame on the stack which will save np and lbot in a
  78: 	   easy to find place in a standard way */
  79:     errp = Pushframe(F_TO_FORT,nil,nil);
  80:     mynp = lbot;
  81:     kind = (((char *)a->bcd.discipline)[0]);
  82: 
  83:     /* dispatch according to whether call by reference or value semantics */
  84:     switch(kind) {
  85:     case 'f': case 'i': case 's': case 'r':
  86:         arglist = (int *) alloca((nargs + 1) * sizeof(int));
  87:         *arglist = nargs;
  88:         for(index = 1; index <=  nargs; index++) {
  89:             switch(TYPE(ltemp=mynp->val)) {
  90:                 /* fixnums and flonums must be reboxed */
  91:             case INT:
  92:                 stack(0);
  93:                 arglist[index] = (int) sp();
  94:                 *(int *) arglist[index] = ltemp->i;
  95:                 break;
  96:             case DOUB:
  97:                 stack(0);
  98:                 stack(0);
  99:                 arglist[index] = (int) sp();
 100:                 *(double *) arglist[index] = ltemp->r;
 101:                 break;
 102: 
 103:                 /* these cause only part of the structure to be sent */
 104: 
 105:             case ARRAY:
 106:                 arglist[index] = (int) ltemp->ar.data;
 107:                 break;
 108: 
 109: 
 110:             case BCD:
 111:                 arglist[index] = (int) ltemp->bcd.start;
 112:                 break;
 113: 
 114:                 /* anything else should be sent directly */
 115: 
 116:             default:
 117:                 arglist[index] = (int) ltemp;
 118:                 break;
 119:             }
 120:             mynp++;
 121:         }
 122:         break;
 123:     case 'v':
 124:         while(TYPE(mynp->val)!=VECTORI)
 125:             mynp->val = error(
 126: "First arg to c-function-returning-vector must be of type vector-immediate",
 127:                       TRUE);
 128:         nargs--;
 129:         mynp++;
 130:         lbot++;
 131:     case 'c': case 'd':
 132:         /* make one pass over args
 133: 		calculating size of arglist */
 134:         while(mynp < np) switch(TYPE(ltemp=mynp++->val)) {
 135:         case DOUB:
 136:             nargs += ((sizeof(double)/sizeof(int))-1);
 137:             break;
 138:         case VECTORI:
 139:             if(ltemp->v.vector[-1]==Vpbv) {
 140:                 nargs += -1+VecTotSize(ltemp->vl.vectorl[-2]);
 141:             }
 142:         }
 143:         arglist = (int *) alloca((nargs+1)*sizeof(int));
 144:         *arglist = nargs;
 145:         ap = arglist + 1;
 146:         /* make another pass over the args
 147: 		   actually copying the arguments */
 148:         for(mynp = lbot; mynp < np; mynp++)
 149:             switch(TYPE(ltemp=mynp->val)) {
 150:         case INT:
 151:             *ap++ = ltemp->i;
 152:             break;
 153:         case DOUB:
 154:             *(double *)ap = ltemp->r;
 155:             ap += (sizeof (double)) / (sizeof (long));
 156:             break;
 157:         case VECTORI:
 158:             if(ltemp->v.vector[-1]==Vpbv) {
 159:                 mysize = ltemp->vl.vectorl[-2];
 160:                 mysize = sizeof(long) * VecTotSize(mysize);
 161:                 xbcopy(ap,ltemp,mysize);
 162:                 ap = (long *) (mysize + (int) ap);
 163:                 break;
 164:             }
 165:         default:
 166:             *ap++ = (long) ltemp;
 167:         }
 168:     }
 169:     switch(kind) {
 170:         case 'i': /* integer-function */
 171:         case 'c': /* C-function */
 172:             ltemp = inewint(callg_(a->bcd.start,arglist));
 173:             break;
 174: 
 175:         case 'r': /* real-function*/
 176:         case 'd': /* C function declared returning double */
 177:             {
 178:             double result =
 179:                (* ((double (*)()) callg_))(a->bcd.start,arglist);
 180:             ltemp = newdoub();
 181:             ltemp->r = result;
 182:             }
 183:             break;
 184: 
 185:         case 'f':  /* function */
 186:             ltemp = (lispval) callg_(a->bcd.start,arglist);
 187:             break;
 188: 
 189:         case 'v': /* C function returning a structure */
 190:             ap = (long *) callg_(a->bcd.start,arglist);
 191:             ltemp = (--lbot)->val;
 192:             mysize = ltemp->vl.vectorl[-2];
 193:             mysize = sizeof(long) * VecTotSize(mysize);
 194:             xbcopy(ltemp,ap,mysize);
 195:             break;
 196: 
 197:         default:
 198:         case 's': /* subroutine */
 199:             callg_(a->bcd.start,arglist);
 200:             ltemp = tatom;
 201:     }
 202:     errp = Popframe();
 203:     Freexs();
 204:     return(ltemp);
 205: }
 206: 
 207: xbcopy(to,from,size)
 208: register char *to, *from;
 209: register size;
 210: {
 211:     while(--size >= 0) *to++ = *from++;
 212: }
 213: 
 214: lispval
 215: ftolsp_(arg1)
 216: lispval arg1;
 217: {
 218:     int count;
 219:     register lispval *ap = &arg1;
 220:     lispval save;
 221:     pbuf pb;
 222:     Savestack(1);
 223: 
 224:     if((count = nargs())==0) return;;
 225: 
 226:     if(errp->class==F_TO_FORT)
 227:         np = errp->svnp;
 228:     errp = Pushframe(F_TO_LISP,nil,nil);
 229:     lbot = np;
 230:     for(; count > 0; count--)
 231:         np++->val = *ap++;
 232:     save = Lfuncal();
 233:     errp = Popframe();
 234:     Restorestack();
 235:     return(save);
 236: }
 237: 
 238: lispval
 239: ftlspn_(func,arglist)
 240: lispval func;
 241: register long *arglist;
 242: {
 243:     int count;
 244:     lispval save;
 245:     pbuf pb;
 246:     Savestack(1);
 247: 
 248:     if(errp->class==F_TO_FORT)
 249:         np = errp->svnp;
 250:     errp = Pushframe(F_TO_LISP,nil,nil);
 251:     lbot = np;
 252:     np++->val = func;
 253:     count = *arglist++;
 254:     for(; count > 0; count--)
 255:         np++->val = (lispval) (*arglist++);
 256:     save = Lfuncal();
 257:     errp = Popframe();
 258:     Restorestack();
 259:     return(save);
 260: }
 261: 
 262: 
 263: 
 264: /* Ifclosure :: evaluate a fclosure  (new version)
 265:  * the argument clos is a vector whose property is the atom fclosure
 266:  * the form of the vector is
 267:  *   0: function to run
 268:  * then for each symbol there is on vector entry containing a
 269:  * pointer to a sequence of two list cells of this form:
 270:  *	(name value . count)
 271:  * name is the symbol name to close over
 272:  * value is the saved value of the closure
 273:  *	(if the closure is 'active', the current value will be in the
 274:  *	 symbol itself)
 275:  * count is a fixnum box (which can be destructively modified safely)
 276:  *  it is normally 0.  Each time the variable is put on the stack, it is
 277:  *  incremented.  It is decremented each time the the closure is left.
 278:  *  If the closure is invoked recusively without a rebinding of the
 279:  *  closure variable X, then the count will not be incremented.
 280:  *
 281:  * when entering a fclosure, for each variable there are three
 282:  * possibities:
 283:  *  (a) this is the first instance of this closed variable
 284:  *  (b) this is the second or greater recursive instance of
 285:  *      this closure variable, however it hasn't been normally lambda
 286:  *	bound since the last closure invocation
 287:  *  (c) like (b) but it has been lambda bound before the most recent
 288:  *	closure.
 289:  *
 290:  * case (a) can be determined by seeing if the count is 0.
 291:  * if the count is >0 then we must scan from the top of the stack down
 292:  * until we find either the closure or a lambda binding of the variable
 293:  * this determines whether it is case (b) or (c).
 294:  *
 295:  * There are three actions to perform in this routine:
 296:  * 1.  determine the closure type (a,b or c) and do any binding necessary
 297:  * 2.  call the closure function
 298:  * 3.  unbind any necessary closure variables.
 299:  *
 300:  * Now, the details of those actions:
 301:  * 1. for case (b), do nothing as we are still working with the correct
 302:  *    value
 303:  *    for case (a), pushdown the symbol and give it the value from
 304:  *	the closure, inc the closure count
 305:  *      push a closure marker on the bindstack too.
 306:  *    for case (c), must locate the correct value to set by searching
 307:  *      for the last lambda binding before the previous closure.
 308:  *      pushdown the symbol and that value, inc the closure count
 309:  *      push a closure marker on the bindstack too.
 310:  *    a closure marker has atom == int:closure-marker and value pointing
 311:  *      to the closure list.  This will be noticed when unbinding.
 312:  *
 313:  *  3. unbinding is just like popnames except if a closure marker is
 314:  *     seen, then this must be done:
 315:  *	if the count is 1, just store the symbol's value in the closure
 316:  *	 and decrement the count.
 317:  *      if the count is >1, then search up the stack for the last
 318:  *	 lambda before the next occurance of this closure variable
 319:  *	 and set its value to the current value of the closure.
 320:  *	 decrement the closure count.
 321:  *
 322:  * clos is the fclosure, funcallp is TRUE if this is called from funcall,
 323:  * otherwise it is called from apply
 324:  */
 325: 
 326: #define Case_A 0
 327: #define Case_B 1
 328: #define Case_C 2
 329: 
 330: lispval
 331: Ifclosure(clos,funcallp)
 332: register lispval clos;
 333: {
 334:     struct nament *oldbnp = bnp, *lbnp, *locatevar();
 335:     register int i;
 336:     register lispval vect;
 337:     int numvars, vlength, tcase, foundc;
 338:     lispval handy, atm_dtpr, value_dtpr, Ifuncal(), Lapply();
 339:     Savestack(3);
 340: 
 341:     /* bind variables to their values given in the fclosure */
 342:     vlength = VecTotSize(clos->vl.vectorl[VSizeOff]);
 343:     /* vector length must be positive (it has to have a function at least) */
 344:     if (vlength < 1)
 345:     errorh1(Vermisc,"funcall: fclosure has wrong size ",nil,FALSE,0, clos);
 346: 
 347:     numvars = (vlength - 1);    /* number of varibles */
 348: 
 349:     for (i = 1 ; i < vlength ; i += 1)
 350:     {
 351:     atm_dtpr = clos->v.vector[i];   /* car is symbol name */
 352:     value_dtpr = atm_dtpr->d.cdr;   /* car: value, cdr:  fixnum count */
 353: 
 354:     if(value_dtpr->d.cdr->i == 0)
 355:         tcase = Case_A;     /* first call */
 356:     else {
 357:         lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
 358:         if (!foundc)
 359:         {
 360:         /* didn't find the expected closure, count must be
 361: 		   wrong, correct it and assume case (a)
 362: 		 */
 363:         tcase = Case_A;
 364:         value_dtpr->d.cdr->i = 0;
 365:         }
 366:         else if(lbnp) tcase = Case_C ; /* found intermediate lambda bnd*/
 367:         else tcase = Case_B;       /* no intermediate lambda bind */
 368:     }
 369: 
 370:     /* now bind the value if necessary */
 371:     switch(tcase) {
 372:         case Case_A: PUSHDOWN(atm_dtpr->d.car,value_dtpr->d.car);
 373:                  PUSHVAL(clos_marker,atm_dtpr);
 374:              value_dtpr->d.cdr->i += 1;
 375:              break;
 376: 
 377:         case Case_B: break;     /* nothing to do */
 378: 
 379:         case Case_C: /* push first bound value after last close */
 380:                      PUSHDOWN(atm_dtpr->d.car,lbnp->val);
 381:              PUSHVAL(clos_marker,atm_dtpr);
 382:              value_dtpr->d.cdr->i += 1;
 383:              break;
 384:     }
 385:     }
 386: 
 387:     if(funcallp)
 388:        handy = Ifuncal(clos->v.vector[0]);
 389:     else {
 390:        handy = lbot[-2].val;    /* get args to apply.  This is hacky and may
 391:        				   fail if apply is changed */
 392:        lbot = np;
 393:        protect(clos->v.vector[0]);
 394:        protect(handy);
 395:        handy = Lapply();
 396:     }
 397: 
 398:     xpopnames(oldbnp);  /* pop names with consideration for closure markers */
 399: 
 400:     if(!funcallp) Restorestack();
 401:     return(handy);
 402: }
 403: 
 404: /* xpopnames :: pop values from bindstack, but look out for
 405:  *  closure markers.  This is  used (instead of the faster popnames)
 406:  * when we know there will be closure markers or when we can't
 407:  * be sure that there won't be closure markers (eg. in non-local go's)
 408:  */
 409: xpopnames(llimit)
 410: register struct nament *llimit;
 411: {
 412:     register struct nament *rnp, *lbnp;
 413:     lispval atm_dtpr, value_dtpr;
 414:     int foundc;
 415: 
 416:     for(rnp = bnp; --rnp >= llimit;)
 417:     {
 418:         if(rnp->atm == clos_marker)
 419:     {
 420:         atm_dtpr = rnp->val;
 421:         value_dtpr = atm_dtpr->d.cdr;
 422:         if(value_dtpr->d.cdr->i <= 1)
 423:         {
 424:         /* this is the only occurance of this closure variable
 425: 		 * just restore current value to this closure.
 426: 		 */
 427:         value_dtpr->d.car = atm_dtpr->d.car->a.clb;
 428:         }
 429:         else {
 430:         /* locate the last lambda before the next occurance of
 431: 		 * this closure and store the current symbol's value
 432: 		 * there
 433: 		 */
 434:         lbnp = locatevar(atm_dtpr,&foundc,rnp-2);
 435:         if(!foundc)
 436:         {
 437:             /* strange, there wasn't a closure to be found.
 438: 		     * well, we will fix things up so the count is
 439: 		     * right.
 440: 		     */
 441:             value_dtpr->d.car = atm_dtpr->d.car->a.clb;
 442:             value_dtpr->d.cdr->i = 1;
 443:         }
 444:         else if (lbnp) {
 445:             /* note how the closures value isn't necessarily
 446: 		     * stored in the closure, it may be stored on
 447: 		     * the bindstack
 448: 		     */
 449:             lbnp->val = atm_dtpr->d.car->a.clb;
 450:         }
 451:         /* the case where lbnp is 0 should never happen, but
 452: 		   if it does, we can just do nothing safely
 453: 		 */
 454:         }
 455:         value_dtpr->d.cdr->i -= 1;
 456:     } else rnp->atm->a.clb = rnp->val;  /* the normal case */
 457:     }
 458:     bnp = llimit;
 459: }
 460: 
 461: 
 462: struct nament *
 463: locatevar(clos,foundc,rnp)
 464: struct nament *rnp;
 465: lispval clos;
 466: int *foundc;
 467: {
 468:     register struct nament  *retbnp;
 469:     lispval symb;
 470: 
 471:     retbnp = (struct nament *) 0;
 472:     *foundc = 0;
 473: 
 474:     symb = clos->d.car;
 475: 
 476:     for(  ; rnp >= orgbnp ; rnp--)
 477:     {
 478:     if((rnp->atm == clos_marker) && (rnp->val == clos))
 479:     {
 480:         *foundc = 1;    /* found the closure */
 481:         return(retbnp);
 482:     }
 483:     if(rnp->atm == symb) retbnp = rnp;
 484:     }
 485:     return(retbnp);
 486: }
 487: 
 488: lispval
 489: LIfss()
 490: {
 491:     register lispval atm_dtpr, value_dtpr;
 492:     struct nament *oldbnp = bnp, *lbnp;
 493:     int tcase, foundc = 0;
 494:     lispval newval;
 495:     int argc = 1;
 496:     Savestack(2);
 497: 
 498:     switch(np-lbot) {
 499:     case 2:
 500:         newval = np[-1].val;
 501:         argc++;
 502:     case 1:
 503:         atm_dtpr = lbot->val;
 504:         value_dtpr = atm_dtpr->d.cdr;
 505:         break;
 506:     default:
 507:         argerr("int:fclosure-symbol-stuff");
 508:     }
 509:     /* this code is copied from Ifclosure */
 510: 
 511:     if(value_dtpr->d.cdr->i==0)
 512:         tcase = Case_A; /* closure is not active */
 513:     else {
 514:         lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
 515:         if (!foundc)
 516:         {
 517:             /* didn't find closure, count must be wrong,
 518: 			   correct it and assume case (a).*/
 519:             tcase = Case_A;
 520:             value_dtpr->d.cdr->i = 0;
 521:         }
 522:         else if(lbnp) tcase = Case_C; /* found intermediate lambda*/
 523:         else tcase = Case_B;
 524:     }
 525: 
 526:     switch(tcase) {
 527:     case Case_B:
 528:         if(argc==2) return(atm_dtpr->d.car->a.clb = newval);
 529:         return(atm_dtpr->d.car->a.clb);
 530: 
 531:     case Case_A:
 532:         if(argc==2) return(value_dtpr->d.car = newval);
 533:         return(value_dtpr->d.car);
 534: 
 535:     case Case_C:
 536:         if(argc==2) return(lbnp->val = newval);
 537:         return(lbnp->val);
 538:     }
 539:     /*NOTREACHED*/
 540: }

Defined functions

Defined variables

Defined macros