BSD 3 development

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

# include "global.h"
# include <sgtty.h>
# include "chkrtab.h"
/**************************************************************************/
/*                                                                        */
/*   file: ccdfns.i                                                       */
/*   contents: LISP functions coded in C                                  */
/*                                                                        */
/*   These include LISP primitives, numeric and boolean functions and     */
/*   	predicates, some list-processing functions, i/o support functions */
/*  	and control flow functions (e.g. cont, break).                    */
/*   There are two types of functions: lambda (prefixed "L") and nlambda  */
/*	(prefixed "N"). 					  	  */
/*   Lambda's all call chkarg to insure that at least the minimum number  */
/* 	of necessary arguments are on the namestack.			  */
/*   All functions take their arguments from the namestack in a read-     */
/*  	only manner, and return their results via the normal C value	  */
/*	return mechanism.						  */
/*									  */



lispval
Leval()
{
	register lispval temp;

	chkarg(1);
	temp = lbot->val;
	    return(eval(temp));
}

lispval
Lxcar()
{	register int typ;
	register lispval temp, result;

	chkarg(1);
	temp = lbot->val;
	if (((typ = TYPE(temp)) == DTPR) || (typ == ATOM))
	    return(temp -> car);
	else if(typ == SDOT) {
		result = inewint(temp->i);
		return(result);
	} else if(Schainp!=nil && typ==ATOM)
		return(nil);
	else
		return(error("BAD ARG TO CAR",FALSE));

}

lispval
Lxcdr()
{	register int typ;
	register lispval temp, result;

	chkarg(1);
	temp = lbot->val;
	if(temp==nil) return (nil);

	if ((typ = TYPE(temp)) == DTPR) 
	    return(temp -> cdr);
	else if(typ==SDOT) {
		if(temp->CDR==0) return(nil);
		return(temp->CDR);
	} else if(Schainp!=nil && typ==ATOM)
		return(nil);
	else
		return(error("BAD ARG TO CDR",FALSE));
}

lispval
cxxr(as,ds)
register int as,ds;
{

	register lispval temp, temp2;
	int i, typ;
	lispval errorh();

	chkarg(1);
	temp = lbot->val;

	for( i=0 ; i<ds ; i++)
	{
	    if( temp != nil)
	    {
		if ((typ = TYPE(temp)) == DTPR) 
		    temp = temp -> cdr;
		else if(typ==SDOT) {
			if(temp->CDR==0) temp = nil;
			else temp = temp->CDR;
		}
		else if(Schainp!=nil && typ==ATOM)
			return(nil);
		else
			return(errorh(Vermisc,"BAD ARG TO CDR",nil,FALSE,5,temp));
	    }
	}

	for( i=0 ; i<as ; i++)
	{
	    if( temp != nil )
	    {
		if ((typ = TYPE(temp)) == DTPR)
		    temp = temp -> car;
		else if(typ == SDOT)
			temp2 = inewint(temp->i), temp = temp2;
		else if(Schainp!=nil && typ==ATOM)
			return(nil);
		else
			return(errorh(Vermisc,"BAD ARG TO CAR",nil,FALSE,5,temp));
	    }
	}

	return(temp);
}


lispval
Lcar()
{	return(cxxr(1,0));
}

lispval
Lcdr()
{	return(cxxr(0,1));
}

lispval
Lcadr()
{	return(cxxr(1,1));
}

lispval
Lcaar()
{	return(cxxr(2,0));
}

lispval
Lc02r()
{	return(cxxr(0,2));	/* cddr */
}

lispval
Lc12r()
{	return(cxxr(1,2));	/* caddr */
}

lispval
Lc03r()
{	return(cxxr(0,3));	/* cdddr */
}

lispval
Lc13r()
{	return(cxxr(1,3));	/* cadddr */
}

lispval
Lc04r()
{	return(cxxr(0,4));	/* cddddr */
}

lispval
Lc14r()
{	return(cxxr(1,4));	/* caddddr */
}

/*************************
*  
*  (nthelem num list)
* returns the num'th element of the list, by doing a caddddd...ddr
* where there are num-1 d's
* if num<=0 or greater than the length of the list, we return nil
******************************************************/

lispval
Lnthelem()
{
	register lispval temp;
	register int i;

	chkarg(2);

	if( TYPE(temp = lbot->val) != INT)
	return (error ("First arg to nthelem must be a fixnum",FALSE));

	i = temp->i;	/* pick up the first arg */

	if( i <= 0) return(nil);

	++lbot;			/* fix lbot for call to cxxr() 'cadddd..r' */
	temp = cxxr(1,i-1);
	--lbot;

	return(temp);
}





lispval
Lscons()
{
	register struct argent *argp = lbot;
	register lispval retp, handy;
	register int typ;

	chkarg(2);
	retp = newsdot();
	handy = (argp) -> val;
	if(TYPE(handy)!=INT)
		error("First arg to scons must be an int.",FALSE);
	retp->I = handy->i;
	handy = (argp+1)->val;
	if(handy==nil)
		retp->CDR = (lispval) 0;
	else {
		if(TYPE(handy)!=SDOT)
			error("Currently you may only link sdots to sdots.",FALSE);
		retp->CDR = handy;
	}
	return(retp);
}
lispval
Lcons()
{   register struct argent *argp;
	     lispval	   retp;

	chkarg(2);
	retp = newdot();
	retp -> cdr = ((argp = np-1) -> val);
	retp -> car = (--argp) -> val;
	return(retp);
}
#define CA 0
#define CD 1

lispval
rpla(what)
int what;
{	register struct argent *argp;
	register int typ; register lispval first, second;

	chkarg(2);
	argp = np-1;
	first = (argp-1)->val;
	while(first==nil)
		first = error("Attempt to rplac[ad] nil.",TRUE);
	second = argp->val;
	if (((typ = TYPE(first)) == DTPR) || (typ == ATOM)) {
		if (what == CA)
			first->car = second;
		else 
			first->cdr = second;
		return(first);
	}
	if (typ==SDOT) {
		if(what == CA) {
			typ = TYPE(second);
			if(typ!=INT) error("Rplacca of a bignum will only replace INTS",FALSE);
			first->i = second->i;
		} else {
			if(second==nil)
				first->CDR = (lispval) 0;
			else
				first->CDR = second;
		}
		return(first);
	}
	return(error("BAD ARG TO RPLA",FALSE));
}
lispval
Lrplaca()
{	return(rpla(CA));	}

lispval
Lrplacd()
{	return(rpla(CD));	}


lispval
Leq()
{
	register struct argent *mynp = lbot + AD;
	int itemp, flag;

	chkarg(2);
	if(mynp->val==(mynp+1)->val) return(tatom);
	return(nil);
}



lispval
Lnull()
{	chkarg(1);
	return ((lbot->val == nil) ? tatom : nil);
}



/* Lreturn **************************************************************/
/* Returns the first argument - which is nill if not specified.		*/
Lreturn()
	{
	chkarg(1);
	contval = lbot->val;
	reset(BRRETN);
	}


/* Lretbrk **************************************************************/
/* The first argument must be an integer and must be in the range	*/
/* -1 .. -depth.							*/
lispval
Lretbrk()
	{
	lispval number;
	register level;


	chkarg(1);
	number = lbot->val;
	if (TYPE(number) != INT)
		level = -1;
	else
		level = number->i;
	if(level < 0)
		level += depth;
	contval = (lispval) level;
	if (level < depth)
		reset(BRRETB);
	return(nil);
}



lispval
Linfile()
{
	FILE *port;
	register lispval name;
	snpand(1);

	chkarg(1);
	name = lbot->val;
	while (TYPE(name)!=ATOM)
		name = error("Please supply atom name for port.",TRUE);
	/* return nil if file couldnt be opened
	if ((port = fopen(name->pname,"r")) == NULL) return(nil); */	

	while ((port = fopen(name->pname,"r")) == NULL)
		name = errorh(Vermisc,"Unable to open file for reading.",nil,TRUE,31,name);
								
	return((lispval)(xports + (port - _iob)));
}

lispval
Loutfile()
{
	FILE *port; register lispval name;

	chkarg(1);
	name = lbot->val;
	while (TYPE(name)!=ATOM)
		name = error("Please supply atom name for port.",TRUE);
	while ((port = fopen(name->pname,"w")) == NULL)
		name = errorh(Vermisc,"Unable to open file for writing.",nil,TRUE,31,name);
	return((lispval)(xports + (port - _iob)));
}
lispval
Lterpr()
{
	FILE *port;

	chkarg(1);
	port = okport(lbot->val,okport(Vpoport->clb,stdout));
	putc('\n',port);
	fflush(port);
	return(nil);
}
lispval
Lclose()
{
	lispval port;

	if(lbot==np)
		port = error("Close requires one argument of type port",TRUE);
	port = lbot->val;
	if((TYPE(port))==PORT) fclose(port->p);
	return(tatom);
}

lispval
Lnwritn()
{
	register FILE *port;
	register value;

	chkarg(1);
	port = okport(lbot->val,okport(Vpoport->clb,stdout));
	value = port->_ptr - port->_base;
	return(inewint(value));
}

lispval
Ldrain()
{
	register FILE *port;
	register int iodes;
	struct sgttyb arg;

	chkarg(1);
	port = okport(lbot->val, okport(Vpoport->clb,stdout));
	if(port->_flag & _IOWRT) {
		fflush(port);
		return(nil);
	}
	if(! port->_flag & _IOREAD) return(nil);
	port->_cnt = 0;
	port->_ptr = port->_base;
	iodes = fileno(port);
	if(gtty(iodes,&arg) != -1) stty(iodes,&arg);
	return((lispval)(xports + (port - _iob)));
}
lispval
Llist()
{
	/* added for the benefit of mapping functions. */
	register struct argent *ulim, *namptr;
	register lispval temp, result;
	register struct argent *lbot, *np;

	ulim = np;
	namptr = lbot + AD;
	temp = result = (lispval) np;
	protect(nil);
	for(; namptr < ulim;) {
		temp = temp->l = newdot();
		temp->car = (namptr++)->val;
	}
	temp->l = nil;
	return(result->l);
}

lispval
Lnumberp()
{
	chkarg(1);
	switch(TYPE(lbot->val)) {
	case INT: case DOUB: case SDOT:
		return(tatom);
	}
	return(nil);
}

lispval
Latom()
{
	chkarg(1);
	if(TYPE(lbot->val)==DTPR)
		return(nil);
	else
		return(tatom);
}
lispval
Ltype()
{
	chkarg(1);
	switch(TYPE(lbot->val)) {
	case INT:
		return(int_name);
	case ATOM:
		return(atom_name);
	case SDOT:
		return(sdot_name);
	case DOUB:
		return(doub_name);
	case DTPR:
		return(dtpr_name);
	case STRNG:
		return(str_name);
	case ARRAY:
		return(array_name);
	case BCD:
		return(funct_name);
	case VALUE:
		return(val_name);
	case PORT:
		return(matom("port"));		/* fix this when name exists */
	}
	return(nil);
}

lispval
Ldtpr()
{
	chkarg(1);
	return(typred(DTPR,lbot->val));
}

lispval
Lbcdp()
{
	chkarg(1);
	return(typred(BCD,lbot->val));
}

lispval
Lportp()
{
	chkarg(1);
	return(typred(PORT,lbot->val));
}

lispval
Larrayp()
{
	chkarg(1);
	return(typred(ARRAY,lbot->val));
}
lispval
Lset()
{
	lispval varble;
	snpand(0);

	chkarg(2);
	varble = lbot->val;
	switch(TYPE(varble))
		{
	case ATOM:	return(varble->clb = lbot[1].val);

	case VALUE:	return(varble->l = lbot[1].val);
		}

	error("IMPROPER USE OF SET",FALSE);
}
lispval
Lequal()
{
	chkarg(2);

	if( lbot[1].val == lbot->val ) return(tatom);
	if(Iequal(lbot[1].val,lbot->val)) return(tatom); else return(nil);
}

Iequal(first,second) 
register lispval first, second;
{
	register type1, type2;
	register struct argent *lbot, *np;
	lispval Lsub(),Lzerop();

	if(first==second)
		return(1);
	type1=TYPE(first);
	type2=TYPE(second);
	if(type1!=type2) {
		if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
			goto dosub;
		return(0);
	}
	switch(type1) {
	case DTPR:
		 return(
			Iequal(first->car,second->car) &&
			Iequal(first->cdr,second->cdr) );
	case DOUB:
		return(first->r==second->r);
	case INT:
		return( (first->i==second->i));
dosub:
	case SDOT:
		lbot = np;
		np++->val = first;
		np++->val = second;
		lbot->val = Lsub();
		np = lbot + 1;
		return(Lzerop()!=nil);
	case VALUE:
		return( first->l==second->l );
	case STRNG:
		return(strcmp(first,second)==0);
	}
	return(0);
}

lispval
Lprint()
{
	chkarg(2);
	chkrtab(Vreadtable->clb);
	printr(lbot->val,okport(lbot[1].val,okport(Vpoport->clb,poport)));
	return(nil);
}

FILE *
okport(arg,proper) 
lispval arg;
FILE *proper;
{
	if(TYPE(arg)!=PORT)
		return(proper);
	else
		return(arg->p);
}
lispval
Lpatom()
{
	register lispval temp;
	FILE *port;

	chkarg(2);
	temp = Vreadtable->clb;
	chkrtab(temp);
	port = okport(lbot[1].val, okport(Vpoport->clb,stdout));
	if ((TYPE((temp = (lbot)->val)))!=ATOM)
		printr(temp, port);
	else
		fputs(temp->pname, port);
	return(temp);
}

/*
 * (pntlen thing) returns the length it takes to print out
 * an atom or number.
 */

lispval
Lpntlen()
{
	register lispval temp;
	return(inewint(Ipntlen()));
}
Ipntlen()
{
	register lispval temp;
	register char *handy;

	temp = np[-1].val;
loop:	switch(TYPE(temp)) {

	case ATOM:
		handy = temp->pname;
		break;

	case INT:
		sprintf(strbuf,"%d",temp->i);
		handy =strbuf;
		break;

	case DOUB:
		sprintf(strbuf,"%g",temp->r);
		handy =strbuf;
		break;

	default:
		temp = error("Non atom or number to pntlen\n",TRUE);
		goto loop;
	}

	return( strlen(handy));
}