BSD 4_1_snap release

[unix-history] / usr / src / cmd / lisp / franz / eval2.c

static char *sccsid = "@(#)eval2.c	35.2 5/18/81";

#include "global.h"

/* Iarray - handle array call.
 *  fun - array object
 *  args - arguments to the array call , most likely subscripts.
 *  evalp - flag, if TRUE then the arguments should be evaluated when they
 *	are stacked.
 */
lispval
Iarray(fun,args,evalp)
register lispval fun,args;
{
	register lispval reg, temp;
	register struct argent *lbot, *np;
	
	lbot = np;
	protect(fun->ar.accfun);
	for ( ; args != nil ; args = args->d.cdr)  /* stack subscripts */
	  if(evalp) protect(eval(args->d.car));
	  else protect(args->d.car);
	protect(fun);
	return(vtemp = Lfuncal());
}

/* Ifcall :: call foreign function/subroutine
 *   Ifcall is handed a binary object which is the function to call.
 * This function has already been determined to be a foreign function
 * by noticing that its discipline field is a string.  
 * The arguments to pass have already been evaluated and stacked.  We
 * create on the stack a 'callg' type argument list to give to the 
 * function.  What is passed to the foreign function depends on the
 * type of argument.  Certain args are passes directly, others must be
 * copied since the foreign function my want to change them.
 * When the foreign function returns, we may have to box the result,
 * depending on the type of foreign function.
 */
lispval
Ifcall(a)
lispval a;
{
	int *alloca();
	register int *arglist;
	register int index;
	register struct argent *mynp;
	register lispval ltemp;
	register struct argent *lbot;
	register struct argent *np;
	int itemp;
	int nargs = np - lbot;

	arglist = alloca((nargs + 1) * sizeof(int));
	mynp = lbot;
	*arglist = nargs;
	for(index = 1; index <=  nargs; index++) {
		switch(TYPE(ltemp=mynp->val)) {
			/* fixnums and flonums must be reboxed */
		case INT:
			arglist[index] = sp();
			stack(0);
			*(int *) arglist[index] = ltemp->i;
			break;
		case DOUB:
			stack(0);
			arglist[index] = sp();
			stack(0);
			*(double *) arglist[index] = ltemp->r;
			break;

			/* these can all be sent directly */
		case HUNK2:
		case HUNK4:
		case HUNK8:
		case HUNK16:
		case HUNK32:
		case HUNK64:
		case HUNK128:
		case DTPR:
		case ATOM:
		case SDOT:
		case STRNG:
			arglist[index] = (int) ltemp;
			break;
			/* these cause only part of the structure to be sent */

		case ARRAY:
			arglist[index] = (int) ltemp->ar.data;
			break;


		case BCD:
			arglist[index] = (int) ltemp->bcd.entry;
			break;

		default:
			error("foreign call: illegal argument ",FALSE);
			break;
		}
		mynp++;
	}
	switch(((char *)a->bcd.discipline)[0]) {
		case 'i': /* integer-function */
			ltemp = inewint(callg(a->bcd.entry,arglist));
			break;

		case 'r': /* real-function*/
			ltemp = newdoub();
			ltemp->r = (* ((double (*)()) callg))(a->bcd.entry,arglist);
			break;

		case 'f':  /* function */
			ltemp = (lispval) callg(a->bcd.entry,arglist);
			break;

		default:
		case 's': /* subroutine */
			callg(a->bcd.entry,arglist);
			ltemp = tatom;
	}
	return(ltemp);
}


callg(funct,arglist)
lispval (*funct)();
int *arglist;
{
	asm("	callg	*8(ap),*4(ap)");
}