Edinburgh Speech Tools  2.4-release
 All Classes Functions Variables Typedefs Enumerations Enumerator Friends Pages
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 
6 Array-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 
21 static LISP bashnum = NIL;
22 
23 static 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 
30 static 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 
37 static 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 
44 static 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 
59 static 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 
94 static 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 
115 static void err1_aset1(LISP i)
116 {err("index to aset too large",i);}
117 
118 static void err2_aset1(LISP v)
119 {err("bad value to store in array",v);}
120 
121 static 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 
149 static 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 
187 static 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 
227 static LISP sxhash(LISP obj,LISP n)
228 {return(flocons(c_sxhash(obj,FLONUMP(n) ? (long) FLONM(n) : 10000)));}
229 
230 static 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 
268 static 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 
306 static 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 
316 static LISP href(LISP table,LISP key)
317 {return(cdr(assoc(key,
318  table->storage_as.lisp_array.data[href_index(table,key)])));}
319 
320 static 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 
331 static 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 
340 static void put_long(long i,FILE *f)
341 {fwrite(&i,sizeof(long),1,f);}
342 
343 static long get_long(FILE *f)
344 {long i;
345  fread(&i,sizeof(long),1,f);
346  return(i);}
347 
348 static 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 
368 static 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 
422 static 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 
481 static 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 
514 static 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 
556 static 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 
574 static 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 
582 void 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 }