Edinburgh Speech Tools 2.4-release
slib_xtr.cc
1/*
2 * COPYRIGHT (c) 1988-1994 BY *
3 * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
4 * See the source file SLIB.C for more information. *
5
6Array-hacking code moved to another source file.
7
8 * Functions *not* used in Edinburgh Speech Tools
9 * arrays, hash tables,
10
11*/
12#include <cstdio>
13#include <cstring>
14#include <setjmp.h>
15#include <cstdlib>
16#include <cctype>
17
18#include "siod.h"
19#include "siodp.h"
20
21static LISP bashnum = NIL;
22
23static LISP array_gc_relocate(LISP ptr)
24{LISP nw;
25 if ((nw = heap) >= heap_end) gc_fatal_error();
26 heap = nw+1;
27 memcpy(nw,ptr,sizeof(struct obj));
28 return(nw);}
29
30static void array_gc_scan(LISP ptr)
31{long j;
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]);}
36
37static LISP array_gc_mark(LISP ptr)
38{long 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]);
42 return(NIL);}
43
44static void array_gc_free(LISP ptr)
45{switch (ptr->type)
46 {case tc_string:
47 wfree(ptr->storage_as.string.data);
48 break;
49 case tc_double_array:
50 wfree(ptr->storage_as.double_array.data);
51 break;
52 case tc_long_array:
53 wfree(ptr->storage_as.long_array.data);
54 break;
55 case tc_lisp_array:
56 wfree(ptr->storage_as.lisp_array.data);
57 break;}}
58
59static void array_prin1(LISP ptr,FILE *f)
60{int j;
61 switch (ptr->type)
62 {case tc_string:
63 fput_st(f,"\"");
64 fput_st(f,ptr->storage_as.string.data);
65 fput_st(f,"\"");
66 break;
67 case tc_double_array:
68 fput_st(f,"#(");
69 for(j=0; j < ptr->storage_as.double_array.dim; ++j)
70 {sprintf(tkbuffer,"%g",ptr->storage_as.double_array.data[j]);
71 fput_st(f,tkbuffer);
72 if ((j + 1) < ptr->storage_as.double_array.dim)
73 fput_st(f," ");}
74 fput_st(f,")");
75 break;
76 case tc_long_array:
77 fput_st(f,"#(");
78 for(j=0; j < ptr->storage_as.long_array.dim; ++j)
79 {sprintf(tkbuffer,"%ld",ptr->storage_as.long_array.data[j]);
80 fput_st(f,tkbuffer);
81 if ((j + 1) < ptr->storage_as.long_array.dim)
82 fput_st(f," ");}
83 fput_st(f,")");
84 break;
85 case tc_lisp_array:
86 fput_st(f,"#(");
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)
90 fput_st(f," ");}
91 fput_st(f,")");
92 break;}}
93
94static LISP aref1(LISP a,LISP i)
95{long k;
96 if NFLONUMP(i) err("bad index to aref",i);
97 k = (long) FLONM(i);
98 if (k < 0) err("negative index to aref",i);
99 switch (a->type)
100 {case tc_string:
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]));
106 case tc_long_array:
107 if (k >= a->storage_as.long_array.dim) err("index too large",i);
108 return(flocons(a->storage_as.long_array.data[k]));
109 case tc_lisp_array:
110 if (k >= a->storage_as.lisp_array.dim) err("index too large",i);
111 return(a->storage_as.lisp_array.data[k]);
112 default:
113 return(err("invalid argument to aref",a));}}
114
115static void err1_aset1(LISP i)
116{err("index to aset too large",i);}
117
118static void err2_aset1(LISP v)
119{err("bad value to store in array",v);}
120
121static LISP aset1(LISP a,LISP i,LISP v)
122{long k;
123 if NFLONUMP(i) err("bad index to aset",i);
124 k = (long) FLONM(i);
125 if (k < 0) err("negative index to aset",i);
126 switch (a->type)
127 {case tc_string:
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);
131 return(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);
136 return(v);
137 case tc_long_array:
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);
141 return(v);
142 case tc_lisp_array:
143 if (k >= a->storage_as.lisp_array.dim) err1_aset1(i);
144 a->storage_as.lisp_array.data[k] = v;
145 return(v);
146 default:
147 return(err("invalid argument to aset",a));}}
148
149static LISP cons_array(LISP dim,LISP kind)
150{LISP a;
151 long flag,n,j;
152 if (NFLONUMP(dim) || (FLONM(dim) < 0))
153 return(err("bad dimension to cons-array",dim));
154 else
155 n = (long) FLONM(dim);
156 flag = no_interrupt(1);
157 a = cons(NIL,NIL);
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 *
162 sizeof(double));
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;}
180 else
181 err("bad type of array",kind);
182 no_interrupt(flag);
183 return(a);}
184
185#define HASH_COMBINE(_h1,_h2,_mod) ((((_h1) * 17 + 1) ^ (_h2)) % (_mod))
186
187static long c_sxhash(LISP obj,long n)
188{long hash;
189 unsigned char *s;
190 LISP tmp;
191 struct user_type_hooks *p;
192 STACK_CHECK(&obj);
193 INTERRUPT_CHECK();
194 switch TYPE(obj)
195 {case tc_nil:
196 return(0);
197 case tc_cons:
198 hash = c_sxhash(CAR(obj),n);
199 for(tmp=CDR(obj);CONSP(tmp);tmp=CDR(tmp))
200 hash = HASH_COMBINE(hash,c_sxhash(CAR(tmp),n),n);
201 hash = HASH_COMBINE(hash,c_sxhash(tmp,n),n);
202 return(hash);
203 case tc_symbol:
204 for(hash=0,s=(unsigned char *)PNAME(obj);*s;++s)
205 hash = HASH_COMBINE(hash,*s,n);
206 return(hash);
207 case tc_subr_0:
208 case tc_subr_1:
209 case tc_subr_2:
210 case tc_subr_3:
211 case tc_subr_4:
212 case tc_lsubr:
213 case tc_fsubr:
214 case tc_msubr:
215 for(hash=0,s=(unsigned char *) obj->storage_as.subr.name;*s;++s)
216 hash = HASH_COMBINE(hash,*s,n);
217 return(hash);
218 case tc_flonum:
219 return(((unsigned long)FLONM(obj)) % n);
220 default:
221 p = get_user_type_hooks(TYPE(obj));
222 if (p->c_sxhash)
223 return((*p->c_sxhash)(obj,n));
224 else
225 return(0);}}
226
227static LISP sxhash(LISP obj,LISP n)
228{return(flocons(c_sxhash(obj,FLONUMP(n) ? (long) FLONM(n) : 10000)));}
229
230static LISP array_equal(LISP a,LISP b)
231{long j,len;
232 switch(TYPE(a))
233 {case tc_string:
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)
237 return(truth);
238 else
239 return(NIL);
240 case tc_long_array:
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)
246 return(truth);
247 else
248 return(NIL);
249 case tc_double_array:
250 len = a->storage_as.double_array.dim;
251 if (len != b->storage_as.double_array.dim) return(NIL);
252 for(j=0;j<len;++j)
253 if (a->storage_as.double_array.data[j] !=
254 b->storage_as.double_array.data[j])
255 return(NIL);
256 return(truth);
257 case tc_lisp_array:
258 len = a->storage_as.lisp_array.dim;
259 if (len != b->storage_as.lisp_array.dim) return(NIL);
260 for(j=0;j<len;++j)
261 if NULLP(equal(a->storage_as.lisp_array.data[j],
262 b->storage_as.lisp_array.data[j]))
263 return(NIL);
264 return(truth);
265 default:
266 return(errswitch());}}
267
268static long array_sxhash(LISP a,long n)
269{long j,len,hash;
270 unsigned char *char_data;
271 unsigned long *long_data;
272 double *double_data;
273 switch(TYPE(a))
274 {case tc_string:
275 len = a->storage_as.string.dim;
276 for(j=0,hash=0,char_data=(unsigned char *)a->storage_as.string.data;
277 j < len;
278 ++j,++char_data)
279 hash = HASH_COMBINE(hash,*char_data,n);
280 return(hash);
281 case tc_long_array:
282 len = a->storage_as.long_array.dim;
283 for(j=0,hash=0,long_data=(unsigned long *)a->storage_as.long_array.data;
284 j < len;
285 ++j,++long_data)
286 hash = HASH_COMBINE(hash,*long_data % n,n);
287 return(hash);
288 case tc_double_array:
289 len = a->storage_as.double_array.dim;
290 for(j=0,hash=0,double_data=a->storage_as.double_array.data;
291 j < len;
292 ++j,++double_data)
293 hash = HASH_COMBINE(hash,(unsigned long)*double_data % n,n);
294 return(hash);
295 case tc_lisp_array:
296 len = a->storage_as.lisp_array.dim;
297 for(j=0,hash=0; j < len; ++j)
298 hash = HASH_COMBINE(hash,
299 c_sxhash(a->storage_as.lisp_array.data[j],n),
300 n);
301 return(hash);
302 default:
303 errswitch();
304 return(0);}}
305
306static long href_index(LISP table,LISP key)
307{long index;
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);
312 return(0);}
313 else
314 return(index);}
315
316static LISP href(LISP table,LISP key)
317{return(cdr(assoc(key,
318 table->storage_as.lisp_array.data[href_index(table,key)])));}
319
320static LISP hset(LISP table,LISP key,LISP value)
321{long index;
322 LISP cell,l;
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);
329 return(value);}
330
331static LISP make_list(LISP x,LISP v)
332{long n;
333 LISP l;
334 n = get_c_int(x);
335 l = NIL;
336 while(n > 0)
337 {l = cons(v,l); --n;}
338 return(l);}
339
340static void put_long(long i,FILE *f)
341{fwrite(&i,sizeof(long),1,f);}
342
343static long get_long(FILE *f)
344{long i;
345 fread(&i,sizeof(long),1,f);
346 return(i);}
347
348static long fast_print_table(LISP obj,LISP table)
349{FILE *f;
350 LISP ht,index;
351 f = get_c_file(car(table),(FILE *) NULL);
352 if NULLP(ht = car(cdr(table)))
353 return(1);
354 index = href(ht,obj);
355 if NNULLP(index)
356 {putc(FO_fetch,f);
357 put_long(get_c_int(index),f);
358 return(0);}
359 if NULLP(index = car(cdr(cdr(table))))
360 return(1);
361 hset(ht,obj,index);
362 FLONM(bashnum) = 1.0;
363 setcar(cdr(cdr(table)),flocons(get_c_int(bashnum)+get_c_int(index)));
364 putc(FO_store,f);
365 put_long(get_c_int(index),f);
366 return(1);}
367
368static LISP fast_print(LISP obj,LISP table)
369{FILE *f;
370 long len;
371 LISP tmp;
372 struct user_type_hooks *p;
373 STACK_CHECK(&obj);
374 f = get_c_file(car(table),(FILE *) NULL);
375 switch(TYPE(obj))
376 {case tc_nil:
377 putc(tc_nil,f);
378 return(NIL);
379 case tc_cons:
380 for(len=0,tmp=obj;CONSP(tmp);tmp=CDR(tmp)) {INTERRUPT_CHECK();++len;}
381 if (len == 1)
382 {putc(tc_cons,f);
383 fast_print(car(obj),table);
384 fast_print(cdr(obj),table);}
385 else if NULLP(tmp)
386 {putc(FO_list,f);
387 put_long(len,f);
388 for(tmp=obj;CONSP(tmp);tmp=CDR(tmp))
389 fast_print(CAR(tmp),table);}
390 else
391 {putc(FO_listd,f);
392 put_long(len,f);
393 for(tmp=obj;CONSP(tmp);tmp=CDR(tmp))
394 fast_print(CAR(tmp),table);
395 fast_print(tmp,table);}
396 return(NIL);
397 case tc_flonum:
398 putc(tc_flonum,f);
399 fwrite(&obj->storage_as.flonum.data,
400 sizeof(obj->storage_as.flonum.data),
401 1,
402 f);
403 return(NIL);
404 case tc_symbol:
405 if (fast_print_table(obj,table))
406 {putc(tc_symbol,f);
407 len = strlen(PNAME(obj));
408 if (len >= TKBUFFERN)
409 err("symbol name too long",obj);
410 put_long(len,f);
411 fwrite(PNAME(obj),len,1,f);
412 return(truth);}
413 else
414 return(NIL);
415 default:
416 p = get_user_type_hooks(TYPE(obj));
417 if (p->fast_print)
418 return((*p->fast_print)(obj,table));
419 else
420 return(err("cannot fast-print",obj));}}
421
422static LISP fast_read(LISP table)
423{FILE *f;
424 LISP tmp,l;
425 struct user_type_hooks *p;
426 int c;
427 long len;
428 f = get_c_file(car(table),(FILE *) NULL);
429 c = getc(f);
430 if (c == EOF) return(table);
431 switch(c)
432 {case FO_fetch:
433 len = get_long(f);
434 FLONM(bashnum) = len;
435 return(href(car(cdr(table)),bashnum));
436 case FO_store:
437 len = get_long(f);
438 tmp = fast_read(table);
439 hset(car(cdr(table)),flocons(len),tmp);
440 return(tmp);
441 case tc_nil:
442 return(NIL);
443 case tc_cons:
444 tmp = fast_read(table);
445 return(cons(tmp,fast_read(table)));
446 case FO_list:
447 case FO_listd:
448 len = get_long(f);
449 FLONM(bashnum) = len;
450 l = make_list(bashnum,NIL);
451 tmp = l;
452 while(len > 1)
453 {CAR(tmp) = fast_read(table);
454 tmp = CDR(tmp);
455 --len;}
456 CAR(tmp) = fast_read(table);
457 if (c == FO_listd)
458 CDR(tmp) = fast_read(table);
459 return(l);
460 case tc_flonum:
461 tmp = newcell(tc_flonum);
462 fread(&tmp->storage_as.flonum.data,
463 sizeof(tmp->storage_as.flonum.data),
464 1,
465 f);
466 return(tmp);
467 case tc_symbol:
468 len = get_long(f);
469 if (len >= TKBUFFERN)
470 err("symbol name too long",NIL);
471 fread(tkbuffer,len,1,f);
472 tkbuffer[len] = 0;
473 return(rintern(tkbuffer));
474 default:
475 p = get_user_type_hooks(c);
476 if (p->fast_read)
477 return(*p->fast_read)(c,table);
478 else
479 return(err("unknown fast-read opcode",flocons(c)));}}
480
481static LISP array_fast_print(LISP ptr,LISP table)
482{int j,len;
483 FILE *f;
484 f = get_c_file(car(table),(FILE *) NULL);
485 switch (ptr->type)
486 {case tc_string:
487 putc(tc_string,f);
488 len = ptr->storage_as.string.dim;
489 put_long(len,f);
490 fwrite(ptr->storage_as.string.data,len,1,f);
491 return(NIL);
492 case tc_double_array:
493 putc(tc_double_array,f);
494 len = ptr->storage_as.double_array.dim * sizeof(double);
495 put_long(len,f);
496 fwrite(ptr->storage_as.double_array.data,len,1,f);
497 return(NIL);
498 case tc_long_array:
499 putc(tc_long_array,f);
500 len = ptr->storage_as.long_array.dim * sizeof(long);
501 put_long(len,f);
502 fwrite(ptr->storage_as.long_array.data,len,1,f);
503 return(NIL);
504 case tc_lisp_array:
505 putc(tc_lisp_array,f);
506 len = ptr->storage_as.lisp_array.dim;
507 put_long(len,f);
508 for(j=0; j < len; ++j)
509 fast_print(ptr->storage_as.lisp_array.data[j],table);
510 return(NIL);
511 default:
512 return(errswitch());}}
513
514static LISP array_fast_read(int code,LISP table)
515{long j,len,iflag;
516 FILE *f;
517 LISP ptr;
518 f = get_c_file(car(table),(FILE *) NULL);
519 switch (code)
520 {case tc_string:
521 len = get_long(f);
522 ptr = strcons(len,NULL);
523 fread(ptr->storage_as.string.data,len,1,f);
524 ptr->storage_as.string.data[len] = 0;
525 return(ptr);
526 case tc_double_array:
527 len = get_long(f);
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);
534 no_interrupt(iflag);
535 return(ptr);
536 case tc_long_array:
537 len = get_long(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);
544 no_interrupt(iflag);
545 return(ptr);
546 case tc_lisp_array:
547 len = get_long(f);
548 FLONM(bashnum) = len;
549 ptr = cons_array(bashnum,NIL);
550 for(j=0; j < len; ++j)
551 ptr->storage_as.lisp_array.data[j] = fast_read(table);
552 return(ptr);
553 default:
554 return(errswitch());}}
555
556static void init_storage_xtr1(long type)
557{long j;
558 struct user_type_hooks *p;
559 set_gc_hooks(type,
560 FALSE,
561 array_gc_relocate,
562 array_gc_mark,
563 array_gc_scan,
564 array_gc_free,
565 NULL,
566 &j);
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;}
573
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);}
581
582void init_subrs_xtr(void)
583{
584
585 init_storage_xtr();
586
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,
598 "(sxhash OBJ N)\n\
599 Return hashing value for OBJ, in range n.");
600 init_subr_2("href",href,
601 "(href TABLE KEY)\n\
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\
608 ");
609 init_subr_2("fast-print",fast_print,
610 "(fast-print P TABLE)\n\
611 ");
612 init_subr_2("make-list",make_list,
613 "(make-list SIZE VALUE)\n\
614 Return list of SIZE with each member VALUE.");
615}
Definition: siod_defs.h:31