eval.c

Functions

Ifuncal           X
Lapply            X
Lfuncal           X
Llexfun           X
Undeff            X
bindfix           X
dumpnamestack     X
eval              X
fchack            X
linterp           X
popnames          X
protect           X
rebind            X
unprot            X

Macros

argptr            X

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: eval.c,v 1.6 83/09/07 17:54:42 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Thu Aug 18 10:07:22 1983 by jkf]-
   7:  * 	eval.c				$Locker:  $
   8:  * evaluator
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: #include "global.h"
  14: #include <signal.h>
  15: #include "frame.h"
  16: 
  17: 
  18: 
  19: /*
  20:  *	eval
  21:  * returns the value of the pointer passed as the argument.
  22:  *
  23:  */
  24: 
  25: lispval
  26: eval(actarg)
  27: lispval actarg;
  28: {
  29: #define argptr handy
  30:     register lispval a = actarg;
  31:     register lispval handy;
  32:     register struct nament *namptr;
  33:     register struct argent *workp;
  34:     struct nament *oldbnp = bnp;
  35:     int dopopframe = FALSE;
  36:     int type, shortcircuit = TRUE;
  37:     lispval Ifcall(), Iarray();
  38:     Savestack(4);
  39: 
  40:     /*debugging
  41:     if (rsetsw && rsetatom->a.clb != nil) {
  42: 	printf("Eval:");
  43: 	printr(a,stdout);
  44: 	printf("\nrsetsw: %d evalhsw: %d\n", rsetsw, evalhsw);
  45: 	printf("*rset: ");
  46: 	printr(rsetatom->a.clb,stdout);
  47: 	printf(" evalhook: ");
  48: 	printr(evalhatom->a.clb,stdout);
  49: 	printf(" evalhook call flag^G: %d\n", evalhcallsw);
  50: 	fflush(stdout);
  51:     };
  52:     */
  53: 
  54:     /* check if an interrupt is pending	 and handle if so */
  55:     if(sigintcnt > 0) sigcall(SIGINT);
  56: 
  57:     if (rsetsw && rsetatom->a.clb != nil)  /* if (*rset t) has been done */
  58:     {
  59:     pbuf pb;
  60:     shortcircuit = FALSE;
  61:     if (evalhsw != nil && evalhatom->a.clb != nil)
  62:     {
  63:                         /*if (sstatus evalhook t)
  64: 						    and evalhook non-nil */
  65:         if (!evalhcallsw)
  66:                 /*if we got here after calling evalhook, then
  67: 			  evalhcallsw will be TRUE, so we want to skip calling
  68: 			  the hook function, permitting one form to be
  69: 			  evaluated before the hook fires.
  70: 			 */
  71:         {
  72:         /* setup equivalent of (funcall evalhook <arg to eval>) */
  73:         (np++)->val = a;        /* push form on namestack */
  74:         lbot=np;            /* set up args to funcall */
  75:         (np++)->val = evalhatom->a.clb; /* push evalhook's clb */
  76:         (np++)->val = a;        /* eval's arg becomes
  77: 					           2nd arg to funcall */
  78:         PUSHDOWN(evalhatom, nil);   /* bind evalhook to nil*/
  79:         PUSHDOWN(funhatom, nil);    /* bind funcallhook to nil*/
  80:         funhcallsw = TRUE;      /* skip any funcall hook */
  81:         handy = Lfuncal();      /* now call funcall */
  82:         funhcallsw = FALSE;
  83:         POP;
  84:         POP;
  85:         Restorestack();
  86:         return(handy);
  87:         };
  88:     }
  89:     errp = Pushframe(F_EVAL,a,nil);
  90:     dopopframe = TRUE;  /* remember to pop later */
  91:     if(retval == C_FRETURN)
  92:     {
  93:         Restorestack();
  94:         errp = Popframe();
  95:         return(lispretval);
  96:     }
  97:     };
  98: 
  99:     evalhcallsw = FALSE;   /* clear indication that evalhook called */
 100: 
 101:     switch (TYPE(a))
 102:     {
 103:     case ATOM:
 104:     if (rsetsw && rsetatom->a.clb != nil && bptr_atom->a.clb != nil) {
 105: 
 106:         struct nament *bpntr, *eval1bptr;
 107:                   /* Both rsetsw and rsetatom for efficiency*/
 108:                     /* bptr_atom set by second arg to eval1 */
 109:         eval1bptr = (struct nament *) bptr_atom->a.clb->d.cdr;
 110:                     /* eval1bptr is bnp when eval1 was called;
 111: 				       if an atom was bound after this,
 112: 				       then its clb is valid */
 113:         for (bpntr = eval1bptr; bpntr < bnp; bpntr++)
 114:         if (bpntr->atm==a) {
 115:             handy = a->a.clb;
 116:             goto gotatom;
 117:         };          /* Value saved in first binding of a,
 118: 				       if any, after pointer to eval1,
 119: 				       is the valid value, else use its clb */
 120:         for (bpntr = (struct nament *)bptr_atom->a.clb->d.car;
 121:           bpntr < eval1bptr; bpntr++)
 122:         if (bpntr->atm==a) {
 123:             handy=bpntr->val;
 124:             goto gotatom;   /* Simply no way around goto here */
 125:         };
 126:     };
 127:         handy = a->a.clb;
 128:     gotatom:
 129:         if(handy==CNIL) {
 130:             handy = errorh1(Vermisc,"Unbound Variable:",nil,TRUE,0,a);
 131:         }
 132:     if(dopopframe) errp = Popframe();
 133:     Restorestack();
 134:         return(handy);
 135: 
 136:     case VALUE:
 137:     if(dopopframe) errp = Popframe();
 138:     Restorestack();
 139:         return(a->l);
 140: 
 141:     case DTPR:
 142:         (np++)->val = a;        /* push form on namestack */
 143:         lbot = np;          /* define beginning of argstack */
 144:         /* oldbnp = bnp;		   redundant - Mitch Marcus */
 145:         a = a->d.car;           /* function name or lambda-expr */
 146:         for(EVER)
 147:             {
 148:             switch(TYPE(a))
 149:                 {
 150:             case ATOM:
 151:                     /*  get function binding  */
 152:                 if(a->a.fnbnd==nil && a->a.clb!=nil) {
 153:                     a=a->a.clb;
 154:                     if(TYPE(a)==ATOM)
 155:                         a=a->a.fnbnd;
 156:                 } else
 157:                     a = a->a.fnbnd;
 158:                 break;
 159:             case VALUE:
 160:                 a = a->l;       /*  get value  */
 161:                 break;
 162:                 }
 163: 
 164:             vtemp = (CNIL-1);       /* sentinel value for error test */
 165: 
 166:         /*funcal:*/    switch (TYPE(a))
 167:                 {
 168:             case BCD:    /* function */
 169:                 argptr = actarg->d.cdr;
 170: 
 171:                     /* decide whether lambda, nlambda or
 172: 				       macro and push args onto argstack
 173: 				       accordingly.                */
 174: 
 175:                 if(a->bcd.discipline==nlambda) {
 176:                     (np++)->val = argptr;
 177:                     TNP;
 178:                 } else if(a->bcd.discipline==macro) {
 179:                     (np++)->val = actarg;
 180:                     TNP;
 181:                 } else for(;argptr!=nil; argptr = argptr->d.cdr) {
 182:             /* short circuit evaluations of ATOM, INT, DOUB
 183: 		     * if not in debugging mode
 184: 		     */
 185:             if(shortcircuit
 186:                && ((type = TYPE(argptr->d.car)) == ATOM)
 187:                && (argptr->d.car->a.clb != CNIL))
 188:                        (np++)->val = argptr->d.car->a.clb;
 189:             else if(shortcircuit &&
 190:                     ((type == INT) || (type == STRNG)))
 191:                        (np++)->val = argptr->d.car;
 192:             else
 193:                        (np++)->val = eval(argptr->d.car);
 194:                     TNP;
 195:                 }
 196:                 /* go for it */
 197: 
 198:                 if(TYPE(a->bcd.discipline)==STRNG)
 199:                     vtemp = Ifcall(a);
 200:                 else
 201:                     vtemp = (*(lispval (*)())(a->bcd.start))();
 202:                 break;
 203: 
 204:             case ARRAY:
 205:                 vtemp = Iarray(a,actarg->d.cdr,TRUE);
 206:                 break;
 207: 
 208:             case DTPR:          /* push args on argstack according to
 209: 				       type                */
 210:         protect(a); /* save function definition in case function
 211: 				   is redefined */
 212:         lbot = np;
 213:                 argptr = a->d.car;
 214:                 if (argptr==lambda) {
 215:                     for(argptr = actarg->d.cdr;
 216:                         argptr!=nil; argptr=argptr->d.cdr) {
 217: 
 218:                         (np++)->val = eval(argptr->d.car);
 219:                         TNP;
 220:                     }
 221:                 } else if (argptr==nlambda) {
 222:                     (np++)->val = actarg->d.cdr;
 223:                     TNP;
 224:                 } else if (argptr==macro) {
 225:                     (np++)->val = actarg;
 226:                     TNP;
 227:                 } else if (argptr==lexpr) {
 228:                     for(argptr = actarg->d.cdr;
 229:                       argptr!=nil; argptr=argptr->d.cdr) {
 230: 
 231:                         (np++)->val = eval(argptr->d.car);
 232:                         TNP;
 233:                     }
 234:                     handy = newdot();
 235:                     handy->d.car = (lispval)lbot;
 236:                     handy->d.cdr = (lispval)np;
 237:                     PUSHDOWN(lexpr_atom,handy);
 238:                     lbot = np;
 239:                     (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);
 240: 
 241:                 } else break;    /* something is wrong - this isn't a proper function */
 242: 
 243:                 argptr = (a->d.cdr)->d.car;
 244:                 namptr =  bnp;
 245:                 workp = lbot;
 246:                 if(bnp + (np - lbot)> bnplim)
 247:                     binderr();
 248:                 for(;argptr != (lispval)nil;
 249:                      workp++,argptr = argptr->d.cdr)    /* rebind formal names (shallow) */
 250:                 {
 251:                     if(argptr->d.car==nil)
 252:                         continue;
 253:                     /*if(((namptr)->atm = argptr->d.car)==nil)
 254:                         error("Attempt to lambda bind nil",FALSE);*/
 255:                     namptr->atm = argptr->d.car;
 256:                     if (workp < np) {
 257:                         namptr->val = namptr->atm->a.clb;
 258:                         namptr->atm->a.clb = workp->val;
 259:                     } else
 260:                         bnp = namptr,
 261:                         error("Too few actual parameters",FALSE);
 262:                     namptr++;
 263:                 }
 264:                 bnp = namptr;
 265:                 if (workp < np)
 266:                     error("Too many actual parameters",FALSE);
 267: 
 268:                     /* execute body, implied prog allowed */
 269: 
 270:                 for (handy = a->d.cdr->d.cdr;
 271:                     handy != nil;
 272:                     handy = handy->d.cdr) {
 273:                         vtemp = eval(handy->d.car);
 274:                     }
 275:                 }
 276:             if (vtemp != (CNIL-1)) {
 277:                 /* if we get here with a believable value, */
 278:                 /* we must have executed a function. */
 279:                 popnames(oldbnp);
 280: 
 281:                 /* in case some clown trashed t */
 282: 
 283:                 tatom->a.clb = (lispval) tatom;
 284:                 if(a->d.car==macro)
 285:         {
 286:             if(Vdisplacemacros->a.clb && (TYPE(vtemp) == DTPR))
 287:             {
 288:             actarg->d.car = vtemp->d.car;
 289:             actarg->d.cdr = vtemp->d.cdr;
 290:             }
 291:             vtemp = eval(vtemp);
 292:         }
 293:                     /* It is of the most wonderful
 294:                        coincidence that the offset
 295:                        for car is the same as for
 296:                        discipline so we get bcd macros
 297:                        for free here ! */
 298:         if(dopopframe) errp = Popframe();
 299:         Restorestack();
 300:         return(vtemp);
 301:         }
 302:             popnames(oldbnp);
 303:             a = (lispval) errorh1(Verundef,"eval: Undefined function ",nil,TRUE,0,actarg->d.car);
 304:             }
 305: 
 306:         }
 307:     if(dopopframe) errp = Popframe();
 308:     Restorestack();
 309:     return(a);    /* other data types are considered constants */
 310: }
 311: 
 312: /*
 313:  *    popnames
 314:  * removes from the name stack all entries above the first argument.
 315:  * routine should usually be used to clean up the name stack as it
 316:  * knows about the special cases.  bnp is returned pointing to the
 317:  * same place as the argument passed.
 318:  */
 319: lispval
 320: popnames(llimit)
 321: register struct nament *llimit;
 322: {
 323:     register struct nament *rnp;
 324: 
 325:     for(rnp = bnp; --rnp >= llimit;)
 326:         rnp->atm->a.clb = rnp->val;
 327:     bnp = llimit;
 328: }
 329: 
 330: 
 331: /* dumpnamestack
 332:  * utility routine to dump out the namestack.
 333:  * from bottom to 5 above np
 334:  * should be put elsewhere
 335:  */
 336: dumpnamestack()
 337: {
 338:     struct argent *newnp;
 339: 
 340:     printf("namestack dump:\n");
 341:     for(newnp = orgnp ; (newnp < np + 6) && (newnp < nplim) ; newnp++)
 342:     {
 343:     if(newnp == np) printf("**np:**\n");
 344:     printf("[%d]: ",newnp-orgnp);
 345:     printr(newnp->val,stdout);
 346:     printf("\n");
 347:     }
 348:     printf("end namestack dump\n");
 349: }
 350: 
 351: 
 352: 
 353: lispval
 354: Lapply()
 355: {
 356:     register lispval a;
 357:     register lispval handy;
 358:     lispval vtemp, Ifclosure();
 359:     struct nament *oldbnp = bnp;
 360:     struct argent *oldlbot = lbot; /* Bottom of my frame! */
 361:     struct argent *oldnp = np; /* First free on stack */
 362:     int extrapush;      /* if must save function value */
 363: 
 364:     a = lbot->val;
 365:     argptr = lbot[1].val;
 366:     if(np-lbot!=2)
 367:         errorh2(Vermisc,"Apply: Wrong number of args.",nil,FALSE,
 368:                999,a,argptr);
 369:     if(TYPE(argptr)!=DTPR && argptr!=nil)
 370:         argptr = errorh1(Vermisc,"Apply: non-list of args",nil,TRUE,
 371:                 998,argptr);
 372:     (np++)->val = a;    /* push form on namestack */
 373:     TNP;
 374:     lbot = np;        /* bottom of current frame */
 375:     for(EVER)
 376:         {
 377:     extrapush = 0;
 378:         if (TYPE(a) == ATOM) { a = a->a.fnbnd; extrapush = 1; }
 379:                     /* get function definition (unless
 380: 					   calling form is itself a lambda-
 381: 					   expression) */
 382:         vtemp = CNIL;           /* sentinel value for error test */
 383:         switch (TYPE(a)) {
 384: 
 385:         case BCD:
 386:                     /* push arguments - value of a */
 387:             if(a->bcd.discipline==nlambda || a->bcd.discipline==macro) {
 388:                 (np++)->val=argptr;
 389:                 TNP;
 390:             } else for (; argptr!=nil; argptr = argptr->d.cdr) {
 391:                 (np++)->val=argptr->d.car;
 392:                 TNP;
 393:             }
 394: 
 395:         if(TYPE(a->bcd.discipline) == STRNG)
 396:           vtemp = Ifcall(a);    /* foreign function */
 397:         else
 398:               vtemp = (*(lispval (*)())(a->bcd.start))(); /* go for it */
 399:             break;
 400: 
 401:         case ARRAY:
 402:             vtemp = Iarray(a,argptr,FALSE);
 403:             break;
 404: 
 405: 
 406:         case DTPR:
 407:             if (a->d.car==nlambda || a->d.car==macro) {
 408:                 (np++)->val = argptr;
 409:                 TNP;
 410:             } else if (a->d.car==lambda)
 411:                 for (; argptr!=nil; argptr = argptr->d.cdr) {
 412:                     (np++)->val = argptr->d.car;
 413:                     TNP;
 414:                 }
 415:             else if(a->d.car==lexpr) {
 416:                 for (; argptr!=nil; argptr = argptr->d.cdr) {
 417: 
 418:                     (np++)->val = argptr->d.car;
 419:                     TNP;
 420:                 }
 421:                 handy = newdot();
 422:                 handy->d.car = (lispval)lbot;
 423:                 handy->d.cdr = (lispval)np;
 424:                 PUSHDOWN(lexpr_atom,handy);
 425:                 lbot = np;
 426:                 (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);
 427: 
 428:             } else break;    /* something is wrong - this isnt a proper function */
 429:             rebind(a->d.cdr->d.car,lbot);
 430: 
 431:         if (extrapush == 1) { protect(a); extrapush = 2;}
 432:             for (handy = a->d.cdr->d.cdr;
 433:                 handy != nil;
 434:                 handy = handy->d.cdr) {
 435:                     vtemp = eval(handy->d.car);    /* go for it */
 436:                 }
 437:         break;
 438: 
 439:     case VECTOR:
 440:         /* certain vectors are valid (fclosures) */
 441:        if(a->v.vector[VPropOff] == fclosure)
 442:            vtemp = (lispval) Ifclosure(a,FALSE);
 443:        break;
 444: 
 445:         };
 446: 
 447:     /* pop off extra value if we pushed it before */
 448:     if (extrapush == 2)
 449:     {
 450:         np--;
 451:         extrapush = 0;
 452:     };
 453: 
 454:         if (vtemp != CNIL)
 455:                 /* if we get here with a believable value, */
 456:                 /* we must have executed a function. */
 457:             {
 458:             popnames(oldbnp);
 459: 
 460:             /* in case some clown trashed t */
 461: 
 462:             tatom->a.clb = (lispval) tatom;
 463:         np = oldnp; lbot = oldlbot;
 464:             return(vtemp);
 465:             }
 466:         popnames(oldbnp);
 467:         a = (lispval) errorh1(Verundef,"apply: Undefined Function ",
 468:                           nil,TRUE,0,oldlbot->val);
 469:     }
 470:     /*NOT REACHED*/
 471: }
 472: 
 473: 
 474: /*
 475:  * Rebind -- rebind formal names
 476:  */
 477: rebind(argptr,workp)
 478: register lispval argptr;        /* argptr points to list of atoms */
 479: register struct argent * workp;        /* workp points to position on stack
 480:                        where evaluated args begin */
 481: {
 482:     register struct nament *namptr = bnp;
 483: 
 484:     for(;argptr != (lispval)nil;
 485:          workp++,argptr = argptr->d.cdr)  /* rebind formal names (shallow) */
 486:     {
 487:         if(argptr->d.car==nil)
 488:             continue;
 489:         namptr->atm = argptr->d.car;
 490:         if (workp < np) {
 491:             namptr->val = namptr->atm->a.clb;
 492:             namptr->atm->a.clb = workp->val;
 493:         } else
 494:             bnp = namptr,
 495:             error("Too few actual parameters",FALSE);
 496:         namptr++;
 497:         if(namptr > bnplim)
 498:             binderr();
 499:     }
 500:     bnp = namptr;
 501:     if (workp < np)
 502:         error("Too many actual parameters",FALSE);
 503: }
 504: 
 505: /* the argument to Lfuncal is now mandatory since nargs
 506:  * wont work on RISC. If it is given  then it is
 507:  * the name of the function to call and lbot points to the first arg.
 508:  * if it is not given, then lbot points to the function to call
 509:  */
 510: lispval
 511: Ifuncal(fcn)
 512: lispval fcn;
 513: {
 514:     register lispval a;
 515:     register lispval handy;
 516:     struct nament *oldbnp = bnp;    /* MUST be first local for evalframe */
 517:     lispval fcncalled;
 518:     lispval Ifcall(),Llist(),Iarray(), Ifclosure();
 519:     lispval vtemp;
 520:     int typ, dopopframe = FALSE, extrapush;
 521:     extern lispval end[];
 522:     Savestack(3);
 523: 
 524:     /*if(nargs()==1)			/* function I am evaling.    */
 525:     a = fcncalled = fcn;
 526:     /*else { a = fcncalled = lbot->val; lbot++; }*/
 527: 
 528:     /*debugging
 529:     if (rsetsw && rsetatom->a.clb != nil) {
 530: 	printf("funcall:");
 531: 	printr(a,stdout);
 532: 	printf("\nrsetsw: %d evalhsw: %d\n", rsetsw, evalhsw);
 533: 	printf("*rset: ");
 534: 	printr(rsetatom->a.clb,stdout);
 535: 	printf(" funhook: ");
 536: 	printr(funhatom->a.clb,stdout);
 537: 	printf(" funhook call flag^G: %d\n",funhcallsw);
 538: 	fflush(stdout);
 539:     };
 540:     */
 541: 
 542:     /* check if exception pending */
 543:     if(sigintcnt > 0 ) sigcall(SIGINT);
 544: 
 545:     if (rsetsw && rsetatom->a.clb != nil)  /* if (*rset t) has been done */
 546:     {
 547:     pbuf pb;
 548:     if (evalhsw != nil && funhatom->a.clb != nil)
 549:     {
 550:                         /*if (sstatus evalhook t)
 551: 						    and evalhook non-nil */
 552:         if (!funhcallsw)
 553:             /*if we got here after calling funcallhook, then
 554: 			  funhcallsw will be TRUE, so we want to skip calling
 555: 			  the hook function, permitting one form to be
 556: 			  evaluated before the hook fires.
 557: 			 */
 558:         {
 559:         /* setup equivalent of (funcall funcallhook <args to eval>) */
 560:         protect(a);
 561:         a = fcncalled = funhatom->a.clb; /* new function to funcall */
 562:         PUSHDOWN(funhatom, nil);    /* lambda-bind
 563: 						 * funcallhook to nil
 564: 						 */
 565:         PUSHDOWN(evalhatom, nil);
 566:          /* printf(" now will funcall ");
 567: 		printr(a,stdout);
 568: 		putchar('\n');
 569: 		fflush(stdout); */
 570:         };
 571:     }
 572:     errp = Pushframe(F_FUNCALL,a,nil);
 573:     dopopframe = TRUE;  /* remember to pop later */
 574:     if(retval == C_FRETURN)
 575:     {
 576:         popnames(oldbnp);
 577:         errp = Popframe();
 578:         Restorestack();
 579:         return(lispretval);
 580:     }
 581:     };
 582: 
 583:     funhcallsw = FALSE; /* so recursive calls to funcall will cause hook
 584:     			   to fire */
 585:     for(EVER)
 586:     {
 587:      top:
 588:         extrapush = 0;
 589: 
 590:         typ = TYPE(a);
 591:         if (typ == ATOM)
 592:     {   /* get function defn (unless calling form */
 593:             /* is itself a lambda-expr) */
 594:         a = a->a.fnbnd;
 595:         typ = TYPE(a);
 596:         extrapush = 1;  /* must protect this later */
 597:     }
 598:         vtemp = CNIL-1;            /* sentinel value for error test */
 599:         switch (typ) {
 600:         case ARRAY:
 601:         protect(a);         /* stack array descriptor on top */
 602:         a = a->ar.accfun;       /* now funcall access function */
 603:         goto top;
 604:         case BCD:
 605:             if(a->bcd.discipline==nlambda)
 606:                 {   if(np==lbot) protect(nil);  /* default is nil */
 607:                 while(np-lbot!=1 || (lbot->val != nil &&
 608:                       TYPE(lbot->val)!=DTPR)) {
 609: 
 610:                 lbot->val = errorh1(Vermisc,"Bad funcall arg(s) to fexpr.",
 611:                          nil,TRUE,0,lbot->val);
 612: 
 613:                     np = lbot+1;
 614:                     }
 615:                 }
 616:             /* go for it */
 617: 
 618:             if(TYPE(a->bcd.discipline)==STRNG)
 619:                 vtemp = Ifcall(a);
 620:             else
 621:                 vtemp = (*(lispval (*)())(a->bcd.start))();
 622:             if(a->bcd.discipline==macro)
 623:                 vtemp = eval(vtemp);
 624:             break;
 625: 
 626: 
 627:         case DTPR:
 628:             if (a->d.car == lambda) {
 629:                 ;/* VOID */
 630:             } else if (a->d.car == nlambda || a->d.car==macro) {
 631:                 if( np==lbot ) protect(nil);    /* default */
 632:                 while(np-lbot!=1 || (lbot->val != nil &&
 633:                           TYPE(lbot->val)!=DTPR)) {
 634:                     lbot->val = error("Bad funcall arg(s) to fexpr.",TRUE);
 635:                     np = lbot+1;
 636:                     }
 637:             } else if (a->d.car == lexpr) {
 638:                 handy = newdot();
 639:                 handy->d.car = (lispval) lbot;
 640:                 handy->d.cdr = (lispval) np;
 641:                 PUSHDOWN(lexpr_atom,handy);
 642:                 lbot = np;
 643:                 (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);
 644:             } else break;        /* something is wrong - this isn't a proper function */
 645:             rebind(a->d.cdr->d.car,lbot);
 646: 
 647:         /* since the actual arguments are bound to their formal params
 648: 	     * we can pop them off the stack.  However if we are doing
 649: 	     * debugging (that is if we've pushed a frame on the stack)
 650: 	     * then we must not pop off the actual args since they must
 651: 	     * be visible for evalframe to work
 652: 	     */
 653:             if(!dopopframe) np = lbot;
 654:         if (extrapush == 1) {protect(a);  extrapush = 2;}
 655:             for (handy = a->d.cdr->d.cdr;
 656:                 handy != nil;
 657:                 handy = handy->d.cdr) {
 658:                     vtemp = eval(handy->d.car);    /* go for it */
 659:                 }
 660:             if(a->d.car==macro)
 661:                 vtemp = eval(vtemp);
 662:         break;
 663: 
 664:     case VECTOR:
 665:        /* A fclosure represented as a vector with the property 'fclosure' */
 666:        if(a->v.vector[VPropOff] == fclosure)
 667:            vtemp = (lispval) Ifclosure(a,TRUE);
 668:        break;
 669: 
 670:         }
 671: 
 672:     /* pop off extra value if we pushed it before */
 673:     if(extrapush == 2) { np-- ; extrapush = 0; }
 674: 
 675:         if (vtemp != CNIL-1)
 676:             /* if we get here with a believable value, */
 677:             /* we must have executed a function. */
 678:             {
 679:             popnames(oldbnp);
 680: 
 681:             /* in case some clown trashed t */
 682: 
 683:             tatom->a.clb = (lispval) tatom;
 684: 
 685:         if(dopopframe) errp = Popframe();
 686:         Restorestack();
 687:             return(vtemp);
 688:             }
 689:         popnames(oldbnp);
 690:         a = fcncalled = (lispval) errorh1(Verundef,"funcall: Bad function",
 691:                            nil,TRUE,0,fcncalled);
 692:     }
 693:     /*NOT REACHED*/
 694: }
 695: lispval   /* this version called from lisp */
 696: Lfuncal()
 697: {
 698:     lispval handy;
 699:     Savestack(0);
 700: 
 701:     switch(np-lbot)
 702:     {
 703:         case 0: argerr("funcall");
 704:                 break;
 705:     }
 706:     handy = lbot++->val;
 707:     handy = Ifuncal(handy);
 708:     Restorestack();
 709:     return(handy);
 710: }
 711: 
 712: /* The following must be the next "function" after Lfuncal, for the
 713: sake of Levalf.  */
 714: fchack () {}
 715: 
 716: 
 717: /*
 718:  * Llexfun  :: lisp function lexpr-funcall
 719:  * lexpr-funcall is a cross between funcall and apply.
 720:  * the last argument is nil or a list of the rest of the arguments.
 721:  * we push those arguments on the stack and call funcall
 722:  *
 723:  */
 724: lispval
 725: Llexfun()
 726: {
 727:     register lispval handy;
 728: 
 729:     switch(np-lbot)
 730:     {
 731:     case 0: argerr("lexpr-funcall");    /* need at least one arg */
 732:         break;
 733:     case 1: return(Lfuncal());   /* no args besides function */
 734:     }
 735:     /* have at least one argument past the function to funcall */
 736:     handy = np[-1].val;     /* get last value */
 737:     np--;           /* pop it off stack */
 738: 
 739:     while((handy != nil) && (TYPE(handy) != DTPR))
 740:         handy = errorh1(Vermisc,"lexpr-funcall: last argument is not a list ",
 741:             nil,TRUE,0,handy);
 742: 
 743:     /* stack arguments */
 744:     for( ; handy != nil ; handy = handy->d.cdr) protect(handy->d.car);
 745: 
 746:     return(Lfuncal());
 747: }
 748: 
 749: 
 750: #undef protect
 751: 
 752: /* protect
 753:  * pushes the first argument onto namestack, thereby protecting from gc
 754:  */
 755: lispval
 756: protect(a)
 757: lispval a;
 758: {
 759:     (np++)->val = a;
 760:        if (np >=  nplim)
 761:         namerr();
 762: }
 763: 
 764: /* unprot
 765:  * returns the top thing on the name stack.  Underflow had better not
 766:  * occur.
 767:  */
 768: lispval
 769: unprot()
 770:     {
 771:     return((--np)->val);
 772:     }
 773: 
 774: lispval
 775: linterp()
 776:     {
 777:     error("BYTE INTERPRETER CALLED ERRONEOUSLY",FALSE);
 778:     }
 779: 
 780: /* Undeff - called from qfuncl when it detects a call to a undefined
 781:     function from compiled code, we print out a message and
 782:     will continue only if returned a symbol (ATOM in C parlance).
 783: */
 784: lispval
 785: Undeff(atmn)
 786: lispval atmn;
 787: {
 788:     do {atmn =errorh1(Verundef,"Undefined function called from compiled code ",
 789:                       nil,TRUE,0,atmn);}
 790:     while(TYPE(atmn) != ATOM);
 791:     return(atmn);
 792: }
 793: 
 794: /* VARARGS1 */
 795: bindfix(firstarg)
 796: lispval firstarg;
 797: {
 798:     register lispval *argp = &firstarg;
 799:     register struct nament *mybnp = bnp;
 800:     while(*argp != nil) {
 801:         mybnp->atm = *argp++;
 802:         mybnp->val = mybnp->atm->a.clb;
 803:         mybnp->atm->a.clb = *argp++;
 804:         bnp = mybnp++;
 805:     }
 806: }