BSD 4_4 development

[unix-history] / usr / src / old / lisp / franz / eval.c

#ifndef lint
static char *rcsid =
   "$Header: eval.c,v 1.6 83/09/07 17:54:42 sklower Exp $";
#endif

/*					-[Thu Aug 18 10:07:22 1983 by jkf]-
 * 	eval.c				$Locker:  $
 * evaluator
 *
 * (c) copyright 1982, Regents of the University of California
 */

#include "global.h"
#include <signal.h>
#include "frame.h"



/*
 *	eval
 * returns the value of the pointer passed as the argument.		
 *
 */

lispval
eval(actarg)
lispval actarg;
{
#define argptr handy
    register lispval a = actarg;
    register lispval handy;
    register struct nament *namptr;
    register struct argent *workp;
    struct nament *oldbnp = bnp;
    int dopopframe = FALSE;
    int type, shortcircuit = TRUE;
    lispval Ifcall(), Iarray();
    Savestack(4);

    /*debugging 
    if (rsetsw && rsetatom->a.clb != nil) {
	printf("Eval:");
	printr(a,stdout);
	printf("\nrsetsw: %d evalhsw: %d\n", rsetsw, evalhsw);
	printf("*rset: ");
	printr(rsetatom->a.clb,stdout);
	printf(" evalhook: ");
	printr(evalhatom->a.clb,stdout);
	printf(" evalhook call flag^G: %d\n", evalhcallsw);
	fflush(stdout); 
    };  
    */

    /* check if an interrupt is pending	 and handle if so */
    if(sigintcnt > 0) sigcall(SIGINT);

    if (rsetsw && rsetatom->a.clb != nil)  /* if (*rset t) has been done */
    {
	pbuf pb;
	shortcircuit = FALSE;
	if (evalhsw != nil && evalhatom->a.clb != nil)
	{
						/*if (sstatus evalhook t)
						    and evalhook non-nil */
	    if (!evalhcallsw)
	    		/*if we got here after calling evalhook, then
			  evalhcallsw will be TRUE, so we want to skip calling
			  the hook function, permitting one form to be
			  evaluated before the hook fires.
			 */
	    {
		/* setup equivalent of (funcall evalhook <arg to eval>) */
		(np++)->val = a;		/* push form on namestack */
		lbot=np;			/* set up args to funcall */
		(np++)->val = evalhatom->a.clb; /* push evalhook's clb */
		(np++)->val = a;		/* eval's arg becomes
					           2nd arg to funcall */
		PUSHDOWN(evalhatom, nil);	/* bind evalhook to nil*/
		PUSHDOWN(funhatom, nil);	/* bind funcallhook to nil*/
		funhcallsw = TRUE;		/* skip any funcall hook */
		handy = Lfuncal();		/* now call funcall */
		funhcallsw = FALSE;
		POP;
		POP;
		Restorestack();
		return(handy);
	    };
	}
	errp = Pushframe(F_EVAL,a,nil);
	dopopframe = TRUE;	/* remember to pop later */
	if(retval == C_FRETURN)
	{
	    Restorestack();
	    errp = Popframe();
	    return(lispretval);
	}
    };
        
    evalhcallsw = FALSE;   /* clear indication that evalhook called */
    
    switch (TYPE(a))
    {
    case ATOM:
	if (rsetsw && rsetatom->a.clb != nil && bptr_atom->a.clb != nil) {

	    struct nament *bpntr, *eval1bptr;
				  /* Both rsetsw and rsetatom for efficiency*/
				    /* bptr_atom set by second arg to eval1 */
	    eval1bptr = (struct nament *) bptr_atom->a.clb->d.cdr;
				    /* eval1bptr is bnp when eval1 was called;
				       if an atom was bound after this,
				       then its clb is valid */
	    for (bpntr = eval1bptr; bpntr < bnp; bpntr++)
		if (bpntr->atm==a) {
		    handy = a->a.clb;
		    goto gotatom;
		};		    /* Value saved in first binding of a,
				       if any, after pointer to eval1,
				       is the valid value, else use its clb */
	    for (bpntr = (struct nament *)bptr_atom->a.clb->d.car;
	      bpntr < eval1bptr; bpntr++)
		if (bpntr->atm==a) {
		    handy=bpntr->val;
		    goto gotatom;   /* Simply no way around goto here */
		};
	};
        handy = a->a.clb;
    gotatom:
        if(handy==CNIL) {
            handy = errorh1(Vermisc,"Unbound Variable:",nil,TRUE,0,a);
        }
	if(dopopframe) errp = Popframe();
	Restorestack();
        return(handy);

    case VALUE:
	if(dopopframe) errp = Popframe();
	Restorestack();
        return(a->l);

    case DTPR:
        (np++)->val = a;		/* push form on namestack */
        lbot = np;			/* define beginning of argstack */
        /* oldbnp = bnp;		   redundant - Mitch Marcus */
        a = a->d.car;			/* function name or lambda-expr */
        for(EVER)
            {
            switch(TYPE(a))
                {
            case ATOM:
					/*  get function binding  */
                if(a->a.fnbnd==nil && a->a.clb!=nil) {
                    a=a->a.clb;
                    if(TYPE(a)==ATOM)
                        a=a->a.fnbnd;
                } else
                    a = a->a.fnbnd;
                break;
            case VALUE:
                a = a->l;		/*  get value  */
                break;
                }

            vtemp = (CNIL-1);       /* sentinel value for error test */

        /*funcal:*/    switch (TYPE(a))
                {
            case BCD:    /* function */
                argptr = actarg->d.cdr;

				    /* decide whether lambda, nlambda or
				       macro and push args onto argstack
				       accordingly.                */

                if(a->bcd.discipline==nlambda) {
                    (np++)->val = argptr;
                    TNP;
                } else if(a->bcd.discipline==macro) {
                    (np++)->val = actarg;
                    TNP;
                } else for(;argptr!=nil; argptr = argptr->d.cdr) {
		    /* short circuit evaluations of ATOM, INT, DOUB
		     * if not in debugging mode
		     */
		    if(shortcircuit
		       && ((type = TYPE(argptr->d.car)) == ATOM)
		       && (argptr->d.car->a.clb != CNIL))
                       (np++)->val = argptr->d.car->a.clb;
		    else if(shortcircuit &&
		    		((type == INT) || (type == STRNG)))
                       (np++)->val = argptr->d.car;
		    else
                       (np++)->val = eval(argptr->d.car);
                    TNP;
                }
                /* go for it */

                if(TYPE(a->bcd.discipline)==STRNG)
                    vtemp = Ifcall(a);
                else
                    vtemp = (*(lispval (*)())(a->bcd.start))();
                break;

            case ARRAY:
                vtemp = Iarray(a,actarg->d.cdr,TRUE);
                break;

            case DTPR:		    /* push args on argstack according to
				       type                */
		protect(a);	/* save function definition in case function
				   is redefined */
		lbot = np;
                argptr = a->d.car;
                if (argptr==lambda) {
                    for(argptr = actarg->d.cdr;
                        argptr!=nil; argptr=argptr->d.cdr) {
                        
                        (np++)->val = eval(argptr->d.car);
                        TNP;
                    }
                } else if (argptr==nlambda) {
                    (np++)->val = actarg->d.cdr;
                    TNP;
                } else if (argptr==macro) {
                    (np++)->val = actarg;
                    TNP;
                } else if (argptr==lexpr) {
                    for(argptr = actarg->d.cdr;
                      argptr!=nil; argptr=argptr->d.cdr) {
                        
                        (np++)->val = eval(argptr->d.car);
                        TNP;
                    }
                    handy = newdot();
                    handy->d.car = (lispval)lbot;
                    handy->d.cdr = (lispval)np;
                    PUSHDOWN(lexpr_atom,handy);
                    lbot = np;
                    (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);

                } else break;    /* something is wrong - this isn't a proper function */

                argptr = (a->d.cdr)->d.car;
                namptr =  bnp;
                workp = lbot;
                if(bnp + (np - lbot)> bnplim)
                    binderr();
                for(;argptr != (lispval)nil;
                     workp++,argptr = argptr->d.cdr)    /* rebind formal names (shallow) */
                {
                    if(argptr->d.car==nil)
                        continue;
                    /*if(((namptr)->atm = argptr->d.car)==nil)
                        error("Attempt to lambda bind nil",FALSE);*/
                    namptr->atm = argptr->d.car;
                    if (workp < np) {
                        namptr->val = namptr->atm->a.clb;
                        namptr->atm->a.clb = workp->val;
                    } else
                        bnp = namptr,
                        error("Too few actual parameters",FALSE);
                    namptr++;
                }
                bnp = namptr;
                if (workp < np)
                    error("Too many actual parameters",FALSE);

				    /* execute body, implied prog allowed */

                for (handy = a->d.cdr->d.cdr;
                    handy != nil;
                    handy = handy->d.cdr) {
                        vtemp = eval(handy->d.car);
                    }
                }
            if (vtemp != (CNIL-1)) {
				/* if we get here with a believable value, */
				/* we must have executed a function. */
                popnames(oldbnp);

                /* in case some clown trashed t */

                tatom->a.clb = (lispval) tatom;
                if(a->d.car==macro)
		{
		    if(Vdisplacemacros->a.clb && (TYPE(vtemp) == DTPR))
		    {
			actarg->d.car = vtemp->d.car;
			actarg->d.cdr = vtemp->d.cdr;
		    }
		    vtemp = eval(vtemp);
		}
                    /* It is of the most wonderful 
                       coincidence that the offset
                       for car is the same as for
                       discipline so we get bcd macros
                       for free here ! */
		if(dopopframe) errp = Popframe();
		Restorestack();
		return(vtemp);
	    }
            popnames(oldbnp);
            a = (lispval) errorh1(Verundef,"eval: Undefined function ",nil,TRUE,0,actarg->d.car);
            }

        }
    if(dopopframe) errp = Popframe();
    Restorestack();
    return(a);    /* other data types are considered constants */
}

/*
 *    popnames
 * removes from the name stack all entries above the first argument.   
 * routine should usually be used to clean up the name stack as it    
 * knows about the special cases.  bnp is returned pointing to the
 * same place as the argument passed.
 */
lispval
popnames(llimit)
register struct nament *llimit;
{
    register struct nament *rnp;

    for(rnp = bnp; --rnp >= llimit;)
        rnp->atm->a.clb = rnp->val;
    bnp = llimit;
}


/* dumpnamestack
 * utility routine to dump out the namestack.
 * from bottom to 5 above np
 * should be put elsewhere
 */
dumpnamestack()
{
    struct argent *newnp;

    printf("namestack dump:\n");
    for(newnp = orgnp ; (newnp < np + 6) && (newnp < nplim) ; newnp++)
    {
	if(newnp == np) printf("**np:**\n");
	printf("[%d]: ",newnp-orgnp);
	printr(newnp->val,stdout);
	printf("\n");
    }
    printf("end namestack dump\n");
}



lispval
Lapply()
{
    register lispval a;
    register lispval handy;
    lispval vtemp, Ifclosure();
    struct nament *oldbnp = bnp;
    struct argent *oldlbot = lbot; /* Bottom of my frame! */
    struct argent *oldnp = np; /* First free on stack */
    int extrapush;		/* if must save function value */

    a = lbot->val;
    argptr = lbot[1].val;
    if(np-lbot!=2)
        errorh2(Vermisc,"Apply: Wrong number of args.",nil,FALSE,
               999,a,argptr);
    if(TYPE(argptr)!=DTPR && argptr!=nil)
        argptr = errorh1(Vermisc,"Apply: non-list of args",nil,TRUE,
                998,argptr);
    (np++)->val = a;    /* push form on namestack */
    TNP;
    lbot = np;        /* bottom of current frame */
    for(EVER)
        {
	extrapush = 0;
        if (TYPE(a) == ATOM) { a = a->a.fnbnd; extrapush = 1; }
					/* get function definition (unless
					   calling form is itself a lambda-
					   expression) */
        vtemp = CNIL;			/* sentinel value for error test */
        switch (TYPE(a)) {

        case BCD: 
					/* push arguments - value of a */
            if(a->bcd.discipline==nlambda || a->bcd.discipline==macro) {
                (np++)->val=argptr;
                TNP;
            } else for (; argptr!=nil; argptr = argptr->d.cdr) {
                (np++)->val=argptr->d.car;
                TNP;
            }

	    if(TYPE(a->bcd.discipline) == STRNG)
	      vtemp = Ifcall(a);	/* foreign function */
	    else
              vtemp = (*(lispval (*)())(a->bcd.start))(); /* go for it */
            break;

        case ARRAY:
            vtemp = Iarray(a,argptr,FALSE);
            break;


        case DTPR:
            if (a->d.car==nlambda || a->d.car==macro) {
                (np++)->val = argptr;
                TNP;
            } else if (a->d.car==lambda)
                for (; argptr!=nil; argptr = argptr->d.cdr) {
                    (np++)->val = argptr->d.car;
                    TNP;
                }
            else if(a->d.car==lexpr) {
                for (; argptr!=nil; argptr = argptr->d.cdr) {
                    
                    (np++)->val = argptr->d.car;
                    TNP;
                }
                handy = newdot();
                handy->d.car = (lispval)lbot;
                handy->d.cdr = (lispval)np;
                PUSHDOWN(lexpr_atom,handy);
                lbot = np;
                (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);

            } else break;    /* something is wrong - this isnt a proper function */
            rebind(a->d.cdr->d.car,lbot);

	    if (extrapush == 1) { protect(a); extrapush = 2;}
            for (handy = a->d.cdr->d.cdr;
                handy != nil;
                handy = handy->d.cdr) {
                    vtemp = eval(handy->d.car);    /* go for it */
                }
	    break;
	    
	case VECTOR:
	    /* certain vectors are valid (fclosures) */
	   if(a->v.vector[VPropOff] == fclosure)
	       vtemp = (lispval) Ifclosure(a,FALSE);
	   break;
		
        };
	
	/* pop off extra value if we pushed it before */
	if (extrapush == 2)
	{
	    np--;
	    extrapush = 0;
	};
	
        if (vtemp != CNIL)
				/* if we get here with a believable value, */
				/* we must have executed a function. */
            {
            popnames(oldbnp);

            /* in case some clown trashed t */

            tatom->a.clb = (lispval) tatom;
	    np = oldnp; lbot = oldlbot;
            return(vtemp);
            }
        popnames(oldbnp);
        a = (lispval) errorh1(Verundef,"apply: Undefined Function ",
					      nil,TRUE,0,oldlbot->val);
    }
    /*NOT REACHED*/
}


/*
 * Rebind -- rebind formal names
 */
rebind(argptr,workp)
register lispval argptr;        /* argptr points to list of atoms */
register struct argent * workp;        /* workp points to position on stack
                       where evaluated args begin */
{
    register struct nament *namptr = bnp;

    for(;argptr != (lispval)nil;
         workp++,argptr = argptr->d.cdr)  /* rebind formal names (shallow) */
    {
        if(argptr->d.car==nil)
            continue;
        namptr->atm = argptr->d.car;
        if (workp < np) {
            namptr->val = namptr->atm->a.clb;
            namptr->atm->a.clb = workp->val;
        } else
            bnp = namptr,
            error("Too few actual parameters",FALSE);
        namptr++;
        if(namptr > bnplim)
            binderr();
    }
    bnp = namptr;
    if (workp < np)
        error("Too many actual parameters",FALSE);
}

/* the argument to Lfuncal is now mandatory since nargs
 * wont work on RISC. If it is given  then it is 
 * the name of the function to call and lbot points to the first arg.
 * if it is not given, then lbot points to the function to call
 */
lispval
Ifuncal(fcn)
lispval fcn;
{
    register lispval a;
    register lispval handy; 
    struct nament *oldbnp = bnp;	/* MUST be first local for evalframe */
    lispval fcncalled;
    lispval Ifcall(),Llist(),Iarray(), Ifclosure();
    lispval vtemp;
    int typ, dopopframe = FALSE, extrapush;
    extern lispval end[];
    Savestack(3);

    /*if(nargs()==1)			/* function I am evaling.    */
	a = fcncalled = fcn;
    /*else { a = fcncalled = lbot->val; lbot++; }*/

    /*debugging 
    if (rsetsw && rsetatom->a.clb != nil) {
	printf("funcall:");
	printr(a,stdout);
	printf("\nrsetsw: %d evalhsw: %d\n", rsetsw, evalhsw);
	printf("*rset: ");
	printr(rsetatom->a.clb,stdout);
	printf(" funhook: ");
	printr(funhatom->a.clb,stdout);
	printf(" funhook call flag^G: %d\n",funhcallsw);
	fflush(stdout); 
    };  
    */

    /* check if exception pending */
    if(sigintcnt > 0 ) sigcall(SIGINT);

    if (rsetsw && rsetatom->a.clb != nil)  /* if (*rset t) has been done */
    {    	
	pbuf pb;
	if (evalhsw != nil && funhatom->a.clb != nil)
	{
						/*if (sstatus evalhook t)
						    and evalhook non-nil */
	    if (!funhcallsw)
			/*if we got here after calling funcallhook, then
			  funhcallsw will be TRUE, so we want to skip calling
			  the hook function, permitting one form to be
			  evaluated before the hook fires.
			 */
	    {
		/* setup equivalent of (funcall funcallhook <args to eval>) */
		protect(a);
		a = fcncalled = funhatom->a.clb; /* new function to funcall */
		PUSHDOWN(funhatom, nil);	/* lambda-bind 
						 * funcallhook to nil
						 */
		PUSHDOWN(evalhatom, nil);	
	     /* printf(" now will funcall ");
		printr(a,stdout);
		putchar('\n');
		fflush(stdout); */
	    };
	}
	errp = Pushframe(F_FUNCALL,a,nil);
	dopopframe = TRUE;	/* remember to pop later */
	if(retval == C_FRETURN)
	{
	    popnames(oldbnp);
	    errp = Popframe();
	    Restorestack();
	    return(lispretval);
	}
    };
    
    funhcallsw = FALSE;	/* so recursive calls to funcall will cause hook
    			   to fire */
    for(EVER)
    {
     top:
        extrapush = 0;
	
        typ = TYPE(a);
        if (typ == ATOM)
	{   /* get function defn (unless calling form */
            /* is itself a lambda-expr) */
	    a = a->a.fnbnd;
	    typ = TYPE(a);
	    extrapush = 1;	/* must protect this later */
	}
        vtemp = CNIL-1;            /* sentinel value for error test */
        switch (typ) {
        case ARRAY:
	    protect(a);			/* stack array descriptor on top */
	    a = a->ar.accfun;		/* now funcall access function */
	    goto top;
        case BCD:
            if(a->bcd.discipline==nlambda)
                {   if(np==lbot) protect(nil);  /* default is nil */
                while(np-lbot!=1 || (lbot->val != nil &&
                      TYPE(lbot->val)!=DTPR)) {

			    lbot->val = errorh1(Vermisc,"Bad funcall arg(s) to fexpr.",
						 nil,TRUE,0,lbot->val);
			    
                    np = lbot+1;
                    }
                }
            /* go for it */

            if(TYPE(a->bcd.discipline)==STRNG)
                vtemp = Ifcall(a);
            else
                vtemp = (*(lispval (*)())(a->bcd.start))();
            if(a->bcd.discipline==macro)
                vtemp = eval(vtemp);
            break;


        case DTPR:
            if (a->d.car == lambda) {
                ;/* VOID */
            } else if (a->d.car == nlambda || a->d.car==macro) {
                if( np==lbot ) protect(nil);    /* default */
                while(np-lbot!=1 || (lbot->val != nil &&
                          TYPE(lbot->val)!=DTPR)) {
                    lbot->val = error("Bad funcall arg(s) to fexpr.",TRUE);
                    np = lbot+1;
                    }
            } else if (a->d.car == lexpr) {
                handy = newdot();
                handy->d.car = (lispval) lbot;
                handy->d.cdr = (lispval) np;
                PUSHDOWN(lexpr_atom,handy);
                lbot = np;
                (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);
            } else break;        /* something is wrong - this isn't a proper function */
            rebind(a->d.cdr->d.car,lbot);

	    /* since the actual arguments are bound to their formal params
	     * we can pop them off the stack.  However if we are doing
	     * debugging (that is if we've pushed a frame on the stack)
	     * then we must not pop off the actual args since they must
	     * be visible for evalframe to work
	     */
            if(!dopopframe) np = lbot;
	    if (extrapush == 1) {protect(a);  extrapush = 2;}
            for (handy = a->d.cdr->d.cdr;
                handy != nil;
                handy = handy->d.cdr) {
                    vtemp = eval(handy->d.car);    /* go for it */
                }
            if(a->d.car==macro)
                vtemp = eval(vtemp);
	    break;
	    
	case VECTOR:
	   /* A fclosure represented as a vector with the property 'fclosure' */
	   if(a->v.vector[VPropOff] == fclosure)
	       vtemp = (lispval) Ifclosure(a,TRUE);
	   break;
	   
        }
	
	/* pop off extra value if we pushed it before */
	if(extrapush == 2) { np-- ; extrapush = 0; }
	
        if (vtemp != CNIL-1)
            /* if we get here with a believable value, */
            /* we must have executed a function. */
            {
            popnames(oldbnp);

            /* in case some clown trashed t */

            tatom->a.clb = (lispval) tatom;

	    if(dopopframe) errp = Popframe();
	    Restorestack();
            return(vtemp);
            }
        popnames(oldbnp);
	    a = fcncalled = (lispval) errorh1(Verundef,"funcall: Bad function",
					       nil,TRUE,0,fcncalled);
    }
    /*NOT REACHED*/
}
lispval   /* this version called from lisp */
Lfuncal()
{
	lispval handy;
	Savestack(0);
	
	switch(np-lbot)
	{
	    case 0: argerr("funcall");
	    	    break;
	}
	handy = lbot++->val;
	handy = Ifuncal(handy);
	Restorestack();
	return(handy);
}

/* The following must be the next "function" after Lfuncal, for the
sake of Levalf.  */
fchack () {}


/*
 * Llexfun  :: lisp function lexpr-funcall
 * lexpr-funcall is a cross between funcall and apply.
 * the last argument is nil or a list of the rest of the arguments.
 * we push those arguments on the stack and call funcall
 *
 */
lispval
Llexfun()
{
    register lispval handy;
    
    switch(np-lbot)
    {
	case 0: argerr("lexpr-funcall");	/* need at least one arg */
		break;
	case 1: return(Lfuncal());	 /* no args besides function */
    }
    /* have at least one argument past the function to funcall */
    handy = np[-1].val;		/* get last value */
    np--;			/* pop it off stack */
    
    while((handy != nil) && (TYPE(handy) != DTPR))
    	handy = errorh1(Vermisc,"lexpr-funcall: last argument is not a list ",
			nil,TRUE,0,handy);

    /* stack arguments */
    for( ; handy != nil ; handy = handy->d.cdr) protect(handy->d.car);

    return(Lfuncal());
}

	
#undef protect
	
/* protect 
 * pushes the first argument onto namestack, thereby protecting from gc
 */
lispval
protect(a)
lispval a;
{
    (np++)->val = a;
       if (np >=  nplim)
        namerr();
}

/* unprot
 * returns the top thing on the name stack.  Underflow had better not
 * occur.
 */
lispval
unprot()
    {
    return((--np)->val);
    }

lispval
linterp()
    {
    error("BYTE INTERPRETER CALLED ERRONEOUSLY",FALSE);
    }

/* Undeff - called from qfuncl when it detects a call to a undefined
    function from compiled code, we print out a message and
    will continue only if returned a symbol (ATOM in C parlance).
*/
lispval
Undeff(atmn)
lispval atmn;
{
    do {atmn =errorh1(Verundef,"Undefined function called from compiled code ",
				      nil,TRUE,0,atmn);}
	while(TYPE(atmn) != ATOM);
    return(atmn);		      
}

/* VARARGS1 */
bindfix(firstarg)
lispval firstarg;
{
    register lispval *argp = &firstarg;
    register struct nament *mybnp = bnp;
    while(*argp != nil) {
        mybnp->atm = *argp++;
        mybnp->val = mybnp->atm->a.clb;
        mybnp->atm->a.clb = *argp++;
        bnp = mybnp++;
    }
}