15 static LISP sym_lambda = NIL;
16 static LISP sym_progn = NIL;
18 LISP setvar(LISP var,LISP val,LISP env)
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);}
25 static LISP leval_setq(LISP args,LISP env)
26 {
return(setvar(car(args),leval(car(cdr(args)),env),env));}
28 static LISP syntax_define(LISP args)
44 static LISP leval_define(LISP args,LISP env)
46 tmp = syntax_define(args);
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);
54 setcar(tmp,cons(var,car(tmp)));
55 setcdr(tmp,cons(val,cdr(tmp)));
58 static LISP leval_if(LISP *pform,LISP *penv)
62 if NNULLP(leval(car(args),env))
63 *pform = car(cdr(args));
else *pform = car(cdr(cdr(args)));
66 static LISP arglchk(LISP x)
68 #if (!ENVLOOKUP_TRICK)
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);
76 static LISP leval_lambda(LISP args,LISP env)
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)));}
83 static LISP leval_progn(LISP *pform,LISP *penv)
99 static LISP leval_or(LISP *pform,LISP *penv)
100 {LISP env,l,next,val;
105 {val = leval(car(l),env);
106 if NNULLP(val) {*pform = val;
return(NIL);}
107 l=next;next=cdr(next);}
111 static LISP leval_and(LISP *pform,LISP *penv)
115 if NULLP(l) {*pform = truth;
return(NIL);}
118 {
if NULLP(leval(car(l),env)) {*pform = NIL;
return(NIL);}
119 l=next;next=cdr(next);}
123 static LISP leval_catch(LISP args,LISP env)
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;
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;
140 static LISP lthrow(LISP tag,LISP value)
142 for(l=catch_framep; l; l = (*l).next)
144 {(*l).retval = value;
145 longjmp((*l).cframe,2);}
146 err(
"no *catch found with this tag",tag);
149 static LISP leval_let(LISP *pform,LISP *penv)
153 *penv = extend_env(leval_args(car(cdr(l)),env),car(l),env);
154 *pform = car(cdr(cdr(l)));
157 static LISP leval_quote(LISP args,LISP env)
161 static LISP leval_tenv(LISP args,LISP env)
165 static LISP leval_while(LISP args,LISP env)
167 while NNULLP(leval(car(args),env))
168 for(l=cdr(args);NNULLP(l);l=cdr(l))
172 static LISP siod_typeof(LISP exp)
179 return rintern(
"cons");
181 return rintern(
"flonum");
183 return rintern(
"string");
192 return rintern(
"subr");
194 return rintern(
"c_file");
196 return rintern(
"closure");
200 char ttkbuffer[1024];
201 p = get_user_type_hooks(TYPE(exp));
204 (*p->print_string)(exp, ttkbuffer);
211 return rintern(p->name);
213 return rintern(
"unknown");
219 static LISP symbolp(LISP x)
220 {
if SYMBOLP(x) return(truth); else return(NIL);}
222 LISP symbol_boundp(LISP x,LISP env)
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);}
229 LISP symbol_value(LISP x,LISP env)
231 if NSYMBOLP(x) err("not a symbol",x);
232 tmp = envlookup(x,env);
233 if NNULLP(tmp) return(CAR(tmp));
235 if EQ(tmp,unbound_marker) err("unbound variable",x);
238 static LISP l_unwind_protect(LISP args, LISP env)
241 jmp_buf *
volatile local_errjmp = est_errjmp;
242 est_errjmp = walloc(jmp_buf,1);
243 volatile long local_errjmp_ok = errjmp_ok;
246 volatile LISP previous_open_files = open_files;
248 if (setjmp(*est_errjmp) != 0)
251 est_errjmp = local_errjmp;
252 errjmp_ok = local_errjmp_ok;
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);
262 r = leval(car(args),env);
264 est_errjmp = local_errjmp;
265 errjmp_ok = local_errjmp_ok;
271 static LISP oblistfn(
void)
272 {
return(copy_list(oblistvar));}
274 LISP let_macro(LISP form)
278 for(p=car(cdr(form));NNULLP(p);p=cdr(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);}}
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"));
288 void init_subrs_core(
void)
290 gc_protect_sym(&sym_lambda,
"lambda");
291 gc_protect_sym(&sym_progn,
"begin");
293 init_fsubr(
"quote",leval_quote,
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\
303 init_fsubr(
"lambda",leval_lambda,
304 "(lambda (ARG1 ARG2 ...) . BODY)\n\
305 Create closure (anonymous function) with arguments ARG1, ARG2 ... and \n\
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,
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\
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,
338 Returns typeof of given object.");
339 init_subr_1(
"symbol?",symbolp,
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\
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,
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\
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\