Edinburgh Speech Tools  2.1-release
 All Classes Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
siod.cc
1 /* Scheme In One Defun, but in C this time.
2 
3  * COPYRIGHT (c) 1988-1994 BY *
4  * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
5  * See the source file SLIB.C for more information. *
6 
7 */
8 
9 /*
10 
11 gjc@paradigm.com or gjc@mitech.com or gjc@world.std.com
12 
13 Paradigm Associates Inc Phone: 617-492-6079
14 29 Putnam Ave, Suite 6
15 Cambridge, MA 02138
16 
17  */
18 
19 /***************************************************************/
20 /* This has been modified to act as an interface to siod as an */
21 /* embedded Lisp module. */
22 /* Also a (large) number of other functions have been added */
23 /* */
24 /* Alan W Black (awb@cstr.ed.ac.uk) 8th April 1996 */
25 /***************************************************************/
26 #include <cstdio>
27 #include "EST_unix.h"
28 #include <cstdlib>
29 #include <cstring>
30 #include "EST_String.h"
31 #include "EST_THash.h"
32 #include "EST_StringTrie.h"
33 #include "EST_cutils.h"
34 #include "EST_strcasecmp.h"
35 #include "siod.h"
36 #include "siodp.h"
37 #include "siodeditline.h"
38 
39 extern "C" const char * repl_prompt;
40 
43 
44 #if defined(INSTANTIATE_TEMPLATES)
45 #include "../base_class/EST_THash.cc"
46 
47  Instantiate_TStringHash_T(EST_Regex *, hash_string_regex)
48 #endif
49 
50 static EST_TStringHash<EST_Regex *> regexes(100);
51 
52 int siod_init(int heap_size)
53 {
54  /* Initialize siod */
55  int actual_heap_size;
56 
57  if (heap_size == -1) // unspecified by user
58  {
59  char *char_heap_size=getenv("SIODHEAPSIZE");
60  if ((char_heap_size == 0) ||
61  (atoi(char_heap_size) < 1000))
62  actual_heap_size=ACTUAL_DEFAULT_HEAP_SIZE;
63  else
64  actual_heap_size=atoi(char_heap_size);
65  }
66  else
67  actual_heap_size = heap_size;
68 
69  init_storage(actual_heap_size);
70  init_subrs();
71 
72  return 0;
73 }
74 
75 void siod_tidy_up()
76 {
77  close_open_files();
78 }
79 
80 LISP siod_get_lval(const char *name,const char *message)
81 {
82  // returns value of variable name. If not set gives an error
83  LISP iii, rval=NIL;
84 
85  iii = rintern(name);
86 
87  // value or NIL if unset
88  if (symbol_boundp(iii,current_env) == NIL)
89  {
90  if (message != NULL)
91  err(message,iii);
92  }
93  else
94  rval = symbol_value(iii, current_env);
95 
96  return rval;
97 }
98 
99 LISP siod_set_lval(const char *name,LISP val)
100 {
101  // set variable name to val
102  LISP iii, rval;
103 
104  iii = rintern(name);
105 
106  rval = setvar(iii,val,current_env);
107 
108  return rval;
109 }
110 
111 LISP siod_assoc_str(const char *key,LISP alist)
112 {
113  // assoc without going through LISP atoms
114  // made get_c_string inline for optimization
115  LISP l,lc,lcc;
116 
117  for (l=alist; CONSP(l); l=CDR(l))
118  {
119  lc = CAR(l);
120  if (CONSP(lc))
121  {
122  lcc = CAR(lc);
123  if (NULLP(lcc)) continue;
124  else if TYPEP(lcc,tc_symbol)
125  {
126  if (strcmp(key,PNAME(lcc))==0)
127  return lc;
128  }
129  else if TYPEP(lcc,tc_flonum)
130  {
131  if (FLONMPNAME(lcc) == NULL)
132  {
133  char b[TKBUFFERN];
134  sprintf(b,"%g",FLONM(lcc));
135  FLONMPNAME(lcc) = (char *)must_malloc(strlen(b)+1);
136  sprintf(FLONMPNAME(lcc),"%s",b);
137  }
138  if (strcmp(key,FLONMPNAME(lcc))==0)
139  return lc;
140  }
141  else if TYPEP(lcc,tc_string)
142  {
143  if (strcmp(key,lcc->storage_as.string.data)==0)
144  return lc;
145  }
146  else
147  continue;
148  }
149  }
150  return NIL;
151 }
152 
153 LISP siod_member_str(const char *key,LISP list)
154 {
155  // member without going through LISP atoms
156  LISP l;
157 
158  for (l=list; CONSP(l); l=CDR(l))
159  if (strcmp(key,get_c_string(CAR(l))) == 0)
160  return l;
161 
162  return NIL;
163 }
164 
165 LISP siod_regex_member_str(const EST_String &key,LISP list)
166 {
167  // Check the regexs in LIST against key
168  LISP l;
169 
170  for (l=list; CONSP(l); l=CDR(l))
171  if (key.matches(make_regex(get_c_string(CAR(l)))))
172  return l;
173 
174  return NIL;
175 }
176 
177 LISP siod_member_int(const int key,LISP list)
178 {
179  // member without going through LISP atoms
180  LISP l;
181 
182  for (l=list; CONSP(l); l=CDR(l))
183  if (key == get_c_int(CAR(l)))
184  return l;
185  return NIL;
186 }
187 
188 int siod_llength(LISP list)
189 {
190  // length of string;
191  int len;
192  LISP l;
193 
194  for (len=0,l=list; CONSP(l); l=CDR(l),len++);
195 
196  return len;
197 
198 }
199 
200 LISP siod_nth(int n,LISP list)
201 {
202  // nth member -- first member is 0;
203  int i;
204  LISP l;
205 
206  for (i=0,l=list; CONSP(l); l=CDR(l),i++)
207  if (i == n)
208  return car(l);
209 
210  return NIL;
211 
212 }
213 
214 int siod_atomic_list(LISP list)
215 {
216  // TRUE is list only contains atoms
217  LISP p;
218 
219  for (p=list; p != NIL; p=cdr(p))
220  if (CONSP(car(p)))
221  return FALSE;
222 
223  return TRUE;
224 }
225 
226 int siod_eof(LISP item)
227 {
228  // TRUE if item is what siod denotes as eof
229  if (CONSP(item) &&
230  (cdr(item) == NIL) &&
231  (SYMBOLP(car(item))) &&
232  (strcmp("eof",get_c_string(car(item))) == 0))
233  return TRUE;
234  else
235  return FALSE;
236 }
237 
238 LISP quote(LISP l)
239 {
240  // Add quote round a Lisp expression
241  return cons(rintern("quote"),cons(l,NIL));
242 }
243 
244 LISP siod_last(LISP list)
245 {
246  LISP l;
247 
248  if ((list == NIL) || (NCONSP(list)))
249  return NIL;
250  else
251  {
252  for (l=list; cdr(l) != NIL; l=cdr(l));
253  return l;
254  }
255 }
256 
257 int get_param_int(const char *name, LISP params, int defval)
258 {
259  // Look up name in params and return value if present or
260  // defval if not present
261  LISP pair;
262 
263  pair = siod_assoc_str(name,params);
264 
265  if (pair == NIL)
266  return defval;
267  else if FLONUMP(car(cdr(pair)))
268  return (int)FLONM(car(cdr(pair)));
269  else
270  {
271  cerr << "param " << name << " not of type int" << endl;
272  err("",NIL);
273  return -1;
274  }
275 
276 }
277 
278 float get_param_float(const char *name, LISP params, float defval)
279 {
280  // Look up name in params and return value if present or
281  // defval if not present
282  LISP pair;
283 
284  pair = siod_assoc_str(name,params);
285 
286  if (pair == NIL)
287  return defval;
288  else if (FLONUMP(car(cdr(pair))))
289  return (float)FLONM(car(cdr(pair)));
290  else
291  {
292  cerr << "param " << name << " not of type float" << endl;
293  err("",NIL);
294  return -1;
295  }
296 
297 }
298 
299 const char *get_param_str(const char *name, LISP params, const char *defval)
300 {
301  // Look up name in params and return value if present or
302  // defval if not present
303  LISP pair;
304 
305  pair = siod_assoc_str(name,params);
306 
307  if (pair == NIL)
308  return defval;
309  else
310  return get_c_string(car(cdr(pair)));
311 }
312 
313 LISP get_param_lisp(const char *name, LISP params, LISP defval)
314 {
315  // Look up name in params and return value if present or
316  // defval if not present
317  LISP pair;
318 
319  pair = siod_assoc_str(name,params);
320 
321  if (pair == NIL)
322  return defval;
323  else
324  return car(cdr(pair));
325 }
326 
327 LISP make_param_str(const char *name,const char *val)
328 {
329  return cons(rintern(name),cons(rintern(val),NIL));
330 }
331 
332 LISP make_param_int(const char *name, int val)
333 {
334  return cons(rintern(name),cons(flocons(val),NIL));
335 }
336 
337 LISP make_param_float(const char *name, float val)
338 {
339  return cons(rintern(name),cons(flocons(val),NIL));
340 }
341 
342 LISP make_param_lisp(const char *name,LISP val)
343 {
344  return cons(rintern(name),cons(val,NIL));
345 }
346 
347 EST_Regex &make_regex(const char *r)
348 {
349  // Return pointer to existing regex if its already been created
350  // otherwise create a new one for this r.
351  EST_Regex *rx;
352  EST_String sr = r;
353  int found;
354 
355  rx = regexes.val(sr,found);
356  if (!found)
357  {
358  rx = new EST_Regex(r);
359  regexes.add_item(sr,rx);
360  }
361 
362  return *rx;
363 }
364 
365 LISP apply_hooks(LISP hooks,LISP arg)
366 {
367  // Apply each function in hooks to arg returning value from
368  // final application (or arg itself)
369  LISP h,r;
370 
371  r = arg;
372 
373  if (hooks && (!CONSP(hooks))) // singleton
374  r = leval(cons(hooks,cons(quote(arg),NIL)),NIL);
375  else
376  for (h=hooks; h != NIL; h=cdr(h))
377  r = leval(cons(car(h),cons(quote(arg),NIL)),NIL);
378  return r;
379 }
380 
381 LISP apply_hooks_right(LISP hooks,LISP args)
382 {
383  // The above version neither quotes its arguments properly of deals
384  // with lists of arguments so here's a better one
385  // Apply each function in hooks to arg returning value from
386  // final application (or arg itself)
387  LISP h,r;
388 
389  if (hooks == NIL)
390  r = args;
391  else if (!CONSP(hooks)) // singleton
392  r = apply(hooks,args);
393  else
394  for (r=args,h=hooks; h != NIL; h=cdr(h))
395  r = apply(car(h),r);
396  return r;
397 }
398 
399 LISP apply(LISP func,LISP args)
400 {
401  LISP qa,a;
402 
403  for (qa=NIL,a=args; a; a=cdr(a))
404  qa = cons(quote(car(a)),qa);
405  return leval(cons(func,reverse(qa)),NIL);
406 }
407 
408 LISP stringexplode(const char *str)
409 {
410  // Explode character string into list of symbols one for each char
411  LISP l=NIL;
412  unsigned int i;
413  char id[2];
414  id[1] = '\0';
415 
416  for (i=0; i < strlen(str); i++)
417  {
418  id[0] = str[i];
419  l = cons(rintern(id),l);
420  }
421 
422  return reverse(l);
423 }
424 
425 /* Editline completion functions */
426 
427 char **siod_variable_generator(char *text,int length)
428 {
429  LISP l,lmatches;
430  const char *name;
431  char **matches = NULL;
432  int i;
433 
434  /* Return the next name which partially matches from the command list. */
435  for(lmatches=NIL,l=oblistvar;CONSP(l);l=CDR(l))
436  {
437  if (VCELL(car(l)) == NIL) continue;
438  switch(TYPE(VCELL(CAR(l))))
439  {
440  case tc_subr_0:
441  case tc_subr_1:
442  case tc_subr_2:
443  case tc_subr_3:
444  case tc_subr_4:
445  case tc_lsubr:
446  case tc_fsubr:
447  case tc_msubr:
448  case tc_closure:
449  continue;
450  default:
451  /* only return names of nonfunctions (sometimes too restrictive) */
452  name = PNAME(CAR(l));
453  if (strncmp(name, text, length) == 0)
454  lmatches = cons(CAR(l),lmatches);
455  }
456  }
457 
458  /* Need to return the matches in a char** */
459  matches = walloc(char *,siod_llength(lmatches)+1);
460  for (l=lmatches,i=0; l; l=cdr(l),i++)
461  matches[i] = wstrdup(PNAME(car(l)));
462  matches[i] = '\0';
463 
464  return matches;
465 }
466 
467 char **siod_command_generator (char *text,int length)
468 {
469  LISP l,lmatches;
470  const char *name;
471  char **matches = NULL;
472  int i;
473 
474  /* Return the next name which partially matches from the command list. */
475  for(lmatches=NIL,l=oblistvar;CONSP(l);l=CDR(l))
476  {
477  if (VCELL(car(l)) == NIL) continue;
478  switch(TYPE(VCELL(CAR(l))))
479  {
480  case tc_subr_0:
481  case tc_subr_1:
482  case tc_subr_2:
483  case tc_subr_3:
484  case tc_subr_4:
485  case tc_lsubr:
486  case tc_fsubr:
487  case tc_msubr:
488  case tc_closure:
489  /* only return names of functions */
490  name = PNAME(CAR(l));
491  if (strncmp(name, text, length) == 0)
492  lmatches = cons(CAR(l),lmatches);
493  default: continue;
494  }
495  }
496 
497  /* Need to return the matches in a char** */
498  matches = walloc(char *,siod_llength(lmatches)+1);
499  for (l=lmatches,i=0; l; l=cdr(l),i++)
500  matches[i] = wstrdup(PNAME(car(l)));
501  matches[i] = '\0';
502 
503  return matches;
504 }
505 
506 void siod_list_to_strlist(LISP l, EST_StrList &a)
507 {
508  // copy l into a
509  LISP b;
510 
511  a.clear();
512 
513  for (b=l; b != NIL; b=cdr(b))
514  a.append(get_c_string(car(b)));
515 
516 }
517 
518 LISP siod_strlist_to_list(EST_StrList &a)
519 {
520  // copy a into l
521  LISP b=NIL;;
522  EST_Litem *p;
523 
524  for (p=a.head(); p != 0; p=p->next())
525  b = cons(rintern(a(p)),b);
526 
527  return reverse(b);
528 }
529 
A Regular expression class to go with the CSTR EST_String class.
Definition: EST_Regex.h:56
A specialised hash table for when the key is an EST_String.
Definition: EST_THash.h:284
void append(const T &item)
add item onto end of list
Definition: EST_TList.h:198
An open hash table. The number of buckets should be set to allow enough space that there are relative...
Definition: EST_THash.h:71
int matches(const char *e, int pos=0) const
Exactly match this string?
Definition: EST_String.cc:652
void clear(void)
remove all items in list
Definition: EST_TList.h:246