#ifndef lint
static char *rcsid =
   "$Header: lam3.c,v 1.4 84/04/06 23:08:13 layer Exp $";
#endif

/*					-[Fri Aug  5 12:47:19 1983 by jkf]-
 * 	lam3.c				$Locker:  $
 * lambda functions
 *
 * (c) copyright 1982, Regents of the University of California
 */

# include "global.h"
# include "chars.h"
# include "chkrtab.h"

lispval
Lalfalp()
{
	register char  *first, *second;

	chkarg(2,"alphalessp");
	first = (char *) verify(lbot->val,"alphalessp: non symbol or string arg");
	second = (char *) verify((lbot+1)->val,"alphalessp: non symbol or string arg");
	if(strcmp(first,second) < 0)
		return(tatom);
	else
		return(nil);
}

lispval
Lncons()
{
	register lispval handy;

	chkarg(1,"ncons");
	handy = newdot();
	handy->d.cdr = nil;
	handy->d.car = lbot->val;
	return(handy);
}
lispval
Lzerop()
{
	register lispval handy;

	chkarg(1,"zerop");
	handy = lbot->val;
	switch(TYPE(handy)) {
	case INT:
		return(handy->i==0?tatom:nil);
	case DOUB:
		return(handy->r==0.0?tatom:nil);
	}
	return(nil);
}
lispval
Lonep()
{
	register lispval handy; 
	lispval Ladd();

	handy = lbot->val;
	switch(TYPE(handy)) {
	case INT:
		return(handy->i==1?tatom:nil);
	case DOUB:
		return(handy->r==1.0?tatom:nil);
	case SDOT:
		protect(inewint(0));
		handy = Ladd();
		if(TYPE(handy)!=INT || handy->i !=1)
			return(nil);
		else
			return(tatom);
	}
	return(nil);
}

lispval
cmpx(lssp)
{
	register struct argent *argp;
	register struct argent *outarg;
	register struct argent *onp = np;
	Savestack(3);


	argp = lbot + 1;
	outarg = np;
	while(argp < onp) {

		np = outarg + 2;
		lbot = outarg;
		if(lssp)
			*outarg = argp[-1], outarg[1]  = *argp++;
		else
			outarg[1]  = argp[-1], *outarg = *argp++;
		lbot->val = Lsub();
		np = lbot + 1;
		if(Lnegp()==nil) 
		{
		    Restorestack();
		    return(nil);
		}
	}
	Restorestack();
	return(tatom);
}

lispval
Lgreaterp()
{
	register int typ;
	/* do the easy cases first */
	if(np-lbot == 2)
	{   if((typ=TYPE(lbot->val)) == INT)
	    {    if((typ=TYPE(lbot[1].val)) == INT)
		   return((lbot[0].val->i - lbot[1].val->i) > 0 ? tatom : nil);
		 else if(typ == DOUB)
		  return((lbot[0].val->i - lbot[1].val->r) > 0.0 ? tatom : nil);
	    }
	    else if(typ == DOUB)
	    {    if((typ=TYPE(lbot[1].val)) == INT)
		  return((lbot[0].val->r - lbot[1].val->i) > 0.0 ? tatom : nil);
		 else if(typ == DOUB)
		  return((lbot[0].val->r - lbot[1].val->r) > 0.0 ? tatom : nil);
	    }
	}
		  
	return(cmpx(FALSE));
}

lispval
Llessp()
{
	register int typ;
	/* do the easy cases first */
	if(np-lbot == 2)
	{   if((typ=TYPE(lbot->val)) == INT)
	    {    if((typ=TYPE(lbot[1].val)) == INT)
		   return((lbot[0].val->i - lbot[1].val->i) < 0 ? tatom : nil);
		 else if(typ == DOUB)
		  return((lbot[0].val->i - lbot[1].val->r) < 0.0 ? tatom : nil);
	    }
	    else if(typ == DOUB)
	    {    if((typ=TYPE(lbot[1].val)) == INT)
		  return((lbot[0].val->r - lbot[1].val->i) < 0.0 ? tatom : nil);
		 else if(typ == DOUB)
		  return((lbot[0].val->r - lbot[1].val->r) < 0.0 ? tatom : nil);
	    }
	}
		  
	return(cmpx(TRUE));
}

lispval
Ldiff()
{
	register lispval arg1,arg2; 
	register handy = 0;


	chkarg(2,"Ldiff");
	arg1 = lbot->val;
	arg2 = (lbot+1)->val;
	if(TYPE(arg1)==INT && TYPE(arg2)==INT) {
		handy=arg1->i - arg2->i;
	}
	else error("non-numeric argument",FALSE);
	return(inewint(handy));
}

lispval
Lmod()
{
	register lispval arg1,arg2;
	lispval  handy;
	struct sdot fake1, fake2;
	fake2.CDR = 0;
	fake1.CDR = 0;

	chkarg(2,"mod");
	handy = arg1 = lbot->val;
	arg2 = (lbot+1)->val;
	switch(TYPE(arg1)) {
	case SDOT:
		switch(TYPE(arg2)) {
		case SDOT:			/* both are already bignums */
			break;
		case INT:			/* convert arg2 to bignum   */
			fake2.I = arg2->i;
			arg2 =(lispval) &fake2;
			break;
		default:
			error("non-numeric argument",FALSE);
		}
		break;
	case INT:
		switch(TYPE(arg2)) {
		case SDOT:			/* convert arg1 to bignum */
			fake1.I = arg1->i;
			arg1 =(lispval) &fake1;
			break;
		case INT:			/* both are fixnums 	  */
			return( inewint ((arg1->i) % (arg2->i)) );
		default:
			error("non-numeric argument",FALSE);
		}
		break;
	default:
		error("non-numeric argument",FALSE);
	}
	if(TYPE((lbot+1)->val)==INT && lbot[1].val->i==0)
		return(handy);
	divbig(arg1,arg2,(lispval *)0,&handy);
	if(handy==((lispval)&fake1))
		handy = inewint(fake1.I);
	if(handy==((lispval)&fake2))
		handy = inewint(fake2.I);
	return(handy);
}
lispval
Ladd1()
{
	register lispval handy;
	lispval Ladd();
	Savestack(1); /* fixup entry mask */
	chkarg(1,"add1");

	/* simple test first */
	if((TYPE(lbot->val) == INT) && (lbot->val->i < MaxINT))
	{
	    Restorestack();
	    return(inewint(lbot->val->i + 1));
	}
	
	handy = rdrint;
	handy->i = 1;
	protect(handy);
	handy=Ladd();
	Restorestack();
	return(handy);

}



lispval
Lsub1()
{
	register lispval handy;
	lispval Ladd();
	Savestack(1); /* fixup entry mask */
	chkarg(1,"sub1");
	
	if((TYPE(lbot->val) == INT) && (lbot->val->i > MinINT))
	{
	    Restorestack();
	    return(inewint(lbot->val->i - 1));
	}

	handy = rdrint;
	handy->i = - 1;
	protect(handy);
	handy=Ladd();
	Restorestack();
	return(handy);
}

lispval
Lminus()
{
	register lispval arg1, handy;
	lispval subbig();

	chkarg(1,"minus");
	arg1 = lbot->val;
	handy = nil;
	switch(TYPE(arg1)) {
	case INT:
		handy= inewint(0 - arg1->i);
		break;
	case DOUB:
		handy = newdoub();
		handy->r = -arg1->r;
		break;
	case SDOT: { struct sdot dummyb;
		handy = (lispval) &dummyb;
		handy->s.I = 0;
		handy->s.CDR = (lispval) 0;
		handy = subbig(handy,arg1);
		break; }

	default:
		error("non-numeric argument",FALSE);
	}
	return(handy);
}

lispval
Lnegp()
{
	register lispval handy = np[-1].val, work;
	register flag = 0;

loop:
	switch(TYPE(handy)) {
	case INT:
		if(handy->i < 0) flag = TRUE;
		break;
	case DOUB:
		if(handy->r < 0) flag = TRUE;
		break;
	case SDOT:
		for(work = handy;
		    work->s.CDR!=(lispval) 0;
		    work = work->s.CDR) {;}
		if(work->s.I < 0) flag = TRUE;
		break;
	default:
		handy = errorh1(Vermisc,
				  "minusp: Non-(int,real,bignum) arg: ",
				  nil,
				  TRUE,
				  0,
				  handy);
		goto loop;
	}
	if(flag) return(tatom);
	return(nil);
}

lispval
Labsval()
{
	register lispval arg1;

	chkarg(1,"absval");
	arg1 = lbot->val;
	if(Lnegp()!=nil) return(Lminus());

	return(arg1);
}

/*
 *
 * (oblist)
 *
 * oblist returns a list of all symbols in the oblist
 *
 * written by jkf.
 */
lispval
Loblist()
{
    int indx;
    lispval headp, tailp ;
    struct atom *symb ;
    extern int hashtop;
    Savestack(0);

    headp = tailp = newdot(); /* allocate first DTPR */
    protect(headp);		/*protect the list from garbage collection*/
				/*line added by kls			  */

    for( indx=0 ; indx <= hashtop-1 ; indx++ ) /* though oblist */
    {
	for( symb = hasht[indx] ;
	     symb != (struct atom *) CNIL ;
	     symb = symb-> hshlnk)
	{
	    if(TYPE(symb) != ATOM) 
	    {   printf(" non symbol in hasht[%d] = %x: ",indx,symb);
		printr((lispval) symb,stdout);
		printf(" \n");
		fflush(stdout);
	    }
	    tailp->d.car = (lispval) symb  ; /* remember this atom */
	    tailp = tailp->d.cdr = newdot() ; /* link to next DTPR */
	}
    }

    tailp->d.cdr = nil ; /* close the list unfortunately throwing away
			  the last DTPR
			  */
    Restorestack();
    return(headp);
}

/*
 * Maclisp setsyntax function:
 *    (setsyntax c s x)
 * c represents character either by fixnum or atom
 * s is the atom "macro" or the atom "splicing" (in which case x is the
 * macro to be invoked); or nil (meaning don't change syntax of c); or
 * (well thats enough for now) if s is a fixnum then we modify the bits
 * for c in the readtable.
 */

lispval
Lsetsyn()
{
	register lispval s, c;
	register struct argent *mynp;
	register index;
	lispval x   /*  ,debugmode  */;
	extern unsigned char *ctable;
	extern lispval Istsrch();

	switch(np-lbot) {
	case 2:
		x= nil;			/* only 2 args given */
	case 3:
		x = lbot[2].val;	/* all three args given */
		break;
	default:
		argerr("setsyntax");
	}
	s = Vreadtable->a.clb;
	chkrtab(s);
	/* debugging code 
	debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr;
	if(debugmode)  printf("Readtable addr: %x\n",ctable);
	  end debugging code */
	mynp = lbot;
	c = (mynp++)->val;
	s = (mynp++)->val;

	switch(TYPE(c)) {
	default:
		error("neither fixnum, atom or string as char to setsyntax",FALSE);

	case ATOM:
		index = *(c->a.pname);
		if((c->a.pname)[1])
		    errorh1(Vermisc,"Only 1 char atoms to setsyntax",
		         nil,FALSE,0,c);
		break;

	case INT:
		index = c->i;
		break;

	case STRNG:
		index = (int) *((char *) c);
	}
	switch(TYPE(s)) {
	case ATOM:
		if(s==splice || s==macro) {
		    if(s==splice)
			    ctable[index] = VSPL;
		    else if(s==macro)
			    ctable[index] = VMAC;
		    if(TYPE(c)!=ATOM) {
			    strbuf[0] = index;
			    strbuf[1] = 0;
			    c = (getatom(TRUE));
		    }
		    Iputprop(c,x,lastrtab);
		    return(tatom);
		}

		/* ... fall into */
	default:  errorh1(Vermisc,"int:setsyntax : illegal second argument ",
				nil,FALSE,0,s);
		/* not reached */
		
	case INT:
		switch(synclass(s->i)) {
		case CESC: Xesc = (char) index; break;
		case CDQ: Xdqc = (char) index; break;
		case CSD: Xsdc = (char) index;	/* string */
		}

		if(synclass(ctable[index])==CESC   /* if we changed the current esc */
		  && (synclass(s->i)!=CESC)          /* to something else, pick current */
		  && Xesc == (char) index) {
	       		ctable[index] = s->i;
			rpltab(CESC,&Xesc);
		}
		else if(synclass(ctable[index])==CDQ   /*  likewise for double quote */
		       && synclass(s->i) != CDQ
		       && Xdqc == (char) index)  {
			ctable[index] = s->i;
			rpltab(CDQ,&Xdqc);
		}
		else if(synclass(ctable[index]) == CSD  /* and for string delimiter */
			&& synclass(s->i) != CSD
			&& Xsdc == (char) index) {
			 ctable[index] = s->i;
			 rpltab(CSD,&Xsdc);
		}
		else ctable[index] = s->i;

		break;

	}
	return(tatom);
}

/*
 * this aux function is used by setsyntax to determine the new current
 * escape or double quote character.  It scans the character table for
 * the first character with the given class (either VESC or VDQ) and
 * puts that character in Xesc or Xdqc (whichever is pointed to by
 * addr).
 */
rpltab(cclass,addr)
char cclass;
unsigned char *addr;
{
	register int i;
	extern unsigned char *ctable;
	for(i=0; i<=127 && synclass(ctable[i]) != cclass; i++);
	if(i<=127) *addr = (unsigned char) i;
	else *addr = '\0';
}


/*
 * int:getsyntax from lisp.
 * returns the fixnum syntax code from the readtable for the given character.
 * to be used by the lisp-code function getsyntax, not to be used by 
 * joe user.
 */
lispval
Lgetsyntax()
{
    register char *name;
    int number, typ;
    lispval handy;
    
    chkarg(1,"int:getsyntax");
    handy = lbot[0].val;
    while (1)
    {
	if((typ = TYPE(handy)) == ATOM)
	{
	    name = handy->a.pname;
	}
	else if (typ == STRNG)
	{
	    name = (char *)handy;
	}
	else if(typ == INT)
	{
	    number = handy->i;
	    break;
	}
	else {
	    handy =
	      errorh1(Vermisc,"int:getsyntax : bad character ",
	      		nil,TRUE,0,handy);
	    continue;	/* start at the top */
	}
	/* figure out the number of the first byte */
	number = (int) name[0];
	if(name[1] != '\0')
	{
	    handy = errorh1(Vermisc,
	    "int:getsyntax : only single character allowed ",
	    nil,TRUE,0,handy);
	}
	else break;
    }
    /* see if number is within range */
    if(number < 0 || number > 255)
    	errorh1(Vermisc,"int:getsyntax : character number out of range ",nil,
		FALSE,0,inewint(number));
    chkrtab(Vreadtable->a.clb);  /* make sure readtable is correct */
    return(inewint(ctable[number]));
}
    
    
	
    
lispval
Lzapline()
{
	register FILE *port;
	extern FILE * rdrport;

	port = rdrport;
	while (!feof(port) && (getc(port)!='\n') );
	return(nil);
}