![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to evalf.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 41BSD / cmd / lisp|
Return to evalf.c CVS log | Up to [CSRG BSD Unix] / 41BSD / cmd / lisp |
1.1 ! root 1: static char *sccsid = "@(#)evalf.c 34.1 10/3/80"; ! 2: ! 3: #include "global.h" ! 4: #include "frame.h" ! 5: /* evalframe off of the c stack. ! 6: We will set fp to point where the register fp points. ! 7: Then fp+2 = saved ap ! 8: fp+4 = saved pc ! 9: fp+3 = saved fp ! 10: ap+1 = first arg ! 11: */ ! 12: ! 13: /* These will keep track of the current saved values of np and lbot ! 14: as we decend the evalstack. These must be read by decoding the registers saved ! 15: by each function call. */ ! 16: struct argent *fakenp; ! 17: struct argent *fakelbot; ! 18: ! 19: lispval ! 20: Levalf () ! 21: { ! 22: register struct frame *myfp; ! 23: struct frame *nextevf(); ! 24: register lispval handy, result; ! 25: int **fp; /* this must be the first local */ ! 26: int evaltype; ! 27: snpand(3); ! 28: if(lbot==np) { ! 29: protect (nil); ! 30: }; ! 31: chkarg(1,"evalf"); ! 32: fakenp = NULL; ! 33: fakelbot = NULL; ! 34: if (lbot->val == nil) { /* Arg of nil means start at the top */ ! 35: myfp = nextevf ((struct frame *) (&fp +1), &evaltype); ! 36: /* myfp now points to evalframe of call to evalframe */ ! 37: myfp = myfp->fp; /* and now to the one past evalframe */ ! 38: } else { ! 39: if( TYPE(lbot->val) != INT ) ! 40: /* Interesting artifact: A pdl pointer will be an INT, but if ! 41: read in, the Franz reader produces a bignum, thus giving some ! 42: protection from being hacked. */ ! 43: error("ARG TO EVALFRAME MUST BE INTEGER",TRUE); ! 44: myfp = (struct frame *) (lbot->val->i); ! 45: if (myfp < (struct frame *) (&fp +1)){ ! 46: /* if purported fp is less than current fp, a fraud ! 47: (since stack grows down, and current fp must be bottom) */ ! 48: error("ARG TO EVALFRAME NOT EVALFRAME POINTER", TRUE); ! 49: } ! 50: }; ! 51: myfp = nextevf(myfp, &evaltype); /* get pointer to frame above */ ! 52: if(myfp > myfp->fp) return(nil); /* end of frames */ ! 53: /* return ( <eval or apply> <fp> <exp being evaled> <bnp>) */ ! 54: protect(result = newdot()); ! 55: /* See maclisp manual for difference between eval frames and apply ! 56: frames, or else see the code below. */ ! 57: result->d.car = matom (evaltype ? "eval" : "apply"); ! 58: result->d.cdr = (handy = newdot()); ! 59: handy->d.car = inewint(myfp->fp); /* The frame pointer as a lisp int */ ! 60: handy->d.cdr = newdot(); ! 61: handy = handy->d.cdr; ! 62: if (evaltype) ! 63: handy->d.car = myfp->ap[1]; /* eval type - simply the arg to eval */ ! 64: else { /* apply type ; must build argument list. The form will look like ! 65: (<function> (<evaled arg1> <evaled arg2> ....)) ! 66: i.e. the function name followed by a list of evaluated args */ ! 67: lispval form, handy1, arglist; ! 68: struct argent *pntr; ! 69: /* name of function will either be arg to Lfuncal or on argstack */ ! 70: (form = newdot())->d.car = ! 71: (int)myfp->ap[0] & 1? myfp->ap[1] : (fakelbot-1)->val; ! 72: /* Assume that Lfuncal increments lbot after getting ! 73: function to call. */ ! 74: (form->d.cdr = newdot())->d.cdr = nil; ! 75: for (arglist = nil, pntr = fakenp; ! 76: pntr > fakelbot;) { ! 77: (handy1 = newdot())->d.cdr = arglist; ! 78: (arglist = handy1)->d.car = (--pntr)->val; ! 79: }; ! 80: form->d.cdr->d.car = arglist; ! 81: handy->d.car = form; ! 82: }; ! 83: handy->d.cdr = newdot(); ! 84: handy = handy->d.cdr; ! 85: /* Next is index into bindstack lisp pseudo-array, for maximum ! 86: usefulness */ ! 87: handy->d.car = inewint( ((struct nament *) *( ((long *)myfp->fp) -1)) ! 88: -orgbnp); /* first part gets oldbnp, if first local */ ! 89: handy->d.cdr = newdot(); ! 90: handy = handy->d.cdr; ! 91: ! 92: handy->d.car = inewint(fakenp-orgnp); /* index of np in namestack*/ ! 93: handy->d.cdr = newdot(); ! 94: handy = handy->d.cdr; ! 95: handy->d.car = inewint(fakelbot-orgnp); /* index of lbot in namestack*/ ! 96: return(result); ! 97: } ! 98: ! 99: #define LBOTNPMASK 03<<22 /* Octal 3 */ ! 100: /* We assume that r6 and r7 are saved as pairs, and that no earlier ! 101: registers are saved. If the Franz snpand hack is changed, this may ! 102: have to change too. */ ! 103: struct frame *nextevf (curfp, ftypep) ! 104: struct frame *curfp; ! 105: int *ftypep; ! 106: { ! 107: register struct frame *myfp; ! 108: lispval _qfuncl(),tynames(); /* locations in qfuncl */ ! 109: lispval fchack(); /*pseudo function after Lfuncal */ ! 110: for (myfp = curfp; myfp < myfp->fp; myfp = myfp->fp) { ! 111: /* Look up stack until find a frame with the right saved pc */ ! 112: if (myfp->mask & LBOTNPMASK) { ! 113: fakenp = (struct argent *)(myfp->r6); ! 114: fakelbot = (struct argent *)(myfp->r7); ! 115: }; ! 116: if (myfp->pc > eval && myfp->pc < popnames) { /* interpreted code */ ! 117: *ftypep = TRUE; ! 118: break; ! 119: } else ! 120: /* if (myfp->pc > _qfuncl && myfp->pc < tynames) { /* compiled code *//* ! 121: *ftypep = FALSE; ! 122: break; ! 123: } else */ ! 124: if (myfp->pc > Lfuncal && myfp->pc < fchack) { /* call to funcall */ ! 125: *ftypep = FALSE; ! 126: break; ! 127: }; ! 128: }; ! 129: return(myfp); ! 130: } ! 131: ! 132: #include "catchfram.h" ! 133: lispval ! 134: Lfretn () ! 135: { ! 136: int **fp; /* this must be the first local */ ! 137: struct frame *myfp; ! 138: struct nament *mybnp; ! 139: extern long errp; ! 140: extern long exitlnk; ! 141: typedef struct catchfr *cp; ! 142: typedef struct savblock *savp; ! 143: cp curp; ! 144: savp cursavp; ! 145: chkarg(2,"freturn"); ! 146: if( TYPE(lbot->val) != INT ) ! 147: error("freturn: 1st arg not pdl pointer",FALSE); ! 148: myfp = (struct frame *) (lbot->val->i); ! 149: if (myfp < (struct frame *) (&fp +1)){ ! 150: /* if purported fp is less than current fp, a fraud ! 151: (since stack grows down, and current fp must be bottom) */ ! 152: error("freturn: 1st arg not current pdl pointer", FALSE); ! 153: }; ! 154: /* Unwind name stack. The oldbnp will be the first local variable of ! 155: the function we are returning from, so it will be immediately below this ! 156: stack frame (i.e. it was pushed right after the call). */ ! 157: mybnp = (struct nament *) *(((long *)myfp) - 1); ! 158: if (mybnp < orgbnp || mybnp > bnp) ! 159: error("freturn: problem with pdl pointer", FALSE); ! 160: popnames (mybnp); ! 161: /* Reset pointer to next catchframe in stack appropriately. */ ! 162: for (curp = (cp) errp ; curp != (cp) nil ; curp = curp->link){ ! 163: /* Debugging... ! 164: printf ("Considering catchframe at %d\n", curp); fflush(stdout); */ ! 165: if ((long *) myfp < (long *) curp) { ! 166: /* printf ("Won\n"); fflush(stdout); */ ! 167: break; ! 168: }; ! 169: }; ! 170: errp = (long)curp; ! 171: /* printf ("errp is now %d\n", errp);fflush(stdout); */ ! 172: /* Reset saveblock for setexit/reset appropriately. */ ! 173: for (cursavp = (savp)exitlnk; cursavp != (savp) NULL; ! 174: cursavp = cursavp->savlnk) { ! 175: /* printf("Considering saveblock at %d\n", cursavp); ! 176: fflush (stdout); */ ! 177: if ((savp) myfp > cursavp && ! 178: ((savp)myfp < cursavp->savlnk || cursavp->savlnk == 0)) { ! 179: /* printf("Won\n"); fflush(stdout); */ ! 180: resexit(cursavp); ! 181: break; ! 182: }; ! 183: }; ! 184: fsmash(myfp, (np-1)->val); /* Smash the fp register..(If myfp not valid fp, ! 185: real trouble follows) Will really return ! 186: from other guy (ha ha) */ ! 187: } ! 188: ! 189: fsmash(framep, retval) ! 190: struct frame *framep; ! 191: lispval retval; ! 192: { ! 193: asm(" movl 4(ap), fp"); ! 194: asm(" movl 8(ap), r0"); ! 195: asm(" ret"); ! 196: } ! 197:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.