MultiSource/Applications/siod/sliba.c

/*  
 *                   COPYRIGHT (c) 1988-1996 BY                             *
 *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
 *        See the source file SLIB.C for more information.                  *

Array-hacking code moved to another source file.

*/

#include <stdio.h>
#include <string.h>
#include <setjmp.h>
#include <stdlib.h>
#include <stdarg.h>
#include <ctype.h>
#include <math.h>

#include "siod.h"
#include "siodp.h"

static void init_sliba_version(void)
{setvar(cintern("*sliba-version*"),
	cintern("$Id$"),
	NIL);}

static LISP sym_plists = NIL;
static LISP bashnum = NIL;
static LISP sym_e = NIL;
static LISP sym_f = NIL;

void init_storage_a1(long type)
{long j;
 struct user_type_hooks *p;
 set_gc_hooks(type,
	      array_gc_relocate,
	      array_gc_mark,
	      array_gc_scan,
	      array_gc_free,
	      &j);
 set_print_hooks(type,array_prin1);
 p = get_user_type_hooks(type);
 p->fast_print = array_fast_print;
 p->fast_read = array_fast_read;
 p->equal = array_equal;
 p->c_sxhash = array_sxhash;}

void init_storage_a(void)
{gc_protect(&bashnum);
 bashnum = newcell(tc_flonum);
 init_storage_a1(tc_string);
 init_storage_a1(tc_double_array);
 init_storage_a1(tc_long_array);
 init_storage_a1(tc_lisp_array);
 init_storage_a1(tc_byte_array);}

LISP array_gc_relocate(LISP ptr)
{LISP nw;
 if ((nw = heap) >= heap_end) gc_fatal_error();
 heap = nw+1;
 memcpy(nw,ptr,sizeof(struct obj));
 return(nw);}

void array_gc_scan(LISP ptr)
{long j;
 if TYPEP(ptr,tc_lisp_array)
   for(j=0;j < ptr->storage_as.lisp_array.dim; ++j)
     ptr->storage_as.lisp_array.data[j] =     
       gc_relocate(ptr->storage_as.lisp_array.data[j]);}

LISP array_gc_mark(LISP ptr)
{long j;
 if TYPEP(ptr,tc_lisp_array)
   for(j=0;j < ptr->storage_as.lisp_array.dim; ++j)
     gc_mark(ptr->storage_as.lisp_array.data[j]);
 return(NIL);}

void array_gc_free(LISP ptr)
{switch (ptr->type)
   {case tc_string:
    case tc_byte_array:
      free(ptr->storage_as.string.data);
      break;
    case tc_double_array:
      free(ptr->storage_as.double_array.data);
      break;
    case tc_long_array:
      free(ptr->storage_as.long_array.data);
      break;
    case tc_lisp_array:
      free(ptr->storage_as.lisp_array.data);
      break;}}

void array_prin1(LISP ptr,struct gen_printio *f)
{int j;
 switch (ptr->type)
   {case tc_string:
      gput_st(f,"\"");
      if (strcspn(ptr->storage_as.string.data,"\"\\\n\r\t") ==
	  strlen(ptr->storage_as.string.data))
	gput_st(f,ptr->storage_as.string.data);
      else
	{int n,c;
	 char cbuff[3];
	 n = strlen(ptr->storage_as.string.data);
	 for(j=0;j<n;++j)
	   switch(c = ptr->storage_as.string.data[j])
	     {case '\\':
	      case '"':
		cbuff[0] = '\\';
		cbuff[1] = c;
		cbuff[2] = 0;
		gput_st(f,cbuff);
		break;
	      case '\n':
		gput_st(f,"\\n");
		break;
	      case '\r':
		gput_st(f,"\\r");
		break;
	      case '\t':
		gput_st(f,"\\t");
		break;
	      default:
		cbuff[0] = c;
		cbuff[1] = 0;
		gput_st(f,cbuff);
		break;}}
      gput_st(f,"\"");
      break;
    case tc_double_array:
      gput_st(f,"#(");
      for(j=0; j < ptr->storage_as.double_array.dim; ++j)
	{sprintf(tkbuffer,"%g",ptr->storage_as.double_array.data[j]);
	 gput_st(f,tkbuffer);
	 if ((j + 1) < ptr->storage_as.double_array.dim)
	   gput_st(f," ");}
      gput_st(f,")");
      break;
    case tc_long_array:
      gput_st(f,"#(");
      for(j=0; j < ptr->storage_as.long_array.dim; ++j)
	{sprintf(tkbuffer,"%ld",ptr->storage_as.long_array.data[j]);
	 gput_st(f,tkbuffer);
	 if ((j + 1) < ptr->storage_as.long_array.dim)
	   gput_st(f," ");}
      gput_st(f,")");
    case tc_byte_array:
      sprintf(tkbuffer,"#%ld\"",ptr->storage_as.string.dim);
      gput_st(f,tkbuffer);
      for(j=0; j < ptr->storage_as.string.dim; ++j)
	{sprintf(tkbuffer,"%02x",ptr->storage_as.string.data[j] & 0xFF);
	 gput_st(f,tkbuffer);}
      gput_st(f,"\"");
      break;
    case tc_lisp_array:
      gput_st(f,"#(");
      for(j=0; j < ptr->storage_as.lisp_array.dim; ++j)
	{lprin1g(ptr->storage_as.lisp_array.data[j],f);
	 if ((j + 1) < ptr->storage_as.lisp_array.dim)
	   gput_st(f," ");}
      gput_st(f,")");
      break;}}

LISP strcons(long length,const char *data)
{long flag;
 LISP s;
 flag = no_interrupt(1);
 s = cons(NIL,NIL);
 s->type = tc_string;
 if (length == -1) length = strlen(data);
 s->storage_as.string.data = must_malloc(length+1);
 s->storage_as.string.dim = length;
 if (data)
   memcpy(s->storage_as.string.data,data,length);
 s->storage_as.string.data[length] = 0;
 no_interrupt(flag);
 return(s);}

int rfs_getc(unsigned char **p)
{int i;
 i = **p;
 if (!i) return(EOF);
 *p = *p + 1;
 return(i);}

void rfs_ungetc(unsigned char c,unsigned char **p)
{*p = *p - 1;}

LISP read_from_string(LISP x)
{char *p;
 struct gen_readio s;
 p = get_c_string(x);
 s.getc_fcn = (int (*)(void *))rfs_getc;
 s.ungetc_fcn = (void (*)(int,void *))rfs_ungetc;
 s.cb_argument = (char *) &p;
 return(readtl(&s));}

int pts_puts(char *from,void *cb)
{LISP into;
 size_t fromlen,intolen,intosize,fitsize;
 into = (LISP) cb;
 fromlen = strlen(from);
 intolen = strlen(into->storage_as.string.data);
 intosize = into->storage_as.string.dim  - intolen;
 fitsize = (fromlen < intosize) ? fromlen : intosize;
 memcpy(&into->storage_as.string.data[intolen],from,fitsize);
 into->storage_as.string.data[intolen+fitsize] = 0;
 if (fitsize < fromlen)
   err("print to string overflow",NIL);
 return(1);}

LISP err_wta_str(LISP exp)
{return(err("not a string",exp));}

LISP print_to_string(LISP exp,LISP str,LISP nostart)
{struct gen_printio s;
 if NTYPEP(str,tc_string) err_wta_str(str);
 s.putc_fcn = NULL;
 s.puts_fcn = pts_puts;
 s.cb_argument = str;
 if NULLP(nostart)
   str->storage_as.string.data[0] = 0;
 lprin1g(exp,&s);
 return(str);}

LISP aref1(LISP a,LISP i)
{long k;
 if NFLONUMP(i) err("bad index to aref",i);
 k = (long) FLONM(i);
 if (k < 0) err("negative index to aref",i);
 switch TYPE(a)
   {case tc_string:
     if (k >= a->storage_as.string.dim) err("index too large",i);
     return(flocons((double) a->storage_as.u_string.data[k]));
    case tc_byte_array:
      if (k >= a->storage_as.string.dim) err("index too large",i);
      return(flocons((double) a->storage_as.string.data[k]));
    case tc_double_array:
      if (k >= a->storage_as.double_array.dim) err("index too large",i);
      return(flocons(a->storage_as.double_array.data[k]));
    case tc_long_array:
      if (k >= a->storage_as.long_array.dim) err("index too large",i);
      return(flocons(a->storage_as.long_array.data[k]));
    case tc_lisp_array:
      if (k >= a->storage_as.lisp_array.dim) err("index too large",i);
      return(a->storage_as.lisp_array.data[k]);
    default:
      return(err("invalid argument to aref",a));}}

void err1_aset1(LISP i)
{err("index to aset too large",i);}

void err2_aset1(LISP v)
{err("bad value to store in array",v);}

LISP aset1(LISP a,LISP i,LISP v)
{long k;
 if NFLONUMP(i) err("bad index to aset",i);
 k = (long) FLONM(i);
 if (k < 0) err("negative index to aset",i);
 switch TYPE(a)
   {case tc_string:
    case tc_byte_array:
      if NFLONUMP(v) err2_aset1(v);
      if (k >= a->storage_as.string.dim) err1_aset1(i);
      a->storage_as.string.data[k] = (char) FLONM(v);
      return(v);
    case tc_double_array:
      if NFLONUMP(v) err2_aset1(v);
      if (k >= a->storage_as.double_array.dim) err1_aset1(i);
      a->storage_as.double_array.data[k] = FLONM(v);
      return(v);
    case tc_long_array:
      if NFLONUMP(v) err2_aset1(v);
      if (k >= a->storage_as.long_array.dim) err1_aset1(i);
      a->storage_as.long_array.data[k] = (long) FLONM(v);
      return(v);
    case tc_lisp_array:
      if (k >= a->storage_as.lisp_array.dim) err1_aset1(i);
      a->storage_as.lisp_array.data[k] = v;
      return(v);
    default:
      return(err("invalid argument to aset",a));}}

LISP arcons(long typecode,long n,long initp)
{LISP a;
 long flag,j;
 flag = no_interrupt(1);
 a = cons(NIL,NIL);
 switch(typecode)
   {case tc_double_array:
      a->storage_as.double_array.dim = n;
      a->storage_as.double_array.data = (double *) must_malloc(n *
							       sizeof(double));
      if (initp)
	for(j=0;j<n;++j) a->storage_as.double_array.data[j] = 0.0;
      break;
    case tc_long_array:
      a->storage_as.long_array.dim = n;
      a->storage_as.long_array.data = (long *) must_malloc(n * sizeof(long));
      if (initp)
	for(j=0;j<n;++j) a->storage_as.long_array.data[j] = 0;
      break;
    case tc_string:
      a->storage_as.string.dim = n;
      a->storage_as.string.data = (char *) must_malloc(n+1);
      a->storage_as.string.data[n] = 0;
      if (initp)
	for(j=0;j<n;++j) a->storage_as.string.data[j] = ' ';
    case tc_byte_array:
      a->storage_as.string.dim = n;
      a->storage_as.string.data = (char *) must_malloc(n);
      if (initp)
	for(j=0;j<n;++j) a->storage_as.string.data[j] = 0;
      break;
    case tc_lisp_array:
      a->storage_as.lisp_array.dim = n;
      a->storage_as.lisp_array.data = (LISP *) must_malloc(n * sizeof(LISP));
      for(j=0;j<n;++j) a->storage_as.lisp_array.data[j] = NIL;
      break;
    default:
      errswitch();}
 a->type = (short) typecode;
 no_interrupt(flag);
 return(a);}

LISP mallocl(void *place,long size)
{long n,r;
 LISP retval;
 n = size / sizeof(long);
 r = size % sizeof(long);
 if (r) ++n;
 retval = arcons(tc_long_array,n,0);
 *(long **)place = retval->storage_as.long_array.data;
 return(retval);}

LISP cons_array(LISP dim,LISP kind)
{LISP a;
 long flag,n,j;
 if (NFLONUMP(dim) || (FLONM(dim) < 0))
   return(err("bad dimension to cons-array",dim));
 else
   n = (long) FLONM(dim);
 flag = no_interrupt(1);
 a = cons(NIL,NIL);
 if EQ(cintern("double"),kind)
   {a->type = tc_double_array;
    a->storage_as.double_array.dim = n;
    a->storage_as.double_array.data = (double *) must_malloc(n *
							     sizeof(double));
    for(j=0;j<n;++j) a->storage_as.double_array.data[j] = 0.0;}
 else if EQ(cintern("long"),kind)
   {a->type = tc_long_array;
    a->storage_as.long_array.dim = n;
    a->storage_as.long_array.data = (long *) must_malloc(n * sizeof(long));
    for(j=0;j<n;++j) a->storage_as.long_array.data[j] = 0;}
 else if EQ(cintern("string"),kind)
   {a->type = tc_string;
    a->storage_as.string.dim = n;
    a->storage_as.string.data = (char *) must_malloc(n+1);
    a->storage_as.string.data[n] = 0;
    for(j=0;j<n;++j) a->storage_as.string.data[j] = ' ';}
 else if EQ(cintern("byte"),kind)
   {a->type = tc_byte_array;
    a->storage_as.string.dim = n;
    a->storage_as.string.data = (char *) must_malloc(n);
    for(j=0;j<n;++j) a->storage_as.string.data[j] = 0;}
 else if (EQ(cintern("lisp"),kind) || NULLP(kind))
   {a->type = tc_lisp_array;
    a->storage_as.lisp_array.dim = n;
    a->storage_as.lisp_array.data = (LISP *) must_malloc(n * sizeof(LISP));
    for(j=0;j<n;++j) a->storage_as.lisp_array.data[j] = NIL;}
 else
   err("bad type of array",kind);
 no_interrupt(flag);
 return(a);}

LISP string_append(LISP args)
{long size;
 LISP l,s;
 char *data;
 size = 0;
 for(l=args;NNULLP(l);l=cdr(l))
   size += strlen(get_c_string(car(l)));
 s = strcons(size,NULL);
 data = s->storage_as.string.data;
 data[0] = 0;
 for(l=args;NNULLP(l);l=cdr(l))
   strcat(data,get_c_string(car(l)));
 return(s);}

LISP bytes_append(LISP args)
{long size,n,j;
 LISP l,s;
 char *data,*ptr;
 size = 0;
 for(l=args;NNULLP(l);l=cdr(l))
   {get_c_string_dim(car(l),&n);
    size += n;}
 s = arcons(tc_byte_array,size,0);
 data = s->storage_as.string.data;
 for(j=0,l=args;NNULLP(l);l=cdr(l))
   {ptr = get_c_string_dim(car(l),&n);
    memcpy(&data[j],ptr,n);
    j += n;}
 return(s);}

LISP substring(LISP str,LISP start,LISP end)
{long s,e,n;
 char *data;
 data = get_c_string_dim(str,&n);
 s = get_c_long(start);
 if NULLP(end)
   e = n;
 else
   e = get_c_long(end);
 if ((s < 0) || (s > e)) err("bad start index",start);
 if ((e < 0) || (e > n)) err("bad end index",end);
 return(strcons(e-s,&data[s]));}

LISP string_search(LISP token,LISP str)
{char *s1,*s2,*ptr;
 s1 = get_c_string(str);
 s2 = get_c_string(token);
 ptr = strstr(s1,s2);
 if (ptr)
   return(flocons(ptr - s1));
 else
   return(NIL);}

#define IS_TRIM_SPACE(_x) (strchr(" \t\r\n",(_x)))

LISP string_trim(LISP str)
{char *start,*end;
 start = get_c_string(str);
 while(*start && IS_TRIM_SPACE(*start)) ++start;
 end = &start[strlen(start)];
 while((end > start) && IS_TRIM_SPACE(*(end-1))) --end;
 return(strcons(end-start,start));}

LISP string_trim_left(LISP str)
{char *start,*end;
 start = get_c_string(str);
 while(*start && IS_TRIM_SPACE(*start)) ++start;
 end = &start[strlen(start)];
 return(strcons(end-start,start));}

LISP string_trim_right(LISP str)
{char *start,*end;
 start = get_c_string(str);
 end = &start[strlen(start)];
 while((end > start) && IS_TRIM_SPACE(*(end-1))) --end;
 return(strcons(end-start,start));}

LISP string_upcase(LISP str)
{LISP result;
 char *s1,*s2;
 long j,n;
 s1 = get_c_string(str);
 n = strlen(s1);
 result = strcons(n,s1);
 s2 = get_c_string(result);
 for(j=0;j<n;++j) s2[j] = toupper(s2[j]);
 return(result);}

LISP string_downcase(LISP str)
{LISP result;
 char *s1,*s2;
 long j,n;
 s1 = get_c_string(str);
 n = strlen(s1);
 result = strcons(n,s1);
 s2 = get_c_string(result);
 for(j=0;j<n;++j) s2[j] = tolower(s2[j]);
 return(result);}

LISP lreadstring(struct gen_readio *f)
{int j,c,n;
 char *p;
 j = 0;
 p = tkbuffer;
 while(((c = GETC_FCN(f)) != '"') && (c != EOF))
   {if (c == '\\')
      {c = GETC_FCN(f);
       if (c == EOF) err("eof after \\",NIL);
       switch(c)
	 {case 'n':
	    c = '\n';
	    break;
	  case 't':
	    c = '\t';
	    break;
	  case 'r':
	    c = '\r';
	    break;
	  case 'd':
	    c = 0x04;
	    break;
	  case 'N':
	    c = 0;
	    break;
	  case 's':
	    c = ' ';
	    break;
	  case '0':
	    n = 0;
	    while(1)
	      {c = GETC_FCN(f);
	       if (c == EOF) err("eof after \\0",NIL);
	       if (isdigit(c))
		 n = n * 8 + c - '0';
	       else
		 {UNGETC_FCN(c,f);
		  break;}}
	    c = n;}}
    if ((j + 1) >= TKBUFFERN) err("read string overflow",NIL);
    ++j;
    *p++ = c;}
 *p = 0;
 return(strcons(j,tkbuffer));}


LISP lreadsharp(struct gen_readio *f)
{LISP obj,l,result;
 long j,n;
 int c;
 c = GETC_FCN(f);
 switch(c)
   {case '(':
      UNGETC_FCN(c,f);
      obj = lreadr(f);
      n = nlength(obj);
      result = arcons(tc_lisp_array,n,1);
      for(l=obj,j=0;j<n;l=cdr(l),++j)
	result->storage_as.lisp_array.data[j] = car(l);
      return(result);
    case '.':
      obj = lreadr(f);
      return(leval(obj,NIL));
    case 'f':
      return(NIL);
    case 't':
      return(flocons(1));
    default:
      return(err("readsharp syntax not handled",NIL));}}

#define HASH_COMBINE(_h1,_h2,_mod) ((((_h1) * 17 + 1) ^ (_h2)) % (_mod))

long c_sxhash(LISP obj,long n)
{long hash;
 unsigned char *s;
 LISP tmp;
 struct user_type_hooks *p;
 STACK_CHECK(&obj);
 INTERRUPT_CHECK();
 switch TYPE(obj)
   {case tc_nil:
      return(0);
    case tc_cons:
      hash = c_sxhash(CAR(obj),n);
      for(tmp=CDR(obj);CONSP(tmp);tmp=CDR(tmp))
	hash = HASH_COMBINE(hash,c_sxhash(CAR(tmp),n),n);
      hash = HASH_COMBINE(hash,c_sxhash(tmp,n),n);
      return(hash);
    case tc_symbol:
      for(hash=0,s=(unsigned char *)PNAME(obj);*s;++s)
	hash = HASH_COMBINE(hash,*s,n);
      return(hash);
    case tc_subr_0:
    case tc_subr_1:
    case tc_subr_2:
    case tc_subr_3:
    case tc_subr_4:
    case tc_subr_5:
    case tc_lsubr:
    case tc_fsubr:
    case tc_msubr:
      for(hash=0,s=(unsigned char *) obj->storage_as.subr.name;*s;++s)
	hash = HASH_COMBINE(hash,*s,n);
      return(hash);
    case tc_flonum:
      return(((unsigned long)FLONM(obj)) % n);
    default:
      p = get_user_type_hooks(TYPE(obj));
      if (p->c_sxhash)
	return((*p->c_sxhash)(obj,n));
      else
	return(0);}}

LISP sxhash(LISP obj,LISP n)
{return(flocons(c_sxhash(obj,FLONUMP(n) ? (long) FLONM(n) : 10000)));}

LISP equal(LISP a,LISP b)
{struct user_type_hooks *p;
 long atype;
 STACK_CHECK(&a);
 loop:
 INTERRUPT_CHECK();
 if EQ(a,b) return(sym_t);
 atype = TYPE(a);
 if (atype != TYPE(b)) return(NIL);
 switch(atype)
   {case tc_cons:
      if NULLP(equal(car(a),car(b))) return(NIL);
      a = cdr(a);
      b = cdr(b);
      goto loop;
    case tc_flonum:
      return((FLONM(a) == FLONM(b)) ? sym_t : NIL);
    case tc_symbol:
      return(NIL);
    default:
      p = get_user_type_hooks(atype);
      if (p->equal)
	return((*p->equal)(a,b));
      else
	return(NIL);}}

LISP array_equal(LISP a,LISP b)
{long j,len;
 switch(TYPE(a))
   {case tc_string:
    case tc_byte_array:
      len = a->storage_as.string.dim;
      if (len != b->storage_as.string.dim) return(NIL);
      if (memcmp(a->storage_as.string.data,b->storage_as.string.data,len) == 0)
	return(sym_t);
      else
	return(NIL);
    case tc_long_array:
      len = a->storage_as.long_array.dim;
      if (len != b->storage_as.long_array.dim) return(NIL);
      if (memcmp(a->storage_as.long_array.data,
		 b->storage_as.long_array.data,
		 len * sizeof(long)) == 0)
	return(sym_t);
      else
	return(NIL);
    case tc_double_array:
      len = a->storage_as.double_array.dim;
      if (len != b->storage_as.double_array.dim) return(NIL);
      for(j=0;j<len;++j)
	if (a->storage_as.double_array.data[j] !=
	    b->storage_as.double_array.data[j])
	  return(NIL);
      return(sym_t);
    case tc_lisp_array:
      len = a->storage_as.lisp_array.dim;
      if (len != b->storage_as.lisp_array.dim) return(NIL);
      for(j=0;j<len;++j)
	if NULLP(equal(a->storage_as.lisp_array.data[j],
		       b->storage_as.lisp_array.data[j]))
	  return(NIL);
      return(sym_t);
    default:
      return(errswitch());}}

long array_sxhash(LISP a,long n)
{long j,len,hash;
 unsigned char *char_data;
 unsigned long *long_data;
 double *double_data;
 switch(TYPE(a))
   {case tc_string:
    case tc_byte_array:
      len = a->storage_as.string.dim;
      for(j=0,hash=0,char_data=(unsigned char *)a->storage_as.string.data;
	  j < len;
	  ++j,++char_data)
	hash = HASH_COMBINE(hash,*char_data,n);
      return(hash);
    case tc_long_array:
      len = a->storage_as.long_array.dim;
      for(j=0,hash=0,long_data=(unsigned long *)a->storage_as.long_array.data;
	  j < len;
	  ++j,++long_data)
	hash = HASH_COMBINE(hash,*long_data % n,n);
      return(hash);
    case tc_double_array:
      len = a->storage_as.double_array.dim;
      for(j=0,hash=0,double_data=a->storage_as.double_array.data;
	  j < len;
	  ++j,++double_data)
	hash = HASH_COMBINE(hash,(unsigned long)*double_data % n,n);
      return(hash);
    case tc_lisp_array:
      len = a->storage_as.lisp_array.dim;
      for(j=0,hash=0; j < len; ++j)
	hash = HASH_COMBINE(hash,
			    c_sxhash(a->storage_as.lisp_array.data[j],n),
			    n);
      return(hash);
    default:
      errswitch();
      return(0);}}

long href_index(LISP table,LISP key)
{long index;
 if NTYPEP(table,tc_lisp_array) err("not a hash table",table);
 index = c_sxhash(key,table->storage_as.lisp_array.dim);
 if ((index < 0) || (index >= table->storage_as.lisp_array.dim))
   {err("sxhash inconsistency",table);
    return(0);}
 else
   return(index);}
 
LISP href(LISP table,LISP key)
{return(cdr(assoc(key,
		  table->storage_as.lisp_array.data[href_index(table,key)])));}

LISP hset(LISP table,LISP key,LISP value)
{long index;
 LISP cell,l;
 index = href_index(table,key);
 l = table->storage_as.lisp_array.data[index];
 if NNULLP(cell = assoc(key,l))
   return(setcdr(cell,value));
 cell = cons(key,value);
 table->storage_as.lisp_array.data[index] = cons(cell,l);
 return(value);}

LISP assoc(LISP x,LISP alist)
{LISP l,tmp;
 for(l=alist;CONSP(l);l=CDR(l))
   {tmp = CAR(l);
    if (CONSP(tmp) && equal(CAR(tmp),x)) return(tmp);
    INTERRUPT_CHECK();}
 if EQ(l,NIL) return(NIL);
 return(err("improper list to assoc",alist));}

LISP assv(LISP x,LISP alist)
{LISP l,tmp;
 for(l=alist;CONSP(l);l=CDR(l))
   {tmp = CAR(l);
    if (CONSP(tmp) && NNULLP(eql(CAR(tmp),x))) return(tmp);
    INTERRUPT_CHECK();}
 if EQ(l,NIL) return(NIL);
 return(err("improper list to assv",alist));}

void put_long(long i,FILE *f)
{fwrite(&i,sizeof(long),1,f);}

long get_long(FILE *f)
{long i;
 fread(&i,sizeof(long),1,f);
 return(i);}

long fast_print_table(LISP obj,LISP table)
{FILE *f;
 LISP ht,index;
 f = get_c_file(car(table),(FILE *) NULL);
 if NULLP(ht = car(cdr(table)))
   return(1);
 index = href(ht,obj);
 if NNULLP(index)
   {putc(FO_fetch,f);
    put_long(get_c_long(index),f);
    return(0);}
 if NULLP(index = car(cdr(cdr(table))))
   return(1);
 hset(ht,obj,index);
 FLONM(bashnum) = 1.0;
 setcar(cdr(cdr(table)),plus(index,bashnum));
 putc(FO_store,f);
 put_long(get_c_long(index),f);
 return(1);}

LISP fast_print(LISP obj,LISP table)
{FILE *f;
 long len;
 LISP tmp;
 struct user_type_hooks *p;
 STACK_CHECK(&obj);
 f = get_c_file(car(table),(FILE *) NULL);
 switch(TYPE(obj))
   {case tc_nil:
      putc(tc_nil,f);
      return(NIL);
    case tc_cons:
      for(len=0,tmp=obj;CONSP(tmp);tmp=CDR(tmp)) {INTERRUPT_CHECK();++len;}
      if (len == 1)
	{putc(tc_cons,f);
	 fast_print(car(obj),table);
	 fast_print(cdr(obj),table);}
      else if NULLP(tmp)
	{putc(FO_list,f);
	 put_long(len,f);
	 for(tmp=obj;CONSP(tmp);tmp=CDR(tmp))
	   fast_print(CAR(tmp),table);}
      else
	{putc(FO_listd,f);
	 put_long(len,f);
	 for(tmp=obj;CONSP(tmp);tmp=CDR(tmp))
	   fast_print(CAR(tmp),table);
	 fast_print(tmp,table);}
      return(NIL);
    case tc_flonum:
      putc(tc_flonum,f);
      fwrite(&obj->storage_as.flonum.data,
	     sizeof(obj->storage_as.flonum.data),
	     1,
	     f);
      return(NIL);
    case tc_symbol:
      if (fast_print_table(obj,table))
	{putc(tc_symbol,f);
	 len = strlen(PNAME(obj));
	 if (len >= TKBUFFERN)
	   err("symbol name too long",obj);
	 put_long(len,f);
	 fwrite(PNAME(obj),len,1,f);
	 return(sym_t);}
      else
	return(NIL);
    default:
      p = get_user_type_hooks(TYPE(obj));
      if (p->fast_print)
	return((*p->fast_print)(obj,table));
      else
	return(err("cannot fast-print",obj));}}

LISP fast_read(LISP table)
{FILE *f;
 LISP tmp,l;
 struct user_type_hooks *p;
 int c;
 long len;
 f = get_c_file(car(table),(FILE *) NULL);
 c = getc(f);
 if (c == EOF) return(table);
 switch(c)
   {case FO_comment:
      while((c = getc(f)))
	switch(c)
	  {case EOF:
	     return(table);
	   case '\n':
	     return(fast_read(table));}
    case FO_fetch:
      len = get_long(f);
      FLONM(bashnum) = len;
      return(href(car(cdr(table)),bashnum));
    case FO_store:
      len = get_long(f);
      tmp = fast_read(table);
      hset(car(cdr(table)),flocons(len),tmp);
      return(tmp);
    case tc_nil:
      return(NIL);
    case tc_cons:
      tmp = fast_read(table);
      return(cons(tmp,fast_read(table)));
    case FO_list:
    case FO_listd:
      len = get_long(f);
      FLONM(bashnum) = len;
      l = make_list(bashnum,NIL);
      tmp = l;
      while(len > 1)
	{CAR(tmp) = fast_read(table);
	 tmp = CDR(tmp);
	 --len;}
      CAR(tmp) = fast_read(table);
      if (c == FO_listd)
	CDR(tmp) = fast_read(table);
      return(l);
    case tc_flonum:
      tmp = newcell(tc_flonum);
      fread(&tmp->storage_as.flonum.data,
	    sizeof(tmp->storage_as.flonum.data),
	    1,
	    f);
      return(tmp);
    case tc_symbol:
      len = get_long(f);
      if (len >= TKBUFFERN)
	err("symbol name too long",NIL);
      fread(tkbuffer,len,1,f);
      tkbuffer[len] = 0;
      return(rintern(tkbuffer));
    default:
      p = get_user_type_hooks(c);
      if (p->fast_read)
	return(*p->fast_read)(c,table);
      else
	return(err("unknown fast-read opcode",flocons(c)));}}

LISP array_fast_print(LISP ptr,LISP table)
{int j,len;
 FILE *f;
 f = get_c_file(car(table),(FILE *) NULL);
 switch (ptr->type)
   {case tc_string:
    case tc_byte_array:
      putc(ptr->type,f);
      len = ptr->storage_as.string.dim;
      put_long(len,f);
      fwrite(ptr->storage_as.string.data,len,1,f);
      return(NIL);
    case tc_double_array:
      putc(tc_double_array,f);
      len = ptr->storage_as.double_array.dim * sizeof(double);
      put_long(len,f);
      fwrite(ptr->storage_as.double_array.data,len,1,f);
      return(NIL);
    case tc_long_array:
      putc(tc_long_array,f);
      len = ptr->storage_as.long_array.dim * sizeof(long);
      put_long(len,f);
      fwrite(ptr->storage_as.long_array.data,len,1,f);
      return(NIL);
    case tc_lisp_array:
      putc(tc_lisp_array,f);
      len = ptr->storage_as.lisp_array.dim;
      put_long(len,f);
      for(j=0; j < len; ++j)
	fast_print(ptr->storage_as.lisp_array.data[j],table);
      return(NIL);
    default:
      return(errswitch());}}

LISP array_fast_read(int code,LISP table)
{long j,len,iflag;
 FILE *f;
 LISP ptr;
 f = get_c_file(car(table),(FILE *) NULL);
 switch (code)
   {case tc_string:
      len = get_long(f);
      ptr = strcons(len,NULL);
      fread(ptr->storage_as.string.data,len,1,f);
      ptr->storage_as.string.data[len] = 0;
      return(ptr);
    case tc_byte_array:
      len = get_long(f);
      iflag = no_interrupt(1);
      ptr = newcell(tc_byte_array);
      ptr->storage_as.string.dim = len;
      ptr->storage_as.string.data =
	(char *) must_malloc(len);
      fread(ptr->storage_as.string.data,len,1,f);
      no_interrupt(iflag);
      return(ptr);
    case tc_double_array:
      len = get_long(f);
      iflag = no_interrupt(1);
      ptr = newcell(tc_double_array);
      ptr->storage_as.double_array.dim = len;
      ptr->storage_as.double_array.data =
	(double *) must_malloc(len * sizeof(double));
      fread(ptr->storage_as.double_array.data,sizeof(double),len,f);
      no_interrupt(iflag);
      return(ptr);
    case tc_long_array:
      len = get_long(f);
      iflag = no_interrupt(1);
      ptr = newcell(tc_long_array);
      ptr->storage_as.long_array.dim = len;
      ptr->storage_as.long_array.data =
	(long *) must_malloc(len * sizeof(long));
      fread(ptr->storage_as.long_array.data,sizeof(long),len,f);
      no_interrupt(iflag);
      return(ptr);
    case tc_lisp_array:
      len = get_long(f);
      FLONM(bashnum) = len;
      ptr = cons_array(bashnum,NIL);
      for(j=0; j < len; ++j)
	ptr->storage_as.lisp_array.data[j] = fast_read(table);
      return(ptr);
    default:
      return(errswitch());}}

long get_c_long(LISP x)
{if NFLONUMP(x) err("not a number",x);
 return((long)FLONM(x));}

double get_c_double(LISP x)
{if NFLONUMP(x) err("not a number",x);
 return(FLONM(x));}

LISP make_list(LISP x,LISP v)
{long n;
 LISP l;
 n = get_c_long(x);
 l = NIL;
 while(n > 0)
   {l = cons(v,l); --n;}
 return(l);}

LISP lfread(LISP size,LISP file)
{long flag,n,ret,m;
 char *buffer;
 LISP s;
 FILE *f;
 f = get_c_file(file,stdin);
 flag = no_interrupt(1);
 switch(TYPE(size))
   {case tc_string:
    case tc_byte_array:
      s = size;
      buffer = s->storage_as.string.data;
      n = s->storage_as.string.dim;
      m = 0;
      break;
    default:
      n = get_c_long(size);
      buffer = (char *) must_malloc(n+1);
      buffer[n] = 0;
      m = 1;}
 ret = fread(buffer,1,n,f);
 if (ret == 0)
   {if (m)
      free(buffer);
    no_interrupt(flag);
    return(NIL);}
 if (m)
   {if (ret == n)
      {s = cons(NIL,NIL);
       s->type = tc_string;
       s->storage_as.string.data = buffer;
       s->storage_as.string.dim = n;}
    else
      {s = strcons(ret,NULL);
       memcpy(s->storage_as.string.data,buffer,ret);
       free(buffer);}
    no_interrupt(flag);
    return(s);}
 no_interrupt(flag);
 return(flocons((double)ret));}

LISP lfwrite(LISP string,LISP file)
{FILE *f;
 long flag;
 char *data;
 long dim,len;
 f = get_c_file(file,stdout);
 data = get_c_string_dim(CONSP(string) ? car(string) : string,&dim);
 len = CONSP(string) ? get_c_long(cadr(string)) : dim;
 if (len <= 0) return(NIL);
 if (len > dim) err("write length too long",string);
 flag = no_interrupt(1);
 fwrite(data,1,len,f);
 no_interrupt(flag);
 return(NIL);}

LISP lfflush(LISP file)
{FILE *f;
 long flag;
 f = get_c_file(file,stdout);
 flag = no_interrupt(1);
 fflush(f);
 no_interrupt(flag);
 return(NIL);}

LISP string_length(LISP string)
{if NTYPEP(string,tc_string) err_wta_str(string);
 return(flocons(strlen(string->storage_as.string.data)));}

LISP string_dim(LISP string)
{if NTYPEP(string,tc_string) err_wta_str(string);
 return(flocons((double)string->storage_as.string.dim));}

long nlength(LISP obj)
{LISP l;
 long n;
 switch TYPE(obj)
   {case tc_string:
      return(strlen(obj->storage_as.string.data));
    case tc_byte_array:
      return(obj->storage_as.string.dim);
    case tc_double_array:
      return(obj->storage_as.double_array.dim);
    case tc_long_array:
      return(obj->storage_as.long_array.dim);
    case tc_lisp_array:
      return(obj->storage_as.lisp_array.dim);
    case tc_nil:
      return(0);
    case tc_cons:
      for(l=obj,n=0;CONSP(l);l=CDR(l),++n) INTERRUPT_CHECK();
      if NNULLP(l) err("improper list to length",obj);
      return(n);
    default:
      err("wta to length",obj);
      return(0);}}

LISP llength(LISP obj)
{return(flocons(nlength(obj)));}

LISP number2string(LISP x,LISP b,LISP w,LISP p)
{char buffer[1000];
 double y;
 long base,width,prec;
 if NFLONUMP(x) err("wta",x);
 y = FLONM(x);
 width = NNULLP(w) ? get_c_long(w) : -1;
 if (width > 100) err("width too long",w);
 prec = NNULLP(p) ? get_c_long(p) : -1;
 if (prec > 100) err("precision too large",p);
 if (NULLP(b) || EQ(sym_e,b) || EQ(sym_f,b))
   {if ((width >= 0) && (prec >= 0))
      sprintf(buffer,
	      NULLP(b) ? "% *.*g" : EQ(sym_e,b) ? "% *.*e" : "% *.*f",
	      width,
	      prec,
	      y);
    else if (width >= 0)
      sprintf(buffer,
	      NULLP(b) ? "% *g" : EQ(sym_e,b) ? "% *e" : "% *f",
	      width,
	      y);
    else if (prec >= 0)
      sprintf(buffer,
	      NULLP(b) ? "%.*g" : EQ(sym_e,b) ? "%.*e" : "%.*f",
	      prec,
	      y);
    else
      sprintf(buffer,
	      NULLP(b) ? "%g" : EQ(sym_e,b) ? "%e" : "%f",
	      y);}
 else if (((base = get_c_long(b)) == 10) || (base == 8) || (base == 16))
   {if (width >= 0)
      sprintf(buffer,
	      (base == 10) ? "%0*ld" : (base == 8) ? "%0*lo" : "%0*lX",
	      width,
	      (long) y);
    else
      sprintf(buffer,
	      (base == 10) ? "%ld" : (base == 8) ? "%lo" : "%lX",
	      (long) y);}
 else
   err("number base not handled",b);
 return(strcons(strlen(buffer),buffer));}

LISP string2number(LISP x,LISP b)
{char *str;
 long base,value = 0;
 double result;
 str = get_c_string(x);
 if NULLP(b)
   result = atof(str);
 else if ((base = get_c_long(b)) == 10)
   {sscanf(str,"%ld",&value);
    result = (double) value;}
 else if (base == 8)
   {sscanf(str,"%lo",&value);
    result = (double) value;}
 else if (base == 16)
   {sscanf(str,"%lx",&value);
    result = (double) value;}
 else if ((base >= 1) && (base <= 16))
   {for(result = 0.0;*str;++str)
     if (isdigit(*str))
       result = result * base + *str - '0';
     else if (isxdigit(*str))
       result = result * base + toupper(*str) - 'A' + 10;}
 else
   return(err("number base not handled",b));
 return(flocons(result));}

LISP lstrcmp(LISP s1,LISP s2)
{return(flocons(strcmp(get_c_string(s1),get_c_string(s2))));}

void chk_string(LISP s,char **data,long *dim)
{if TYPEP(s,tc_string)
   {*data = s->storage_as.string.data;
    *dim = s->storage_as.string.dim;}
 else
   err_wta_str(s);}

LISP lstrcpy(LISP dest,LISP src)
{long ddim,slen;
 char *d,*s;
 chk_string(dest,&d,&ddim);
 s = get_c_string(src);
 slen = strlen(s);
 if (slen > ddim)
   err("string too long",src);
 memcpy(d,s,slen);
 d[slen] = 0;
 return(NIL);}

LISP lstrcat(LISP dest,LISP src)
{long ddim,dlen,slen;
 char *d,*s;
 chk_string(dest,&d,&ddim);
 s = get_c_string(src);
 slen = strlen(s);
 dlen = strlen(d);
 if ((slen + dlen) > ddim)
   err("string too long",src);
 memcpy(&d[dlen],s,slen);
 d[dlen+slen] = 0;
 return(NIL);}

LISP lstrbreakup(LISP str,LISP lmarker)
{char *start,*end,*marker;
 size_t k;
 LISP result = NIL;
 start = get_c_string(str);
 marker = get_c_string(lmarker);
 k = strlen(marker);
 while(*start)
   {if (!(end = strstr(start,marker))) end = &start[strlen(start)];
    result = cons(strcons(end-start,start),result);
    start = (*end) ? end+k : end;}
 return(nreverse(result));}

LISP lstrunbreakup(LISP elems,LISP lmarker)
{LISP result,l;
 for(l=elems,result=NIL;NNULLP(l);l=cdr(l))
   if EQ(l,elems)
     result = cons(car(l),result);
   else
     result = cons(car(l),cons(lmarker,result));
 return(string_append(nreverse(result)));}

LISP stringp(LISP x)
{return(TYPEP(x,tc_string) ? sym_t : NIL);}

static char *base64_encode_table = "\
ABCDEFGHIJKLMNOPQRSTUVWXYZ\
abcdefghijklmnopqrstuvwxyz\
0123456789+/=";

static char *base64_decode_table = NULL;

static void init_base64_table(void)
{int j;
 base64_decode_table = (char *) malloc(256);
 memset(base64_decode_table,-1,256);
 for(j=0;j<65;++j)
   base64_decode_table[base64_encode_table[j]] = j;}

#define BITMSK(N) ((1 << (N)) - 1)

#define ITEM1(X)   (X >> 2) & BITMSK(6)
#define ITEM2(X,Y) ((X & BITMSK(2)) << 4) | ((Y >> 4) & BITMSK(4))
#define ITEM3(X,Y) ((X & BITMSK(4)) << 2) | ((Y >> 6) & BITMSK(2))
#define ITEM4(X)   X & BITMSK(6)

LISP base64encode(LISP in)
{char *s,*t = base64_encode_table;
 unsigned char *p1,*p2;
 LISP out;
 long j,m,n,chunks,leftover;
 s = get_c_string_dim(in,&n);
 chunks = n / 3;
 leftover = n % 3;
 m = (chunks + ((leftover) ? 1 : 0)) * 4;
 out = strcons(m,NULL);
 p2 = (unsigned char *) get_c_string(out);
 for(j=0,p1=(unsigned char *)s;j<chunks;++j,p1 += 3)
   {*p2++ = t[ITEM1(p1[0])];
    *p2++ = t[ITEM2(p1[0],p1[1])];
    *p2++ = t[ITEM3(p1[1],p1[2])];
    *p2++ = t[ITEM4(p1[2])];}
 switch(leftover)
   {case 0:
      break;
    case 1:
      *p2++ = t[ITEM1(p1[0])];
      *p2++ = t[ITEM2(p1[0],0)];
      *p2++ = base64_encode_table[64];
      *p2++ = base64_encode_table[64];
      break;
    case 2:
      *p2++ = t[ITEM1(p1[0])];
      *p2++ = t[ITEM2(p1[0],p1[1])];
      *p2++ = t[ITEM3(p1[1],0)];
      *p2++ = base64_encode_table[64];
      break;
    default:
      errswitch();}
 return(out);}

LISP base64decode(LISP in)
{char *s,*t = base64_decode_table;
 LISP out;
 unsigned char *p1,*p2;
 long j,m,n,chunks,leftover,item1,item2,item3,item4;
 s = get_c_string(in);
 n = strlen(s);
 if (n == 0) return(strcons(0,NULL));
 if (n % 4)
   err("illegal base64 data length",in);
 if (s[n-1] == base64_encode_table[64])
   if (s[n-2] == base64_encode_table[64])
     leftover = 1;
   else
     leftover = 2;
 else
   leftover = 0;
 chunks = (n / 4 ) - ((leftover) ? 1 : 0);
 m = (chunks * 3) + leftover;
 out = strcons(m,NULL);
 p2 = (unsigned char *) get_c_string(out);
 for(j=0,p1=(unsigned char *)s;j<chunks;++j,p1 += 4)
   {if ((item1 = t[p1[0]]) & ~BITMSK(6)) return(NIL);
    if ((item2 = t[p1[1]]) & ~BITMSK(6)) return(NIL);
    if ((item3 = t[p1[2]]) & ~BITMSK(6)) return(NIL);
    if ((item4 = t[p1[3]]) & ~BITMSK(6)) return(NIL);
    *p2++ = (unsigned char) ((item1 << 2) | (item2 >> 4));
    *p2++ = (unsigned char) ((item2 << 4) | (item3 >> 2));
    *p2++ = (unsigned char) ((item3 << 6) | item4);}
 switch(leftover)
   {case 0:
      break;
    case 1:
      if ((item1 = t[p1[0]]) & ~BITMSK(6)) return(NIL);
      if ((item2 = t[p1[1]]) & ~BITMSK(6)) return(NIL);
      *p2++ = (unsigned char) ((item1 << 2) | (item2 >> 4));
      break;
    case 2:
      if ((item1 = t[p1[0]]) & ~BITMSK(6)) return(NIL);
      if ((item2 = t[p1[1]]) & ~BITMSK(6)) return(NIL);
      if ((item3 = t[p1[2]]) & ~BITMSK(6)) return(NIL);
      *p2++ = (unsigned char) ((item1 << 2) | (item2 >> 4));
      *p2++ = (unsigned char) ((item2 << 4) | (item3 >> 2));
      break;
    default:
      errswitch();}
 return(out);}

LISP memq(LISP x,LISP il)
{LISP l,tmp;
 for(l=il;CONSP(l);l=CDR(l))
   {tmp = CAR(l);
    if EQ(x,tmp) return(l);
    INTERRUPT_CHECK();}
 if EQ(l,NIL) return(NIL);
 return(err("improper list to memq",il));}

LISP member(LISP x,LISP il)
{LISP l,tmp;
 for(l=il;CONSP(l);l=CDR(l))
   {tmp = CAR(l);
    if NNULLP(equal(x,tmp)) return(l);
    INTERRUPT_CHECK();}
 if EQ(l,NIL) return(NIL);
 return(err("improper list to member",il));}

LISP memv(LISP x,LISP il)
{LISP l,tmp;
 for(l=il;CONSP(l);l=CDR(l))
   {tmp = CAR(l);
    if NNULLP(eql(x,tmp)) return(l);
    INTERRUPT_CHECK();}
 if EQ(l,NIL) return(NIL);
 return(err("improper list to memv",il));}


LISP nth(LISP x,LISP li)
{LISP l;
 long j,n = get_c_long(x);
 for(j = 0, l = li; (j < n) && CONSP(l); ++j) l = CDR(l);
 if CONSP(l)
   return(CAR(l));
 else
   return(err("bad arg to nth",x));}

/* these lxxx_default functions are convenient for manipulating
   command-line argument lists */

LISP lref_default(LISP li,LISP x,LISP fcn)
{LISP l;
 long j,n = get_c_long(x);
 for(j = 0, l = li; (j < n) && CONSP(l); ++j) l = CDR(l);
 if CONSP(l)
   return(CAR(l));
 else if NNULLP(fcn)
   return(lapply(fcn,NIL));
 else
   return(NIL);}

LISP larg_default(LISP li,LISP x,LISP dval)
{LISP l = li,elem;
 long j=0,n = get_c_long(x);
 while NNULLP(l)
   {elem = car(l);
    if (TYPEP(elem,tc_string) && strchr("-:",*get_c_string(elem)))
      l = cdr(l);
    else if (j == n)
      return(elem);
    else
      {l = cdr(l);
       ++j;}}
 return(dval);}

LISP lkey_default(LISP li,LISP key,LISP dval)
{LISP l = li,elem;
 char *ckey,*celem;
 long n;
 ckey = get_c_string(key);
 n = strlen(ckey);
 while NNULLP(l)
   {elem = car(l);
    if (TYPEP(elem,tc_string) && (*(celem = get_c_string(elem)) == ':') &&
	(strncmp(&celem[1],ckey,n) == 0) && (celem[n+1] == '='))
      return(strcons(strlen(&celem[n+2]),&celem[n+2]));
    l = cdr(l);}
 return(dval);}


LISP llist(LISP l)
{return(l);}

LISP writes1(FILE *f,LISP l)
{LISP v;
 STACK_CHECK(&v);
 INTERRUPT_CHECK();
 for(v=l;CONSP(v);v=CDR(v))
   writes1(f,CAR(v));
 switch TYPE(v)
   {case tc_nil:
      break;
    case tc_symbol:
    case tc_string:
      fput_st(f,get_c_string(v));
      break;
    default:
      lprin1f(v,f);
      break;}
 return(NIL);}

LISP writes(LISP args)
{return(writes1(get_c_file(car(args),stdout),cdr(args)));}

LISP last(LISP l)
{LISP v1,v2;
 v1 = l;
 v2 = CONSP(v1) ? CDR(v1) : err("bad arg to last",l);
 while(CONSP(v2))
   {INTERRUPT_CHECK();
    v1 = v2;
    v2 = CDR(v2);}
 return(v1);}

LISP butlast(LISP l)
{INTERRUPT_CHECK();
 STACK_CHECK(&l);
 if NULLP(l) err("list is empty",l);
 if CONSP(l)
   if NULLP(CDR(l))
     return(NIL);
   else
     return(cons(CAR(l),butlast(CDR(l))));
 return(err("not a list",l));}

LISP nconc(LISP a,LISP b)
{if NULLP(a)
   return(b);
 setcdr(last(a),b);
 return(a);}

LISP funcall1(LISP fcn,LISP a1)
{switch TYPE(fcn)
   {case tc_subr_1:
      STACK_CHECK(&fcn);
      INTERRUPT_CHECK();
      return(SUBR1(fcn)(a1));
    case tc_closure:
      if TYPEP(fcn->storage_as.closure.code,tc_subr_2)
	{STACK_CHECK(&fcn);
	 INTERRUPT_CHECK();
	 return(SUBR2(fcn->storage_as.closure.code)
		(fcn->storage_as.closure.env,a1));}
    default:
      return(lapply(fcn,cons(a1,NIL)));}}

LISP funcall2(LISP fcn,LISP a1,LISP a2)
{switch TYPE(fcn)
   {case tc_subr_2:
    case tc_subr_2n:
      STACK_CHECK(&fcn);
      INTERRUPT_CHECK();
      return(SUBR2(fcn)(a1,a2));
    default:
      return(lapply(fcn,cons(a1,cons(a2,NIL))));}}

LISP lqsort(LISP l,LISP f,LISP g)
     /* this is a stupid recursive qsort */
{int j,n;
 LISP v,mark,less,notless;
 for(v=l,n=0;CONSP(v);v=CDR(v),++n) INTERRUPT_CHECK();
 if NNULLP(v) err("bad list to qsort",l);
 if (n == 0)
   return(NIL);
 j = rand() % n;
 for(v=l,n=0;n<j;++n) v=CDR(v);
 mark = CAR(v);
 for(less=NIL,notless=NIL,v=l,n=0;NNULLP(v);v=CDR(v),++n)
   if (j != n)
     {if NNULLP(funcall2(f,
			 NULLP(g) ? CAR(v) : funcall1(g,CAR(v)),
			 NULLP(g) ? mark   : funcall1(g,mark)))
	less = cons(CAR(v),less);
      else
	notless = cons(CAR(v),notless);}
 return(nconc(lqsort(less,f,g),
	      cons(mark,
		   lqsort(notless,f,g))));}

LISP string_lessp(LISP s1,LISP s2)
{if (strcmp(get_c_string(s1),get_c_string(s2)) < 0)
   return(sym_t);
 else
   return(NIL);}

LISP benchmark_funcall1(LISP ln,LISP f,LISP a1)
{long j,n;
 LISP value = NIL;
 n = get_c_long(ln);
 for(j=0;j<n;++j)
   value = funcall1(f,a1);
 return(value);}

LISP benchmark_funcall2(LISP l)
{long j,n;
 LISP ln = car(l);LISP f = car(cdr(l)); LISP a1 = car(cdr(cdr(l)));
 LISP a2 = car(cdr(cdr(cdr(l))));
 LISP value = NIL;
 n = get_c_long(ln);
 for(j=0;j<n;++j)
   value = funcall2(f,a1,a2);
 return(value);}

LISP benchmark_eval(LISP ln,LISP exp,LISP env)
{long j,n;
 LISP value = NIL;
 n = get_c_long(ln);
 for(j=0;j<n;++j)
   value = leval(exp,env);
 return(value);}

LISP mapcar1(LISP fcn,LISP in)
{LISP res,ptr,l;
 if NULLP(in) return(NIL);
 res = ptr = cons(funcall1(fcn,car(in)),NIL);
 for(l=cdr(in);CONSP(l);l=CDR(l))
   ptr = CDR(ptr) = cons(funcall1(fcn,CAR(l)),CDR(ptr));
 return(res);}

LISP mapcar2(LISP fcn,LISP in1,LISP in2)
{LISP res,ptr,l1,l2;
 if (NULLP(in1) || NULLP(in2)) return(NIL);
 res = ptr = cons(funcall2(fcn,car(in1),car(in2)),NIL);
 for(l1=cdr(in1),l2=cdr(in2);CONSP(l1) && CONSP(l2);l1=CDR(l1),l2=CDR(l2))
   ptr = CDR(ptr) = cons(funcall2(fcn,CAR(l1),CAR(l2)),CDR(ptr));
 return(res);}

LISP mapcar(LISP l)
{LISP fcn = car(l);
 switch(get_c_long(llength(l)))
   {case 2:
      return(mapcar1(fcn,car(cdr(l))));
    case 3:
      return(mapcar2(fcn,car(cdr(l)),car(cdr(cdr(l)))));
    default:
      return(err("mapcar case not handled",l));}}

LISP lfmod(LISP x,LISP y)
{if NFLONUMP(x) err("wta(1st) to fmod",x);
 if NFLONUMP(y) err("wta(2nd) to fmod",y);
 return(flocons(fmod(FLONM(x),FLONM(y))));}

LISP lsubset(LISP fcn,LISP l)
{LISP result = NIL,v;
 for(v=l;CONSP(v);v=CDR(v))
   if NNULLP(funcall1(fcn,CAR(v)))
     result = cons(CAR(v),result);
 return(nreverse(result));}

LISP ass(LISP x,LISP alist,LISP fcn)
{LISP l,tmp;
 for(l=alist;CONSP(l);l=CDR(l))
   {tmp = CAR(l);
    if (CONSP(tmp) && NNULLP(funcall2(fcn,CAR(tmp),x))) return(tmp);
    INTERRUPT_CHECK();}
 if EQ(l,NIL) return(NIL);
 return(err("improper list to ass",alist));}

LISP append2(LISP l1,LISP l2)
{long n;
 LISP result = NIL,p1,p2;
 n = nlength(l1) + nlength(l2);
 while(n > 0) {result = cons(NIL,result); --n;}
 for(p1=result,p2=l1;NNULLP(p2);p1=cdr(p1),p2=cdr(p2)) setcar(p1,car(p2));
 for(p2=l2;NNULLP(p2);p1=cdr(p1),p2=cdr(p2)) setcar(p1,car(p2));
 return(result);}

LISP append(LISP l)
{STACK_CHECK(&l);
 INTERRUPT_CHECK();
 if NULLP(l)
   return(NIL);
 else if NULLP(cdr(l))
   return(car(l));
 else if NULLP(cddr(l))
   return(append2(car(l),cadr(l)));
 else
   return(append2(car(l),append(cdr(l))));}

LISP listn(long n, ...)
{LISP result,ptr;
 long j;
 va_list args;
 for(j=0,result=NIL;j<n;++j)  result = cons(NIL,result);
 va_start(args,n);
 for(j=0,ptr=result;j<n;ptr=cdr(ptr),++j)
   setcar(ptr,va_arg(args,LISP));
 va_end(args);
 return(result);}


LISP fast_load(LISP lfname,LISP noeval)
{char *fname;
 LISP stream;
 LISP result = NIL,form;
 fname = get_c_string(lfname);
 if (siod_verbose_level >= 3)
   {put_st("fast loading ");
    put_st(fname);
    put_st("\n");}
 stream = listn(3,
		fopen_c(fname,"rb"),
		cons_array(flocons(100),NIL),
		flocons(0));
 while(NEQ(stream,form = fast_read(stream)))
   {if (siod_verbose_level >= 5)
      lprint(form,NIL);
    if NULLP(noeval)
      leval(form,NIL);
    else
      result = cons(form,result);}
 fclose_l(car(stream));
 if (siod_verbose_level >= 3)
   put_st("done.\n");
 return(nreverse(result));}

static void shexstr(char *outstr,void *buff,size_t len)
{unsigned char *data = buff;
 size_t j;
 for(j=0;j<len;++j)
   sprintf(&outstr[j*2],"%02X",data[j]);}

LISP fast_save(LISP fname,LISP forms,LISP nohash,LISP comment,LISP fmode)
{char *cname,msgbuff[100],databuff[50];
 LISP stream,l;
 FILE *f;
 long l_one = 1;
 double d_one = 1.0;
 cname = get_c_string(fname);
 if (siod_verbose_level >= 3)
   {put_st("fast saving forms to ");
    put_st(cname);
    put_st("\n");}
 stream = listn(3,
		fopen_c(cname,NNULLP(fmode) ? get_c_string(fmode) : "wb"),
		NNULLP(nohash) ? NIL : cons_array(flocons(100),NIL),
		flocons(0));
 f = get_c_file(car(stream),NULL);
 if NNULLP(comment)
   fput_st(f,get_c_string(comment));
 sprintf(msgbuff,"# Siod Binary Object Save File\n");
 fput_st(f,msgbuff);
 sprintf(msgbuff,"# sizeof(long) = %d\n# sizeof(double) = %d\n",
	 sizeof(long),sizeof(double));
 fput_st(f,msgbuff);
 shexstr(databuff,&l_one,sizeof(l_one));
 sprintf(msgbuff,"# 1 = %s\n",databuff);
 fput_st(f,msgbuff);
 shexstr(databuff,&d_one,sizeof(d_one));
 sprintf(msgbuff,"# 1.0 = %s\n",databuff);
 fput_st(f,msgbuff);
 for(l=forms;NNULLP(l);l=cdr(l))
   fast_print(car(l),stream);
 fclose_l(car(stream));
 if (siod_verbose_level >= 3)
   put_st("done.\n");
 return(NIL);}

void swrite1(LISP stream,LISP data)
{FILE *f = get_c_file(stream,stdout);
 switch TYPE(data)
   {case tc_symbol:
    case tc_string:
      fput_st(f,get_c_string(data));
      break;
    default:
      lprin1f(data,f);
      break;}}

static LISP swrite2(LISP name,LISP table)
{LISP value,key;
 if (SYMBOLP(name) && (PNAME(name)[0] == '.'))
   key = rintern(&PNAME(name)[1]);
 else
   key = name;
 value = href(table,key);
 if (CONSP(value))
   {if (CONSP(CDR(value)) && EQ(name,key))
     hset(table,key,CDR(value));
    return(CAR(value));}
 else if (NULLP(value))
   return(name);
 else
   return(value);}

LISP swrite(LISP stream,LISP table,LISP data)
{long j,k,m,n;
 switch(TYPE(data))
   {case tc_symbol:
      swrite1(stream,swrite2(data,table));
      break;
    case tc_lisp_array:
      n = data->storage_as.lisp_array.dim;
      if (n < 1)
	err("no object repeat count",data);
      m = get_c_long(swrite2(data->storage_as.lisp_array.data[0],
			     table));
      for(k=0;k<m;++k)
	for(j=1;j<n;++j)
	  swrite(stream,table,data->storage_as.lisp_array.data[j]);
      break;
    case tc_cons:
      /* this should be handled similar to the array case */
      break;
    default:
      swrite1(stream,data);}
 return(NIL);}

LISP lpow(LISP x,LISP y)
{if NFLONUMP(x) err("wta(1st) to pow",x);
 if NFLONUMP(y) err("wta(2nd) to pow",y);
 return(flocons(pow(FLONM(x),FLONM(y))));}

LISP lexp(LISP x)
{return(flocons(exp(get_c_double(x))));}

LISP llog(LISP x)
{return(flocons(log(get_c_double(x))));}

LISP lsin(LISP x)
{return(flocons(sin(get_c_double(x))));}

LISP lcos(LISP x)
{return(flocons(cos(get_c_double(x))));}

LISP ltan(LISP x)
{return(flocons(tan(get_c_double(x))));}

LISP lasin(LISP x)
{return(flocons(asin(get_c_double(x))));}

LISP lacos(LISP x)
{return(flocons(acos(get_c_double(x))));}

LISP latan(LISP x)
{return(flocons(atan(get_c_double(x))));}

LISP latan2(LISP x,LISP y)
{return(flocons(atan2(get_c_double(x),get_c_double(y))));}

LISP hexstr(LISP a)
{unsigned char *in;
 char *out;
 LISP result;
 long j,dim;
 in = (unsigned char *) get_c_string_dim(a,&dim);
 result = strcons(dim*2,NULL);
 for(out=get_c_string(result),j=0;j<dim;++j,out += 2)
   sprintf(out,"%02x",in[j]);
 return(result);}

static int xdigitvalue(int c)
{if (isdigit(c))
   return(c - '0');
 if (isxdigit(c))
   return(toupper(c) - 'A' + 10);
 return(0);}

LISP hexstr2bytes(LISP a)
{char *in;
 unsigned char *out;
 LISP result;
 long j,dim;
 in = get_c_string(a);
 dim = strlen(in) / 2; 
 result = arcons(tc_byte_array,dim,0);
 out = (unsigned char *) result->storage_as.string.data;
 for(j=0;j<dim;++j)
   out[j] = xdigitvalue(in[j*2]) * 16 + xdigitvalue(in[j*2+1]);
 return(result);}

LISP getprop(LISP plist,LISP key)
{LISP l;
 for(l=cdr(plist);NNULLP(l);l=cddr(l))
   if EQ(car(l),key)
     return(cadr(l));
   else
     INTERRUPT_CHECK();
 return(NIL);}

LISP setprop(LISP plist,LISP key,LISP value)
{err("not implemented",NIL);
 return(NIL);}

LISP putprop(LISP plist,LISP value,LISP key)
{return(setprop(plist,key,value));}

LISP ltypeof(LISP obj)
{long x;
 x = TYPE(obj);
 switch(x)
   {case tc_nil: return(cintern("tc_nil"));
    case tc_cons: return(cintern("tc_cons"));
    case tc_flonum: return(cintern("tc_flonum"));
    case tc_symbol: return(cintern("tc_symbol"));
    case tc_subr_0: return(cintern("tc_subr_0"));
    case tc_subr_1: return(cintern("tc_subr_1"));
    case tc_subr_2: return(cintern("tc_subr_2"));
    case tc_subr_2n: return(cintern("tc_subr_2n"));
    case tc_subr_3: return(cintern("tc_subr_3"));
    case tc_subr_4: return(cintern("tc_subr_4"));
    case tc_subr_5: return(cintern("tc_subr_5"));
    case tc_lsubr: return(cintern("tc_lsubr"));
    case tc_fsubr: return(cintern("tc_fsubr"));
    case tc_msubr: return(cintern("tc_msubr"));
    case tc_closure: return(cintern("tc_closure"));
    case tc_free_cell: return(cintern("tc_free_cell"));
    case tc_string: return(cintern("tc_string"));
    case tc_byte_array: return(cintern("tc_byte_array"));
    case tc_double_array: return(cintern("tc_double_array"));
    case tc_long_array: return(cintern("tc_long_array"));
    case tc_lisp_array: return(cintern("tc_lisp_array"));
    case tc_c_file: return(cintern("tc_c_file"));
    default: return(flocons(x));}}

LISP caaar(LISP x)
{return(car(car(car(x))));}

LISP caadr(LISP x)
{return(car(car(cdr(x))));}

LISP cadar(LISP x)
{return(car(cdr(car(x))));}

LISP caddr(LISP x)
{return(car(cdr(cdr(x))));}

LISP cdaar(LISP x)
{return(cdr(car(car(x))));}

LISP cdadr(LISP x)
{return(cdr(car(cdr(x))));}

LISP cddar(LISP x)
{return(cdr(cdr(car(x))));}

LISP cdddr(LISP x)
{return(cdr(cdr(cdr(x))));}

LISP ash(LISP value,LISP n)
{long m,k;
 m = get_c_long(value);
 k = get_c_long(n);
 if (k > 0)
   m = m << k;
 else
   m = m >> (-k);
 return(flocons(m));}

LISP bitand(LISP a,LISP b)
{return(flocons(get_c_long(a) & get_c_long(b)));}

LISP bitor(LISP a,LISP b)
{return(flocons(get_c_long(a) | get_c_long(b)));}

LISP bitxor(LISP a,LISP b)
{return(flocons(get_c_long(a) ^ get_c_long(b)));}

LISP bitnot(LISP a)
{return(flocons(~get_c_long(a)));}

LISP leval_prog1(LISP args,LISP env)
{LISP retval,l;
 retval = leval(car(args),env);
 for(l=cdr(args);NNULLP(l);l=cdr(l))
   leval(car(l),env);
 return(retval);}

LISP leval_cond(LISP *pform,LISP *penv)
{LISP args,env,clause,value,next;
 args = cdr(*pform);
 env = *penv;
 if NULLP(args)
   {*pform = NIL;
    return(NIL);}
 next = cdr(args);
 while NNULLP(next)
   {clause = car(args);
    value = leval(car(clause),env);
    if NNULLP(value)
      {clause = cdr(clause);
       if NULLP(clause)
	 {*pform = value;
	  return(NIL);}
       else
	 {next = cdr(clause);
	  while(NNULLP(next))
	    {leval(car(clause),env);
	     clause=next;
	     next=cdr(next);}
	  *pform = car(clause); 
	  return(sym_t);}}
    args = next;
    next = cdr(next);}
 clause = car(args);
 next = cdr(clause);
 if NULLP(next)
   {*pform = car(clause);
    return(sym_t);}
 value = leval(car(clause),env);
 if NULLP(value)
   {*pform = NIL;
    return(NIL);}
 clause = next;
 next = cdr(next);
 while(NNULLP(next))
   {leval(car(clause),env);
    clause=next;
    next=cdr(next);}
 *pform = car(clause);
 return(sym_t);}

LISP lstrspn(LISP str1,LISP str2)
{return(flocons(strspn(get_c_string(str1),get_c_string(str2))));}

LISP lstrcspn(LISP str1,LISP str2)
{return(flocons(strcspn(get_c_string(str1),get_c_string(str2))));}

LISP substring_equal(LISP str1,LISP str2,LISP start,LISP end)
{char *cstr1,*cstr2;
 long len1,n,s,e;
 cstr1 = get_c_string_dim(str1,&len1);
 cstr2 = get_c_string_dim(str2,&n);
 s = NULLP(start) ? 0 : get_c_long(start);
 e = NULLP(end) ? len1 : get_c_long(end);
 if ((s < 0) || (s > e) || (e < 0) || (e > n) || ((e - s) != len1))
   return(NIL);
 return((memcmp(cstr1,&cstr2[s],e-s) == 0) ? a_true_value() : NIL);}

#ifdef vms
int strncasecmp(const char *s1, const char *s2, int n)
{int j,c1,c2;
 for(j=0;j<n;++j)
     {c1 = toupper(s1[j]);
    c2 = toupper(s2[j]);
    if ((c1 == 0) && (c2 == 0)) return(0);
    if (c1 == 0) return(-1);
    if (c2 == 0) return(1);
    if (c1 < c2) return(-1);
    if (c2 > c1) return(1);}
 return(0);}
#endif

LISP substring_equalcase(LISP str1,LISP str2,LISP start,LISP end)
{char *cstr1,*cstr2;
 long len1,n,s,e;
 cstr1 = get_c_string_dim(str1,&len1);
 cstr2 = get_c_string_dim(str2,&n);
 s = NULLP(start) ? 0 : get_c_long(start);
 e = NULLP(end) ? len1 : get_c_long(end);
 if ((s < 0) || (s > e) || (e < 0) || (e > n) || ((e - s) != len1))
   return(NIL);
 return((strncasecmp(cstr1,&cstr2[s],e-s) == 0) ? a_true_value() : NIL);}

LISP set_eval_history(LISP len,LISP circ)
{LISP data;
 data = NULLP(len) ? len : make_list(len,NIL);
 if NNULLP(circ)
   data = nconc(data,data);
 setvar(cintern("*eval-history-ptr*"),data,NIL);
 setvar(cintern("*eval-history*"),data,NIL);
 return(len);}

static LISP parser_fasl(LISP ignore)
{return(closure(listn(3,
		      NIL,
		      cons_array(flocons(100),NIL),
		      flocons(0)),
		leval(cintern("parser_fasl_hook"),NIL)));}

static LISP parser_fasl_hook(LISP env,LISP f)
{LISP result;
 setcar(env,f);
 result = fast_read(env);
 if EQ(result,env)
   return(get_eof_val());
 else
   return(result);}

void init_subrs_a(void)
{init_subr_2("aref",aref1);
 init_subr_3("aset",aset1);
 init_lsubr("string-append",string_append);
 init_lsubr("bytes-append",bytes_append);
 init_subr_1("string-length",string_length);
 init_subr_1("string-dimension",string_dim);
 init_subr_1("read-from-string",read_from_string);
 init_subr_3("print-to-string",print_to_string);
 init_subr_2("cons-array",cons_array);
 init_subr_2("sxhash",sxhash);
 init_subr_2("equal?",equal);
 init_subr_2("href",href);
 init_subr_3("hset",hset);
 init_subr_2("assoc",assoc);
 init_subr_2("assv",assv);
 init_subr_1("fast-read",fast_read);
 init_subr_2("fast-print",fast_print);
 init_subr_2("make-list",make_list);
 init_subr_2("fread",lfread);
 init_subr_2("fwrite",lfwrite);
 init_subr_1("fflush",lfflush);
 init_subr_1("length",llength);
 init_subr_4("number->string",number2string);
 init_subr_2("string->number",string2number);
 init_subr_3("substring",substring);
 init_subr_2("string-search",string_search);
 init_subr_1("string-trim",string_trim);
 init_subr_1("string-trim-left",string_trim_left);
 init_subr_1("string-trim-right",string_trim_right);
 init_subr_1("string-upcase",string_upcase);
 init_subr_1("string-downcase",string_downcase);
 init_subr_2("strcmp",lstrcmp);
 init_subr_2("strcat",lstrcat);
 init_subr_2("strcpy",lstrcpy);
 init_subr_2("strbreakup",lstrbreakup);
 init_subr_2("unbreakupstr",lstrunbreakup);
 init_subr_1("string?",stringp);
 gc_protect_sym(&sym_e,"e");
 gc_protect_sym(&sym_f,"f");
 gc_protect_sym(&sym_plists,"*plists*");
 setvar(sym_plists,arcons(tc_lisp_array,100,1),NIL);
 init_subr_3("lref-default",lref_default);
 init_subr_3("larg-default",larg_default);
 init_subr_3("lkey-default",lkey_default);
 init_lsubr("list",llist);
 init_lsubr("writes",writes);
 init_subr_3("qsort",lqsort);
 init_subr_2("string-lessp",string_lessp);
 init_lsubr("mapcar",mapcar);
 init_subr_3("mapcar2",mapcar2);
 init_subr_2("mapcar1",mapcar1);
 init_subr_3("benchmark-funcall1",benchmark_funcall1);
 init_lsubr("benchmark-funcall2",benchmark_funcall2);
 init_subr_3("benchmark-eval",benchmark_eval);
 init_subr_2("fmod",lfmod);
 init_subr_2("subset",lsubset);
 init_subr_1("base64encode",base64encode);
 init_subr_1("base64decode",base64decode);
 init_subr_3("ass",ass);
 init_subr_2("append2",append2);
 init_lsubr("append",append);
 init_subr_5("fast-save",fast_save);
 init_subr_2("fast-load",fast_load);
 init_subr_3("swrite",swrite);
 init_subr_2("pow",lpow);
 init_subr_1("exp",lexp);
 init_subr_1("log",llog);
 init_subr_1("sin",lsin);
 init_subr_1("cos",lcos);
 init_subr_1("tan",ltan);
 init_subr_1("asin",lasin);
 init_subr_1("acos",lacos);
 init_subr_1("atan",latan);
 init_subr_2("atan2",latan2);
 init_subr_1("typeof",ltypeof);
 init_subr_1("caaar",caaar);
 init_subr_1("caadr",caadr);
 init_subr_1("cadar",cadar);
 init_subr_1("caddr",caddr);
 init_subr_1("cdaar",cdaar);
 init_subr_1("cdadr",cdadr);
 init_subr_1("cddar",cddar);
 init_subr_1("cdddr",cdddr);
 setvar(cintern("*pi*"),flocons(atan(1.0)*4),NIL);
 init_base64_table();
 init_subr_1("array->hexstr",hexstr);
 init_subr_1("hexstr->bytes",hexstr2bytes);
 init_subr_3("ass",ass);
 init_subr_2("bit-and",bitand);
 init_subr_2("bit-or",bitor);
 init_subr_2("bit-xor",bitxor);
 init_subr_1("bit-not",bitnot);
 init_msubr("cond",leval_cond);
 init_fsubr("prog1",leval_prog1);
 init_subr_2("strspn",lstrspn);
 init_subr_2("strcspn",lstrcspn);
 init_subr_4("substring-equal?",substring_equal);
 init_subr_4("substring-equalcase?",substring_equalcase);
 init_subr_1("butlast",butlast);
 init_subr_2("ash",ash);
 init_subr_2("get",getprop);
 init_subr_3("setprop",setprop);
 init_subr_3("putprop",putprop);
 init_subr_1("last",last);
 init_subr_2("memq",memq);
 init_subr_2("memv",memv);
 init_subr_2("member",member);
 init_subr_2("nth",nth);
 init_subr_2("nconc",nconc);
 init_subr_2("set-eval-history",set_eval_history);
 init_subr_1("parser_fasl",parser_fasl);
 setvar(cintern("*parser_fasl.scm-loaded*"),a_true_value(),NIL);
 init_subr_2("parser_fasl_hook",parser_fasl_hook);
 init_sliba_version();}