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