Loading...
Searching...
No Matches
slib_xtr.cc
/*
* COPYRIGHT (c) 1988-1994 BY *
* PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
* See the source file SLIB.C for more information. *
Array-hacking code moved to another source file.
* Functions *not* used in Edinburgh Speech Tools
* arrays, hash tables,
*/
#include <cstdio>
#include <cstring>
#include <setjmp.h>
#include <cstdlib>
#include <cctype>
#include "siod.h"
#include "siodp.h"
static LISP bashnum = NIL;
static 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);}
static 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]);}
static 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);}
static void array_gc_free(LISP ptr)
{switch (ptr->type)
{case tc_string:
wfree(ptr->storage_as.string.data);
break;
case tc_double_array:
wfree(ptr->storage_as.double_array.data);
break;
case tc_long_array:
wfree(ptr->storage_as.long_array.data);
break;
case tc_lisp_array:
wfree(ptr->storage_as.lisp_array.data);
break;}}
static void array_prin1(LISP ptr,FILE *f)
{int j;
switch (ptr->type)
{case tc_string:
fput_st(f,"\"");
fput_st(f,ptr->storage_as.string.data);
fput_st(f,"\"");
break;
case tc_double_array:
fput_st(f,"#(");
for(j=0; j < ptr->storage_as.double_array.dim; ++j)
{sprintf(tkbuffer,"%g",ptr->storage_as.double_array.data[j]);
fput_st(f,tkbuffer);
if ((j + 1) < ptr->storage_as.double_array.dim)
fput_st(f," ");}
fput_st(f,")");
break;
case tc_long_array:
fput_st(f,"#(");
for(j=0; j < ptr->storage_as.long_array.dim; ++j)
{sprintf(tkbuffer,"%ld",ptr->storage_as.long_array.data[j]);
fput_st(f,tkbuffer);
if ((j + 1) < ptr->storage_as.long_array.dim)
fput_st(f," ");}
fput_st(f,")");
break;
case tc_lisp_array:
fput_st(f,"#(");
for(j=0; j < ptr->storage_as.lisp_array.dim; ++j)
{lprin1f(ptr->storage_as.lisp_array.data[j],f);
if ((j + 1) < ptr->storage_as.lisp_array.dim)
fput_st(f," ");}
fput_st(f,")");
break;}}
static 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 (a->type)
{case tc_string:
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));}}
static void err1_aset1(LISP i)
{err("index to aset too large",i);}
static void err2_aset1(LISP v)
{err("bad value to store in array",v);}
static 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 (a->type)
{case tc_string:
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));}}
static 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.double_array.dim = n+1;
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("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);}
#define HASH_COMBINE(_h1,_h2,_mod) ((((_h1) * 17 + 1) ^ (_h2)) % (_mod))
static 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_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);}}
static LISP sxhash(LISP obj,LISP n)
{return(flocons(c_sxhash(obj,FLONUMP(n) ? (long) FLONM(n) : 10000)));}
static LISP array_equal(LISP a,LISP b)
{long j,len;
switch(TYPE(a))
{case tc_string:
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(truth);
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(truth);
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(truth);
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(truth);
default:
return(errswitch());}}
static 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:
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);}}
static 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);}
static LISP href(LISP table,LISP key)
{return(cdr(assoc(key,
table->storage_as.lisp_array.data[href_index(table,key)])));}
static 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);}
static LISP make_list(LISP x,LISP v)
{long n;
LISP l;
n = get_c_int(x);
l = NIL;
while(n > 0)
{l = cons(v,l); --n;}
return(l);}
static void put_long(long i,FILE *f)
{fwrite(&i,sizeof(long),1,f);}
static long get_long(FILE *f)
{long i;
fread(&i,sizeof(long),1,f);
return(i);}
static 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_int(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)),flocons(get_c_int(bashnum)+get_c_int(index)));
putc(FO_store,f);
put_long(get_c_int(index),f);
return(1);}
static 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(truth);}
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));}}
static 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_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)));}}
static 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:
putc(tc_string,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());}}
static 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_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());}}
static void init_storage_xtr1(long type)
{long j;
struct user_type_hooks *p;
set_gc_hooks(type,
FALSE,
array_gc_relocate,
array_gc_mark,
array_gc_scan,
array_gc_free,
NULL,
&j);
set_print_hooks(type,array_prin1, NULL);
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;}
static void init_storage_xtr(void)
{gc_protect(&bashnum);
bashnum = newcell(tc_flonum);
init_storage_xtr1(tc_string);
init_storage_xtr1(tc_double_array);
init_storage_xtr1(tc_long_array);
init_storage_xtr1(tc_lisp_array);}
void init_subrs_xtr(void)
{
init_storage_xtr();
init_subr_2("aref",aref1,
"(aref ARRAY INDEX)\n\
Return ARRAY[INDEX]");
init_subr_3("aset",aset1,
"(aset ARRAY INDEX VAL)\n\
Set ARRAY[INDEX] = VAL");
init_subr_2("cons-array",cons_array,
"(cons-array DIM KIND)\n\
Construct array of size DIM and type KIND. Where KIND may be one of\n\
double, long, string or lisp.");
init_subr_2("sxhash",sxhash,
"(sxhash OBJ N)\n\
Return hashing value for OBJ, in range n.");
init_subr_2("href",href,
"(href TABLE KEY)\n\
Return value in hash table TABLE with KEY.");
init_subr_3("hset",hset,
"(hset TABLE KEY VALUE)\n\
Set hash table TABLE KEY to VALUE.");
init_subr_1("fast-read",fast_read,
"(fast-read TABLE)\n\
");
init_subr_2("fast-print",fast_print,
"(fast-print P TABLE)\n\
");
init_subr_2("make-list",make_list,
"(make-list SIZE VALUE)\n\
Return list of SIZE with each member VALUE.");
}
obj
Definition siod_defs.h:31
user_type_hooks
Definition siodp.h:41