15static LISP sym_lambda = NIL;
16static LISP sym_progn = NIL;
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);}
26{
return(setvar(car(args),leval(car(cdr(args)),env),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)));
62 if NNULLP(leval(car(args),env))
63 *
pform = car(cdr(args));
else *
pform = car(cdr(cdr(args)));
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);
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)));}
105 {val = leval(car(l),env);
106 if NNULLP(val) {*
pform = val;
return(NIL);}
107 l=next;next=cdr(next);}
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);}
127 volatile LISP val = NIL;
128 frame.tag = leval(car(args),env);
129 frame.next = catch_framep;
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;
142 for(l=catch_framep; l; l = (*l).next)
144 {(*l).retval = value;
146 err(
"no *catch found with this tag",tag);
153 *
penv = extend_env(leval_args(car(cdr(l)),env),car(l),env);
154 *
pform = car(cdr(cdr(l)));
167 while NNULLP(leval(car(args),env))
168 for(l=cdr(args);NNULLP(l);l=cdr(l))
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");
201 p = get_user_type_hooks(TYPE(
exp));
206 return rintern(
tkb.after(
"#<").before(
" "));
211 return rintern(p->name);
213 return rintern(
"unknown");
220{
if SYMBOLP(
x)
return(truth);
else return(NIL);}
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);}
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);
242 est_errjmp = walloc(
jmp_buf,1);
248 if (
setjmp(*est_errjmp) != 0)
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);
271static LISP oblistfn(
void)
272{
return(copy_list(oblistvar));}
278 for(p=car(cdr(
form));NNULLP(p);p=cdr(p))
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"));
288void 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\