Return to evalf.c CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz

Annotation of 42BSD/ucb/lisp/franz/evalf.c, revision 1.1

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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.