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

   1: #include "global.h"
   2: #include "frame.h"
   3: 
   4: lispval
   5: Levalf ()
   6: {
   7:     register struct frame *myfp;
   8:     register lispval handy, result;
   9:     struct frame *searchforpdl();
  10:     int evaltype;
  11:     Savestack(3);
  12: 
  13:     if(lbot==np) handy = nil;
  14:     else if((np-lbot) == 1) handy = lbot->val;
  15:     else argerr("evalf");
  16: 
  17:     if (handy == nil)  /* Arg of nil means start at the top */
  18:     {
  19:     myfp = searchforpdl(errp);
  20:     /*
  21: 	 * myfp may be nil, if *rset t wasn't done. In that case we
  22: 	 * just return nil
  23: 	 */
  24:     if(myfp == (struct frame *) 0) return(nil);
  25:     /*
  26: 	 * myfp may point to the call to evalframe, in which case we
  27: 	 * want to go to the next frame down.  myfp will not point
  28: 	 * to the call to evalframe if for example the translink tables
  29: 	 * are turned on and the call came from compiled code
  30: 	 */
  31:     if(    ((myfp->class == F_EVAL)
  32:                  && TYPE(myfp->larg1) == DTPR
  33:                  && myfp->larg1->d.car == Vevalframe)
  34:         || ((myfp->class == F_FUNCALL)
  35:              && (myfp->larg1 = Vevalframe)))
  36: 
  37:        myfp = searchforpdl(myfp->olderrp);  /* advance to next frame */
  38:     }
  39:     else
  40:     {
  41:     if( TYPE(handy) != INT )
  42:         error("Arg to evalframe must be integer",TRUE);
  43:         /*
  44: 	     * Interesting artifact: A pdl pointer will be an INT, but if
  45: 	     * read in, the Franz reader produces a bignum, thus giving some
  46: 	     * protection from being hacked.
  47: 	     */
  48: 
  49:     myfp = (struct frame *)(handy->i);
  50:     vfypdlp(myfp);  /* make sure we are given valid pointer */
  51:     myfp = searchforpdl(myfp);
  52:         if (myfp == (struct frame *) 0 ) return(nil);   /* end of frames */
  53:     myfp = searchforpdl(myfp->olderrp); /* advance to next one */
  54:     };
  55: 
  56: 
  57:     if (myfp == (struct frame *) 0 ) return(nil);   /* end of frames */
  58: 
  59:     if(myfp->class == F_EVAL) evaltype = TRUE; else evaltype = FALSE;
  60: 
  61:     /* return ( <eval or apply> <fp> <exp being evaled> <bnp>) */
  62:     protect(result = newdot());
  63:     /*
  64:      * See maclisp manual for difference between eval frames and apply
  65:      * frames, or else see the code below.
  66:      */
  67:     result->d.car = matom (evaltype ? "eval" : "apply");
  68:     result->d.cdr = (handy = newdot());
  69:     handy->d.car = inewint(myfp); /* The frame pointer as a lisp int */
  70:     handy->d.cdr = newdot();
  71:     handy = handy->d.cdr;
  72:     if (evaltype)
  73:     handy->d.car = myfp->larg1;  /* eval type - simply the arg to eval */
  74:     else
  75:     {  /*
  76:         * apply type ; must build argument list. The form will look like
  77: 	*
  78:  	*	  (<function> (<evaled arg1> <evaled arg2> ....))
  79: 	*   i.e. the function name followed by a list of evaluated args
  80: 	*/
  81:     lispval form, arglist;
  82:     struct argent *pntr;
  83:     (form = newdot())->d.car = myfp->larg1;
  84:     handy->d.car = form;            /* link in to save from gc */
  85:     (form->d.cdr = newdot())->d.cdr = nil;
  86:     for (arglist = nil, pntr = myfp->svlbot; pntr < myfp->svnp;  pntr++)
  87:     {
  88:         if(arglist == nil)
  89:         {
  90:         protect(arglist = newdot());
  91:         form->d.cdr->d.car = arglist;   /* save from gc */
  92:         }
  93:         else arglist = (arglist->d.cdr = newdot());
  94:         arglist->d.car = pntr->val;
  95:     };
  96:     };
  97:     handy->d.cdr = newdot();
  98:     handy = handy->d.cdr;
  99:     /* Next is index into bindstack lisp pseudo-array, for maximum
 100: 	    usefulness */
 101:     handy->d.car = inewint( myfp->svbnp - orgbnp);
 102:     handy->d.cdr = newdot();
 103:     handy = handy->d.cdr;
 104: 
 105:     handy->d.car = inewint(myfp->svnp - orgnp); /* index of np in namestack*/
 106:     handy->d.cdr = newdot();
 107:     handy = handy->d.cdr;
 108:     handy->d.car = inewint(myfp->svlbot - orgnp);/* index of lbot in namestack*/
 109:     Restorestack();
 110:     return(result);
 111: }
 112: 
 113: struct frame *searchforpdl (myfp)
 114: struct frame *myfp;
 115: {
 116:     /*
 117:      * for safety sake, we verify that this is a real pdl pointer by
 118:      * tracing back all pdl pointers from the start
 119:      * then after we find it, we just advance to next F_EVAL or F_FUNCALL
 120:      */
 121:     vfypdlp(myfp);
 122:     for(  ; myfp != (struct frame *)0 ; myfp= myfp->olderrp)
 123:     {
 124:     if((myfp->class == F_EVAL) || (myfp->class == F_FUNCALL))
 125:         return(myfp);
 126:     }
 127:     return((struct frame *)0);
 128: }
 129: 
 130: /*
 131:  * vfypdlp :: verify pdl pointer as existing,  do not return unless
 132:  * it is valid
 133:  */
 134: vfypdlp(curfp)
 135: register struct frame *curfp;
 136: {
 137:     register struct frame *myfp;
 138: 
 139:     for (myfp = errp; myfp != (struct frame *)0 ; myfp = myfp->olderrp)
 140:     if(myfp == curfp) return;
 141:     errorh1(Vermisc,"Invalid pdl pointer given: ",nil,FALSE,0,inewint(curfp));
 142: }
 143: 
 144: lispval
 145: Lfretn ()
 146: {
 147:     struct frame *myfp;
 148:     chkarg(2,"freturn");
 149: 
 150:     if( TYPE(lbot->val) != INT )
 151:     error("freturn: 1st arg not pdl pointer",FALSE);
 152: 
 153:     myfp = (struct frame *) (lbot->val->i);
 154:     vfypdlp(myfp);      /* make sure pdlp is valid */
 155: 
 156:     retval = C_FRETURN;     /* signal coming from freturn */
 157:     lispretval = (lbot+1)->val; /* value to return 	*/
 158:     Iretfromfr(myfp);
 159:     /* NOT REACHED */
 160: }

Defined functions