Edinburgh Speech Tools  2.4-release
 All Classes Functions Variables Typedefs Enumerations Enumerator Friends Pages
slib_core.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  * Reorganization of files (Mar 1999) by Alan W Black <awb@cstr.ed.ac.uk>
7 
8  * System functions
9 
10 */
11 #include <cstdio>
12 #include "siod.h"
13 #include "siodp.h"
14 
15 static LISP sym_lambda = NIL;
16 static LISP sym_progn = NIL;
17 
18 LISP setvar(LISP var,LISP val,LISP env)
19 {LISP tmp;
20  if NSYMBOLP(var) err("wrong type of argument(non-symbol) to setvar",var);
21  tmp = envlookup(var,env);
22  if NULLP(tmp) return(VCELL(var) = val);
23  return(CAR(tmp)=val);}
24 
25 static LISP leval_setq(LISP args,LISP env)
26 {return(setvar(car(args),leval(car(cdr(args)),env),env));}
27 
28 static LISP syntax_define(LISP args)
29 {
30  if SYMBOLP(car(args))
31  return(args);
32  else
33  {
34  need_n_cells(4);
35  return(syntax_define(
36  cons(car(car(args)),
37  cons(cons(sym_lambda,
38  cons(cdr(car(args)),
39  cdr(args))),
40  NIL))));
41  }
42 }
43 
44 static LISP leval_define(LISP args,LISP env)
45 {LISP tmp,var,val;
46  tmp = syntax_define(args);
47  var = car(tmp);
48  if NSYMBOLP(var) err("wrong type of argument(non-symbol) to define",var);
49  val = leval(car(cdr(tmp)),env);
50  tmp = envlookup(var,env);
51  if NNULLP(tmp) return(CAR(tmp) = val);
52  if NULLP(env) return(VCELL(var) = val);
53  tmp = car(env);
54  setcar(tmp,cons(var,car(tmp)));
55  setcdr(tmp,cons(val,cdr(tmp)));
56  return(val);}
57 
58 static LISP leval_if(LISP *pform,LISP *penv)
59 {LISP args,env;
60  args = cdr(*pform);
61  env = *penv;
62  if NNULLP(leval(car(args),env))
63  *pform = car(cdr(args)); else *pform = car(cdr(cdr(args)));
64  return(truth);}
65 
66 static LISP arglchk(LISP x)
67 {
68 #if (!ENVLOOKUP_TRICK)
69  LISP l;
70  if SYMBOLP(x) return(x);
71  for(l=x;CONSP(l);l=CDR(l));
72  if NNULLP(l) err("improper formal argument list",x);
73 #endif
74  return(x);}
75 
76 static LISP leval_lambda(LISP args,LISP env)
77 {LISP body;
78  if NULLP(cdr(cdr(args)))
79  body = car(cdr(args));
80  else body = cons(sym_progn,cdr(args));
81  return(closure(env,cons(arglchk(car(args)),body)));}
82 
83 static LISP leval_progn(LISP *pform,LISP *penv)
84 {LISP env,l,next;
85  env = *penv;
86  gc_protect(&env);
87  l = cdr(*pform);
88  next = cdr(l);
89  while (NNULLP(next))
90  {
91  leval(car(l),env);
92  l=next;
93  next=cdr(next);
94  }
95  gc_unprotect(&env);
96  *pform = car(l);
97  return(truth);}
98 
99 static LISP leval_or(LISP *pform,LISP *penv)
100 {LISP env,l,next,val;
101  env = *penv;
102  l = cdr(*pform);
103  next = cdr(l);
104  while(NNULLP(next))
105  {val = leval(car(l),env);
106  if NNULLP(val) {*pform = val; return(NIL);}
107  l=next;next=cdr(next);}
108  *pform = car(l);
109  return(truth);}
110 
111 static LISP leval_and(LISP *pform,LISP *penv)
112 {LISP env,l,next;
113  env = *penv;
114  l = cdr(*pform);
115  if NULLP(l) {*pform = truth; return(NIL);}
116  next = cdr(l);
117  while(NNULLP(next))
118  {if NULLP(leval(car(l),env)) {*pform = NIL; return(NIL);}
119  l=next;next=cdr(next);}
120  *pform = car(l);
121  return(truth);}
122 
123 static LISP leval_catch(LISP args,LISP env)
124 {struct catch_frame frame;
125  int k;
126  LISP l;
127  volatile LISP val = NIL;
128  frame.tag = leval(car(args),env);
129  frame.next = catch_framep;
130  k = setjmp(frame.cframe);
131  catch_framep = &frame;
132  if (k == 2)
133  {catch_framep = frame.next;
134  return(frame.retval);}
135  for(l=cdr(args); NNULLP(l); l = cdr(l))
136  val = leval(car(l),env);
137  catch_framep = frame.next;
138  return(val);}
139 
140 static LISP lthrow(LISP tag,LISP value)
141 {struct catch_frame *l;
142  for(l=catch_framep; l; l = (*l).next)
143  if EQ((*l).tag,tag)
144  {(*l).retval = value;
145  longjmp((*l).cframe,2);}
146  err("no *catch found with this tag",tag);
147  return(NIL);}
148 
149 static LISP leval_let(LISP *pform,LISP *penv)
150 {LISP env,l;
151  l = cdr(*pform);
152  env = *penv;
153  *penv = extend_env(leval_args(car(cdr(l)),env),car(l),env);
154  *pform = car(cdr(cdr(l)));
155  return(truth);}
156 
157 static LISP leval_quote(LISP args,LISP env)
158 {(void)env;
159  return(car(args));}
160 
161 static LISP leval_tenv(LISP args,LISP env)
162 {(void)args;
163  return(env);}
164 
165 static LISP leval_while(LISP args,LISP env)
166 {LISP l;
167  while NNULLP(leval(car(args),env))
168  for(l=cdr(args);NNULLP(l);l=cdr(l))
169  leval(car(l),env);
170  return(NIL);}
171 
172 static LISP siod_typeof(LISP exp)
173 {
174  switch TYPE(exp)
175  {
176  case tc_nil:
177  return NIL;
178  case tc_cons:
179  return rintern("cons");
180  case tc_flonum:
181  return rintern("flonum");
182  case tc_string:
183  return rintern("string");
184  case tc_subr_0:
185  case tc_subr_1:
186  case tc_subr_2:
187  case tc_subr_3:
188  case tc_subr_4:
189  case tc_lsubr:
190  case tc_fsubr:
191  case tc_msubr:
192  return rintern("subr");
193  case tc_c_file:
194  return rintern("c_file");
195  case tc_closure:
196  return rintern("closure");
197  default:
198  struct user_type_hooks *p;
199  EST_String tkb;
200  char ttkbuffer[1024];
201  p = get_user_type_hooks(TYPE(exp));
202  if (p->print_string)
203  {
204  (*p->print_string)(exp, ttkbuffer);
205  tkb = ttkbuffer;
206  return rintern(tkb.after("#<").before(" "));
207  }
208  else
209  {
210  if (p->name)
211  return rintern(p->name);
212  else
213  return rintern("unknown");
214  }
215 
216  }
217 }
218 
219 static LISP symbolp(LISP x)
220 {if SYMBOLP(x) return(truth); else return(NIL);}
221 
222 LISP symbol_boundp(LISP x,LISP env)
223 {LISP tmp;
224  if NSYMBOLP(x) err("not a symbol",x);
225  tmp = envlookup(x,env);
226  if NNULLP(tmp) return(truth);
227  if EQ(VCELL(x),unbound_marker) return(NIL); else return(truth);}
228 
229 LISP symbol_value(LISP x,LISP env)
230 {LISP tmp;
231  if NSYMBOLP(x) err("not a symbol",x);
232  tmp = envlookup(x,env);
233  if NNULLP(tmp) return(CAR(tmp));
234  tmp = VCELL(x);
235  if EQ(tmp,unbound_marker) err("unbound variable",x);
236  return(tmp);}
237 
238 static LISP l_unwind_protect(LISP args, LISP env)
239 {
240  // Do normal, if an error occurs do onerror
241  jmp_buf * volatile local_errjmp = est_errjmp;
242  est_errjmp = walloc(jmp_buf,1);
243  volatile long local_errjmp_ok = errjmp_ok;
244  errjmp_ok=1; /* allow errjmps in here */
245  volatile LISP r=NIL;
246  volatile LISP previous_open_files = open_files;
247 
248  if (setjmp(*est_errjmp) != 0)
249  {
250  wfree(est_errjmp);
251  est_errjmp = local_errjmp;
252  errjmp_ok = local_errjmp_ok;
253  siod_reset_prompt();
254  // Close any that were opened below here
255  close_open_files_upto(previous_open_files);
256  if (siod_ctrl_c == TRUE)
257  err("forwarded through unwind-protect",NIL);
258  r = leval(car(cdr(args)),env);
259  }
260  else
261  {
262  r = leval(car(args),env);
263  wfree(est_errjmp);
264  est_errjmp = local_errjmp;
265  errjmp_ok = local_errjmp_ok;
266  }
267 
268  return r;
269 }
270 
271 static LISP oblistfn(void)
272 {return(copy_list(oblistvar));}
273 
274 LISP let_macro(LISP form)
275 {LISP p,fl,al,tmp;
276  fl = NIL;
277  al = NIL;
278  for(p=car(cdr(form));NNULLP(p);p=cdr(p))
279  {tmp = car(p);
280  if SYMBOLP(tmp) {fl = cons(tmp,fl); al = cons(NIL,al);}
281  else {fl = cons(car(tmp),fl); al = cons(car(cdr(tmp)),al);}}
282  p = cdr(cdr(form));
283  if NULLP(cdr(p)) p = car(p); else p = cons(sym_progn,p);
284  setcdr(form,cons(reverse(fl),cons(reverse(al),cons(p,NIL))));
285  setcar(form,cintern("let-internal"));
286  return(form);}
287 
288 void init_subrs_core(void)
289 {
290  gc_protect_sym(&sym_lambda,"lambda");
291  gc_protect_sym(&sym_progn,"begin");
292 
293  init_fsubr("quote",leval_quote,
294  "(quote DATA)\n\
295  Return data (unevaluated).");
296  init_fsubr("set!",leval_setq,
297  "(set! SYMBOL VAL)\n\
298  Set SYMBOL to have value VAL, returns VAL.");
299  init_fsubr("define",leval_define,
300  "(define (FUNCNAME ARG1 ARG2 ...) . BODY)\n\
301  Define a new function call FUNCNAME with arguments ARG1, ARG2 ... and\n\
302  BODY.");
303  init_fsubr("lambda",leval_lambda,
304  "(lambda (ARG1 ARG2 ...) . BODY)\n\
305  Create closure (anonymous function) with arguments ARG1, ARG2 ... and \n\
306  BODY.");
307  init_msubr("if",leval_if,
308  "(if COND TRUEPART FALSEPART)\n\
309  If COND evaluates to non-nil evaluate TRUEPART and return result,\n\
310  otherwise evaluate and return FALSEPART. If COND is nil and FALSEPART\n\
311  is nil, nil is returned.");
312  init_fsubr("while",leval_while,
313  "(while COND . BODY)\n\
314  While COND evaluates to non-nil evaluate BODY.");
315  init_msubr("begin",leval_progn,
316  "(begin . BODY)\n\
317  Evaluate s-expressions in BODY returning value of from last expression.");
318  init_fsubr("*catch",leval_catch,
319  "(*catch TAG . BODY)\n\
320  Evaluate BODY, if a *throw occurs with TAG then return value specified\n\
321  by *throw.");
322  init_subr_2("*throw",lthrow,
323  "(*throw TAG VALUE)\n\
324  Jump to *catch with TAG, causing *catch to return VALUE.");
325  init_msubr("let-internal",leval_let,
326  "(let-internal STUFF)\n\
327  Internal function used to implement let.");
328  init_msubr("or",leval_or,
329  "(or DISJ1 DISJ2 ...)\n\
330  Evaluate each disjunction DISJn in turn until one evaluates to non-nil.\n\
331  Otherwise return nil.");
332  init_msubr("and",leval_and,
333  "(and CONJ1 CONJ2 ... CONJN)\n\
334  Evaluate each conjunction CONJn in turn until one evaluates to nil.\n\
335  Otherwise return value of CONJN.");
336  init_subr_1("typeof",siod_typeof,
337  "(typeof OBJ)\n\
338  Returns typeof of given object.");
339  init_subr_1("symbol?",symbolp,
340  "(symbol? DATA)\n\
341  Returns t if DATA is a symbol, nil otherwise.");
342  init_subr_2("symbol-bound?",symbol_boundp,
343  "(symbol-bound? VARNAME)\n\
344  Return t is VARNAME has a value, nil otherwise.");
345  init_subr_2("symbol-value",symbol_value,
346  "(symbol-value SYMBOLNAME)\n\
347  Returns the value of SYMBOLNAME, an error is given SYMBOLNAME is not a\n\
348  bound symbol.");
349  init_fsubr("the-environment",leval_tenv,
350  "(the-environment)\n\
351  Returns the current (SIOD) environment.");
352  init_fsubr("unwind-protect",l_unwind_protect,
353  "(unwind-protect NORMALFORM ERRORFORM)\n\
354  If an error is found while evaluating NORMALFORM catch it and evaluate\n\
355  ERRORFORM and continue. If an error occurs while evaluating NORMALFORM\n\
356  all file open evaluating NORMALFORM up to the error while be automatically\n\
357  closed. Note interrupts (ctrl-c) is not caught by this function.");
358  init_subr_0("oblist",oblistfn,
359  "(oblist)\n\
360  Return oblist.");
361  init_subr_1("let-internal-macro",let_macro,
362  "(let ((VAR1 VAL1) (VAR2 VAL2) ...) . BODY)\n\
363  Evaluate BODY in an environment where VAR1 is set to VAL1, VAR2 is set\n\
364  to VAL2 etc.");
365  init_subr_3("set-symbol-value!",setvar,
366  "(set-symbol-value! SYMBOLNAME VALUE)\n\
367  Set SYMBOLNAME's value to VALUE, this is much faster than set! but use\n\
368  with caution.");
369 
370 }