Edinburgh Speech Tools 2.4-release
 
Loading...
Searching...
No Matches
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
15static LISP sym_lambda = NIL;
16static LISP sym_progn = NIL;
17
18LISP 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
25static LISP leval_setq(LISP args,LISP env)
26{return(setvar(car(args),leval(car(cdr(args)),env),env));}
27
28static 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
44static 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
58static 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
66static 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
76static 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
83static 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
99static 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
111static 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
123static 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
140static 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
149static 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
157static LISP leval_quote(LISP args,LISP env)
158{(void)env;
159 return(car(args));}
160
161static LISP leval_tenv(LISP args,LISP env)
162{(void)args;
163 return(env);}
164
165static 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
172static 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;
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
219static LISP symbolp(LISP x)
220{if SYMBOLP(x) return(truth); else return(NIL);}
221
222LISP 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
229LISP 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
238static 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
271static LISP oblistfn(void)
272{return(copy_list(oblistvar));}
273
274LISP 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
288void 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}