21static LISP bashnum = NIL;
23static LISP array_gc_relocate(
LISP ptr)
25 if ((
nw = heap) >= heap_end) gc_fatal_error();
27 memcpy(
nw,ptr,
sizeof(
struct obj));
30static void array_gc_scan(
LISP ptr)
32 if TYPEP(ptr,tc_lisp_array)
33 for(
j=0;
j < ptr->storage_as.lisp_array.dim; ++
j)
34 ptr->storage_as.lisp_array.data[
j] =
35 gc_relocate(ptr->storage_as.lisp_array.data[
j]);}
39 if TYPEP(ptr,tc_lisp_array)
40 for(
j=0;
j < ptr->storage_as.lisp_array.dim; ++
j)
41 gc_mark(ptr->storage_as.lisp_array.data[
j]);
44static void array_gc_free(
LISP ptr)
47 wfree(ptr->storage_as.string.data);
50 wfree(ptr->storage_as.double_array.data);
53 wfree(ptr->storage_as.long_array.data);
56 wfree(ptr->storage_as.lisp_array.data);
59static void array_prin1(
LISP ptr,
FILE *f)
64 fput_st(f,ptr->storage_as.string.data);
69 for(
j=0;
j < ptr->storage_as.double_array.dim; ++
j)
70 {
sprintf(tkbuffer,
"%g",ptr->storage_as.double_array.data[
j]);
72 if ((
j + 1) < ptr->storage_as.double_array.dim)
78 for(
j=0;
j < ptr->storage_as.long_array.dim; ++
j)
79 {
sprintf(tkbuffer,
"%ld",ptr->storage_as.long_array.data[
j]);
81 if ((
j + 1) < ptr->storage_as.long_array.dim)
87 for(
j=0;
j < ptr->storage_as.lisp_array.dim; ++
j)
88 {lprin1f(ptr->storage_as.lisp_array.data[
j],f);
89 if ((
j + 1) < ptr->storage_as.lisp_array.dim)
96 if NFLONUMP(i) err(
"bad index to aref",i);
98 if (k < 0) err(
"negative index to aref",i);
101 if (k >= a->storage_as.string.dim) err(
"index too large",i);
102 return(flocons((
double) a->storage_as.string.data[k]));
103 case tc_double_array:
104 if (k >= a->storage_as.double_array.dim) err(
"index too large",i);
105 return(flocons(a->storage_as.double_array.data[k]));
107 if (k >= a->storage_as.long_array.dim) err(
"index too large",i);
108 return(flocons(a->storage_as.long_array.data[k]));
110 if (k >= a->storage_as.lisp_array.dim) err(
"index too large",i);
111 return(a->storage_as.lisp_array.data[k]);
113 return(err(
"invalid argument to aref",a));}}
115static void err1_aset1(
LISP i)
116{err(
"index to aset too large",i);}
118static void err2_aset1(
LISP v)
119{err(
"bad value to store in array",v);}
123 if NFLONUMP(i) err(
"bad index to aset",i);
125 if (k < 0) err(
"negative index to aset",i);
128 if NFLONUMP(v) err2_aset1(v);
129 if (k >= a->storage_as.string.dim) err1_aset1(i);
130 a->storage_as.string.data[k] = (
char) FLONM(v);
132 case tc_double_array:
133 if NFLONUMP(v) err2_aset1(v);
134 if (k >= a->storage_as.double_array.dim) err1_aset1(i);
135 a->storage_as.double_array.data[k] = FLONM(v);
138 if NFLONUMP(v) err2_aset1(v);
139 if (k >= a->storage_as.long_array.dim) err1_aset1(i);
140 a->storage_as.long_array.data[k] = (
long) FLONM(v);
143 if (k >= a->storage_as.lisp_array.dim) err1_aset1(i);
144 a->storage_as.lisp_array.data[k] = v;
147 return(err(
"invalid argument to aset",a));}}
152 if (NFLONUMP(dim) || (FLONM(dim) < 0))
153 return(err(
"bad dimension to cons-array",dim));
155 n = (
long) FLONM(dim);
156 flag = no_interrupt(1);
158 if EQ(cintern(
"double"),
kind)
159 {a->type = tc_double_array;
160 a->storage_as.double_array.dim = n;
161 a->storage_as.double_array.data = (
double *) must_malloc(n *
163 for(
j=0;
j<n;++
j) a->storage_as.double_array.data[
j] = 0.0;}
164 else if EQ(cintern(
"long"),
kind)
165 {a->type = tc_long_array;
166 a->storage_as.long_array.dim = n;
167 a->storage_as.long_array.data = (
long *) must_malloc(n *
sizeof(
long));
168 for(
j=0;
j<n;++
j) a->storage_as.long_array.data[
j] = 0;}
169 else if EQ(cintern(
"string"),
kind)
170 {a->type = tc_string;
171 a->storage_as.double_array.dim = n+1;
172 a->storage_as.string.data = (
char *) must_malloc(n+1);
173 a->storage_as.string.data[n] = 0;
174 for(
j=0;
j<n;++
j) a->storage_as.string.data[
j] =
' ';}
175 else if (EQ(cintern(
"lisp"),
kind) || NULLP(
kind))
176 {a->type = tc_lisp_array;
177 a->storage_as.lisp_array.dim = n;
178 a->storage_as.lisp_array.data = (
LISP *) must_malloc(n *
sizeof(
LISP));
179 for(
j=0;
j<n;++
j) a->storage_as.lisp_array.data[
j] = NIL;}
181 err(
"bad type of array",
kind);
185#define HASH_COMBINE(_h1,_h2,_mod) ((((_h1) * 17 + 1) ^ (_h2)) % (_mod))
187static long c_sxhash(
LISP obj,
long n)
204 for(
hash=0,s=(
unsigned char *)PNAME(
obj);*s;++s)
215 for(
hash=0,s=(
unsigned char *)
obj->storage_as.subr.name;*s;++s)
219 return(((
unsigned long)FLONM(
obj)) % n);
221 p = get_user_type_hooks(TYPE(
obj));
223 return((*p->c_sxhash)(
obj,n));
228{
return(flocons(c_sxhash(
obj,FLONUMP(n) ? (
long) FLONM(n) : 10000)));}
234 len = a->storage_as.string.dim;
235 if (
len != b->storage_as.string.dim)
return(NIL);
236 if (
memcmp(a->storage_as.string.data,b->storage_as.string.data,
len) == 0)
241 len = a->storage_as.long_array.dim;
242 if (
len != b->storage_as.long_array.dim)
return(NIL);
243 if (
memcmp(a->storage_as.long_array.data,
244 b->storage_as.long_array.data,
245 len *
sizeof(
long)) == 0)
249 case tc_double_array:
250 len = a->storage_as.double_array.dim;
251 if (
len != b->storage_as.double_array.dim)
return(NIL);
253 if (a->storage_as.double_array.data[
j] !=
254 b->storage_as.double_array.data[
j])
258 len = a->storage_as.lisp_array.dim;
259 if (
len != b->storage_as.lisp_array.dim)
return(NIL);
261 if NULLP(equal(a->storage_as.lisp_array.data[
j],
262 b->storage_as.lisp_array.data[
j]))
266 return(errswitch());}}
268static long array_sxhash(
LISP a,
long n)
275 len = a->storage_as.string.dim;
276 for(
j=0,
hash=0,
char_data=(
unsigned char *)a->storage_as.string.data;
282 len = a->storage_as.long_array.dim;
283 for(
j=0,
hash=0,
long_data=(
unsigned long *)a->storage_as.long_array.data;
288 case tc_double_array:
289 len = a->storage_as.double_array.dim;
296 len = a->storage_as.lisp_array.dim;
299 c_sxhash(a->storage_as.lisp_array.data[
j],n),
308 if NTYPEP(
table,tc_lisp_array) err(
"not a hash table",
table);
309 index = c_sxhash(key,
table->storage_as.lisp_array.dim);
310 if ((index < 0) || (index >=
table->storage_as.lisp_array.dim))
311 {err(
"sxhash inconsistency",
table);
317{
return(cdr(assoc(key,
318 table->storage_as.lisp_array.data[href_index(
table,key)])));}
323 index = href_index(
table,key);
324 l =
table->storage_as.lisp_array.data[index];
325 if NNULLP(
cell = assoc(key,l))
326 return(setcdr(
cell,value));
327 cell = cons(key,value);
328 table->storage_as.lisp_array.data[index] = cons(
cell,l);
337 {l = cons(v,l); --n;}
340static void put_long(
long i,
FILE *f)
341{
fwrite(&i,
sizeof(
long),1,f);}
343static long get_long(
FILE *f)
345 fread(&i,
sizeof(
long),1,f);
351 f = get_c_file(car(
table),(
FILE *) NULL);
354 index = href(
ht,
obj);
357 put_long(get_c_int(index),f);
359 if NULLP(index = car(cdr(cdr(
table))))
362 FLONM(bashnum) = 1.0;
363 setcar(cdr(cdr(
table)),flocons(get_c_int(bashnum)+get_c_int(index)));
365 put_long(get_c_int(index),f);
374 f = get_c_file(car(
table),(
FILE *) NULL);
400 sizeof(
obj->storage_as.flonum.data),
408 if (
len >= TKBUFFERN)
409 err(
"symbol name too long",
obj);
416 p = get_user_type_hooks(TYPE(
obj));
418 return((*p->fast_print)(
obj,
table));
420 return(err(
"cannot fast-print",
obj));}}
428 f = get_c_file(car(
table),(
FILE *) NULL);
434 FLONM(bashnum) =
len;
435 return(href(car(cdr(
table)),bashnum));
449 FLONM(bashnum) =
len;
450 l = make_list(bashnum,NIL);
461 tmp = newcell(tc_flonum);
462 fread(&
tmp->storage_as.flonum.data,
463 sizeof(
tmp->storage_as.flonum.data),
469 if (
len >= TKBUFFERN)
470 err(
"symbol name too long",NIL);
471 fread(tkbuffer,
len,1,f);
473 return(rintern(tkbuffer));
475 p = get_user_type_hooks(c);
477 return(*p->fast_read)(c,
table);
479 return(err(
"unknown fast-read opcode",flocons(c)));}}
484 f = get_c_file(car(
table),(
FILE *) NULL);
488 len = ptr->storage_as.string.dim;
490 fwrite(ptr->storage_as.string.data,
len,1,f);
492 case tc_double_array:
493 putc(tc_double_array,f);
494 len = ptr->storage_as.double_array.dim *
sizeof(
double);
496 fwrite(ptr->storage_as.double_array.data,
len,1,f);
499 putc(tc_long_array,f);
500 len = ptr->storage_as.long_array.dim *
sizeof(
long);
502 fwrite(ptr->storage_as.long_array.data,
len,1,f);
505 putc(tc_lisp_array,f);
506 len = ptr->storage_as.lisp_array.dim;
509 fast_print(ptr->storage_as.lisp_array.data[
j],
table);
512 return(errswitch());}}
518 f = get_c_file(car(
table),(
FILE *) NULL);
522 ptr = strcons(
len,NULL);
523 fread(ptr->storage_as.string.data,
len,1,f);
524 ptr->storage_as.string.data[
len] = 0;
526 case tc_double_array:
528 iflag = no_interrupt(1);
529 ptr = newcell(tc_double_array);
530 ptr->storage_as.double_array.dim =
len;
531 ptr->storage_as.double_array.data =
532 (
double *) must_malloc(
len *
sizeof(
double));
533 fread(ptr->storage_as.double_array.data,
sizeof(
double),
len,f);
538 iflag = no_interrupt(1);
539 ptr = newcell(tc_long_array);
540 ptr->storage_as.long_array.dim =
len;
541 ptr->storage_as.long_array.data =
542 (
long *) must_malloc(
len *
sizeof(
long));
543 fread(ptr->storage_as.long_array.data,
sizeof(
long),
len,f);
548 FLONM(bashnum) =
len;
549 ptr = cons_array(bashnum,NIL);
551 ptr->storage_as.lisp_array.data[
j] = fast_read(
table);
554 return(errswitch());}}
556static void init_storage_xtr1(
long type)
567 set_print_hooks(type,array_prin1, NULL);
568 p = get_user_type_hooks(type);
569 p->fast_print = array_fast_print;
570 p->fast_read = array_fast_read;
571 p->equal = array_equal;
572 p->c_sxhash = array_sxhash;}
574static void init_storage_xtr(
void)
575{gc_protect(&bashnum);
576 bashnum = newcell(tc_flonum);
577 init_storage_xtr1(tc_string);
578 init_storage_xtr1(tc_double_array);
579 init_storage_xtr1(tc_long_array);
580 init_storage_xtr1(tc_lisp_array);}
582void init_subrs_xtr(
void)
587 init_subr_2(
"aref",aref1,
588 "(aref ARRAY INDEX)\n\
589 Return ARRAY[INDEX]");
590 init_subr_3(
"aset",aset1,
591 "(aset ARRAY INDEX VAL)\n\
592 Set ARRAY[INDEX] = VAL");
593 init_subr_2(
"cons-array",cons_array,
594 "(cons-array DIM KIND)\n\
595 Construct array of size DIM and type KIND. Where KIND may be one of\n\
596 double, long, string or lisp.");
597 init_subr_2(
"sxhash",sxhash,
599 Return hashing value for OBJ, in range n.");
600 init_subr_2(
"href",href,
602 Return value in hash table TABLE with KEY.");
603 init_subr_3(
"hset",hset,
604 "(hset TABLE KEY VALUE)\n\
605 Set hash table TABLE KEY to VALUE.");
606 init_subr_1(
"fast-read",fast_read,
607 "(fast-read TABLE)\n\
609 init_subr_2(
"fast-print",fast_print,
610 "(fast-print P TABLE)\n\
612 init_subr_2(
"make-list",make_list,
613 "(make-list SIZE VALUE)\n\
614 Return list of SIZE with each member VALUE.");