#include "lisp.h"

char *stringify();

/* evaluate next arg from list on the stack, return answer.  flag <> 0 if
 * this should be last arg.  name is used to report errors, if type <> 0
 * arg must be this type.  ev <> 0 if arg should be evaluated.
 */
object ev_next(type,name,ev,last)
  char *name;
  {	register cons *c;
	object next = nth_stack(0);
	object ans;

	if (TYPE(next) == CONS) {
	  c = (cons *)ADDR(next);
	  if (next==nil || (last && c->cdr!=nil))
	    { error(";wrong number of args to %s\n\n",name); goto badnxt; }
	  if ((ans = ev ? eval(c->car) : c->car) == NULL) goto badnxt;
	  if (type!=0 && TYPE(ans)!=type)
	    { error(";wrong type arg for %s\n%S\n",name,c->car); goto badnxt; }
	  else if (!last) nth_exch(0,c->cdr);
	  else pop(1); 
	  return(ans);
	}
	error(";bad arg list to %s\n\n",name);

badnxt:	pop(1);
	return(NULL);
}

/* eval subr */
object _eval(arg)
  object arg;
  {	push(arg);
	arg = ev_next(0,"eval",1,1);
	return(arg == NULL ? NULL : eval(arg));
}

/* list and miscellaneous subrs */
object _car(arg)
  object arg;
  {	push(arg);
	arg = ev_next(CONS,"car",1,1);
	return(arg==NULL ? NULL : ((cons *)ADDR(arg))->car);
}

object _cdr(arg)
  object arg;
  {	push(arg);
	arg = ev_next(CONS,"cdr",1,1);
	return(arg==NULL ? NULL : ((cons *)ADDR(arg))->cdr);
}

object _rcar(arg)
  object arg;
  {	object obj;

	push(arg);
	if ((obj = ev_next(CONS,"rplaca",1,0)) == NULL) return(NULL);
	push(nth_exch(0,obj));
	arg = ev_next(0,"rplaca",1,1);
	pop(1);
	if (arg == NULL) return(NULL);
	((cons *)ADDR(obj))->car = arg;
	return(obj);
}

object _rcdr(arg)
  object arg;
  {	object obj;

	push(arg);
	if ((obj = ev_next(CONS,"rplacd",1,0)) == NULL) return(NULL);
	push(nth_exch(0,obj));
	arg = ev_next(0,"rplacd",1,1);
	pop(1);
	if (arg == NULL) return(NULL);
	((cons *)ADDR(obj))->cdr = arg;
	return(obj);
}

object _cons(arg)
  object arg;
  {	register cons *c;
	object obj;

	push(arg);
	obj = al_obj(CONS);
	push(nth_exch(0,obj));
	c = (cons *)ADDR(obj);
	c->car = ev_next(0,"cons",1,0);
	if (c->car == NULL) { pop(1); return(NULL); }
	c->cdr = ev_next(0,"cons",1,1);
	pop(1);
	if (c->cdr == NULL) return(NULL);
	return(obj);
}

object _list(arg)
  object arg;
  {	register cons *c = NULL;

	push(nil);
	push(arg);
	while (nth_stack(0) != nil) {
	  arg = al_obj(CONS);
	  if (c == NULL) nth_exch(1,arg);
	  else c->cdr = arg;
	  c = (cons *)ADDR(arg);
	  c->cdr = nil;
	  if ((c->car = ev_next(0,"list",1,0)) == NULL) {
	    pop(1);
	    return(NULL);
	  }
	}
	pop(1);
	return(pop(1));
}

object _memq(arg)
  object arg;
  {	register cons *c;
	object obj;

	push(arg);
	if ((arg = ev_next(0,"memq",1,0)) == NULL) return(NULL);
	push(nth_exch(0,arg));
	obj = ev_next(0,"memq",1,1);
	pop(1);
	if (obj == NULL) return(NULL);
	while (obj != nil) {
	  if (!ISCONS(obj)) return(nil);
	  c = (cons *)ADDR(obj);
	  if (c->car == arg) return(obj);
	  obj = c->cdr;
	}
	return(nil);
}

/* miscellaneous special forms */

object _cond(body)
  object body;
  {	register cons *c;
	object clause,temp;

	push(body);
	while (body != nil) {
	  if (!ISCONS(body)) goto badcond;
	  clause = ((cons *)ADDR(body))->car;
	  if (!ISCONS(clause)) goto badcond;
	  c = (cons *)ADDR(clause);
	  if ((temp = eval(c->car)) == NULL) { pop(1); return(NULL); }
	  if (temp != nil) {
	    pop(1);
	    if (c->cdr != nil) return(ev_list(c->cdr));
	    else return(temp);
	  }
	  body = ((cons *)ADDR(body))->cdr;
	}
	pop(1);
	return(nil);

badcond: error("; bad cond syntax\n");
	pop(1);
	return(NULL);
}

object _prog(body)
  object body;
  {	register cons *c;
	register int bvlcnt = 0;
	object bvl,temp;

	if (!ISCONS(body)) goto badprog;
	bvl = ((cons *)ADDR(body))->car;
	while (bvl != nil) {
	  if (!ISCONS(bvl)) goto badprog;
	  c = (cons *)ADDR(bvl);
	  if (!ISSYMBOL(c->car)) goto badprog;
	  push(c->car);
	  push(nil);
	  bvlcnt++;
	  bvl = c->cdr;
	}
	bind(bvlcnt);
	temp = ev_list(((cons *)ADDR(body))->cdr);
	bind(bvlcnt);
	pop(2*bvlcnt);
	return(temp);

badprog: error("; bad prog syntax\n");
	return(NULL);
}

object _defun(arg)
  object arg;
  {	register symbol *s;
	register cons *c;
	object name;

	push(arg);
	if (!ISCONS(arg)) goto baddefun;
	name = ((cons *)ADDR(arg))->car;
	if (!ISSYMBOL(name)) goto baddefun;
	s = (symbol *)ADDR(name);
	s->sym_function = al_obj(CONS);
	c = (cons *)ADDR(s->sym_function);
	c->car = intern("lambda");
	c->cdr = ((cons *)ADDR(arg))->cdr;
	pop(1);
	return(name);

baddefun: error("; bad defun syntax\n");
	pop(1);
	return(NULL);
}

object _do(arg)
  object arg;
  {	register cons *c;
	register symbol *s;
	object varlist,exit,body,var;
	int varcount = 0;

	push(arg);
	if (!ISCONS(arg)) goto baddo;
	varlist = ((cons *)ADDR(arg))->car;
	arg = ((cons *)ADDR(arg))->cdr;
	if (!ISCONS(arg)) goto baddo;
	exit = ((cons *)ADDR(arg))->car;
	if (!ISCONS(exit)) goto baddo;
	body = ((cons *)ADDR(arg))->cdr;
	if (body!=nil && !ISCONS(body)) goto baddo;

	/* go through varlist setting up bindings and initial values */
	arg = varlist;
	while (arg != nil) {
	  if (!ISCONS(arg)) goto baddo;
	  var = ((cons *)ADDR(arg))->car;
	  if (ISSYMBOL(var)) { push(var); varcount++; push(nil); }
	  else if (ISCONS(var)) {
	    c = (cons *)ADDR(var);
	    if (!ISSYMBOL(c->car)) goto baddo;
	    push(c->car);
	    varcount++;
	    if (c->cdr == nil) { push(nil); goto nextvar; }
	    push(nil);		/* reserve slot in stack */
	    var = c->cdr;
	    if (!ISCONS(var)) goto baddo;
	    var = eval(((cons *)ADDR(var))->car);
	    if (var == NULL) goto exitdo1;
	    nth_exch(0,var);
	  } else goto baddo;

 nextvar: arg = ((cons *)ADDR(arg))->cdr;
	}

	/* check exit test, eval body, eval iterators, then loop */
	bind(varcount);
	while (1) {
	  c = (cons *)ADDR(exit);
	  if ((arg = eval(c->car)) == NULL) goto exitdo2;
	  if (arg != nil) {
	    if (c->cdr != nil) arg = ev_list(c->cdr);
	    bind(varcount);
	    pop(2*varcount + 1);
	    return(arg);
	  }
	  if (ev_list(body) == NULL) goto exitdo2;

	  arg = varlist;
	  while (arg != nil) {
	    var = ((cons *)ADDR(arg))->car;
	    if (ISSYMBOL(var)) goto nextiter;
	    else if (ISCONS(var)) {
	      c = (cons *)ADDR(var);
	      s = (symbol *)ADDR(c->car);
	      if (c->cdr == nil) goto nextiter;
	      var = c->cdr;
	      if (!ISCONS(var)) goto nextiter;
	      c = (cons *)ADDR(var);
	      if (c->cdr == nil) goto nextiter;
	      var = c->cdr;
	      if (!ISCONS(var)) goto nextiter;
	      c = (cons *)ADDR(var);
	      if ((var = eval(c->car)) == NULL) goto exitdo2;
	      s->sym_value = var;
	    }
	  nextiter:
	    arg = ((cons *)ADDR(arg))->cdr;
	  }
	}

baddo:	error("; bad do syntax\n");
	goto exitdo1;

exitdo2:  bind(varcount);
exitdo1:  pop(2*varcount + 1);
	return(NULL);
}

/* io subrs */

object _load(arg)
  object arg;
  {	char *name;

	push(arg);
	if ((name = stringify(ev_next(STRING,"load",1,1))) == NULL) return(NULL);
	loadit(name);
	return(intern("done"));
}

loadit(name)
  register char *name;
  {	FILE *lfile;
	object arg;
	object eof = intern("end-of-file");

	if ((lfile = fopen(name,"r")) == NULL) {
	  error("; can't open load file %s\n",name);
	  return(NULL);
	}
	while (1) {
	  arg = obj_read(lfile,1);
	  if (arg==NULL || arg==eof) break;
	  if (eval(arg) == NULL) break;
	}
	fclose(lfile);	
}

_nlexit()
  {	exit(0);
}

FILE *logfile = NULL;	/* currently open log file */

object _logfile(arg)
  object arg;
  {	char *name;

	if (arg == nil) {
	  if (logfile != NULL) { fclose(logfile); logfile = NULL; }
	  return;
	}

	push(arg);
	if ((name = stringify(ev_next(0,"log-file",1,1))) == NULL) return(NULL);
	if ((logfile = WOPEN(name)) == NULL) {
	  error("; cannot open %s for output\n",name);
	  return(NULL);
	}
	SETTYPE(arg,FIXNUM);
	SETVALUE(arg,logfile);
	return(arg);
}

object _iopen(arg)
  object arg;
  {	char *name;
	FILE *f;

	push(arg);
	if ((name = stringify(ev_next(0,"openi",1,1))) == NULL) return(NULL);
	if ((f = fopen(name,"r")) == NULL) {
	  error("; cannot open %s for input\n",name);
	  return(NULL);
	}
	SETTYPE(arg,FIXNUM);
	SETVALUE(arg,f);
	return(arg);
}

object _oopen(arg)
  object arg;
  {	char *name;
	FILE *f;

	push(arg);
	if ((name = stringify(ev_next(0,"openo",1,1))) == NULL) return(NULL);
	if ((f = WOPEN(name)) == NULL) {
	  error("; cannot open %s for output\n",name);
	  return(NULL);
	}
	SETTYPE(arg,FIXNUM);
	SETVALUE(arg,f);
	return(arg);
}

object _lclose(arg)
  object arg;
  {	FILE *f;

	push(arg);
	if ((arg = ev_next(FIXNUM,"close",1,1)) == NULL) return(NULL);
	fclose(ADDR(arg));
	return(arg);
}

object _rread(arg)
  object arg;
  {	FILE *f = stdin;

	if (arg != nil) {
	  push(arg);
	  if ((arg = ev_next(FIXNUM,"read",1,1)) == NULL) return(NULL);
	  f = (FILE *)ADDR(arg);
	}

	return(obj_read(f,0));
}

object _flush(arg)
  object arg;
  {	FILE *f = stdout;

	if (arg != nil) {
	  push(arg);
	  if ((arg = ev_next(FIXNUM,"flush",1,1)) == NULL) return(NULL);
	  f = (FILE *)ADDR(arg);
	}

	fflush(f);
	return(arg);
}

object pr(arg,fname,flag)
  object arg;
  char *fname;
  {	object f;
	FILE *out;

	push(arg);
	if ((arg = ev_next(0,fname,1,0)) == NULL) return(NULL);

	if (nth_stack(0) != nil) {
	  push(nth_exch(0,arg));
	  f = ev_next(FIXNUM,fname,1,1);
	  pop(1);
	  if (f == NULL) return(NULL);
	  out = (FILE *)ADDR(f);
	} else { out = stdout; pop(1); }

	obj_print(arg,out,flag);
	return(arg);
}

object _prnt(obj)
  object obj;
  {	return(pr(obj,"print",0));
}

object _prn1(obj)
  object obj;
  {	return(pr(obj,"prin1",1));
}

object _prnc(obj)
  object obj;
  {	return(pr(obj,"princ",2));
}

object _terpri(obj)
  object obj;
  {	extern FILE *pfile;

	push(obj);
	if (obj != nil) {
	  if ((obj = ev_next(FIXNUM,"terpri",1,1)) == NULL) return(NULL);
	  pfile = (FILE *)ADDR(obj);
	} else { pfile = stdout; pop(1); }

	p_char('\n');
	return(nil);
}

object _printf(arg)
  object arg;
  {	extern FILE *pfile;
	register char *format;
	char ch;

	push(arg);
	if ((arg = ev_next(0,"printf",1,0)) == NULL) return(NULL);

	/* see if file id is given */
	if (ISFIX(arg)) {
	  pfile = (FILE *)ADDR(arg);
	  if ((arg = ev_next(0,"printf",1,0)) == NULL) return(NULL);
	} else pfile = stdout;

	if (TYPE(arg) != STRING) {
	  error("; no format string for printf\n");
	  pop(1);
	  return(NULL);
	} else format = (char *)ADDR(arg);

	while (ch = *format++) {
	  if (ch == '%') {
	    ch = *format++;
	    if (ch == 0) { p_char('%'); goto done; }
	    else if (ch == '%') { p_char('%'); continue; }
	    if ((arg = ev_next(0,"printf",1,0)) == NULL) return(NULL);
	    if (ch == 'S') obj_print(arg,pfile,1);
	    else if (ch == 'c') {
	      if (TYPE(arg) != FIXNUM) error("; exp corresponding to %%c not fixnum\n");
	      else p_char(SVALUE(arg));
	    } else { p_char('%'); p_char(ch); }
	  } else p_char(ch);
	}

 done:  pop(1);
	return(nil);
}

object _quote(arg)
  object arg;
  {	push(arg);
	return(ev_next(0,"quote",0,1));
}

object _set(arg)
  object arg;
  {	register symbol *s;

	push(arg);
	if ((arg = ev_next(SYMBOL,"set",1,0)) == NULL) return(NULL);
	s = (symbol *)ADDR(arg);
	if ((arg = ev_next(0,"set",1,1)) == NULL) return(NULL);
	s->sym_value = arg;
	return(arg);
}

object _fset(arg)
  object arg;
  {	register symbol *s;

	push(arg);
	if ((arg = ev_next(SYMBOL,"fset",1,0)) == NULL) return(NULL);
	s = (symbol *)ADDR(arg);
	if ((arg = ev_next(0,"fset",1,1)) == NULL) return(NULL);
	s->sym_function = arg;
	return(arg);
}

object _symeval(arg)
  object arg;
  {	register symbol *s;

	push(arg);
	if ((arg = ev_next(SYMBOL,"symeval",1,1)) == NULL) return(NULL);
	s = (symbol *)ADDR(arg);
	if (s->sym_value == NULL)
	  { error(";uninitialized variable %S\n\n",arg); return(NULL); }
	return (s->sym_value);
}

object _fsymeval(arg)
  object arg;
  {	register symbol *s;

	push(arg);
	if ((arg = ev_next(SYMBOL,"fsymeval",1,1)) == NULL) return(NULL);
	s = (symbol *)ADDR(arg);
	if (s->sym_function == NULL)
	  { error(";uninitialized function %S\n\n",arg); return(NULL); }
	return (s->sym_function);
}

object _setq(arg)
  object arg;
  {	register symbol *s;

	push(arg);
	while (nth_stack(0) != nil) {
	  if ((arg = ev_next(SYMBOL,"setq",0,0)) == NULL) return(NULL);
	  s = (symbol *)ADDR(arg);
	  if ((arg = ev_next(0,"setq",1,0)) == NULL) return(NULL);
	  s->sym_value = arg;
	}
	pop(1);
	return(arg);
}

/* arithmetic subrs */

object _add(arg)
  object arg;
  {	register int ac = 0;
	register int fpflag = 0;
	double fac;

	push(arg);
	while (nth_stack(0) != nil) {
	  if ((arg = ev_next(0,"+",1,0)) == NULL) return(NULL);
	  if (TYPE(arg) == FIXNUM) {
	    if (fpflag) fac += SVALUE(arg);
	    else ac += SVALUE(arg);
	  } else if (TYPE(arg) == FLONUM) {
	    if (!fpflag) { fpflag = 1; fac = ac; }
	    fac += ((flonum *)ADDR(arg))->flo_value;
	  } else {
	    error(";wrong type arg for +\n%S\n",arg);
	    pop(1);
	    return(NULL);
	  }
	}
	pop(1);

	if (fpflag) { arg = al_obj(FLONUM); ((flonum *)ADDR(arg))->flo_value = fac; }
	else { SETTYPE(arg,FIXNUM); SETVALUE(arg,ac); }
	return(arg);
}

object _mul(arg)
  object arg;
  {	register int ac = 1;
	register int fpflag = 0;
	double fac;

	push(arg);
	while (nth_stack(0) != nil) {
	  if ((arg = ev_next(0,"*",1,0)) == NULL) return(NULL);
	  if (TYPE(arg) == FIXNUM) {
	    if (fpflag) fac *= SVALUE(arg);
	    else ac *= SVALUE(arg);
	  } else if (TYPE(arg) == FLONUM) {
	    if (!fpflag) { fpflag = 1; fac = ac; }
	    fac *= ((flonum *)ADDR(arg))->flo_value;
	  } else {
	    error(";wrong type arg for *\n%S\n",arg);
	    pop(1);
	    return(NULL);
	  }
	}
	pop(1);

	if (fpflag) { arg = al_obj(FLONUM); ((flonum *)ADDR(arg))->flo_value = fac; }
	else { SETTYPE(arg,FIXNUM); SETVALUE(arg,ac); }
	return(arg);
}

object _sub(arg)
  object arg;
  {	register int ac;
	register int argcount = 0;
	register int fpflag = 0;
	double fac;

	push(arg);
	if ((arg = ev_next(0,"-",1,0)) == NULL) return(NULL);
	if (TYPE(arg) == FIXNUM) ac = SVALUE(arg);
	else if (TYPE(arg) == FLONUM) {
	  fac = ((flonum *)ADDR(arg))->flo_value;
	  fpflag = 1;
	} else goto badarg;

	while (nth_stack(0) != nil) {
	  if ((arg = ev_next(0,"-",1,0)) == NULL) return(NULL);
	  argcount++;
	  if (TYPE(arg) == FIXNUM) {
	    if (fpflag) fac -= SVALUE(arg);
	    else ac -= SVALUE(arg);
	  } else if (TYPE(arg) == FLONUM) {
	    if (!fpflag) { fpflag = 1; fac = ac; }
	    fac -= ((flonum *)ADDR(arg))->flo_value;
	  } else goto badarg;
	}
	pop(1);

	if (fpflag) {
	  arg = al_obj(FLONUM);
	  ((flonum *)ADDR(arg))->flo_value = argcount ? fac : -fac;
	} else {
	 SETTYPE(arg,FIXNUM);
	 SETVALUE(arg,argcount ? ac : (-ac));
	}
	return(arg);

badarg: error(";wrong type arg for -\n%S\n",arg);
	pop(1);
	return(NULL);
}

object _div(arg)
  object arg;
  {	register int ac;
	register int argcount = 0;
	register int fpflag = 0;
	double fac;

	push(arg);
	if ((arg = ev_next(0,"/",1,0)) == NULL) return(NULL);
	if (TYPE(arg) == FIXNUM) ac = SVALUE(arg);
	else if (TYPE(arg) == FLONUM) {
	  fac = ((flonum *)ADDR(arg))->flo_value;
	  fpflag = 1;
	} else goto badarg;

	while (nth_stack(0) != nil) {
	  if ((arg = ev_next(0,"/",1,0)) == NULL) return(NULL);
	  argcount++;
	  if (TYPE(arg) == FIXNUM) {
	    if (fpflag) fac /= SVALUE(arg);
	    else ac /= SVALUE(arg);
	  } else if (TYPE(arg) == FLONUM) {
	    if (!fpflag) { fpflag = 1; fac = ac; }
	    fac /= ((flonum *)ADDR(arg))->flo_value;
	  } else goto badarg;
	}
	pop(1);

	if (fpflag) {
	  arg = al_obj(FLONUM);
	  ((flonum *)ADDR(arg))->flo_value = argcount ? fac : 0.0;
	} else {
	 SETTYPE(arg,FIXNUM);
	 SETVALUE(arg,argcount ? ac : 0);
	}
	return(arg);

badarg: error(";wrong type arg for /\n%S\n",arg);
	pop(1);
	return(NULL);
}

object _rem(arg)
  object arg;
  {	register int ac;

	push(arg);
	if ((arg = ev_next(FIXNUM,"%",1,0)) == NULL) return(NULL);
	ac = SVALUE(arg);
	if ((arg = ev_next(FIXNUM,"%",1,1)) == NULL) return(NULL);
	ac %= SVALUE(arg);
	SETTYPE(arg,FIXNUM);
	SETVALUE(arg,ac);
	return(arg);
}

object _max(arg)
  object arg;
  {	register int ac,n;

	push(arg);
	if ((arg = ev_next(FIXNUM,"max",1,0)) == NULL) return(NULL);
	ac = SVALUE(arg);
	while (nth_stack(0) != nil) {
	  if ((arg = ev_next(FIXNUM,"max",1,0)) == NULL) return(NULL);
	  n = SVALUE(arg);
	  if (n > ac) ac = n;
	}
	pop(1);
	SETTYPE(arg,FIXNUM);
	SETVALUE(arg,ac);
	return(arg);
}

object _min(arg)
  object arg;
  {	register int ac,n;

	push(arg);
	if ((arg = ev_next(FIXNUM,"min",1,0)) == NULL) return(NULL);
	ac = SVALUE(arg);
	while (nth_stack(0) != nil) {
	  if ((arg = ev_next(FIXNUM,"min",1,0)) == NULL) return(NULL);
	  n = SVALUE(arg);
	  if (n < ac) ac = n;
	}
	pop(1);
	SETTYPE(arg,FIXNUM);
	SETVALUE(arg,ac);
	return(arg);
}

object _abs(arg)
  object arg;
  {	register int ac;
	double fac;

	push(arg);
	if ((arg = ev_next(0,"abs",1,1)) == NULL) return(NULL);
	if (TYPE(arg) == FIXNUM) {
	  ac = SVALUE(arg);
	  SETVALUE(arg,(ac >= 0) ? ac : (-ac));
	  return(arg);
	} else if (TYPE(arg) == FLONUM) {
	  fac = ((flonum *)ADDR(arg))->flo_value;
	  arg = al_obj(FLONUM);
	  ((flonum *)ADDR(arg))->flo_value = (fac >= 0.0) ? fac : -fac;
	  return(arg);
	}
	error(";wrong type arg for abs\n%S\n",arg);
	return(NULL);
}

object _inc(arg)
  object arg;
  {	register int ac;

	push(arg);
	if ((arg = ev_next(FIXNUM,"inc",1,1)) == NULL) return(NULL);
	ac = SVALUE(arg);
	SETTYPE(arg,FIXNUM);
	SETVALUE(arg,ac+1);
	return(arg);
}

object _dec(arg)
  object arg;
  {	register int ac;

	push(arg);
	if ((arg = ev_next(FIXNUM,"dec",1,1)) == NULL) return(NULL);
	ac = SVALUE(arg);
	SETTYPE(arg,FIXNUM);
	SETVALUE(arg,ac-1);
	return(arg);
}

object _fix(arg)
  object arg;
  {	push(arg);
	if ((arg = ev_next(0,"fix",1,1)) == NULL) return(NULL);
	if (TYPE(arg) == FIXNUM) return(arg);
	else if (TYPE(arg) == FLONUM) {
	  SETTYPE(arg,FIXNUM);
	  SETVALUE(arg,(((flonum *)ADDR(arg))->flo_value));
	  return(arg);
	}
	error(";wrong type arg for fix\n%S\n",arg);
	return(NULL);
}

object _float(arg)
  object arg;
  {	register int ac;

	push(arg);
	if ((arg = ev_next(0,"float",1,1)) == NULL) return(NULL);
	if (TYPE(arg) == FLONUM) return(arg);
	else if (TYPE(arg) == FIXNUM) {
	  ac = SVALUE(arg);
	  arg = al_obj(FLONUM);
	  ((flonum *)ADDR(arg))->flo_value = ac;
	  return(arg);
	}
	error(";wrong type arg for float\n%S\n",arg);
	return(NULL);
}

object relational(arg,test,name)
  object arg;
  char *name;
  {	register int ac1,ac2;
	register int ans = 0;
	register int fpflag = 0;
	double fac1,fac2;

	push(arg);

	if ((arg = ev_next(0,name,1,0)) == NULL) return(NULL);
	if (TYPE(arg) == FIXNUM) ac1 = SVALUE(arg);
 	else if (TYPE(arg) == FLONUM) {
	  fpflag = 1;
	  fac1 = ((flonum *)ADDR(arg))->flo_value;
	} else { pop(1); goto badarg; }

	if ((arg = ev_next(0,name,1,1)) == NULL) return(NULL);
	if (TYPE(arg) == FIXNUM) {
	  if (fpflag) fac2 = SVALUE(arg);
	  else ac2 = SVALUE(arg);
	} else if (TYPE(arg) == FLONUM) {
	  if (!fpflag) { fpflag = 1; fac1 = ac1; }
	  fac2 = ((flonum *)ADDR(arg))->flo_value;
	} else goto badarg;

	if (!fpflag) switch (test) {
	  case 0:	if (ac1 < ac2) ans++; break;
	  case 1:	if (ac1 <= ac2) ans++; break;
	  case 2:	if (ac1 == ac2) ans++; break;
	  case 3:	if (ac1 != ac2) ans++; break;
	  case 4:	if (ac1 >= ac2) ans++; break;
	  case 5:	if (ac1 > ac2) ans++; break;
	} else switch (test) {
	  case 0:	if (fac1 < fac2) ans++; break;
	  case 1:	if (fac1 <= fac2) ans++; break;
	  case 2:	if (fac1 == fac2) ans++; break;
	  case 3:	if (fac1 != fac2) ans++; break;
	  case 4:	if (fac1 >= fac2) ans++; break;
	  case 5:	if (fac1 > fac2) ans++; break;
	}

	if (ans) return(t);
	return(nil);

badarg:	error(";wrong type arg for %s\n%S\n",name,arg);
	return(NULL);
}

object _lt(arg)
  object arg;
  {	return(relational(arg,0,"<"));
}

object _le(arg)
  object arg;
  {	return(relational(arg,1,"<="));
}

object _eqeq(arg)
  object arg;
  {	return(relational(arg,2,"=="));
}

object _ne(arg)
  object arg;
  {	return(relational(arg,3,"!="));
}

object _ge(arg)
  object arg;
  {	return(relational(arg,4,">="));
}

object _gt(arg)
  object arg;
  {	return(relational(arg,5,">"));
}

object _and(arg)
  object arg;
  {	push(arg);
	while (nth_stack(0) != nil) {
	  if ((arg = ev_next(0,"and",1,0)) == NULL) return(NULL);
	  if (arg == nil) { pop(1); return(arg); }
	}
	pop(1);
	return(arg);
}

object _or(arg)
  object arg;
  {	push(arg);
	while (nth_stack(0) != nil) {
	  if ((arg = ev_next(0,"or",1,0)) == NULL) return(NULL);
	  if (arg != nil) { pop(1); return(arg); }
	}
	return(pop(1));
}

object _null(arg)
  object arg;
  {	push(arg);
	if ((arg = ev_next(0,"not or null",1,1)) == NULL) return(NULL);
	if (arg == nil) return(t);
	else return(nil);
}

object _eq(arg)
  object arg;
  {	object temp;

	push(nil);
	push(arg);
	if ((temp = ev_next(0,"eq",1,0)) == NULL) { pop(1); return(NULL); }
	nth_exch(1,temp);
	if ((arg = ev_next(0,"eq",1,1)) == NULL) { pop(1); return(NULL); }
	if (pop(1) == arg) return(t);
	else return(nil);
}

equal(obj1,obj2)
  object obj1,obj2;
  {	register cons *c1,*c2;

	if (obj1 == obj2) return(1);
	if (!ISCONS(obj1) || !ISCONS(obj2)) return(0);
	c1 = (cons *)ADDR(obj1);
	c2 = (cons *)ADDR(obj2);
	return(equal(c1->car,c2->car) && equal(c1->cdr,c2->cdr));
}

object _equal(arg)
  object arg;
  {	object temp;

	push(nil);
	push(arg);
	if ((temp = ev_next(0,"equal",1,0)) == NULL) { pop(1); return(NULL); }
	nth_exch(1,temp);
	if ((arg = ev_next(0,"equal",1,1)) == NULL) { pop(1); return(NULL); }
	if (equal(arg,pop(1))) return(t);
	else return(nil);
}

object _atom(arg)
  object arg;
  {	push(arg);
	if ((arg = ev_next(0,"atom",1,1)) == NULL) return(NULL);
	if (arg!=nil && ISCONS(arg)) return(nil);
	return(t);
}

object _numberp(arg)
  object arg;
  {	push(arg);
	if ((arg = ev_next(0,"numberp",1,1)) == NULL) return(NULL);
	if (ISFIX(arg)) return(t);
	return(nil);
}

object _stringp(arg)
  object arg;
  {	push(arg);
	if ((arg = ev_next(0,"stringp",1,1)) == NULL) return(NULL);
	if (TYPE(arg) == STRING) return(t);
	return(nil);
}
static char str_buf[100];

/* convert object into asciz string */
char *stringify(obj)
  object obj;
  {	if (obj != NULL) switch (TYPE(obj)) {
	  case FIXNUM:
		sprintf(str_buf,"%d",SVALUE(obj));
		return(str_buf);

	  case STRING:
		return((char *)ADDR(obj));

	  case SYMBOL:
		return((char *)ADDR(((symbol *)ADDR(obj))->sym_pname));
	}
	return(NULL);
}

/* convert list of objects into symbol */
object _msym(arg)
  object arg;
  {	register char *p,*q;
	char temp[500];

	p = temp;
	push(arg);
	while (nth_stack(0) != nil) {
	  if ((arg = ev_next(0,"make-symbol",1,0)) == NULL) return(NULL);
	  q = stringify(arg);
	  while (*p++ = *q++);
	  p--;
	}
	*p = '\0';
	pop(1);
	return(intern(temp));
}

/* like make-symbol, but puts "." between components */
object _ssym(arg)
  object arg;
  {	register char *p,*q;
	int first = 1;
	char temp[500];

	p = temp;
	push(arg);
	while (nth_stack(0) != nil) {
	  if ((arg = ev_next(0,"-struct-",0,0)) == NULL) return(NULL);
	  if (TYPE(arg)==CONS && (arg = eval(arg))==NULL) { pop(1); return(NULL); }
	  q = stringify(arg);
	  if (!first) *p++ = '.';
	  else first = 0;
	  while (*p++ = *q++);
	  p--;
	}
	*p = '\0';
	pop(1);
	return(intern(temp));
}