![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to eval.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / lisp|
Return to eval.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 ! root 1: static char *sccsid = "@(#)eval.c 34.2 10/21/80"; ! 2: ! 3: #include "global.h" ! 4: #include <signal.h> ! 5: /************************************************************************/ ! 6: /* */ ! 7: /* file: eval.i */ ! 8: /* contents: evaluator and namestack maintenance routines */ ! 9: /* */ ! 10: /************************************************************************/ ! 11: ! 12: ! 13: /* eval *****************************************************************/ ! 14: /* returns the value of the pointer passed as the argument. */ ! 15: ! 16: ! 17: lispval ! 18: eval(actarg) ! 19: lispval actarg; ! 20: { ! 21: #define argptr handy ! 22: register lispval a = actarg; ! 23: register lispval handy; ! 24: register struct nament *namptr; ! 25: register struct argent *workp; ! 26: register struct argent *lbot; ! 27: register struct argent *np; ! 28: /* struct argent *poplbot; Why this here? - M. Marcus */ ! 29: struct nament *oldbnp = bnp; ! 30: lispval Ifcall(), Iarray(); ! 31: ! 32: /*debugging ! 33: if (rsetsw && rsetatom->a.clb != nil) { ! 34: printf("Eval:"); ! 35: printr(a,stdout); ! 36: printf("\nrsetsw: %d evalhsw: %d\n", rsetsw, evalhsw); ! 37: printf("*rset: "); ! 38: printr(rsetatom->a.clb,stdout); ! 39: printf(" evalhook: "); ! 40: printr(evalhatom->a.clb,stdout); ! 41: printf(" evalhook call flag^G: "); ! 42: printr(evalhcall->a.clb, stdout); ! 43: fflush(stdout); ! 44: }; */ ! 45: ! 46: /* check if an interrupt is pending and handle if so */ ! 47: if(sigintcnt > 0) sigcall(SIGINT); ! 48: ! 49: if (rsetsw && rsetatom->a.clb != nil){ /* if (*rset t) has been done */ ! 50: if (evalhsw != nil && evalhatom->a.clb != nil) ! 51: /*if (sstatus evalhook t) ! 52: and evalhook non-nil */ ! 53: if (evalhcall->a.clb == tatom) ! 54: /*if this is a call to evalhook, don't call evalhook ! 55: function, but clobber evalhcall atom, so recursive ! 56: calls to eval cause evalhook function to fire. */ ! 57: evalhcall->a.clb = nil; ! 58: else { ! 59: /* setup equivalent of (funcall evalhook <arg to eval>) */ ! 60: (np++)->val = a; /* push form on namestack */ ! 61: lbot=np; /* set up args to funcall */ ! 62: (np++)->val = evalhatom->a.clb; /* push evalhook's clb */ ! 63: (np++)->val = a; /* eval's arg becomes ! 64: 2nd arg to funcall */ ! 65: PUSHDOWN(evalhatom, nil); /* lambda-bind evalhook to nil*/ ! 66: handy = Lfuncal(); /* now call funcall */ ! 67: POP; ! 68: return(handy); ! 69: }; ! 70: }; ! 71: ! 72: switch (TYPE(a)) ! 73: { ! 74: case ATOM: ! 75: if (rsetsw && rsetatom->a.clb != nil && bptr_atom->a.clb != nil) { ! 76: ! 77: struct nament *bpntr, *eval1bptr; ! 78: /* Both rsetsw and rsetatom for efficiency*/ ! 79: /* bptr_atom set by second arg to eval1 */ ! 80: eval1bptr = (struct nament *) bptr_atom->a.clb->d.cdr; ! 81: /* eval1bptr is bnp when eval1 was called; ! 82: if an atom was bound after this, ! 83: then its clb is valid */ ! 84: for (bpntr = eval1bptr; bpntr < bnp; bpntr++) ! 85: if (bpntr->atm==a) { ! 86: handy = a->a.clb; ! 87: goto gotatom; ! 88: }; /* Value saved in first binding of a, ! 89: if any, after pointer to eval1, ! 90: is the valid value, else use its clb */ ! 91: for (bpntr = (struct nament *)bptr_atom->a.clb->d.car; ! 92: bpntr < eval1bptr; bpntr++) ! 93: if (bpntr->atm==a) { ! 94: handy=bpntr->val; ! 95: goto gotatom; /* Simply no way around goto here */ ! 96: }; ! 97: }; ! 98: handy = a->a.clb; ! 99: gotatom: ! 100: if(handy==CNIL) { ! 101: handy = errorh(Vermisc,"Unbound Variable:",nil,TRUE,0,a); ! 102: } ! 103: return(handy); ! 104: ! 105: case VALUE: ! 106: return(a->l); ! 107: ! 108: case DTPR: ! 109: (np++)->val = a; /* push form on namestack */ ! 110: lbot = np; /* define beginning of argstack */ ! 111: /* oldbnp = bnp; redundant - Mitch Marcus */ ! 112: a = a->d.car; /* function name or lambda-expr */ ! 113: for(EVER) ! 114: { ! 115: switch(TYPE(a)) ! 116: { ! 117: case ATOM: ! 118: /* get function binding */ ! 119: if(a->a.fnbnd==nil && a->a.clb!=nil) { ! 120: a=a->a.clb; ! 121: if(TYPE(a)==ATOM) ! 122: a=a->a.fnbnd; ! 123: } else ! 124: a = a->a.fnbnd; ! 125: break; ! 126: case VALUE: ! 127: a = a->l; /* get value */ ! 128: break; ! 129: } ! 130: ! 131: vtemp = (CNIL-1); /* sentinel value for error test */ ! 132: ! 133: funcal: switch (TYPE(a)) ! 134: { ! 135: case BCD: /* function */ ! 136: argptr = actarg->d.cdr; ! 137: ! 138: /* decide whether lambda, nlambda or ! 139: macro and push args onto argstack ! 140: accordingly. */ ! 141: ! 142: if(a->bcd.discipline==nlambda) { ! 143: (np++)->val = argptr; ! 144: TNP; ! 145: } else if(a->bcd.discipline==macro) { ! 146: (np++)->val = actarg; ! 147: TNP; ! 148: } else for(;argptr!=nil; argptr = argptr->d.cdr) { ! 149: (np++)->val = eval(argptr->d.car); ! 150: TNP; ! 151: } ! 152: /* go for it */ ! 153: ! 154: if(TYPE(a->bcd.discipline)==STRNG) ! 155: vtemp = Ifcall(a); ! 156: else ! 157: vtemp = (*(lispval (*)())(a->bcd.entry))(); ! 158: break; ! 159: ! 160: case ARRAY: ! 161: vtemp = Iarray(a,actarg->d.cdr,TRUE); ! 162: break; ! 163: ! 164: case DTPR: /* push args on argstack according to ! 165: type */ ! 166: argptr = a->d.car; ! 167: if (argptr==lambda) { ! 168: for(argptr = actarg->d.cdr; ! 169: argptr!=nil; argptr=argptr->d.cdr) { ! 170: ! 171: (np++)->val = eval(argptr->d.car); ! 172: TNP; ! 173: } ! 174: } else if (argptr==nlambda) { ! 175: (np++)->val = actarg->d.cdr; ! 176: TNP; ! 177: } else if (argptr==macro) { ! 178: (np++)->val = actarg; ! 179: TNP; ! 180: } else if (argptr==lexpr) { ! 181: for(argptr = actarg->d.cdr; ! 182: argptr!=nil; argptr=argptr->d.cdr) { ! 183: ! 184: (np++)->val = eval(argptr->d.car); ! 185: TNP; ! 186: } ! 187: handy = newdot(); ! 188: handy->d.car = (lispval)lbot; ! 189: handy->d.cdr = (lispval)np; ! 190: PUSHDOWN(lexpr_atom,handy); ! 191: lbot = np; ! 192: (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car); ! 193: ! 194: } else break; /* something is wrong - this isn't a proper function */ ! 195: ! 196: argptr = (a->d.cdr)->d.car; ! 197: namptr = bnp; ! 198: workp = lbot; ! 199: if(bnp + (np - lbot)> bnplim) ! 200: binderr(); ! 201: for(;argptr != (lispval)nil; ! 202: workp++,argptr = argptr->d.cdr) /* rebind formal names (shallow) */ ! 203: { ! 204: if(argptr->d.car==nil) ! 205: continue; ! 206: /*if(((namptr)->atm = argptr->d.car)==nil) ! 207: error("Attempt to lambda bind nil",FALSE);*/ ! 208: namptr->atm = argptr->d.car; ! 209: if (workp < np) { ! 210: namptr->val = namptr->atm->a.clb; ! 211: namptr->atm->a.clb = workp->val; ! 212: } else ! 213: bnp = namptr, ! 214: error("Too few actual parameters",FALSE); ! 215: namptr++; ! 216: } ! 217: bnp = namptr; ! 218: if (workp < np) ! 219: error("Too many actual parameters",FALSE); ! 220: ! 221: /* execute body, implied prog allowed */ ! 222: ! 223: for (handy = a->d.cdr->d.cdr; ! 224: handy != nil; ! 225: handy = handy->d.cdr) { ! 226: vtemp = eval(handy->d.car); ! 227: } ! 228: } ! 229: if (vtemp != (CNIL-1)) { ! 230: /* if we get here with a believable value, */ ! 231: /* we must have executed a function. */ ! 232: popnames(oldbnp); ! 233: ! 234: /* in case some clown trashed t */ ! 235: ! 236: tatom->a.clb = (lispval) tatom; ! 237: if(a->d.car==macro) ! 238: return(eval(vtemp)); ! 239: /* It is of the most wonderful ! 240: coincidence that the offset ! 241: for car is the same as for ! 242: discipline so we get bcd macros ! 243: for free here ! */ ! 244: else return(vtemp); ! 245: } ! 246: popnames(oldbnp); ! 247: a = (lispval) errorh(Verundef,"eval: Undefined function ",nil,TRUE,0,actarg->d.car); ! 248: } ! 249: ! 250: } ! 251: return(a); /* other data types are considered constants */ ! 252: } ! 253: ! 254: ! 255: ! 256: ! 257: /* popnames *************************************************************/ ! 258: /* removes from the name stack all entries above the first argument. */ ! 259: /* routine should usually be used to clean up the name stack as it */ ! 260: /* knows about the special cases. np is returned pointing to the */ ! 261: /* same place as the argument passed. */ ! 262: lispval ! 263: popnames(llimit) ! 264: register struct nament *llimit; ! 265: { ! 266: register struct nament *rnp; ! 267: ! 268: for(rnp = bnp; --rnp >= llimit;) ! 269: rnp->atm->a.clb = rnp->val; ! 270: bnp = llimit; ! 271: } ! 272: ! 273: ! 274: /************************************************************************/ ! 275: /* */ ! 276: /* file: apply.c */ ! 277: /* Caveat -- Work in Progress -- not guaranteed! not tested! */ ! 278: /* */ ! 279: /* apply ***************************************************************/ ! 280: lispval ! 281: Lapply() ! 282: { ! 283: register lispval a; ! 284: register lispval handy; ! 285: register struct argent *workp; ! 286: register struct nament *namptr; ! 287: register struct argent *lbot; ! 288: register struct argent *np; ! 289: lispval vtemp; ! 290: struct nament *oldbnp = bnp; ! 291: struct argent *oldlbot = lbot; /* Bottom of my frame! */ ! 292: ! 293: a = lbot->val; ! 294: argptr = lbot[1].val; ! 295: if(np-lbot!=2) ! 296: errorh(Vermisc,"Apply: Wrong number of args.",nil,FALSE, ! 297: 999,a,argptr); ! 298: if(TYPE(argptr)!=DTPR && argptr!=nil) ! 299: argptr = errorh(Vermisc,"Apply: non-list of args",nil,TRUE, ! 300: 998,argptr); ! 301: (np++)->val = a; /* push form on namestack */ ! 302: TNP; ! 303: lbot = np; /* bottom of current frame */ ! 304: for(EVER) ! 305: { ! 306: if (TYPE(a) == ATOM) a = a->a.fnbnd; ! 307: /* get function definition (unless ! 308: calling form is itself a lambda- ! 309: expression) */ ! 310: vtemp = CNIL; /* sentinel value for error test */ ! 311: switch (TYPE(a)) { ! 312: ! 313: case BCD: ! 314: /* push arguments - value of a */ ! 315: if(a->bcd.discipline==nlambda || a->bcd.discipline==macro) { ! 316: (np++)->val=argptr; ! 317: TNP; ! 318: } else for (; argptr!=nil; argptr = argptr->d.cdr) { ! 319: (np++)->val=argptr->d.car; ! 320: TNP; ! 321: } ! 322: ! 323: if(TYPE(a->bcd.discipline) == STRNG) ! 324: vtemp = Ifcall(a); /* foreign function */ ! 325: else ! 326: vtemp = (*(lispval (*)())(a->bcd.entry))(); /* go for it */ ! 327: break; ! 328: ! 329: case ARRAY: ! 330: vtemp = Iarray(a,argptr,FALSE); ! 331: break; ! 332: ! 333: ! 334: case DTPR: ! 335: if (a->d.car==nlambda || a->d.car==macro) { ! 336: (np++)->val = argptr; ! 337: TNP; ! 338: } else if (a->d.car==lambda) ! 339: for (; argptr!=nil; argptr = argptr->d.cdr) { ! 340: (np++)->val = argptr->d.car; ! 341: TNP; ! 342: } ! 343: else if(a->d.car==lexpr) { ! 344: for (; argptr!=nil; argptr = argptr->d.cdr) { ! 345: ! 346: (np++)->val = argptr->d.car; ! 347: TNP; ! 348: } ! 349: handy = newdot(); ! 350: handy->d.car = (lispval)lbot; ! 351: handy->d.cdr = (lispval)np; ! 352: PUSHDOWN(lexpr_atom,handy); ! 353: lbot = np; ! 354: (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car); ! 355: ! 356: } else break; /* something is wrong - this isn't a proper function */ ! 357: rebind(a->d.cdr->d.car,lbot); ! 358: np = lbot; ! 359: for (handy = a->d.cdr->d.cdr; ! 360: handy != nil; ! 361: handy = handy->d.cdr) { ! 362: vtemp = eval(handy->d.car); /* go for it */ ! 363: } ! 364: } ! 365: if (vtemp != CNIL) ! 366: /* if we get here with a believable value, */ ! 367: /* we must have executed a function. */ ! 368: { ! 369: popnames(oldbnp); ! 370: ! 371: /* in case some clown trashed t */ ! 372: ! 373: tatom->a.clb = (lispval) tatom; ! 374: return(vtemp); ! 375: } ! 376: popnames(oldbnp); ! 377: a = (lispval) errorh(Verundef,"apply: Undefined Function ", ! 378: nil,TRUE,0,oldlbot->val); ! 379: } ! 380: /*NOT REACHED*/ ! 381: } ! 382: ! 383: ! 384: /* ! 385: * Rebind -- rebind formal names ! 386: */ ! 387: rebind(argptr,workp) ! 388: register lispval argptr; /* argptr points to list of atoms */ ! 389: register struct argent * workp; /* workp points to position on stack ! 390: where evaluated args begin */ ! 391: { ! 392: register lispval vtemp; ! 393: register struct nament *namptr = bnp; ! 394: register struct argent *lbot; ! 395: register struct argent *np; ! 396: ! 397: for(;argptr != (lispval)nil; ! 398: workp++,argptr = argptr->d.cdr) /* rebind formal names (shallow) */ ! 399: { ! 400: if(argptr->d.car==nil) ! 401: continue; ! 402: namptr->atm = argptr->d.car; ! 403: if (workp < np) { ! 404: namptr->val = namptr->atm->a.clb; ! 405: namptr->atm->a.clb = workp->val; ! 406: } else ! 407: bnp = namptr, ! 408: error("Too few actual parameters",FALSE); ! 409: namptr++; ! 410: if(namptr > bnplim) ! 411: binderr(); ! 412: } ! 413: bnp = namptr; ! 414: if (workp < np) ! 415: error("Too many actual parameters",FALSE); ! 416: } ! 417: ! 418: /* the argument to Lfuncal is optional, if it is given then it is ! 419: * the name of the function to call and lbot points to the first arg. ! 420: * if it is not given, then lbot points to the function to call ! 421: */ ! 422: lispval ! 423: Lfuncal(fcn) ! 424: lispval fcn; ! 425: { ! 426: register lispval a; ! 427: register lispval handy; ! 428: register struct argent *oldlbot; ! 429: register struct nament **namptr; ! 430: register struct argent *lbot; ! 431: register struct argent *np; ! 432: struct nament *oldbnp = bnp; /* MUST be first local for evalframe */ ! 433: lispval fcncalled; ! 434: lispval Ifcall(),Llist(),Iarray(); ! 435: lispval vtemp; ! 436: int typ; ! 437: extern lispval end[]; ! 438: ! 439: /*debugging stufff ! 440: printf("In funcal: "); ! 441: printr(lbot->val,stdout); ! 442: fflush(stdout); ! 443: printf("\n"); */ ! 444: ! 445: /* atrocity to avoid call to nargs() */ ! 446: /*define nargs() (* (char *) (&fcn -1))*/ ! 447: ! 448: oldlbot = lbot; /* bottom of my namestack frame */ ! 449: if((&fcn)[-1]==(lispval)1) /* function I am evaling. */ ! 450: a = fcncalled = fcn; ! 451: else { ! 452: a = fcncalled = lbot->val; ! 453: lbot++; ! 454: } ! 455: ! 456: /* check if exception pending */ ! 457: if(sigintcnt > 0 ) sigcall(SIGINT); ! 458: ! 459: for(EVER) ! 460: { ! 461: top: ! 462: typ = TYPE(a); ! 463: if (typ == ATOM) a = a->a.fnbnd, typ = TYPE(a); ! 464: ! 465: /* get function defn (unless calling form */ ! 466: /* is itself a lambda-expr) */ ! 467: vtemp = CNIL-1; /* sentinel value for error test */ ! 468: switch (typ) { ! 469: case ARRAY: ! 470: protect(a); /* stack array descriptor on top */ ! 471: a = a->ar.accfun; /* now funcall access function */ ! 472: goto top; ! 473: case BCD: ! 474: if(a->bcd.discipline==nlambda) ! 475: { if(np==lbot) protect(nil); /* default is nil */ ! 476: while(np-lbot!=1 || (lbot->val != nil && ! 477: TYPE(lbot->val)!=DTPR)) { ! 478: ! 479: lbot->val = errorh(Vermisc,"Bad funcall arg(s) to fexpr.", ! 480: nil,TRUE,0,lbot->val); ! 481: ! 482: np = lbot+1; ! 483: } ! 484: } ! 485: /* go for it */ ! 486: ! 487: if(TYPE(a->bcd.discipline)==STRNG) ! 488: vtemp = Ifcall(a); ! 489: else ! 490: vtemp = (*(lispval (*)())(a->bcd.entry))(); ! 491: if(a->bcd.discipline==macro) ! 492: vtemp = eval(vtemp); ! 493: break; ! 494: ! 495: ! 496: case DTPR: ! 497: if (a->d.car == lambda) { ! 498: ;/* VOID */ ! 499: } else if (a->d.car == nlambda || a->d.car==macro) { ! 500: if( np==lbot ) protect(nil); /* default */ ! 501: while(np-lbot!=1 || (lbot->val != nil && ! 502: TYPE(lbot->val)!=DTPR)) { ! 503: lbot->val = error("Bad funcall arg(s) to fexpr.",TRUE); ! 504: np = lbot+1; ! 505: } ! 506: } else if (a->d.car == lexpr) { ! 507: handy = newdot(); ! 508: handy->d.car = (lispval) lbot; ! 509: handy->d.cdr = (lispval) np; ! 510: PUSHDOWN(lexpr_atom,handy); ! 511: lbot = np; ! 512: (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car); ! 513: } else break; /* something is wrong - this isn't a proper function */ ! 514: rebind(a->d.cdr->d.car,lbot); ! 515: np = lbot; ! 516: for (handy = a->d.cdr->d.cdr; ! 517: handy != nil; ! 518: handy = handy->d.cdr) { ! 519: vtemp = eval(handy->d.car); /* go for it */ ! 520: } ! 521: if(a->d.car==macro) ! 522: vtemp = eval(vtemp); ! 523: } ! 524: if (vtemp != CNIL-1) ! 525: /* if we get here with a believable value, */ ! 526: /* we must have executed a function. */ ! 527: { ! 528: popnames(oldbnp); ! 529: ! 530: /* in case some clown trashed t */ ! 531: ! 532: tatom->a.clb = (lispval) tatom; ! 533: /*debugging ! 534: if(a>(lispval) end){printf(" leaving:"); ! 535: printr(a,stdout); ! 536: fflush(stdout);} */ ! 537: return(vtemp); ! 538: } ! 539: popnames(oldbnp); ! 540: a = fcncalled = (lispval) errorh(Verundef,"funcall: Bad function", ! 541: nil,TRUE,0,fcncalled); ! 542: } ! 543: /*NOT REACHED*/ ! 544: } ! 545: ! 546: /* The following must be the next "function" after Lfuncal, for the ! 547: sake of Levalf. */ ! 548: fchack () {} ! 549: ! 550: #undef protect ! 551: ! 552: /* protect **************************************************************/ ! 553: /* pushes the first argument onto namestack, thereby protecting from gc */ ! 554: lispval ! 555: protect(a) ! 556: lispval a; ! 557: { ! 558: /* (np++)->val = a; ! 559: if (np >= nplim) ! 560: namerr(); ! 561: */ ! 562: asm(" movl 4(ap),(r6)+"); ! 563: asm(" cmpl r6,_nplim"); ! 564: asm(" jlss out1"); ! 565: asm(" calls $0,_namerr"); ! 566: asm("out1: ret"); ! 567: } ! 568: ! 569: ! 570: /* unprot ****************************************************************/ ! 571: /* returns the top thing on the name stack. Underflow had better not */ ! 572: /* occur. */ ! 573: lispval ! 574: unprot() ! 575: { ! 576: asm(" movl -(r6),r0"); ! 577: } ! 578: ! 579: lispval ! 580: linterp() ! 581: { ! 582: error("BYTE INTERPRETER CALLED ERRONEOUSLY",FALSE); ! 583: } ! 584: ! 585: /* Undeff - called from qfuncl when it detects a call to a undefined ! 586: function from compiled code, we print out a message and ! 587: dont allow continuation ! 588: */ ! 589: lispval ! 590: Undeff(atmn) ! 591: lispval atmn; ! 592: { ! 593: return(errorh(Verundef,"Undefined function called from compiled code ", ! 594: nil,TRUE,0,atmn)); ! 595: } ! 596: bindfix(firstarg) ! 597: lispval firstarg; ! 598: { ! 599: register lispval *argp = &firstarg; ! 600: register struct nament *mybnp = bnp; ! 601: while(*argp != nil) { ! 602: mybnp->atm = *argp++; ! 603: mybnp->val = mybnp->atm->a.clb; ! 604: mybnp->atm->a.clb = *argp++; ! 605: bnp = mybnp++; ! 606: } ! 607: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.