1 /* eval.c -- evaluator library implementation */
2 /* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
3 /* BSD-style license: http://synthcode.com/license.txt */
4
5 #include "chibi/eval.h"
6
7 #if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM || SEXP_USE_STATIC_LIBS
8 #include "opt/opcode_names.h"
9 #endif
10
11 /************************************************************************/
12
13 static int scheme_initialized_p = 0;
14
15 static sexp analyze (sexp ctx, sexp x, int depth, int defok);
16
17 #if SEXP_USE_MODULES
18 sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env);
19 sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file);
20 sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n);
21 #endif
22
sexp_compile_error(sexp ctx,const char * message,sexp o)23 sexp sexp_compile_error (sexp ctx, const char *message, sexp o) {
24 sexp exn;
25 sexp_gc_var3(sym, irritants, msg);
26 sexp_gc_preserve3(ctx, sym, irritants, msg);
27 irritants = sexp_list1(ctx, o);
28 msg = sexp_c_string(ctx, message, -1);
29 exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1),
30 msg, irritants, SEXP_FALSE,
31 (sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE));
32 sexp_gc_release3(ctx);
33 return exn;
34 }
35
sexp_warn(sexp ctx,const char * msg,sexp x)36 void sexp_warn (sexp ctx, const char *msg, sexp x) {
37 sexp_gc_var1(out);
38 int strictp = sexp_truep(sexp_global(ctx, SEXP_G_STRICT_P));
39 sexp_gc_preserve1(ctx, out);
40 out = sexp_current_error_port(ctx);
41 if (sexp_not(out)) { /* generate a throw-away port */
42 out = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
43 sexp_port_no_closep(out) = 1;
44 }
45 if (sexp_oportp(out)) {
46 sexp_write_string(ctx, strictp ? "ERROR: " : "WARNING: ", out);
47 sexp_write_string(ctx, msg, out);
48 sexp_write(ctx, x, out);
49 sexp_write_char(ctx, '\n', out);
50 if (strictp) sexp_stack_trace(ctx, out);
51 }
52 sexp_gc_release1(ctx);
53 if (strictp) exit(1);
54 }
55
sexp_warn_undefs_op(sexp ctx,sexp self,sexp_sint_t n,sexp from,sexp to,sexp res)56 sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res) {
57 sexp x, ignore = (res && sexp_exceptionp(res)) ? sexp_exception_irritants(res) : SEXP_NULL;
58 if (sexp_envp(from)) from = sexp_env_bindings(from);
59 for (x=from; sexp_pairp(x) && x!=to; x=sexp_env_next_cell(x))
60 if (sexp_cdr(x) == SEXP_UNDEF && sexp_car(x) != ignore
61 && !sexp_synclop(sexp_car(x))
62 && sexp_not(sexp_memq(ctx, sexp_car(x), ignore)))
63 sexp_warn(ctx, "reference to undefined variable: ", sexp_car(x));
64 return SEXP_VOID;
65 }
66
sexp_maybe_wrap_error(sexp ctx,sexp obj)67 sexp sexp_maybe_wrap_error (sexp ctx, sexp obj) {
68 sexp_gc_var2(tmp, res);
69 if (sexp_exceptionp(obj)) {
70 sexp_gc_preserve2(ctx, tmp, res);
71 tmp = obj;
72 tmp = sexp_list1(ctx, tmp);
73 res = sexp_make_trampoline(ctx, SEXP_FALSE, tmp);
74 sexp_gc_release2(ctx);
75 return res;
76 }
77 return obj;
78 }
79
80 /********************** environment utilities ***************************/
81
sexp_env_cell_loc1(sexp env,sexp key,int localp,sexp * varenv)82 static sexp sexp_env_cell_loc1 (sexp env, sexp key, int localp, sexp *varenv) {
83 sexp ls;
84 do {
85 #if SEXP_USE_RENAME_BINDINGS
86 for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
87 if (sexp_car(ls) == key) {
88 if (varenv) *varenv = env;
89 return sexp_cdr(ls);
90 }
91 #endif
92 for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
93 if (sexp_car(ls) == key) {
94 if (varenv) *varenv = env;
95 return ls;
96 }
97 if (localp) break;
98 env = sexp_env_parent(env);
99 } while (env && sexp_envp(env));
100 return NULL;
101 }
102
sexp_env_cell_loc(sexp ctx,sexp env,sexp key,int localp,sexp * varenv)103 static sexp sexp_env_cell_loc (sexp ctx, sexp env, sexp key, int localp, sexp *varenv) {
104 sexp cell, ls = sexp_vectorp(sexp_context_specific(ctx)) ? sexp_memq(ctx, sexp_id_name(key), sexp_context_fv(ctx)) : SEXP_NULL;
105 for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
106 if (sexp_envp(sexp_car(ls))) {
107 env = sexp_car(ls);
108 break;
109 }
110 cell = sexp_env_cell_loc1(env, key, localp, varenv);
111 while (!cell && key && sexp_synclop(key)) {
112 if (!sexp_pairp(ls) && sexp_not(sexp_memq(ctx, sexp_synclo_expr(key), sexp_synclo_free_vars(key))))
113 env = sexp_synclo_env(key);
114 key = sexp_synclo_expr(key);
115 cell = sexp_env_cell_loc1(env, key, localp, varenv);
116 }
117 return cell;
118 }
119
sexp_env_cell(sexp ctx,sexp env,sexp key,int localp)120 sexp sexp_env_cell (sexp ctx, sexp env, sexp key, int localp) {
121 return sexp_env_cell_loc(ctx, env, key, localp, NULL);
122 }
123
sexp_env_undefine(sexp ctx,sexp env,sexp key)124 static sexp sexp_env_undefine (sexp ctx, sexp env, sexp key) {
125 sexp ls1=NULL, ls2;
126 for (ls2=sexp_env_bindings(env); sexp_pairp(ls2);
127 ls1=ls2, ls2=sexp_env_next_cell(ls2))
128 if (sexp_car(ls2) == key) {
129 if (ls1) sexp_env_next_cell(ls1) = sexp_env_next_cell(ls2);
130 else sexp_env_bindings(env) = sexp_env_next_cell(ls2);
131 return SEXP_TRUE;
132 }
133 return SEXP_FALSE;
134 }
135
sexp_env_cell_define(sexp ctx,sexp env,sexp key,sexp value,sexp * varenv)136 sexp sexp_env_cell_define (sexp ctx, sexp env, sexp key,
137 sexp value, sexp *varenv) {
138 sexp_gc_var2(cell, ls);
139 while (sexp_env_lambda(env) || sexp_env_syntactic_p(env))
140 env = sexp_env_parent(env);
141 if (varenv) *varenv = env;
142 #if SEXP_USE_RENAME_BINDINGS
143 /* remove any existing renamed definition */
144 for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
145 if (sexp_car(ls) == key) {
146 sexp_car(ls) = SEXP_FALSE;
147 break;
148 }
149 #endif
150 for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
151 if (sexp_car(ls) == key) {
152 sexp_cdr(ls) = value;
153 return ls;
154 }
155 sexp_gc_preserve2(ctx, cell, ls);
156 sexp_env_push(ctx, env, cell, key, value);
157 sexp_gc_release2(ctx);
158 return cell;
159 }
160
sexp_env_cell_create(sexp ctx,sexp env,sexp key,sexp value,sexp * varenv)161 static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key,
162 sexp value, sexp *varenv) {
163 sexp cell = sexp_env_cell_loc(ctx, env, key, 0, varenv);
164 if (!cell) cell = sexp_env_cell_define(ctx, env, key, value, varenv);
165 return cell;
166 }
167
sexp_env_ref(sexp ctx,sexp env,sexp key,sexp dflt)168 sexp sexp_env_ref (sexp ctx, sexp env, sexp key, sexp dflt) {
169 sexp cell = sexp_env_cell(ctx, env, key, 0);
170 return (cell ? sexp_cdr(cell) : dflt);
171 }
172
sexp_env_define(sexp ctx,sexp env,sexp key,sexp value)173 sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) {
174 sexp cell, tmp, res = SEXP_VOID;
175 if (sexp_immutablep(env))
176 return sexp_user_exception(ctx, NULL, "immutable binding", key);
177 cell = sexp_env_cell(ctx, env, key, 1);
178 if (!cell) {
179 while (sexp_env_syntactic_p(env) && sexp_env_parent(env))
180 env = sexp_env_parent(env);
181 sexp_env_push(ctx, env, tmp, key, value);
182 } else if (sexp_immutablep(cell)) {
183 res = sexp_user_exception(ctx, NULL, "immutable binding", key);
184 } else if (sexp_syntacticp(value) && !sexp_syntacticp(sexp_cdr(cell))) {
185 sexp_env_undefine(ctx, env, key);
186 sexp_env_push(ctx, env, tmp, key, value);
187 } else {
188 sexp_cdr(cell) = value;
189 }
190 return res;
191 }
192
193 #if SEXP_USE_RENAME_BINDINGS
sexp_env_rename(sexp ctx,sexp env,sexp key,sexp value)194 sexp sexp_env_rename (sexp ctx, sexp env, sexp key, sexp value) {
195 sexp tmp;
196 sexp_env_push_rename(ctx, env, tmp, key, value);
197 return SEXP_VOID;
198 }
199 #endif
200
sexp_env_exports_op(sexp ctx,sexp self,sexp_sint_t n,sexp env)201 sexp sexp_env_exports_op (sexp ctx, sexp self, sexp_sint_t n, sexp env) {
202 sexp ls;
203 sexp_gc_var1(res);
204 sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
205 sexp_gc_preserve1(ctx, res);
206 res = SEXP_NULL;
207 #if SEXP_USE_RENAME_BINDINGS
208 for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
209 sexp_push(ctx, res, sexp_car(ls));
210 #endif
211 for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
212 if (sexp_env_value(ls) != SEXP_UNDEF)
213 sexp_push(ctx, res, sexp_car(ls));
214 sexp_gc_release1(ctx);
215 return res;
216 }
217
sexp_extend_env(sexp ctx,sexp env,sexp vars,sexp value)218 sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
219 sexp_gc_var2(e, tmp);
220 sexp_gc_preserve2(ctx, e, tmp);
221 e = sexp_alloc_type(ctx, env, SEXP_ENV);
222 sexp_env_parent(e) = env;
223 sexp_env_bindings(e) = SEXP_NULL;
224 #if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
225 sexp_env_renames(e) = SEXP_NULL;
226 #endif
227 for ( ; sexp_pairp(vars); vars = sexp_cdr(vars))
228 sexp_env_push(ctx, e, tmp, sexp_car(vars), value);
229 sexp_gc_release2(ctx);
230 return e;
231 }
232
sexp_extend_synclo_env(sexp ctx,sexp env)233 sexp sexp_extend_synclo_env (sexp ctx, sexp env) {
234 sexp e1, e2;
235 sexp_gc_var1(e);
236 sexp_gc_preserve1(ctx, e);
237 e = env;
238 if (sexp_pairp(sexp_context_fv(ctx))) {
239 e = sexp_alloc_type(ctx, env, SEXP_ENV);
240 for (e1=env, e2=NULL; e1; e1=sexp_env_parent(e1)) {
241 e2 = e2 ? (sexp_env_parent(e2) = sexp_alloc_type(ctx, env, SEXP_ENV)) : e;
242 sexp_env_bindings(e2) = sexp_env_bindings(e1);
243 sexp_env_syntactic_p(e2) = 1;
244 #if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
245 sexp_env_renames(e2) = sexp_env_renames(e1);
246 #endif
247 }
248 if (!e2) { return sexp_global(ctx, SEXP_G_OOM_ERROR); }
249 sexp_env_parent(e2) = sexp_context_env(ctx);
250 }
251 sexp_gc_release1(ctx);
252 return e;
253 }
254
sexp_reverse_flatten_dot(sexp ctx,sexp ls)255 static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) {
256 sexp_gc_var1(res);
257 sexp_gc_preserve1(ctx, res);
258 for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls))
259 sexp_push(ctx, res, sexp_car(ls));
260 if (!sexp_nullp(ls))
261 res = sexp_cons(ctx, ls, res);
262 sexp_gc_release1(ctx);
263 return res;
264 }
265
sexp_flatten_dot(sexp ctx,sexp ls)266 static sexp sexp_flatten_dot (sexp ctx, sexp ls) {
267 return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls));
268 }
269
sexp_param_index(sexp ctx,sexp lambda,sexp name)270 int sexp_param_index (sexp ctx, sexp lambda, sexp name) {
271 sexp ls;
272 int i;
273 while (1) {
274 ls = sexp_lambda_params(lambda);
275 for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++)
276 if (sexp_car(ls) == name)
277 return i;
278 if (ls == name)
279 return i;
280 ls = sexp_lambda_locals(lambda);
281 for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--)
282 if (sexp_car(ls) == name)
283 return i-4;
284 if (sexp_synclop(name))
285 name = sexp_synclo_expr(name);
286 else
287 break;
288 }
289 sexp_warn(ctx, "can't happen: no argument: ", name);
290 return -10000;
291 }
292
293 /************************* bytecode utilities ***************************/
294
sexp_shrink_bcode(sexp ctx,sexp_uint_t i)295 void sexp_shrink_bcode (sexp ctx, sexp_uint_t i) {
296 sexp tmp;
297 if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) {
298 tmp = sexp_alloc_bytecode(ctx, i);
299 if (!sexp_exceptionp(tmp)) {
300 sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx));
301 sexp_bytecode_length(tmp) = i;
302 sexp_bytecode_literals(tmp)
303 = sexp_bytecode_literals(sexp_context_bc(ctx));
304 sexp_bytecode_source(tmp)
305 = sexp_bytecode_source(sexp_context_bc(ctx));
306 memcpy(sexp_bytecode_data(tmp),
307 sexp_bytecode_data(sexp_context_bc(ctx)),
308 i);
309 sexp_context_bc(ctx) = tmp;
310 }
311 }
312 }
313
sexp_expand_bcode(sexp ctx,sexp_sint_t size)314 void sexp_expand_bcode (sexp ctx, sexp_sint_t size) {
315 sexp tmp;
316 if ((sexp_sint_t)sexp_bytecode_length(sexp_context_bc(ctx))
317 < (sexp_unbox_fixnum(sexp_context_pos(ctx)))+size) {
318 tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2);
319 if (sexp_exceptionp(tmp)) {
320 sexp_context_exception(ctx) = tmp;
321 } else {
322 sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx));
323 sexp_bytecode_length(tmp)
324 = sexp_bytecode_length(sexp_context_bc(ctx))*2;
325 sexp_bytecode_literals(tmp)
326 = sexp_bytecode_literals(sexp_context_bc(ctx));
327 sexp_bytecode_source(tmp)
328 = sexp_bytecode_source(sexp_context_bc(ctx));
329 memcpy(sexp_bytecode_data(tmp),
330 sexp_bytecode_data(sexp_context_bc(ctx)),
331 sexp_bytecode_length(sexp_context_bc(ctx)));
332 sexp_context_bc(ctx) = tmp;
333 }
334 }
335 }
336
sexp_emit(sexp ctx,unsigned char c)337 void sexp_emit (sexp ctx, unsigned char c) {
338 sexp_expand_bcode(ctx, 1);
339 if (sexp_exceptionp(sexp_context_exception(ctx)))
340 return;
341 sexp_bytecode_data(sexp_context_bc(ctx))[sexp_unbox_fixnum(sexp_context_pos(ctx))] = c;
342 sexp_context_pos(ctx) = sexp_fx_add(sexp_context_pos(ctx), SEXP_ONE);
343 }
344
sexp_complete_bytecode(sexp ctx)345 sexp sexp_complete_bytecode (sexp ctx) {
346 sexp bc;
347 sexp_emit_return(ctx);
348 sexp_shrink_bcode(ctx, sexp_unbox_fixnum(sexp_context_pos(ctx)));
349 bc = sexp_context_bc(ctx);
350 if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */
351 if (sexp_nullp(sexp_cdr(sexp_bytecode_literals(bc))))
352 sexp_bytecode_literals(bc) = sexp_car(sexp_bytecode_literals(bc));
353 else if (sexp_nullp(sexp_cddr(sexp_bytecode_literals(bc))))
354 sexp_cdr(sexp_bytecode_literals(bc)) = sexp_cadr(sexp_bytecode_literals(bc));
355 else
356 sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc));
357 if (sexp_exceptionp(sexp_bytecode_literals(bc)))
358 return sexp_bytecode_literals(bc);
359 }
360 sexp_bytecode_max_depth(bc) = sexp_unbox_fixnum(sexp_context_max_depth(ctx));
361 #if SEXP_USE_FULL_SOURCE_INFO
362 if (sexp_bytecode_source(bc) && sexp_pairp(sexp_bytecode_source(bc))) {
363 sexp_bytecode_source(bc) = sexp_nreverse(ctx, sexp_bytecode_source(bc));
364 /* omit the leading -1 source marker for the bytecode if the next */
365 /* entry is in the same file */
366 if (sexp_pairp(sexp_cdr(sexp_bytecode_source(bc))) &&
367 sexp_pairp(sexp_car(sexp_bytecode_source(bc))) &&
368 sexp_pairp(sexp_cdar(sexp_bytecode_source(bc))) &&
369 sexp_pairp(sexp_cadr(sexp_bytecode_source(bc))) &&
370 sexp_pairp(sexp_cdr(sexp_cadr(sexp_bytecode_source(bc)))) &&
371 sexp_cadr(sexp_car(sexp_bytecode_source(bc)))
372 == sexp_cadr(sexp_cadr(sexp_bytecode_source(bc)))) {
373 sexp_bytecode_source(bc) = sexp_cdr(sexp_bytecode_source(bc));
374 }
375 sexp_bytecode_source(bc) = sexp_list_to_vector(ctx, sexp_bytecode_source(bc));
376 }
377 #endif
378 sexp_bless_bytecode(ctx, bc);
379 if (sexp_exceptionp(sexp_context_exception(ctx)))
380 return sexp_context_exception(ctx);
381 return bc;
382 }
383
sexp_make_procedure_op(sexp ctx,sexp self,sexp_sint_t n,sexp flags,sexp num_args,sexp bc,sexp vars)384 sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags,
385 sexp num_args, sexp bc, sexp vars) {
386 sexp proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE);
387 sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags;
388 sexp_procedure_num_args(proc) = sexp_unbox_fixnum(num_args);
389 sexp_procedure_code(proc) = bc;
390 sexp_procedure_vars(proc) = vars;
391 return proc;
392 }
393
sexp_make_macro(sexp ctx,sexp p,sexp e)394 static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) {
395 sexp mac = sexp_alloc_type(ctx, macro, SEXP_MACRO);
396 sexp_macro_env(mac) = e;
397 sexp_macro_proc(mac) = p;
398 sexp_macro_aux(mac) = SEXP_FALSE;
399 return mac;
400 }
401
sexp_make_synclo_op(sexp ctx,sexp self,sexp_sint_t n,sexp env,sexp fv,sexp expr)402 sexp sexp_make_synclo_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv, sexp expr) {
403 sexp res;
404 sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
405 if (! (sexp_symbolp(expr) || sexp_pairp(expr) || sexp_synclop(expr)))
406 return expr;
407 res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO);
408 if (SEXP_USE_FLAT_SYNTACTIC_CLOSURES && sexp_synclop(expr)) {
409 sexp_synclo_env(res) = sexp_synclo_env(expr);
410 sexp_synclo_free_vars(res) = sexp_synclo_free_vars(expr);
411 sexp_synclo_expr(res) = sexp_synclo_expr(expr);
412 sexp_synclo_rename(res) = sexp_synclo_rename(expr);
413 } else {
414 sexp_synclo_env(res) = env;
415 sexp_synclo_free_vars(res) = fv;
416 sexp_synclo_expr(res) = expr;
417 sexp_synclo_rename(res) = SEXP_FALSE;
418 }
419 return res;
420 }
421
422 /* internal AST */
423
sexp_make_lambda(sexp ctx,sexp params)424 sexp sexp_make_lambda (sexp ctx, sexp params) {
425 sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
426 sexp_lambda_name(res) = SEXP_FALSE;
427 sexp_lambda_params(res) = params;
428 sexp_lambda_fv(res) = SEXP_NULL;
429 sexp_lambda_sv(res) = SEXP_NULL;
430 sexp_lambda_locals(res) = SEXP_NULL;
431 sexp_lambda_defs(res) = SEXP_NULL;
432 sexp_lambda_return_type(res) = SEXP_FALSE;
433 sexp_lambda_param_types(res) = SEXP_NULL;
434 return res;
435 }
436
sexp_make_ref(sexp ctx,sexp name,sexp cell)437 sexp sexp_make_ref (sexp ctx, sexp name, sexp cell) {
438 sexp res = sexp_alloc_type(ctx, ref, SEXP_REF);
439 sexp_ref_name(res) = name;
440 sexp_ref_cell(res) = cell;
441 return res;
442 }
443
sexp_make_set(sexp ctx,sexp var,sexp value)444 static sexp sexp_make_set (sexp ctx, sexp var, sexp value) {
445 sexp res = sexp_alloc_type(ctx, set, SEXP_SET);
446 sexp_set_var(res) = var;
447 sexp_set_value(res) = value;
448 return res;
449 }
450
sexp_make_cnd(sexp ctx,sexp test,sexp pass,sexp fail)451 static sexp sexp_make_cnd (sexp ctx, sexp test, sexp pass, sexp fail) {
452 sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND);
453 sexp_cnd_test(res) = test;
454 sexp_cnd_pass(res) = pass;
455 sexp_cnd_fail(res) = fail;
456 return res;
457 }
458
sexp_make_lit(sexp ctx,sexp value)459 sexp sexp_make_lit (sexp ctx, sexp value) {
460 sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT);
461 sexp_lit_value(res) = value;
462 return res;
463 }
464
465 /****************************** contexts ******************************/
466
467 #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE)
468
sexp_add_path(sexp ctx,const char * str)469 static void sexp_add_path (sexp ctx, const char *str) {
470 const char *colon;
471 if (str && *str) {
472 colon = strchr(str, ':');
473 if (colon)
474 sexp_add_path(ctx, colon+1);
475 else
476 colon = str + strlen(str);
477 sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), SEXP_VOID);
478 sexp_car(sexp_global(ctx, SEXP_G_MODULE_PATH))
479 = sexp_c_string(ctx, str, colon-str);
480 sexp_immutablep(sexp_global(ctx, SEXP_G_MODULE_PATH)) = 1;
481 }
482 }
483
484 #if ! SEXP_USE_NATIVE_X86
sexp_init_eval_context_bytecodes(sexp ctx)485 static void sexp_init_eval_context_bytecodes (sexp ctx) {
486 sexp_gc_var3(tmp, vec, ctx2);
487 sexp_gc_preserve3(ctx, tmp, vec, ctx2);
488 sexp_emit(ctx, SEXP_OP_RESUMECC);
489 sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = sexp_complete_bytecode(ctx);
490 ctx2 = sexp_make_child_context(ctx, NULL);
491 sexp_emit(ctx2, SEXP_OP_DONE);
492 tmp = sexp_complete_bytecode(ctx2);
493 vec = sexp_make_vector(ctx, 0, SEXP_VOID);
494 sexp_global(ctx, SEXP_G_FINAL_RESUMER)
495 = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec);
496 sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER)))
497 = sexp_intern(ctx, "final-resumer", -1);
498 sexp_gc_release3(ctx);
499 }
500 #endif
501
sexp_init_eval_context_globals(sexp ctx)502 void sexp_init_eval_context_globals (sexp ctx) {
503 const char* no_sys_path;
504 const char* user_path;
505 ctx = sexp_make_child_context(ctx, NULL);
506 #if ! SEXP_USE_NATIVE_X86
507 sexp_init_eval_context_bytecodes(ctx);
508 #endif
509 sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL;
510 user_path = getenv(SEXP_MODULE_PATH_VAR);
511 if (!user_path) user_path = sexp_default_user_module_path;
512 sexp_add_path(ctx, user_path);
513 no_sys_path = getenv(SEXP_NO_SYSTEM_PATH_VAR);
514 if (!no_sys_path || strcmp(no_sys_path, "0")==0)
515 sexp_add_path(ctx, sexp_default_module_path);
516 #if SEXP_USE_GREEN_THREADS
517 sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)
518 = sexp_user_exception(ctx, SEXP_FALSE, "I/O would block", SEXP_NULL);
519 sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR)
520 = sexp_user_exception(ctx, SEXP_FALSE, "I/O would block once", SEXP_NULL);
521 sexp_global(ctx, SEXP_G_THREAD_TERMINATE_ERROR)
522 = sexp_user_exception(ctx, SEXP_FALSE, "thread terminated", SEXP_NULL);
523 sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL;
524 sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL;
525 sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO;
526 sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE;
527 sexp_global(ctx, SEXP_G_ATOMIC_P) = SEXP_FALSE;
528 #endif
529 }
530
sexp_make_eval_context(sexp ctx,sexp stack,sexp env,sexp_uint_t size,sexp_uint_t max_size)531 sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size) {
532 sexp_gc_var1(res);
533 res = sexp_make_context(ctx, size, max_size);
534 if (!res || sexp_exceptionp(res))
535 return res;
536 if (ctx) sexp_gc_preserve1(ctx, res);
537 sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_SEVEN));
538 sexp_context_specific(res) = sexp_make_vector(res, SEXP_SEVEN, SEXP_ZERO);
539 sexp_context_lambda(res) = SEXP_FALSE;
540 sexp_context_fv(res) = SEXP_NULL;
541 sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE);
542 if (sexp_exceptionp(sexp_context_env(res))) {
543 res = sexp_context_env(res);
544 } else if (sexp_exceptionp(sexp_context_specific(res))) {
545 res = sexp_context_specific(res);
546 } else if (sexp_exceptionp(sexp_context_bc(res))) {
547 res = sexp_context_bc(res);
548 } else {
549 sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE;
550 sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE;
551 sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL;
552 sexp_bytecode_source(sexp_context_bc(res)) = SEXP_NULL;
553 if ((! stack) || (stack == SEXP_FALSE)) {
554 stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK);
555 if (sexp_exceptionp(stack)) {
556 if (ctx) sexp_gc_release1(ctx);
557 return stack;
558 } else {
559 sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE;
560 sexp_stack_top(stack) = 0;
561 }
562 }
563 sexp_context_stack(res) = stack;
564 if (! ctx) sexp_init_eval_context_globals(res);
565 if (ctx) {
566 sexp_context_params(res) = sexp_context_params(ctx);
567 sexp_context_tracep(res) = sexp_context_tracep(ctx);
568 sexp_context_dk(res) = sexp_context_dk(ctx);
569 sexp_gc_release1(ctx);
570 } else {
571 /* TODO: make the root a global (with friendly error in/out) */
572 sexp_context_dk(res) = sexp_make_vector(res, SEXP_FOUR, SEXP_FALSE);
573 sexp_vector_set(sexp_context_dk(res), SEXP_ZERO, SEXP_ZERO);
574 }
575 }
576 return res;
577 }
578
sexp_make_child_context(sexp ctx,sexp lambda)579 sexp sexp_make_child_context (sexp ctx, sexp lambda) {
580 sexp res = sexp_make_eval_context(ctx,
581 sexp_context_stack(ctx),
582 sexp_context_env(ctx),
583 0,
584 sexp_context_max_size(ctx));
585 if (! sexp_exceptionp(res)) {
586 sexp_context_lambda(res) = lambda;
587 sexp_context_top(res) = sexp_context_top(ctx);
588 sexp_context_fv(res) = sexp_context_fv(ctx);
589 sexp_context_tracep(res) = sexp_context_tracep(ctx);
590 }
591 return res;
592 }
593
594 /**************************** identifiers *****************************/
595
sexp_id_name(sexp x)596 sexp sexp_id_name (sexp x) {
597 while (sexp_synclop(x)) x = sexp_synclo_expr(x);
598 return x;
599 }
600
sexp_idp(sexp x)601 int sexp_idp (sexp x) {
602 return sexp_symbolp(sexp_id_name(x));
603 }
604
sexp_identifierp_op(sexp ctx,sexp self,sexp_sint_t n,sexp x)605 sexp sexp_identifierp_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
606 return sexp_make_boolean(sexp_idp(x));
607 }
608
sexp_syntactic_closure_expr_op(sexp ctx,sexp self,sexp_sint_t n,sexp x)609 sexp sexp_syntactic_closure_expr_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
610 return (sexp_synclop(x) ? sexp_synclo_expr(x) : x);
611 }
612
sexp_contains_syntax_p_bound(sexp x,int depth)613 static int sexp_contains_syntax_p_bound(sexp x, int depth) {
614 int i;
615 sexp ls1, ls2;
616 if (sexp_synclop(x))
617 return 1;
618 if (depth <= 0)
619 return 0;
620 if (sexp_pairp(x)) {
621 for (i=0, ls1=x, ls2=x; sexp_pairp(ls1); ls1=sexp_cdr(ls1), ls2=(i++ & 1 ? sexp_cdr(ls2) : ls2)) {
622 if (sexp_contains_syntax_p_bound(sexp_car(ls1), depth-1))
623 return 1;
624 if (i > 0 && (ls1 == ls2 || ls1 == sexp_car(ls2)))
625 return 0; /* cycle, no synclo found, assume none */
626 }
627 if (sexp_synclop(ls1))
628 return sexp_contains_syntax_p_bound(sexp_id_name(ls1), depth-1);
629 } else if (sexp_vectorp(x)) {
630 for (i = 0; i < sexp_vector_length(x); ++i)
631 if (sexp_contains_syntax_p_bound(sexp_vector_ref(x, sexp_make_fixnum(i)), depth-1))
632 return 1;
633 }
634 return 0;
635 }
636
sexp_strip_synclos_bound(sexp ctx,sexp x,int depth)637 sexp sexp_strip_synclos_bound (sexp ctx, sexp x, int depth) {
638 int i;
639 sexp_gc_var3(res, kar, kdr);
640 if (depth <= 0) return x;
641 sexp_gc_preserve3(ctx, res, kar, kdr);
642 x = sexp_id_name(x);
643 if (sexp_pairp(x)) {
644 kar = sexp_strip_synclos_bound(ctx, sexp_car(x), depth-1);
645 kdr = sexp_strip_synclos_bound(ctx, sexp_cdr(x), depth-1);
646 res = sexp_cons(ctx, kar, kdr);
647 sexp_pair_source(res) = sexp_pair_source(x);
648 sexp_immutablep(res) = 1;
649 } else {
650 if (sexp_vectorp(x))
651 for (i = 0; i < sexp_vector_length(x); ++i)
652 sexp_vector_set(x, sexp_make_fixnum(i), sexp_strip_synclos_bound(ctx, sexp_vector_ref(x, sexp_make_fixnum(i)), depth-1));
653 res = x;
654 }
655 sexp_gc_release3(ctx);
656 return res;
657 }
658
sexp_strip_synclos(sexp ctx,sexp self,sexp_sint_t n,sexp x)659 sexp sexp_strip_synclos (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
660 if (!sexp_contains_syntax_p_bound(x, SEXP_STRIP_SYNCLOS_BOUND))
661 return x;
662 return sexp_strip_synclos_bound(ctx, x, SEXP_STRIP_SYNCLOS_BOUND);
663 }
664
sexp_identifier_eq_op(sexp ctx,sexp self,sexp_sint_t n,sexp e1,sexp id1,sexp e2,sexp id2)665 sexp sexp_identifier_eq_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp id1, sexp e2, sexp id2) {
666 sexp cell1, cell2;
667 cell1 = sexp_env_cell(ctx, e1, id1, 0);
668 cell2 = sexp_env_cell(ctx, e2, id2, 0);
669 if (cell1 && (cell1 == cell2))
670 return SEXP_TRUE;
671 else if (!cell1 && !cell2 && (id1 == id2))
672 return SEXP_TRUE;
673 /* If the symbols are the same and the cells are either unbound or
674 * (optionally) bound to top-level variables, consider them the
675 * same. Local (non-toplevel) bindings must still match exactly.
676 */
677 while (sexp_synclop(id1))
678 id1 = sexp_synclo_expr(id1);
679 while (sexp_synclop(id2))
680 id2 = sexp_synclo_expr(id2);
681 if ((id1 == id2)
682 && ((!cell1 && !cell2)
683 #if !SEXP_USE_STRICT_TOPLEVEL_BINDINGS
684 || ((!cell1 || (!sexp_lambdap(sexp_cdr(cell1)) &&
685 !sexp_env_cell_syntactic_p(cell1))) &&
686 (!cell2 || (!sexp_lambdap(sexp_cdr(cell2)) &&
687 !sexp_env_cell_syntactic_p(cell2))))
688 #endif
689 ))
690 return SEXP_TRUE;
691 return SEXP_FALSE;
692 }
693
694 /************************* the compiler ***************************/
695
lambda_envp(sexp ctx)696 static int lambda_envp(sexp ctx) {
697 sexp env;
698 for (env=sexp_context_env(ctx); env && sexp_envp(env); env=sexp_env_parent(env))
699 if (sexp_env_lambda(env))
700 return 1;
701 return 0;
702 }
703
nondefp(sexp x)704 static int nondefp(sexp x) {
705 sexp ls;
706 if (sexp_pairp(x) || sexp_cndp(x))
707 return 1;
708 if (sexp_seqp(x))
709 for (ls=sexp_seq_ls(x); sexp_pairp(ls); ls=sexp_cdr(ls))
710 if (nondefp(sexp_car(ls)))
711 return 1;
712 return 0;
713 }
714
analyze_list(sexp ctx,sexp x,int depth,int defok)715 static sexp analyze_list (sexp ctx, sexp x, int depth, int defok) {
716 sexp_gc_var2(res, tmp);
717 sexp_gc_preserve2(ctx, res, tmp);
718 for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) {
719 sexp_push(ctx, res, SEXP_FALSE);
720 tmp = analyze(ctx, sexp_car(x), depth, defok);
721 if (sexp_exceptionp(tmp)) {
722 res = tmp;
723 break;
724 } else {
725 if (lambda_envp(ctx) && nondefp(tmp)) defok = -1; /* -1 to warn */
726 sexp_pair_source(res) = sexp_pair_source(x);
727 sexp_car(res) = tmp;
728 }
729 }
730 if (sexp_pairp(res)) res = sexp_nreverse(ctx, res);
731 sexp_gc_release2(ctx);
732 return res;
733 }
734
analyze_app(sexp ctx,sexp x,int depth)735 static sexp analyze_app (sexp ctx, sexp x, int depth) {
736 sexp p, res, tmp;
737 res = analyze_list(ctx, x, depth, 0);
738 if (sexp_lambdap(sexp_car(res))) { /* fill in lambda names */
739 p=sexp_lambda_params(sexp_car(res));
740 for (tmp=sexp_cdr(res); sexp_pairp(tmp)&&sexp_pairp(p); tmp=sexp_cdr(tmp), p=sexp_cdr(p))
741 if (sexp_lambdap(sexp_car(tmp)))
742 sexp_lambda_name(sexp_car(tmp)) = sexp_car(p);
743 }
744 return res;
745 }
746
analyze_seq(sexp ctx,sexp ls,int depth,int defok)747 static sexp analyze_seq (sexp ctx, sexp ls, int depth, int defok) {
748 sexp_gc_var2(res, tmp);
749 sexp_gc_preserve2(ctx, res, tmp);
750 if (sexp_nullp(ls))
751 res = SEXP_VOID;
752 else if (sexp_nullp(sexp_cdr(ls)))
753 res = analyze(ctx, sexp_car(ls), depth, defok);
754 else {
755 res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
756 sexp_seq_source(res) = sexp_pair_source(ls);
757 tmp = analyze_list(ctx, ls, depth, defok);
758 if (sexp_exceptionp(tmp))
759 res = tmp;
760 else
761 sexp_seq_ls(res) = tmp;
762 }
763 sexp_gc_release2(ctx);
764 return res;
765 }
766
analyze_var_ref(sexp ctx,sexp x,sexp * varenv)767 static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
768 sexp env = sexp_context_env(ctx), res;
769 sexp_gc_var1(cell);
770 sexp_gc_preserve1(ctx, cell);
771 cell = sexp_env_cell_loc(ctx, env, x, 0, varenv);
772 if (! cell) {
773 cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv);
774 }
775 if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) {
776 res = sexp_compile_error(ctx, "invalid use of syntax as value", x);
777 } else {
778 res = sexp_make_ref(ctx, sexp_car(cell), cell);
779 }
780 sexp_gc_release1(ctx);
781 return res;
782 }
783
analyze_set(sexp ctx,sexp x,int depth)784 static sexp analyze_set (sexp ctx, sexp x, int depth) {
785 sexp res, varenv;
786 sexp_gc_var2(ref, value);
787 sexp_gc_preserve2(ctx, ref, value);
788 if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))
789 && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) {
790 res = sexp_compile_error(ctx, "bad set! syntax", x);
791 } else {
792 ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv);
793 if (sexp_lambdap(sexp_ref_loc(ref)))
794 sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
795 value = analyze(ctx, sexp_caddr(x), depth, 0);
796 if (sexp_exceptionp(ref)) {
797 res = ref;
798 } else if (sexp_exceptionp(value)) {
799 res = value;
800 } else if (sexp_immutablep(sexp_ref_cell(ref))
801 || (varenv && sexp_immutablep(varenv))) {
802 res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x));
803 } else {
804 res = sexp_make_set(ctx, ref, value);
805 sexp_set_source(res) = sexp_pair_source(x);
806 }
807 }
808 sexp_gc_release2(ctx);
809 return res;
810 }
811
812 #define sexp_return(res, val) do {res=val; goto cleanup;} while (0)
813
analyze_lambda(sexp ctx,sexp x,int depth)814 static sexp analyze_lambda (sexp ctx, sexp x, int depth) {
815 int trailing_non_procs, verify_duplicates_p;
816 sexp name, ls, ctx3;
817 sexp_gc_var6(res, body, tmp, value, defs, ctx2);
818 sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2);
819 /* verify syntax */
820 if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))))
821 sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x));
822 verify_duplicates_p = sexp_length_unboxed(sexp_cadr(x)) < 100;
823 for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls))
824 if (! sexp_idp(sexp_car(ls)))
825 sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x));
826 else if (verify_duplicates_p && sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls))))
827 sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x));
828 if (! sexp_nullp(ls)) { /* verify rest param */
829 if (! sexp_idp(ls))
830 sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x));
831 else if (sexp_truep(sexp_memq(ctx, ls, sexp_cadr(x))))
832 sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x));
833 }
834 /* build lambda and analyze body */
835 res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x)));
836 if (sexp_exceptionp(res)) sexp_return(res, res);
837 sexp_lambda_source(res) = sexp_pair_source(x);
838 if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res))))
839 sexp_lambda_source(res) = sexp_pair_source(sexp_cdr(x));
840 if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res))))
841 sexp_lambda_source(res) = sexp_pair_source(sexp_cddr(x));
842 ctx2 = sexp_make_child_context(ctx, res);
843 if (sexp_exceptionp(ctx2)) sexp_return(res, ctx2);
844 tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res));
845 sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res);
846 if (sexp_exceptionp(sexp_context_env(ctx2))) sexp_return(res, sexp_context_env(ctx2));
847 sexp_env_lambda(sexp_context_env(ctx2)) = res;
848 body = analyze_seq(ctx2, sexp_cddr(x), depth, 1);
849 if (sexp_exceptionp(body)) sexp_return(res, body);
850 /* delayed analyze internal defines */
851 trailing_non_procs = 0;
852 defs = SEXP_NULL;
853 for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) {
854 tmp = sexp_car(ls);
855 ctx3 = sexp_cdr(tmp);
856 if (sexp_pairp(sexp_caar(tmp))) {
857 name = sexp_caaar(tmp);
858 tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp));
859 tmp = sexp_cons(ctx3, SEXP_VOID, tmp);
860 sexp_pair_source(tmp) = sexp_pair_source(sexp_caar(ls));
861 value = analyze_lambda(ctx3, tmp, depth);
862 } else {
863 name = sexp_caar(tmp);
864 value = analyze(ctx3, sexp_cadar(tmp), depth, 0);
865 }
866 if (sexp_exceptionp(value)) sexp_return(res, value);
867 if (sexp_lambdap(value)) sexp_lambda_name(value) = name;
868 tmp = analyze_var_ref(ctx3, name, NULL);
869 if (sexp_exceptionp(tmp)) sexp_return(res, tmp);
870 tmp = sexp_make_set(ctx3, tmp, value);
871 if (sexp_exceptionp(tmp)) sexp_return(res, tmp);
872 sexp_push(ctx3, defs, tmp);
873 if (!sexp_lambdap(value)) trailing_non_procs = 1;
874 if (trailing_non_procs || !SEXP_USE_UNBOXED_LOCALS)
875 sexp_insert(ctx3, sexp_lambda_sv(res), name);
876 }
877 if (sexp_pairp(defs)) {
878 if (! sexp_seqp(body)) {
879 tmp = sexp_alloc_type(ctx2, seq, SEXP_SEQ);
880 sexp_seq_ls(tmp) = sexp_list1(ctx2, body);
881 body = tmp;
882 }
883 sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body));
884 if (sexp_exceptionp(sexp_seq_ls(body))) sexp_return(res, sexp_seq_ls(body));
885 }
886 if (sexp_exceptionp(body)) res = body;
887 else sexp_lambda_body(res) = body;
888 cleanup:
889 sexp_gc_release6(ctx);
890 return res;
891 }
892
analyze_if(sexp ctx,sexp x,int depth)893 static sexp analyze_if (sexp ctx, sexp x, int depth) {
894 sexp res, fail_expr;
895 sexp_gc_var3(test, pass, fail);
896 sexp_gc_preserve3(ctx, test, pass, fail);
897 if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
898 res = sexp_compile_error(ctx, "not enough args to if", x);
899 } else if (sexp_pairp(sexp_cdddr(x)) && sexp_cdr(sexp_cdddr(x)) != SEXP_NULL) {
900 res = sexp_compile_error(ctx, "too many args to if", x);
901 } else {
902 test = analyze(ctx, sexp_cadr(x), depth, 0);
903 pass = analyze(ctx, sexp_caddr(x), depth, 0);
904 fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
905 fail = analyze(ctx, fail_expr, depth, 0);
906 res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
907 sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail));
908 if (sexp_cndp(res)) sexp_cnd_source(res) = sexp_pair_source(x);
909 }
910 sexp_gc_release3(ctx);
911 return res;
912 }
913
analyze_define(sexp ctx,sexp x,int depth)914 static sexp analyze_define (sexp ctx, sexp x, int depth) {
915 sexp name, res, varenv;
916 sexp_gc_var4(ref, value, tmp, env);
917 sexp_gc_preserve4(ctx, ref, value, tmp, env);
918 env = sexp_context_env(ctx);
919 while (sexp_env_syntactic_p(env) && sexp_env_parent(env))
920 env = sexp_env_parent(env);
921 if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
922 res = sexp_compile_error(ctx, "bad define syntax", x);
923 } else {
924 name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x));
925 if (! sexp_idp(name)) {
926 res = sexp_compile_error(ctx, "can't define a non-symbol", x);
927 } else if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) {
928 sexp_env_push(ctx, env, tmp, name, sexp_context_lambda(ctx));
929 sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name);
930 tmp = sexp_cons(ctx, sexp_cdr(x), ctx);
931 sexp_pair_source(sexp_cdr(x)) = sexp_pair_source(x);
932 sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp);
933 res = SEXP_VOID;
934 } else {
935 #if SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS
936 if (sexp_synclop(name)) name = sexp_synclo_expr(name);
937 #endif
938 sexp_env_cell_define(ctx, env, name, SEXP_VOID, &varenv);
939 if (sexp_pairp(sexp_cadr(x))) {
940 tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x));
941 tmp = sexp_cons(ctx, SEXP_VOID, tmp);
942 sexp_pair_source(tmp) = sexp_pair_source(x);
943 value = analyze_lambda(ctx, tmp, depth);
944 } else
945 value = analyze(ctx, sexp_caddr(x), depth, 0);
946 tmp = sexp_env_cell_loc(ctx, env, name, 0, &varenv);
947 ref = sexp_make_ref(ctx, name, tmp);
948 if (sexp_exceptionp(ref)) {
949 res = ref;
950 } else if (sexp_exceptionp(value)) {
951 res = value;
952 } else if (varenv && sexp_immutablep(varenv)) {
953 res = sexp_compile_error(ctx, "immutable binding", name);
954 } else {
955 if (sexp_lambdap(value)) sexp_lambda_name(value) = name;
956 res = sexp_make_set(ctx, ref, value);
957 if (sexp_setp(res)) sexp_set_source(res) = sexp_pair_source(x);
958 }
959 }
960 }
961 sexp_gc_release4(ctx);
962 return res;
963 }
964
analyze_bind_syntax(sexp ls,sexp eval_ctx,sexp bind_ctx,int localp)965 static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx, int localp) {
966 sexp res = SEXP_VOID, name;
967 sexp_gc_var2(mac, tmp);
968 sexp_gc_preserve2(eval_ctx, mac, tmp);
969 for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
970 if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls))
971 && sexp_idp(sexp_caar(ls)) && sexp_nullp(sexp_cddar(ls)))) {
972 res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_pairp(ls) ? sexp_car(ls) : ls);
973 break;
974 }
975 if (sexp_idp(sexp_cadar(ls)))
976 mac = sexp_env_ref(eval_ctx, sexp_context_env(eval_ctx), sexp_cadar(ls), SEXP_FALSE);
977 else
978 mac = sexp_eval(eval_ctx, sexp_cadar(ls), NULL);
979 if (sexp_procedurep(mac))
980 mac = sexp_make_macro(eval_ctx, mac, sexp_context_env(eval_ctx));
981 if (!(sexp_macrop(mac)||sexp_corep(mac))) {
982 res = (sexp_exceptionp(mac) ? mac
983 : sexp_compile_error(eval_ctx, "non-procedure macro", mac));
984 break;
985 }
986 name = sexp_caar(ls);
987 if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx)))
988 name = sexp_synclo_expr(name);
989 if (sexp_macrop(mac) && sexp_pairp(sexp_cadar(ls)))
990 sexp_macro_source(mac) = sexp_pair_source(sexp_cadar(ls));
991 if (localp)
992 sexp_env_push(eval_ctx, sexp_context_env(bind_ctx), tmp, name, mac);
993 else
994 sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac);
995 #if !SEXP_USE_STRICT_TOPLEVEL_BINDINGS
996 if (localp)
997 sexp_env_cell_syntactic_p(sexp_env_cell(eval_ctx, sexp_context_env(bind_ctx), name, 0)) = 1;
998 #endif
999 }
1000 sexp_gc_release2(eval_ctx);
1001 return res;
1002 }
1003
analyze_define_syntax(sexp ctx,sexp x)1004 static sexp analyze_define_syntax (sexp ctx, sexp x) {
1005 sexp res;
1006 sexp_gc_var1(tmp);
1007 sexp_gc_preserve1(ctx, tmp);
1008 tmp = sexp_list1(ctx, sexp_cdr(x));
1009 res = sexp_exceptionp(tmp) ? tmp : analyze_bind_syntax(tmp, ctx, ctx, 0);
1010 sexp_gc_release1(ctx);
1011 return res;
1012 }
1013
analyze_let_syntax_aux(sexp ctx,sexp x,int recp,int depth)1014 static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp, int depth) {
1015 sexp res;
1016 sexp_gc_var3(env, ctx2, tmp);
1017 sexp_gc_preserve3(ctx, env, ctx2, tmp);
1018 if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
1019 res = sexp_compile_error(ctx, "bad let(rec)-syntax", x);
1020 } else {
1021 env = sexp_alloc_type(ctx, env, SEXP_ENV);
1022 sexp_env_syntactic_p(env) = 1;
1023 sexp_env_parent(env) = sexp_context_env(ctx);
1024 sexp_env_bindings(env) = SEXP_NULL;
1025 #if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
1026 sexp_env_renames(env) = SEXP_NULL;
1027 #endif
1028 ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
1029 sexp_context_env(ctx2) = env;
1030 tmp = analyze_bind_syntax(sexp_cadr(x), (recp ? ctx2 : ctx), ctx2, 1);
1031 res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x), depth, 1));
1032 }
1033 sexp_gc_release3(ctx);
1034 return res;
1035 }
1036
analyze_let_syntax(sexp ctx,sexp x,int depth)1037 static sexp analyze_let_syntax (sexp ctx, sexp x, int depth) {
1038 return analyze_let_syntax_aux(ctx, x, 0, depth);
1039 }
1040
analyze_letrec_syntax(sexp ctx,sexp x,int depth)1041 static sexp analyze_letrec_syntax (sexp ctx, sexp x, int depth) {
1042 return analyze_let_syntax_aux(ctx, x, 1, depth);
1043 }
1044
analyze(sexp ctx,sexp object,int depth,int defok)1045 static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
1046 sexp op;
1047 sexp_gc_var4(res, tmp, x, cell);
1048 sexp_gc_preserve4(ctx, res, tmp, x, cell);
1049 x = object;
1050
1051 if (++depth > SEXP_MAX_ANALYZE_DEPTH) {
1052 res = sexp_compile_error(ctx, "SEXP_MAX_ANALYZE_DEPTH exceeded", x);
1053 goto error;
1054 }
1055
1056 loop:
1057 if (sexp_pairp(x)) {
1058 cell = sexp_idp(sexp_car(x)) ? sexp_env_cell(ctx, sexp_context_env(ctx), sexp_car(x), 0) : NULL;
1059 if (sexp_not(sexp_listp(ctx, x))
1060 && !(cell && sexp_macrop(sexp_cdr(cell)))) {
1061 res = sexp_compile_error(ctx, "dotted list in source", x);
1062 } else if (sexp_idp(sexp_car(x))) {
1063 if (! cell) {
1064 res = analyze_app(ctx, x, depth);
1065 if (sexp_exceptionp(res))
1066 sexp_warn(ctx, "exception inside undefined operator: ", sexp_car(x));
1067 } else {
1068 op = sexp_cdr(cell);
1069 if (sexp_corep(op)) {
1070 switch (sexp_core_code(op)) {
1071 case SEXP_CORE_DEFINE:
1072 if (defok < 0)
1073 sexp_warn(ctx, "out of order define: ", x);
1074 res = defok ? analyze_define(ctx, x, depth)
1075 : sexp_compile_error(ctx, "unexpected define", x);
1076 break;
1077 case SEXP_CORE_SET:
1078 res = analyze_set(ctx, x, depth); break;
1079 case SEXP_CORE_LAMBDA:
1080 res = analyze_lambda(ctx, x, depth); break;
1081 case SEXP_CORE_IF:
1082 res = analyze_if(ctx, x, depth); break;
1083 case SEXP_CORE_BEGIN:
1084 res = analyze_seq(ctx, sexp_cdr(x), depth, defok); break;
1085 case SEXP_CORE_QUOTE:
1086 case SEXP_CORE_SYNTAX_QUOTE:
1087 if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x))))
1088 res = sexp_compile_error(ctx, "bad quote form", x);
1089 else
1090 res = sexp_make_lit(ctx,
1091 (sexp_core_code(op) == SEXP_CORE_QUOTE) ?
1092 tmp=sexp_strip_synclos(ctx , NULL, 1, sexp_cadr(x)) :
1093 sexp_cadr(x));
1094 break;
1095 case SEXP_CORE_DEFINE_SYNTAX:
1096 if (defok < 0)
1097 sexp_warn(ctx, "out of order define-syntax: ", x);
1098 res = defok ? analyze_define_syntax(ctx, x)
1099 : sexp_compile_error(ctx, "unexpected define-syntax", x);
1100 break;
1101 case SEXP_CORE_LET_SYNTAX:
1102 res = analyze_let_syntax(ctx, x, depth); break;
1103 case SEXP_CORE_LETREC_SYNTAX:
1104 res = analyze_letrec_syntax(ctx, x, depth); break;
1105 default:
1106 res = sexp_compile_error(ctx, "unknown core form", op); break;
1107 }
1108 } else if (sexp_macrop(op)) {
1109 tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL);
1110 tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp);
1111 tmp = sexp_cons(ctx, x, tmp);
1112 x = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx));
1113 if (!sexp_exceptionp(x) && !sexp_exceptionp(sexp_context_exception(ctx)))
1114 x = sexp_apply(x, sexp_macro_proc(op), tmp);
1115 if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x)))
1116 sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp));
1117 goto loop;
1118 } else if (sexp_opcodep(op)) {
1119 res = sexp_length(ctx, sexp_cdr(x));
1120 if (sexp_unbox_fixnum(res) < sexp_opcode_num_args(op)) {
1121 sexp_warn(ctx, "not enough args for opcode: ", x);
1122 op = analyze_var_ref(ctx, sexp_car(x), NULL);
1123 } else if ((sexp_unbox_fixnum(res) > sexp_opcode_num_args(op))
1124 && (! sexp_opcode_variadic_p(op))) {
1125 sexp_warn(ctx, "too many args for opcode: ", x);
1126 op = analyze_var_ref(ctx, sexp_car(x), NULL);
1127 }
1128 res = analyze_list(ctx, sexp_cdr(x), 0, 0);
1129 if (! sexp_exceptionp(res)) {
1130 /* push op, which will be a direct opcode if the call is valid */
1131 sexp_push(ctx, res, op);
1132 if (sexp_pairp(res))
1133 sexp_pair_source(res) = sexp_pair_source(x);
1134 }
1135 } else {
1136 res = analyze_app(ctx, x, depth);
1137 }
1138 }
1139 } else {
1140 res = analyze_app(ctx, x, depth);
1141 if (!sexp_exceptionp(res)
1142 && !(sexp_pairp(sexp_car(x))
1143 || (sexp_synclop(sexp_car(x))
1144 && sexp_pairp(sexp_synclo_expr(sexp_car(x))))))
1145 sexp_warn(ctx, "invalid operator in application: ", x);
1146 }
1147 } else if (sexp_idp(x)) {
1148 res = analyze_var_ref(ctx, x, NULL);
1149 } else if (sexp_synclop(x)) {
1150 tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
1151 if (sexp_pairp(sexp_synclo_free_vars(x))) {
1152 sexp_push(ctx, sexp_context_fv(tmp), sexp_context_env(ctx));
1153 sexp_context_fv(tmp) = sexp_append2(tmp,
1154 sexp_synclo_free_vars(x),
1155 sexp_context_fv(tmp));
1156 }
1157 sexp_context_env(tmp) = sexp_extend_synclo_env(tmp, sexp_synclo_env(x));
1158 x = sexp_synclo_expr(x);
1159 res = analyze(tmp, x, depth, defok);
1160 } else if (sexp_nullp(x)) {
1161 res = sexp_compile_error(ctx, "empty application in source", x);
1162 } else {
1163 if (sexp_pointerp(x)) { /* accept vectors and other literals directly, */
1164 sexp_immutablep(x) = 1; /* but they must be immutable */
1165 x = sexp_strip_synclos(ctx , NULL, 1, x);
1166 }
1167 res = x;
1168 }
1169
1170 error:
1171 if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res))
1172 && sexp_pairp(x))
1173 sexp_exception_source(res) = sexp_pair_source(x);
1174 sexp_gc_release4(ctx);
1175 return res;
1176 }
1177
sexp_analyze(sexp ctx,sexp x)1178 sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x, 0, 1);}
1179
1180 /********************** free varable analysis *************************/
1181
insert_free_var(sexp ctx,sexp x,sexp fv)1182 static sexp insert_free_var (sexp ctx, sexp x, sexp fv) {
1183 sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls;
1184 for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls))
1185 if ((name == sexp_ref_name(sexp_car(ls)))
1186 && (loc == sexp_ref_loc(sexp_car(ls))))
1187 return fv;
1188 return sexp_cons(ctx, x, fv);
1189 }
1190
union_free_vars(sexp ctx,sexp fv1,sexp fv2)1191 static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) {
1192 sexp_gc_var1(res);
1193 if (sexp_nullp(fv2))
1194 return fv1;
1195 sexp_gc_preserve1(ctx, res);
1196 for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1))
1197 res = insert_free_var(ctx, sexp_car(fv1), res);
1198 sexp_gc_release1(ctx);
1199 return res;
1200 }
1201
diff_free_vars(sexp ctx,sexp lambda,sexp fv,sexp params)1202 static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) {
1203 sexp_gc_var1(res);
1204 sexp_gc_preserve1(ctx, res);
1205 res = SEXP_NULL;
1206 for ( ; sexp_pairp(fv); fv=sexp_cdr(fv))
1207 if ((sexp_ref_loc(sexp_car(fv)) != lambda)
1208 || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params)
1209 == SEXP_FALSE))
1210 sexp_push(ctx, res, sexp_car(fv));
1211 sexp_gc_release1(ctx);
1212 return res;
1213 }
1214
sexp_free_vars(sexp ctx,sexp x,sexp fv)1215 sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) {
1216 sexp_gc_var2(fv1, fv2);
1217 sexp_gc_preserve2(ctx, fv1, fv2);
1218 fv1 = fv;
1219 if (sexp_lambdap(x)) {
1220 fv1 = sexp_free_vars(ctx, sexp_lambda_body(x), SEXP_NULL);
1221 fv2 = sexp_flatten_dot(ctx, sexp_lambda_params(x));
1222 fv2 = sexp_append2(ctx, sexp_lambda_locals(x), fv2);
1223 fv2 = diff_free_vars(ctx, x, fv1, fv2);
1224 sexp_lambda_fv(x) = fv2;
1225 fv1 = union_free_vars(ctx, fv2, fv);
1226 } else if (sexp_pairp(x)) {
1227 for ( ; sexp_pairp(x); x=sexp_cdr(x))
1228 fv1 = sexp_free_vars(ctx, sexp_car(x), fv1);
1229 } else if (sexp_cndp(x)) {
1230 fv1 = sexp_free_vars(ctx, sexp_cnd_test(x), fv);
1231 fv1 = sexp_free_vars(ctx, sexp_cnd_pass(x), fv1);
1232 fv1 = sexp_free_vars(ctx, sexp_cnd_fail(x), fv1);
1233 } else if (sexp_seqp(x)) {
1234 for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x))
1235 fv1 = sexp_free_vars(ctx, sexp_car(x), fv1);
1236 } else if (sexp_setp(x)) {
1237 fv1 = sexp_free_vars(ctx, sexp_set_value(x), fv);
1238 fv1 = sexp_free_vars(ctx, sexp_set_var(x), fv1);
1239 } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) {
1240 fv1 = insert_free_var(ctx, x, fv);
1241 } else if (sexp_synclop(x)) {
1242 fv1 = sexp_free_vars(ctx, sexp_synclo_expr(x), fv);
1243 }
1244 sexp_gc_release2(ctx);
1245 return fv1;
1246 }
1247
1248 /************************ library procedures **************************/
1249
sexp_open_input_file_op(sexp ctx,sexp self,sexp_sint_t n,sexp path)1250 sexp sexp_open_input_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
1251 FILE *in;
1252 int count = 0;
1253 sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path);
1254 do {
1255 if (count != 0) sexp_gc(ctx, NULL);
1256 in = fopen(sexp_string_data(path), "r");
1257 } while (!in && sexp_out_of_file_descriptors() && !count++);
1258 if (!in)
1259 return sexp_file_exception(ctx, self, "couldn't open input file", path);
1260 #if SEXP_USE_GREEN_THREADS
1261 fcntl(fileno(in), F_SETFL, O_NONBLOCK);
1262 #endif
1263 return sexp_make_input_port(ctx, in, path);
1264 }
1265
sexp_open_output_file_op(sexp ctx,sexp self,sexp_sint_t n,sexp path)1266 sexp sexp_open_output_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
1267 FILE *out;
1268 int count = 0;
1269 sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path);
1270 do {
1271 if (count != 0) sexp_gc(ctx, NULL);
1272 out = fopen(sexp_string_data(path), "w");
1273 } while (!out && sexp_out_of_file_descriptors() && !count++);
1274 if (!out)
1275 return sexp_file_exception(ctx, self, "couldn't open output file", path);
1276 #if SEXP_USE_GREEN_THREADS
1277 fcntl(fileno(out), F_SETFL, O_NONBLOCK);
1278 #endif
1279 return sexp_make_output_port(ctx, out, path);
1280 }
1281
sexp_open_binary_input_file(sexp ctx,sexp self,sexp_sint_t n,sexp path)1282 sexp sexp_open_binary_input_file (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
1283 sexp res = sexp_open_input_file_op(ctx, self, n, path);
1284 if (sexp_portp(res)) sexp_port_binaryp(res) = 1;
1285 return res;
1286 }
1287
sexp_open_binary_output_file(sexp ctx,sexp self,sexp_sint_t n,sexp path)1288 sexp sexp_open_binary_output_file (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
1289 sexp res = sexp_open_output_file_op(ctx, self, n, path);
1290 if (sexp_portp(res)) sexp_port_binaryp(res) = 1;
1291 return res;
1292 }
1293
sexp_close_port_op(sexp ctx,sexp self,sexp_sint_t n,sexp port)1294 sexp sexp_close_port_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
1295 sexp res = SEXP_VOID;
1296 sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port);
1297 /* we can't run arbitrary scheme code in the finalizer, so we need */
1298 /* to flush and run the closer here */
1299 if (sexp_port_customp(port)) {
1300 if (sexp_oportp(port)) res = sexp_flush_output(ctx, port);
1301 if (sexp_exceptionp(res)) return res;
1302 if (sexp_applicablep(sexp_port_closer(port)))
1303 res = sexp_apply1(ctx, sexp_port_closer(port), port);
1304 if (sexp_exceptionp(res)) return res;
1305 }
1306 return sexp_finalize_port(ctx, self, n, port);
1307 }
1308
sexp_set_port_line_op(sexp ctx,sexp self,sexp_sint_t n,sexp port,sexp line)1309 sexp sexp_set_port_line_op (sexp ctx, sexp self, sexp_sint_t n, sexp port, sexp line) {
1310 sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, port);
1311 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, line);
1312 sexp_port_sourcep(port) = 1;
1313 sexp_port_line(port) = sexp_unbox_fixnum(line);
1314 return SEXP_VOID;
1315 }
1316
1317 #ifndef PLAN9
sexp_get_port_fileno(sexp ctx,sexp self,sexp_sint_t n,sexp port)1318 sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
1319 int fd;
1320 sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port);
1321 fd = sexp_port_fileno(port);
1322 if (fd >= 0)
1323 return sexp_make_fixnum(fd);
1324 return SEXP_FALSE;
1325 }
sexp_stream_portp_op(sexp ctx,sexp self,sexp_sint_t n,sexp port)1326 sexp sexp_stream_portp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
1327 sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port);
1328 return sexp_make_boolean(sexp_stream_portp(port));
1329 }
1330 #endif
1331
1332 #if SEXP_USE_STATIC_LIBS
1333 #if SEXP_USE_STATIC_LIBS_NO_INCLUDE
1334 extern struct sexp_library_entry_t* sexp_static_libraries;
1335 #else
1336 #include "clibs.c"
1337 #endif
sexp_find_static_library(const char * file)1338 static struct sexp_library_entry_t *sexp_find_static_library(const char *file)
1339 {
1340 size_t base_len;
1341 struct sexp_library_entry_t *entry;
1342
1343 if (file[0] == '.' && file[1] == '/')
1344 file += 2;
1345 base_len = strlen(file) - strlen(sexp_so_extension);
1346 if (strcmp(file + base_len, sexp_so_extension))
1347 return NULL;
1348 for (entry = &sexp_static_libraries[0]; entry->name; entry++)
1349 if (! strncmp(file, entry->name, base_len))
1350 return entry;
1351 return NULL;
1352 }
1353 #else
1354 #define sexp_find_static_library(path) NULL
1355 #endif
1356
1357 #if SEXP_USE_DL
1358 #ifdef _WIN32
1359 #include <windows.h>
sexp_load_dl(sexp ctx,sexp file,sexp env)1360 static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) {
1361 sexp res;
1362 sexp_init_proc init;
1363 HINSTANCE handle = LoadLibraryA(sexp_string_data(file));
1364 if (!handle)
1365 return sexp_compile_error(ctx, "couldn't load dynamic library", file);
1366 init = (sexp_init_proc) GetProcAddress(handle, "sexp_init_library");
1367 if (!init) {
1368 FreeLibrary(handle);
1369 return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file);
1370 }
1371 res = init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER);
1372 if (res == SEXP_ABI_ERROR) res = sexp_global(ctx, SEXP_G_ABI_ERROR);
1373 return res;
1374 }
1375 #else
sexp_make_dl(sexp ctx,sexp file,void * handle)1376 static sexp sexp_make_dl (sexp ctx, sexp file, void* handle) {
1377 sexp res = sexp_alloc_type(ctx, dl, SEXP_DL);
1378 sexp_dl_file(res) = file;
1379 sexp_dl_handle(res) = handle;
1380 return res;
1381 }
sexp_load_dl(sexp ctx,sexp file,sexp env)1382 static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) {
1383 sexp_init_proc init;
1384 sexp_gc_var2(res, old_dl);
1385 void *handle = dlopen(sexp_string_data(file), RTLD_LAZY);
1386 if (! handle) {
1387 return sexp_compile_error(ctx, "couldn't load dynamic library", file);
1388 }
1389 init = dlsym(handle, "sexp_init_library");
1390 if (! init) {
1391 res = sexp_c_string(ctx, dlerror(), -1);
1392 res = sexp_list2(ctx, file, res);
1393 dlclose(handle);
1394 return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", res);
1395 }
1396 sexp_gc_preserve2(ctx, res, old_dl);
1397 old_dl = sexp_context_dl(ctx);
1398 sexp_context_dl(ctx) = sexp_make_dl(ctx, file, handle);
1399 res = init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER);
1400 /* If the ABI is incompatible the library may not even be able to
1401 properly reference a global, so it returns a special immediate
1402 which we need to translate. */
1403 if (res == SEXP_ABI_ERROR) res = sexp_global(ctx, SEXP_G_ABI_ERROR);
1404 sexp_context_dl(ctx) = old_dl;
1405 sexp_gc_release2(ctx);
1406 return res;
1407 }
1408 #endif
1409 #else
1410 #define sexp_load_dl(ctx, file, env) SEXP_UNDEF
1411 #endif
1412
1413 #if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
sexp_load_binary(sexp ctx,sexp file,sexp env)1414 static sexp sexp_load_binary(sexp ctx, sexp file, sexp env) {
1415 #if SEXP_USE_STATIC_LIBS
1416 struct sexp_library_entry_t *entry;
1417 #endif
1418 sexp res = sexp_load_dl(ctx, file, env);
1419 #if SEXP_USE_STATIC_LIBS
1420 if (res == SEXP_UNDEF || sexp_exceptionp(res)) {
1421 entry = sexp_find_static_library(sexp_string_data(file));
1422 if (entry == NULL)
1423 res = (res == SEXP_UNDEF ? sexp_compile_error(ctx, "couldn't find builtin library", file) : res);
1424 else
1425 res = entry->init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER);
1426 }
1427 #endif
1428 return res;
1429 }
1430 #endif
1431
sexp_load_op(sexp ctx,sexp self,sexp_sint_t n,sexp source,sexp env)1432 sexp sexp_load_op (sexp ctx, sexp self, sexp_sint_t n, sexp source, sexp env) {
1433 #if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
1434 const char *suffix;
1435 #endif
1436 sexp_gc_var5(ctx2, x, in, res, out);
1437 if (!env) env = sexp_context_env(ctx);
1438 sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
1439 #if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
1440 suffix = sexp_stringp(source) ? sexp_string_data(source)
1441 + sexp_string_size(source) - strlen(sexp_so_extension) : "...";
1442 if (strcmp(suffix, sexp_so_extension) == 0) {
1443 res = sexp_load_binary(ctx, source, env);
1444 } else {
1445 #endif
1446 res = SEXP_VOID;
1447 if (sexp_iportp(source)) {
1448 in = source;
1449 } else {
1450 sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source);
1451 in = sexp_open_input_file(ctx, source);
1452 }
1453 sexp_gc_preserve5(ctx, ctx2, x, in, res, out);
1454 if (sexp_exceptionp(in)) {
1455 out = sexp_current_error_port(ctx);
1456 if (sexp_not(out)) out = sexp_current_error_port(ctx);
1457 if (sexp_oportp(out))
1458 sexp_print_exception(ctx, in, out);
1459 res = in;
1460 } else {
1461 sexp_port_sourcep(in) = 1;
1462 ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
1463 sexp_context_parent(ctx2) = ctx;
1464 sexp_context_tailp(ctx2) = 0;
1465 while ((x=sexp_read(ctx2, in)) != (sexp) SEXP_EOF) {
1466 res = sexp_exceptionp(x) ? x : sexp_eval(ctx2, x, env);
1467 if (sexp_exceptionp(res))
1468 break;
1469 }
1470 sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2);
1471 if (x == SEXP_EOF)
1472 res = SEXP_VOID;
1473 sexp_close_port(ctx, in);
1474 }
1475 sexp_gc_release5(ctx);
1476 #if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
1477 }
1478 #endif
1479 return res;
1480 }
1481
sexp_register_optimization(sexp ctx,sexp self,sexp_sint_t n,sexp f,sexp priority)1482 sexp sexp_register_optimization (sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp priority) {
1483 sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, f);
1484 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, priority);
1485 sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), SEXP_VOID);
1486 sexp_car(sexp_global(ctx, SEXP_G_OPTIMIZATIONS)) = sexp_cons(ctx, priority, f);
1487 return SEXP_VOID;
1488 }
1489
1490 #if SEXP_USE_MATH
1491
1492 #if SEXP_USE_BIGNUMS
1493 #define maybe_convert_bignum(z) \
1494 else if (sexp_bignump(z)) d = sexp_bignum_to_double(z);
1495 #else
1496 #define maybe_convert_bignum(z)
1497 #endif
1498
1499 #if SEXP_USE_RATIOS
1500 #define maybe_convert_ratio(ctx, z) \
1501 else if (sexp_ratiop(z)) d = sexp_ratio_to_double(ctx, z);
1502 #else
1503 #define maybe_convert_ratio(ctx, z)
1504 #endif
1505
1506 #if SEXP_USE_COMPLEX
1507 #define maybe_convert_complex(z, f) \
1508 else if (sexp_complexp(z)) return sexp_complex_normalize(f(ctx, z));
1509 #define sexp_complex_dummy(ctx, z) 0
1510 #else
1511 #define maybe_convert_complex(z, f)
1512 #endif
1513
1514 #define define_math_op(name, cname, f) \
1515 sexp name (sexp ctx, sexp self, sexp_sint_t n, sexp z) { \
1516 double d; \
1517 if (sexp_flonump(z)) \
1518 d = sexp_flonum_value(z); \
1519 else if (sexp_fixnump(z)) \
1520 d = (double)sexp_unbox_fixnum(z); \
1521 maybe_convert_ratio(ctx, z) \
1522 maybe_convert_bignum(z) \
1523 maybe_convert_complex(z, f) \
1524 else \
1525 return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \
1526 return sexp_make_flonum(ctx, cname(d)); \
1527 }
1528
1529 #if SEXP_USE_COMPLEX
1530 #define define_complex_math_op(name, cname, f, a, b) \
1531 sexp name (sexp ctx, sexp self, sexp_sint_t n, sexp z) { \
1532 double d; \
1533 if (sexp_flonump(z)) \
1534 d = sexp_flonum_value(z); \
1535 else if (sexp_fixnump(z)) \
1536 d = (double)sexp_unbox_fixnum(z); \
1537 maybe_convert_ratio(ctx, z) \
1538 maybe_convert_bignum(z) \
1539 maybe_convert_complex(z, f) \
1540 else \
1541 return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \
1542 if (d < a || d > b) \
1543 return sexp_complex_normalize \
1544 (f(ctx, sexp_make_complex(ctx, z, SEXP_ZERO))); \
1545 return sexp_make_flonum(ctx, cname(d)); \
1546 }
1547 #else
1548 #define define_complex_math_op(name, cname, f, a, b) \
1549 define_math_op(name, cname, f)
1550 #endif
1551
define_math_op(sexp_exp,exp,sexp_complex_exp)1552 define_math_op(sexp_exp, exp, sexp_complex_exp)
1553 define_math_op(sexp_sin, sin, sexp_complex_sin)
1554 define_math_op(sexp_cos, cos, sexp_complex_cos)
1555 define_math_op(sexp_tan, tan, sexp_complex_tan)
1556 define_complex_math_op(sexp_asin, asin, sexp_complex_asin, -1, 1)
1557 define_complex_math_op(sexp_acos, acos, sexp_complex_acos, -1, 1)
1558 define_math_op(sexp_atan, atan, sexp_complex_atan)
1559
1560 #if SEXP_USE_RATIOS
1561 #define maybe_round_ratio(ctx, q, f) \
1562 if (sexp_ratiop(q)) return f(ctx, q);
1563 #else
1564 #define maybe_round_ratio(ctx, q, f)
1565 #endif
1566
1567 #define define_math_rounder(name, cname, f) \
1568 sexp name (sexp ctx, sexp self, sexp_sint_t n, sexp z) { \
1569 maybe_round_ratio(ctx, z, f) \
1570 if (sexp_flonump(z)) \
1571 return sexp_make_flonum(ctx, cname(sexp_flonum_value(z))); \
1572 else if (sexp_fixnump(z) || sexp_bignump(z)) \
1573 return z; \
1574 return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \
1575 }
1576
1577 static double even_round (double d) {
1578 double res = round(d);
1579 if (fabs(d - res) == 0.5 && ((long)res & 1))
1580 res += (res < 0) ? 1 : -1;
1581 return res;
1582 }
1583
define_math_rounder(sexp_round,even_round,sexp_ratio_round)1584 define_math_rounder(sexp_round, even_round, sexp_ratio_round)
1585 define_math_rounder(sexp_trunc, trunc, sexp_ratio_trunc)
1586 define_math_rounder(sexp_floor, floor, sexp_ratio_floor)
1587 define_math_rounder(sexp_ceiling, ceil, sexp_ratio_ceiling)
1588
1589 sexp sexp_log (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
1590 double d;
1591 #if SEXP_USE_COMPLEX
1592 sexp_gc_var1(tmp);
1593 if (sexp_complexp(z))
1594 return sexp_complex_log(ctx, z);
1595 #endif
1596 if (sexp_flonump(z))
1597 d = sexp_flonum_value(z);
1598 else if (sexp_fixnump(z))
1599 d = (double)sexp_unbox_fixnum(z);
1600 maybe_convert_ratio(ctx, z)
1601 maybe_convert_bignum(z)
1602 else
1603 return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
1604 #if SEXP_USE_COMPLEX
1605 if (d < 0) {
1606 sexp_gc_preserve1(ctx, tmp);
1607 tmp = sexp_make_flonum(ctx, d);
1608 tmp = sexp_make_complex(ctx, tmp, SEXP_ZERO);
1609 tmp = sexp_complex_log(ctx, tmp);
1610 sexp_gc_release1(ctx);
1611 return tmp;
1612 }
1613 #endif
1614 return sexp_make_flonum(ctx, log(d));
1615 }
1616
sexp_inexact_sqrt(sexp ctx,sexp self,sexp_sint_t n,sexp z)1617 sexp sexp_inexact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
1618 #if SEXP_USE_COMPLEX
1619 int negativep = 0;
1620 #endif
1621 double d, r;
1622 sexp_gc_var1(res);
1623 if (sexp_flonump(z))
1624 d = sexp_flonum_value(z);
1625 else if (sexp_fixnump(z))
1626 d = (double)sexp_unbox_fixnum(z);
1627 maybe_convert_ratio(ctx, z) /* XXXX add ratio sqrt */
1628 maybe_convert_complex(z, sexp_complex_sqrt)
1629 else
1630 return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
1631 #if SEXP_USE_COMPLEX
1632 if (d < 0) {
1633 negativep = 1;
1634 d = -d;
1635 }
1636 #endif
1637 sexp_gc_preserve1(ctx, res);
1638 r = sqrt(d);
1639 if (sexp_fixnump(z)
1640 && (((sexp_uint_t)r*(sexp_uint_t)r)==labs(sexp_unbox_fixnum(z))))
1641 res = sexp_make_fixnum(round(r));
1642 else
1643 res = sexp_make_flonum(ctx, r);
1644 #if SEXP_USE_COMPLEX
1645 if (negativep)
1646 res = sexp_make_complex(ctx, SEXP_ZERO, res);
1647 #endif
1648 sexp_gc_release1(ctx);
1649 return res;
1650 }
1651
1652 #if SEXP_USE_BIGNUMS
sexp_exact_sqrt(sexp ctx,sexp self,sexp_sint_t n,sexp z)1653 sexp sexp_exact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
1654 sexp_gc_var2(res, rem);
1655 sexp_gc_preserve2(ctx, res, rem);
1656 if (sexp_bignump(z)) {
1657 res = sexp_bignum_sqrt(ctx, z, &rem);
1658 res = sexp_cons(ctx, res, rem);
1659 } else {
1660 res = sexp_inexact_sqrt(ctx, self, n, z);
1661 if (sexp_flonump(res)) {
1662 res = sexp_bignum_normalize(sexp_double_to_bignum(ctx, trunc(sexp_flonum_value(res))));
1663 }
1664 if (!sexp_exceptionp(res)) {
1665 rem = sexp_mul(ctx, res, res);
1666 rem = sexp_sub(ctx, z, rem);
1667 res = sexp_cons(ctx, res, rem);
1668 }
1669 }
1670 sexp_gc_release2(ctx);
1671 return res;
1672 }
1673 #endif
1674
sexp_sqrt(sexp ctx,sexp self,sexp_sint_t n,sexp z)1675 sexp sexp_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
1676 #if SEXP_USE_BIGNUMS || SEXP_USE_RATIOS
1677 sexp_gc_var2(res, rem);
1678 #endif
1679 #if SEXP_USE_BIGNUMS
1680 if (sexp_bignump(z)) {
1681 sexp_gc_preserve2(ctx, res, rem);
1682 res = sexp_bignum_sqrt(ctx, z, &rem);
1683 rem = sexp_bignum_normalize(rem);
1684 if (rem != SEXP_ZERO)
1685 res = sexp_make_flonum(ctx, sexp_fixnump(res) ? sexp_unbox_fixnum(res) : sexp_bignum_to_double(res));
1686 sexp_gc_release2(ctx);
1687 return res;
1688 }
1689 #endif
1690 #if SEXP_USE_RATIOS
1691 if (sexp_ratiop(z)) {
1692 sexp_gc_preserve2(ctx, res, rem);
1693 res = sexp_sqrt(ctx, self, n, sexp_ratio_numerator(z));
1694 rem = sexp_sqrt(ctx, self, n, sexp_ratio_denominator(z));
1695 if (sexp_exactp(res) && sexp_exactp(rem)) {
1696 res = sexp_make_ratio(ctx, res, rem);
1697 } else {
1698 res = sexp_inexact_sqrt(ctx, self, n, z);
1699 }
1700 sexp_gc_release2(ctx);
1701 return res;
1702 }
1703 #endif
1704 return sexp_inexact_sqrt(ctx, self, n, z);
1705 }
1706
1707 #endif /* SEXP_USE_MATH */
1708
1709 #if SEXP_USE_RATIOS || !SEXP_USE_FLONUMS
sexp_generic_expt(sexp ctx,sexp x,sexp_sint_t e)1710 sexp sexp_generic_expt (sexp ctx, sexp x, sexp_sint_t e) {
1711 sexp_gc_var2(res, tmp);
1712 sexp_gc_preserve2(ctx, res, tmp);
1713 for (res = SEXP_ONE, tmp = x; e > 0; e >>= 1) {
1714 if (e&1) res = sexp_mul(ctx, res, tmp);
1715 tmp = sexp_mul(ctx, tmp, tmp);
1716 }
1717 sexp_gc_release2(ctx);
1718 return res;
1719 }
1720 #endif
1721
sexp_expt_op(sexp ctx,sexp self,sexp_sint_t n,sexp x,sexp e)1722 sexp sexp_expt_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
1723 #if !SEXP_USE_FLONUMS
1724 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, x);
1725 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, e);
1726 return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e));
1727 #else
1728 long double f, x1, e1;
1729 sexp res;
1730 #if SEXP_USE_BIGNUMS
1731 sexp_gc_var1(tmp);
1732 #endif
1733 #if SEXP_USE_COMPLEX
1734 if (sexp_complexp(x) || sexp_complexp(e))
1735 return sexp_complex_expt(ctx, x, e);
1736 #endif
1737 #if SEXP_USE_BIGNUMS
1738 if (sexp_bignump(e)) { /* bignum exponent needs special handling */
1739 if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE))
1740 res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */
1741 else if (x == SEXP_ONE)
1742 res = SEXP_ONE; /* 1.0 */
1743 else if (sexp_flonump(x))
1744 res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e)));
1745 else
1746 res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */
1747 } else if (sexp_bignump(x)) {
1748 res = sexp_bignum_expt(ctx, x, e);
1749 } else {
1750 #endif
1751 if (sexp_fixnump(x))
1752 x1 = sexp_unbox_fixnum(x);
1753 else if (sexp_flonump(x))
1754 x1 = sexp_flonum_value(x);
1755 #if SEXP_USE_RATIOS
1756 else if (sexp_ratiop(x)) {
1757 if (sexp_fixnump(e)) {
1758 return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e));
1759 } else {
1760 x1 = sexp_ratio_to_double(ctx, x);
1761 }
1762 }
1763 #endif
1764 else
1765 return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
1766 if (sexp_fixnump(e))
1767 e1 = sexp_unbox_fixnum(e);
1768 else if (sexp_flonump(e))
1769 e1 = sexp_flonum_value(e);
1770 #if SEXP_USE_RATIOS
1771 else if (sexp_ratiop(e))
1772 e1 = sexp_ratio_to_double(ctx, e);
1773 #endif
1774 else
1775 return sexp_type_exception(ctx, self, SEXP_FIXNUM, e);
1776 f = pow(x1, e1);
1777 if ((f*1000.0 > SEXP_MAX_FIXNUM) || (f*1000.0 < SEXP_MIN_FIXNUM)
1778 || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) || (e1 < 0.0)) {
1779 #if SEXP_USE_BIGNUMS
1780 if (sexp_fixnump(x) && sexp_fixnump(e)) {
1781 sexp_gc_preserve1(ctx, tmp);
1782 tmp = sexp_fixnum_to_bignum(ctx, x);
1783 res = sexp_bignum_expt(ctx, tmp, e);
1784 sexp_gc_release1(ctx);
1785 } else
1786 #endif
1787 res = sexp_make_flonum(ctx, f);
1788 } else
1789 res = sexp_make_fixnum((sexp_sint_t)round(f));
1790 #if SEXP_USE_BIGNUMS
1791 }
1792 #endif
1793 return res;
1794 #endif /* !SEXP_USE_FLONUMS */
1795 }
1796
1797 #if SEXP_USE_RATIOS
sexp_ratio_numerator_op(sexp ctx,sexp self,sexp_sint_t n,sexp rat)1798 sexp sexp_ratio_numerator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat) {
1799 sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat);
1800 return sexp_ratio_numerator(rat);
1801 }
sexp_ratio_denominator_op(sexp ctx,sexp self,sexp_sint_t n,sexp rat)1802 sexp sexp_ratio_denominator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat) {
1803 sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat);
1804 return sexp_ratio_denominator(rat);
1805 }
1806 #endif
1807
1808 #if SEXP_USE_COMPLEX
sexp_complex_real_op(sexp ctx,sexp self,sexp_sint_t n,sexp cpx)1809 sexp sexp_complex_real_op (sexp ctx, sexp self, sexp_sint_t n, sexp cpx) {
1810 sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx);
1811 return sexp_complex_real(cpx);
1812 }
sexp_complex_imag_op(sexp ctx,sexp self,sexp_sint_t n,sexp cpx)1813 sexp sexp_complex_imag_op (sexp ctx, sexp self, sexp_sint_t n, sexp cpx) {
1814 sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx);
1815 return sexp_complex_imag(cpx);
1816 }
1817 #endif
1818
sexp_exact_to_inexact(sexp ctx,sexp self,sexp_sint_t n,sexp i)1819 sexp sexp_exact_to_inexact (sexp ctx, sexp self, sexp_sint_t n, sexp i) {
1820 sexp_gc_var1(res);
1821 res = i;
1822 if (sexp_fixnump(i))
1823 res = sexp_fixnum_to_flonum(ctx, i);
1824 #if SEXP_USE_FLONUMS
1825 else if (sexp_flonump(i))
1826 res = i;
1827 #endif
1828 #if SEXP_USE_BIGNUMS
1829 else if (sexp_bignump(i))
1830 res = sexp_make_flonum(ctx, sexp_bignum_to_double(i));
1831 #endif
1832 #if SEXP_USE_RATIOS
1833 else if (sexp_ratiop(i))
1834 res = sexp_make_flonum(ctx, sexp_ratio_to_double(ctx, i));
1835 #endif
1836 #if SEXP_USE_COMPLEX
1837 else if (sexp_complexp(i)) {
1838 sexp_gc_preserve1(ctx, res);
1839 res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
1840 sexp_complex_real(res) = sexp_exact_to_inexact(ctx, self, 1, sexp_complex_real(i));
1841 sexp_complex_imag(res) = sexp_exact_to_inexact(ctx, self, 1, sexp_complex_imag(i));
1842 sexp_gc_release1(ctx);
1843 }
1844 #endif
1845 else
1846 res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i);
1847 return res;
1848 }
1849
sexp_inexact_to_exact(sexp ctx,sexp self,sexp_sint_t n,sexp z)1850 sexp sexp_inexact_to_exact (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
1851 sexp_gc_var1(res);
1852 if (sexp_exactp(z)) {
1853 res = z;
1854 }
1855 #if SEXP_USE_FLONUMS
1856 else if (sexp_flonump(z)) {
1857 if (isinf(sexp_flonum_value(z)) || isnan(sexp_flonum_value(z))) {
1858 res = sexp_xtype_exception(ctx, self, "exact: not a finite number", z);
1859 } else if (sexp_flonum_value(z) != trunc(sexp_flonum_value(z))) {
1860 #if SEXP_USE_RATIOS
1861 res = sexp_double_to_ratio_2(ctx, sexp_flonum_value(z));
1862 #else
1863 res = sexp_xtype_exception(ctx, self, "exact: not an integer", z);
1864 #endif
1865 #if SEXP_USE_BIGNUMS
1866 } else if ((sexp_flonum_value(z) > SEXP_MAX_FIXNUM)
1867 || sexp_flonum_value(z) < SEXP_MIN_FIXNUM) {
1868 res = sexp_double_to_bignum(ctx, sexp_flonum_value(z));
1869 #endif
1870 } else {
1871 res = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(z));
1872 }
1873 }
1874 #endif
1875 #if SEXP_USE_COMPLEX
1876 else if (sexp_complexp(z)) {
1877 sexp_gc_preserve1(ctx, res);
1878 res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
1879 sexp_complex_real(res) = sexp_inexact_to_exact(ctx, self, 1, sexp_complex_real(z));
1880 sexp_complex_imag(res) = sexp_inexact_to_exact(ctx, self, 1, sexp_complex_imag(z));
1881 if (sexp_exceptionp(sexp_complex_real(res)))
1882 res = sexp_complex_real(res);
1883 else if (sexp_exceptionp(sexp_complex_imag(res)))
1884 res = sexp_complex_imag(res);
1885 else if (sexp_complex_imag(res) == SEXP_ZERO)
1886 res = sexp_complex_real(res);
1887 sexp_gc_release1(ctx);
1888 }
1889 #endif
1890 else {
1891 res = sexp_type_exception(ctx, self, SEXP_FLONUM, z);
1892 }
1893 return res;
1894 }
1895
sexp_string_cmp_op(sexp ctx,sexp self,sexp_sint_t n,sexp str1,sexp str2,sexp ci)1896 sexp sexp_string_cmp_op (sexp ctx, sexp self, sexp_sint_t n, sexp str1, sexp str2, sexp ci) {
1897 sexp_sint_t len1, len2, len, diff;
1898 sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1);
1899 sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2);
1900 len1 = sexp_string_size(str1);
1901 len2 = sexp_string_size(str2);
1902 len = ((len1<len2) ? len1 : len2);
1903 if (ci==SEXP_FALSE)
1904 diff = strncmp(sexp_string_data(str1), sexp_string_data(str2), len);
1905 else
1906 diff = strncasecmp(sexp_string_data(str1), sexp_string_data(str2), len);
1907 if (! diff)
1908 diff = len1 - len2;
1909 return sexp_make_fixnum(diff);
1910 }
1911
1912 #if SEXP_USE_UTF8_STRINGS
1913
sexp_string_utf8_index_ref(sexp ctx,sexp self,sexp_sint_t n,sexp str,sexp i)1914 sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i) {
1915 sexp off;
1916 sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
1917 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
1918 off = sexp_string_index_to_cursor(ctx, self, n, str, i);
1919 if (sexp_exceptionp(off)) return off;
1920 if (sexp_unbox_string_cursor(off) >= (sexp_sint_t)sexp_string_size(str))
1921 return sexp_user_exception(ctx, self, "string-ref: index out of range", i);
1922 return sexp_string_utf8_ref(ctx, str, off);
1923 }
1924
sexp_read_utf8_char(sexp ctx,sexp port,int i)1925 sexp sexp_read_utf8_char (sexp ctx, sexp port, int i) {
1926 if (i >= 0x80) {
1927 if ((i < 0xC0) || (i > 0xF7)) {
1928 return sexp_user_exception(ctx, NULL, "read-char: invalid utf8 byte", sexp_make_fixnum(i));
1929 } else if (i < 0xE0) {
1930 i = ((i&0x3F)<<6) + (sexp_read_char(ctx, port)&0x3F);
1931 } else if (i < 0xF0) {
1932 i = ((i&0x1F)<<12) + ((sexp_read_char(ctx, port)&0x3F)<<6);
1933 i += sexp_read_char(ctx, port)&0x3F;
1934 } else {
1935 i = ((i&0x0F)<<18) + ((sexp_read_char(ctx, port)&0x3F)<<12);
1936 i += (sexp_read_char(ctx, port)&0x3F)<<6;
1937 i += sexp_read_char(ctx, port)&0x3F;
1938 }
1939 }
1940 return sexp_make_character(i);
1941 }
1942
sexp_push_utf8_char(sexp ctx,int i,sexp port)1943 void sexp_push_utf8_char (sexp ctx, int i, sexp port) {
1944 unsigned char ch[6];
1945 int len = sexp_utf8_char_byte_count(i);
1946 sexp_utf8_encode_char(ch, len, i);
1947 if (sexp_port_stream(port)) {
1948 while (len>0)
1949 ungetc(ch[--len], sexp_port_stream(port));
1950 } else {
1951 while (len>0)
1952 sexp_port_buf(port)[--sexp_port_offset(port)] = ch[--len];
1953 }
1954 }
1955
1956 #if SEXP_USE_MUTABLE_STRINGS
1957
sexp_string_utf8_set(sexp ctx,sexp str,sexp index,sexp ch)1958 void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) {
1959 sexp b;
1960 unsigned char *p, *q;
1961 int i = sexp_unbox_string_cursor(index), c = sexp_unbox_character(ch),
1962 old_len, new_len, len;
1963 p = (unsigned char*)sexp_string_data(str) + i;
1964 old_len = sexp_utf8_initial_byte_count(*p);
1965 new_len = sexp_utf8_char_byte_count(c);
1966 if (old_len != new_len) { /* resize bytes if needed */
1967 len = sexp_string_size(str)+(new_len-old_len);
1968 b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID);
1969 if (! sexp_exceptionp(b)) {
1970 q = (unsigned char*)sexp_bytes_data(b);
1971 memcpy(q, sexp_string_data(str), i);
1972 memcpy(q+i+new_len, p+old_len, len-i-new_len+1);
1973 sexp_string_bytes(str) = b;
1974 p = q + i;
1975 }
1976 sexp_string_size(str) += new_len - old_len;
1977 }
1978 sexp_utf8_encode_char(p, new_len, c);
1979 if (old_len != new_len)
1980 sexp_update_string_index_lookup(ctx, str);
1981 }
1982
sexp_string_utf8_index_set(sexp ctx,sexp self,sexp_sint_t n,sexp str,sexp i,sexp ch)1983 sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch) {
1984 sexp off;
1985 sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
1986 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
1987 sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch);
1988 off = sexp_string_index_to_cursor(ctx, self, n, str, i);
1989 if (sexp_exceptionp(off)) return off;
1990 if (sexp_unbox_string_cursor(off) >= (sexp_sint_t)sexp_string_size(str))
1991 return sexp_user_exception(ctx, self, "string-set!: index out of range", i);
1992 sexp_string_utf8_set(ctx, str, off, ch);
1993 return SEXP_VOID;
1994 }
1995
1996 #endif
1997 #endif
1998
1999 #if SEXP_USE_AUTO_FORCE
sexp_make_promise(sexp ctx,sexp self,sexp_sint_t n,sexp done,sexp val)2000 sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val) {
2001 sexp res = sexp_alloc_type(ctx, promise, SEXP_PROMISE);
2002 sexp_promise_donep(res) = sexp_unbox_boolean(done);
2003 sexp_promise_value(res) = val;
2004 return res;
2005 }
2006 #endif
2007
2008 /***************************** opcodes ********************************/
2009
2010 #if SEXP_USE_TYPE_DEFS
2011
sexp_type_slot_offset_op(sexp ctx,sexp self,sexp_sint_t n,sexp type,sexp slot)2012 sexp sexp_type_slot_offset_op (sexp ctx , sexp self, sexp_sint_t n, sexp type, sexp slot) {
2013 sexp cpl, slots, *v;
2014 int i, offset, len;
2015 sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, type);
2016 cpl = sexp_type_cpl(type);
2017 if (sexp_vectorp(cpl)) {
2018 v = sexp_vector_data(cpl);
2019 len = sexp_vector_length(cpl);
2020 } else {
2021 v = &sexp_type_slots(type);
2022 len = 1;
2023 }
2024 len = sexp_vectorp(cpl) ? sexp_vector_length(cpl) : 1;
2025 for (i=len-1; i>=0; --i)
2026 for (slots=sexp_type_slots(v[i]), offset=0; sexp_pairp(slots); slots=sexp_cdr(slots), ++offset)
2027 if (sexp_car(slots) == slot) {
2028 while (--i>=0)
2029 offset += sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(v[i])));
2030 return sexp_make_fixnum(offset);
2031 }
2032 return SEXP_FALSE;
2033 }
2034
sexp_make_type_predicate_op(sexp ctx,sexp self,sexp_sint_t n,sexp name,sexp type)2035 sexp sexp_make_type_predicate_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type) {
2036 if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
2037 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
2038 return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE),
2039 sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO,
2040 SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL);
2041 }
2042
sexp_make_constructor_op(sexp ctx,sexp self,sexp_sint_t n,sexp name,sexp type)2043 sexp sexp_make_constructor_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type) {
2044 sexp_uint_t type_size;
2045 if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
2046 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
2047 type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type)));
2048 return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR),
2049 sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO,
2050 SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type,
2051 sexp_make_fixnum(type_size), NULL);
2052 }
2053
sexp_make_getter_op(sexp ctx,sexp self,sexp_sint_t n,sexp name,sexp type,sexp index)2054 sexp sexp_make_getter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index) {
2055 if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
2056 if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0))
2057 return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
2058 if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
2059 return sexp_type_exception(ctx, self, SEXP_FIXNUM, index);
2060 return
2061 sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER),
2062 sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO,
2063 type, SEXP_ZERO, SEXP_ZERO, type, index, NULL);
2064 }
2065
sexp_make_setter_op(sexp ctx,sexp self,sexp_sint_t n,sexp name,sexp type,sexp index)2066 sexp sexp_make_setter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index) {
2067 sexp res;
2068 if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
2069 if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0))
2070 return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
2071 if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
2072 return sexp_type_exception(ctx, self, SEXP_FIXNUM, index);
2073 res
2074 = sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER),
2075 sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO,
2076 type, SEXP_ZERO, SEXP_ZERO, type, index, NULL);
2077 if (!sexp_exceptionp(res)) sexp_opcode_return_type(res) = SEXP_VOID;
2078 return res;
2079 }
2080
2081 #endif
2082
sexp_copy_core(sexp ctx,struct sexp_core_form_struct * core)2083 static sexp sexp_copy_core (sexp ctx, struct sexp_core_form_struct *core) {
2084 sexp res = sexp_alloc_type(ctx, core, SEXP_CORE);
2085 memcpy(&(res->value), core, sizeof(core[0]));
2086 return res;
2087 }
2088
sexp_copy_opcode(sexp ctx,struct sexp_opcode_struct * op)2089 static sexp sexp_copy_opcode (sexp ctx, struct sexp_opcode_struct *op) {
2090 sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
2091 memcpy(&(res->value), op, sizeof(op[0]));
2092 return res;
2093 }
2094
sexp_make_opcode(sexp ctx,sexp self,sexp name,sexp op_class,sexp code,sexp num_args,sexp flags,sexp arg1t,sexp arg2t,sexp invp,sexp data,sexp data2,sexp_proc1 func)2095 sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code,
2096 sexp num_args, sexp flags, sexp arg1t, sexp arg2t,
2097 sexp invp, sexp data, sexp data2, sexp_proc1 func) {
2098 sexp res;
2099 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, num_args);
2100 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, flags);
2101 if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0)
2102 || (sexp_unbox_fixnum(op_class) >= SEXP_OPC_NUM_OP_CLASSES))
2103 res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class);
2104 else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0)
2105 || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES))
2106 res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code);
2107 else {
2108 res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
2109 sexp_opcode_class(res) = (unsigned char)sexp_unbox_fixnum(op_class);
2110 sexp_opcode_code(res) = (unsigned char)sexp_unbox_fixnum(code);
2111 sexp_opcode_num_args(res) = (unsigned char)sexp_unbox_fixnum(num_args);
2112 sexp_opcode_flags(res) = (unsigned char)sexp_unbox_fixnum(flags);
2113 sexp_opcode_arg1_type(res) = arg1t;
2114 sexp_opcode_arg2_type(res) = arg2t;
2115 sexp_opcode_inverse(res) = (unsigned char)sexp_unbox_fixnum(invp);
2116 sexp_opcode_data(res) = data;
2117 sexp_opcode_data2(res) = data2;
2118 sexp_opcode_func(res) = func;
2119 sexp_opcode_name(res) = name;
2120 #if SEXP_USE_DL
2121 sexp_opcode_dl(res) = sexp_context_dl(ctx);
2122 #endif
2123 }
2124 return res;
2125 }
2126
sexp_make_foreign(sexp ctx,const char * name,int num_args,int flags,const char * fname,sexp_proc1 f,sexp data)2127 sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
2128 int flags, const char *fname, sexp_proc1 f, sexp data) {
2129 sexp_gc_var1(res);
2130 sexp_gc_preserve1(ctx, res);
2131 #if ! SEXP_USE_EXTENDED_FCALL
2132 if (num_args > 4)
2133 return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit",
2134 sexp_make_fixnum(num_args));
2135 #endif
2136 res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
2137 sexp_opcode_class(res) = SEXP_OPC_FOREIGN;
2138 #if SEXP_USE_EXTENDED_FCALL
2139 if (num_args > 4)
2140 sexp_opcode_code(res) = SEXP_OP_FCALLN;
2141 else
2142 #endif
2143 sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1;
2144 if (flags & 1) num_args--;
2145 sexp_opcode_num_args(res) = num_args;
2146 sexp_opcode_flags(res) = flags;
2147 sexp_opcode_name(res) = sexp_c_string(ctx, name, -1);
2148 sexp_opcode_data(res) = data;
2149 sexp_opcode_func(res) = f;
2150 if (fname) {
2151 sexp_opcode_data2(res) = sexp_c_string(ctx, fname, -1);
2152 }
2153 #if SEXP_USE_DL
2154 sexp_opcode_dl(res) = sexp_context_dl(ctx);
2155 #endif
2156 sexp_gc_release1(ctx);
2157 return res;
2158 }
2159
sexp_define_foreign_aux(sexp ctx,sexp env,const char * name,int num_args,int flags,const char * fname,sexp_proc1 f,sexp data)2160 sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args,
2161 int flags, const char *fname, sexp_proc1 f, sexp data) {
2162 sexp_gc_var2(sym, res);
2163 sexp_gc_preserve2(ctx, sym, res);
2164 res = sexp_make_foreign(ctx, name, num_args, flags, fname, f, data);
2165 if (!sexp_exceptionp(res))
2166 sexp_env_define(ctx, env, sym = sexp_intern(ctx, name, -1), res);
2167 sexp_gc_release2(ctx);
2168 return res;
2169 }
2170
sexp_define_foreign_param_aux(sexp ctx,sexp env,const char * name,int num_args,const char * fname,sexp_proc1 f,const char * param)2171 sexp sexp_define_foreign_param_aux (sexp ctx, sexp env, const char *name,
2172 int num_args, const char *fname, sexp_proc1 f, const char *param) {
2173 sexp res = SEXP_FALSE;
2174 sexp_gc_var1(tmp);
2175 sexp_gc_preserve1(ctx, tmp);
2176 tmp = sexp_intern(ctx, param, -1);
2177 tmp = sexp_env_ref(ctx, env, tmp, SEXP_FALSE);
2178 if (sexp_opcodep(tmp))
2179 res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, fname, f, tmp);
2180 sexp_gc_release1(ctx);
2181 return res;
2182 }
2183
2184 /*********************** standard environment *************************/
2185
2186 /* The 10 core forms. Note quote can be defined as derived syntax: */
2187
2188 /* (define-syntax quote */
2189 /* (lambda (expr use-env mac-env) */
2190 /* (list */
2191 /* (make-syntactic-closure mac-env (list) (syntax-quote syntax-quote)) */
2192 /* (strip-syntactic-closures (car (cdr expr)))))) */
2193
2194 static struct sexp_core_form_struct core_forms[] = {
2195 {SEXP_CORE_DEFINE, (sexp)"define"},
2196 {SEXP_CORE_SET, (sexp)"set!"},
2197 {SEXP_CORE_LAMBDA, (sexp)"lambda"},
2198 {SEXP_CORE_IF, (sexp)"if"},
2199 {SEXP_CORE_BEGIN, (sexp)"begin"},
2200 {SEXP_CORE_QUOTE, (sexp)"quote"},
2201 {SEXP_CORE_SYNTAX_QUOTE, (sexp)"syntax-quote"},
2202 {SEXP_CORE_DEFINE_SYNTAX, (sexp)"%define-syntax"},
2203 {SEXP_CORE_LET_SYNTAX, (sexp)"%let-syntax"},
2204 {SEXP_CORE_LETREC_SYNTAX, (sexp)"%letrec-syntax"},
2205 };
2206
sexp_make_env_op(sexp ctx,sexp self,sexp_sint_t n)2207 sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) {
2208 sexp e = sexp_alloc_type(ctx, env, SEXP_ENV);
2209 sexp_env_lambda(e) = NULL;
2210 sexp_env_parent(e) = NULL;
2211 sexp_env_bindings(e) = SEXP_NULL;
2212 #if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
2213 sexp_env_renames(e) = SEXP_NULL;
2214 #endif
2215 return e;
2216 }
2217
sexp_make_null_env_op(sexp ctx,sexp self,sexp_sint_t n,sexp version)2218 sexp sexp_make_null_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) {
2219 sexp_uint_t i;
2220 sexp_gc_var2(e, core);
2221 sexp_gc_preserve2(ctx, e, core);
2222 e = sexp_make_env(ctx);
2223 for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) {
2224 core = sexp_copy_core(ctx, &core_forms[i]);
2225 sexp_env_define(ctx, e, sexp_intern(ctx, (char*)sexp_core_name(core), -1), core);
2226 sexp_core_name(core) = sexp_c_string(ctx, (char*)sexp_core_name(core), -1);
2227 }
2228 sexp_gc_release2(ctx);
2229 return e;
2230 }
2231
2232 extern struct sexp_opcode_struct* sexp_primitive_opcodes; /* from opcodes.c */
2233
sexp_make_primitive_env_op(sexp ctx,sexp self,sexp_sint_t n,sexp version)2234 sexp sexp_make_primitive_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) {
2235 int i;
2236 sexp_gc_var4(e, op, sym, name);
2237 sexp_gc_preserve4(ctx, e, op, sym, name);
2238 e = sexp_make_null_env(ctx, version);
2239 for (i=0; sexp_primitive_opcodes[i].op_class; i++) {
2240 op = sexp_copy_opcode(ctx, &sexp_primitive_opcodes[i]);
2241 name = sexp_intern(ctx, (char*)sexp_opcode_name(op), -1);
2242 sexp_opcode_name(op) = sexp_c_string(ctx, (char*)sexp_opcode_name(op), -1);
2243 if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) {
2244 sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1);
2245 sexp_opcode_data(op) = sexp_env_ref(ctx, e, sym, SEXP_FALSE);
2246 } else if (sexp_opcode_class(op) == SEXP_OPC_PARAMETER) {
2247 sexp_opcode_data(op) = sexp_cons(ctx, name, SEXP_FALSE);
2248 }
2249 if (sexp_opcode_class(op) == SEXP_OPC_FOREIGN && sexp_opcode_data2(op)) {
2250 sexp_opcode_data2(op) = sexp_c_string(ctx, (char*)sexp_opcode_data2(op), -1);
2251 }
2252 sexp_env_define(ctx, e, name, op);
2253 }
2254 sexp_gc_release4(ctx);
2255 return e;
2256 }
2257
sexp_find_module_file_raw(sexp ctx,const char * file)2258 char* sexp_find_module_file_raw (sexp ctx, const char *file) {
2259 sexp ls;
2260 char *dir, *path;
2261 sexp_uint_t slash, dirlen, filelen, len;
2262 #ifdef PLAN9
2263 #define file_exists_p(path, buf) (stat(path, buf, 128) >= 0)
2264 unsigned char buf[128];
2265 #else
2266 #define file_exists_p(path, buf) (! stat(path, buf))
2267 struct stat buf_str;
2268 struct stat *buf = &buf_str;
2269 #endif
2270
2271 filelen = strlen(file);
2272
2273 ls = sexp_global(ctx, SEXP_G_MODULE_PATH);
2274 for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
2275 dir = sexp_string_data(sexp_car(ls));
2276 dirlen = sexp_string_size(sexp_car(ls));
2277 slash = dir[dirlen-1] == '/';
2278 len = dirlen+filelen+2-slash;
2279 path = (char*) sexp_malloc(len);
2280 if (! path) return NULL;
2281 memcpy(path, dir, dirlen);
2282 if (! slash) path[dirlen] = '/';
2283 memcpy(path+len-filelen-1, file, filelen);
2284 path[len-1] = '\0';
2285 if (sexp_find_static_library(path) || file_exists_p(path, buf))
2286 return path;
2287 free(path);
2288 }
2289
2290 return NULL;
2291 }
2292
sexp_find_module_file(sexp ctx,const char * file)2293 sexp sexp_find_module_file (sexp ctx, const char *file) {
2294 char* path = sexp_find_module_file_raw(ctx, file);
2295 sexp res = sexp_c_string(ctx, path, -1);
2296 if (path) free(path);
2297 return res;
2298 }
2299
2300 #define sexp_file_not_found "couldn't find file in module path"
2301
sexp_load_module_file(sexp ctx,const char * file,sexp env)2302 sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) {
2303 sexp res;
2304 sexp_gc_var1(path);
2305 sexp_gc_preserve1(ctx, path);
2306 path = sexp_find_module_file(ctx, file);
2307 if (sexp_stringp(path)) {
2308 res = sexp_load(ctx, path, env);
2309 } else {
2310 path = sexp_c_string(ctx, file, -1);
2311 res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path);
2312 }
2313 sexp_gc_release1(ctx);
2314 return res;
2315 }
2316
sexp_current_environment(sexp ctx,sexp self,sexp_sint_t n)2317 sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n) {
2318 return sexp_context_env(ctx);
2319 }
2320
2321 #if SEXP_USE_MODULES
sexp_current_module_path_op(sexp ctx,sexp self,sexp_sint_t n,sexp x)2322 sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
2323 if (sexp_pairp(x) && sexp_stringp(sexp_car(x))) {
2324 sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_reverse(ctx, x);
2325 sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_reverse(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH));
2326 }
2327 return sexp_global(ctx, SEXP_G_MODULE_PATH);
2328 }
sexp_find_module_file_op(sexp ctx,sexp self,sexp_sint_t n,sexp file)2329 sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file) {
2330 sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file);
2331 return sexp_find_module_file(ctx, sexp_string_data(file));
2332 }
sexp_load_module_file_op(sexp ctx,sexp self,sexp_sint_t n,sexp file,sexp env)2333 sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env) {
2334 sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file);
2335 sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
2336 return sexp_load_module_file(ctx, sexp_string_data(file), env);
2337 }
sexp_set_current_environment(sexp ctx,sexp self,sexp_sint_t n,sexp env)2338 sexp sexp_set_current_environment (sexp ctx, sexp self, sexp_sint_t n, sexp env) {
2339 sexp oldenv;
2340 sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
2341 oldenv = sexp_context_env(ctx);
2342 sexp_context_env(ctx) = env;
2343 return oldenv;
2344 }
sexp_meta_environment(sexp ctx,sexp self,sexp_sint_t n)2345 sexp sexp_meta_environment (sexp ctx, sexp self, sexp_sint_t n) {
2346 return sexp_global(ctx, SEXP_G_META_ENV);
2347 }
2348 #endif
2349
sexp_add_module_directory_op(sexp ctx,sexp self,sexp_sint_t n,sexp dir,sexp appendp)2350 sexp sexp_add_module_directory_op (sexp ctx, sexp self, sexp_sint_t n, sexp dir, sexp appendp) {
2351 sexp ls;
2352 sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir);
2353 if (sexp_truep(appendp)) {
2354 if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) {
2355 for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls))
2356 ;
2357 sexp_cdr(ls) = sexp_list1(ctx, dir);
2358 } else {
2359 sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir);
2360 }
2361 } else {
2362 sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir);
2363 }
2364 return SEXP_VOID;
2365 }
2366
sexp_parameter_ref(sexp ctx,sexp param)2367 sexp sexp_parameter_ref (sexp ctx, sexp param) {
2368 #if SEXP_USE_GREEN_THREADS
2369 sexp ls;
2370 for (ls=sexp_context_params(ctx); sexp_pairp(ls); ls=sexp_cdr(ls))
2371 if (sexp_caar(ls) == param)
2372 return sexp_cdar(ls);
2373 #endif
2374 return sexp_opcodep(param) && sexp_opcode_data(param) && sexp_pairp(sexp_opcode_data(param))
2375 ? sexp_cdr(sexp_opcode_data(param)) : SEXP_FALSE;
2376 }
2377
2378 #if SEXP_USE_GREEN_THREADS
sexp_dk(sexp ctx,sexp self,sexp_sint_t n,sexp val)2379 sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val) {
2380 if (sexp_not(val)) {
2381 return sexp_context_dk(ctx) ? sexp_context_dk(ctx) : SEXP_FALSE;
2382 } else {
2383 sexp_context_dk(ctx) = val;
2384 return SEXP_VOID;
2385 }
2386 }
2387 #endif
2388
sexp_thread_parameters(sexp ctx,sexp self,sexp_sint_t n)2389 sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n) {
2390 sexp res = sexp_context_params(ctx);
2391 return res ? res : SEXP_NULL;
2392 }
2393
sexp_thread_parameters_set(sexp ctx,sexp self,sexp_sint_t n,sexp new)2394 sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp new) {
2395 sexp_context_params(ctx) = new;
2396 return SEXP_VOID;
2397 }
2398
sexp_set_parameter(sexp ctx,sexp env,sexp name,sexp value)2399 void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) {
2400 sexp param = sexp_env_ref(ctx, env, name, SEXP_FALSE);
2401 if (sexp_opcodep(param)) {
2402 if (! sexp_pairp(sexp_opcode_data(param)))
2403 sexp_opcode_data(param) = sexp_cons(ctx, name, value);
2404 else
2405 sexp_cdr(sexp_opcode_data(param)) = value;
2406 } else {
2407 sexp_warn(ctx, "can't set non-parameter: ", name);
2408 }
2409 }
2410
sexp_load_standard_ports(sexp ctx,sexp env,FILE * in,FILE * out,FILE * err,int no_close)2411 sexp sexp_load_standard_ports (sexp ctx, sexp env, FILE* in, FILE* out,
2412 FILE* err, int no_close) {
2413 sexp_gc_var1(p);
2414 sexp_gc_preserve1(ctx, p);
2415 if (!env) env = sexp_context_env(ctx);
2416 if (in) {
2417 p = sexp_make_input_port(ctx, in, SEXP_FALSE);
2418 sexp_port_no_closep(p) = no_close;
2419 sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p);
2420 }
2421 if (out) {
2422 p = sexp_make_output_port(ctx, out, SEXP_FALSE);
2423 sexp_port_no_closep(p) = no_close;
2424 sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p);
2425 }
2426 if (err) {
2427 p = sexp_make_output_port(ctx, err, SEXP_FALSE);
2428 sexp_port_no_closep(p) = no_close;
2429 sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p);
2430 }
2431 sexp_gc_release1(ctx);
2432 return SEXP_VOID;
2433 }
2434
sexp_load_standard_env(sexp ctx,sexp e,sexp version)2435 sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
2436 int len;
2437 char init_file[128];
2438 sexp_gc_var3(op, tmp, sym);
2439 sexp_gc_preserve3(ctx, op, tmp, sym);
2440 if (!e) e = sexp_context_env(ctx);
2441 sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1),
2442 tmp=sexp_c_string(ctx, sexp_so_extension, -1));
2443 sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*features*", -1), sexp_global(ctx, SEXP_G_FEATURES));
2444 sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL;
2445 #if SEXP_USE_SIMPLIFY
2446 op = sexp_make_foreign(ctx, "sexp_simplify", 1, 0,
2447 NULL, (sexp_proc1)sexp_simplify, SEXP_VOID);
2448 tmp = sexp_cons(ctx, sexp_make_fixnum(500), op);
2449 sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp);
2450 #endif
2451 sexp_global(ctx, SEXP_G_ERR_HANDLER)
2452 = sexp_env_ref(ctx, e, sym=sexp_intern(ctx, "current-exception-handler", -1), SEXP_FALSE);
2453 /* load init-7.scm */
2454 len = strlen(sexp_init_file);
2455 strncpy(init_file, sexp_init_file, len+1);
2456 init_file[len] = (char)sexp_unbox_fixnum(version) + '0';
2457 strncpy(init_file + len + 1, sexp_init_file_suffix, strlen(sexp_init_file_suffix)+1);
2458 init_file[len + 1 + strlen(sexp_init_file_suffix)] = 0;
2459 tmp = sexp_load_module_file(ctx, init_file, e);
2460 sexp_set_parameter(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e);
2461 /* load and bind meta-7.scm env */
2462 #if SEXP_USE_MODULES
2463 if (!sexp_exceptionp(tmp)) {
2464 if (!sexp_envp(tmp=sexp_global(ctx, SEXP_G_META_ENV))) {
2465 tmp = sexp_make_env(ctx);
2466 if (! sexp_exceptionp(tmp)) {
2467 sexp_global(ctx, SEXP_G_META_ENV) = tmp;
2468 sexp_env_parent(tmp) = e;
2469 op = sexp_load_module_file(ctx, sexp_meta_file, tmp);
2470 if (sexp_exceptionp(op))
2471 sexp_print_exception(ctx, op, sexp_current_error_port(ctx));
2472 }
2473 }
2474 if (!sexp_exceptionp(tmp)) {
2475 sym = sexp_intern(ctx, "repl-import", -1);
2476 tmp = sexp_env_ref(ctx, tmp, sym, SEXP_VOID);
2477 sym = sexp_intern(ctx, "import", -1);
2478 /* splice import in place to mutate both this env and the */
2479 /* frozen version in the meta env) */
2480 tmp = sexp_cons(ctx, sym, tmp);
2481 sexp_env_next_cell(tmp) = sexp_env_next_cell(sexp_env_bindings(e));
2482 sexp_env_next_cell(sexp_env_bindings(e)) = tmp;
2483 }
2484 }
2485 #endif
2486 sexp_gc_release3(ctx);
2487 return sexp_exceptionp(tmp) ? tmp : e;
2488 }
2489
sexp_make_standard_env_op(sexp ctx,sexp self,sexp_sint_t n,sexp version)2490 sexp sexp_make_standard_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) {
2491 sexp_gc_var1(env);
2492 sexp_gc_preserve1(ctx, env);
2493 env = sexp_make_primitive_env(ctx, version);
2494 if (! sexp_exceptionp(env)) env = sexp_load_standard_env(ctx, env, SEXP_SEVEN);
2495 sexp_gc_release1(ctx);
2496 return env;
2497 }
2498
sexp_env_parent_op(sexp ctx,sexp self,sexp_sint_t n,sexp e)2499 sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
2500 sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
2501 return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;
2502 }
2503
2504 #if SEXP_USE_RENAME_BINDINGS
2505 #define sexp_same_bindingp(x, y) ((x) == (y))
2506 #else
2507 #define sexp_same_bindingp(x, y) (sexp_env_value(x) == sexp_env_value(y))
2508 #endif
2509
2510 /* Rewrite to in place: to => empty->imports->to */
sexp_env_import_op(sexp ctx,sexp self,sexp_sint_t n,sexp to,sexp from,sexp ls,sexp immutp)2511 sexp sexp_env_import_op (sexp ctx, sexp self, sexp_sint_t n, sexp to, sexp from, sexp ls, sexp immutp) {
2512 sexp oldname, newname;
2513 sexp_gc_var3(value, oldcell, tmp);
2514 sexp_gc_preserve3(ctx, value, oldcell, tmp);
2515 if (! sexp_envp(to)) to = sexp_context_env(ctx);
2516 if (! sexp_envp(from)) from = sexp_context_env(ctx);
2517 /* create an empty imports env frame */
2518 value = sexp_make_env(ctx);
2519 sexp_env_parent(value) = sexp_env_parent(to);
2520 sexp_env_parent(to) = value;
2521 sexp_env_lambda(value) = sexp_env_lambda(to);
2522 sexp_env_lambda(to) = NULL;
2523 sexp_env_bindings(value) = sexp_env_bindings(to);
2524 sexp_env_bindings(to) = SEXP_NULL;
2525 #if SEXP_USE_RENAME_BINDINGS
2526 sexp_env_renames(value) = sexp_env_renames(to);
2527 sexp_env_renames(to) = SEXP_NULL;
2528 #endif
2529 sexp_immutablep(value) = sexp_immutablep(to);
2530 sexp_immutablep(to) = sexp_truep(immutp);
2531 /* import the bindings, one at a time or in bulk */
2532 if (sexp_not(ls)) {
2533 sexp_env_bindings(to) = sexp_env_bindings(from);
2534 #if SEXP_USE_RENAME_BINDINGS
2535 sexp_env_renames(to) = sexp_env_renames(from);
2536 #endif
2537 } else {
2538 for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
2539 if (sexp_pairp(sexp_car(ls))) {
2540 newname = sexp_caar(ls); oldname = sexp_cdar(ls);
2541 } else {
2542 newname = oldname = sexp_car(ls);
2543 }
2544 oldcell = sexp_env_cell(ctx, to, newname, 0);
2545 value = sexp_env_cell(ctx, from, oldname, 0);
2546 if (value) {
2547 #if SEXP_USE_RENAME_BINDINGS
2548 sexp_env_rename(ctx, to, newname, value);
2549 #else
2550 sexp_env_push(ctx, to, tmp, newname, sexp_cdr(value));
2551 #endif
2552 #if SEXP_USE_WARN_UNDEFS
2553 if (oldcell
2554 && sexp_cdr(oldcell) != SEXP_UNDEF
2555 && !sexp_same_bindingp(oldcell, value))
2556 sexp_warn(ctx, "importing already defined binding: ", newname);
2557 } else {
2558 sexp_warn(ctx, "importing undefined variable: ", oldname);
2559 #endif
2560 }
2561 }
2562 }
2563 /* create a new empty frame for future defines */
2564 value = sexp_make_env(ctx);
2565 sexp_env_parent(value) = sexp_env_parent(to);
2566 sexp_env_lambda(value) = sexp_env_lambda(to);
2567 sexp_env_bindings(value) = sexp_env_bindings(to);
2568 #if SEXP_USE_RENAME_BINDINGS
2569 sexp_env_renames(value) = sexp_env_renames(to);
2570 sexp_env_renames(to) = SEXP_NULL;
2571 #endif
2572 sexp_env_parent(to) = value;
2573 sexp_env_bindings(to) = SEXP_NULL;
2574 sexp_immutablep(to) = 0;
2575 sexp_gc_release3(ctx);
2576 return SEXP_VOID;
2577 }
2578
2579 /************************** eval interface ****************************/
2580
sexp_generate_op(sexp ctx,sexp self,sexp_sint_t n,sexp ast,sexp env)2581 sexp sexp_generate_op (sexp ctx, sexp self, sexp_sint_t n, sexp ast, sexp env) {
2582 sexp_gc_var3(ctx2, vec, res);
2583 if (sexp_contextp(env)) {
2584 ctx2 = env;
2585 } else {
2586 sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
2587 ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
2588 }
2589 sexp_gc_preserve3(ctx, ctx2, vec, res);
2590 sexp_free_vars(ctx2, ast, SEXP_NULL); /* should return SEXP_NULL */
2591 sexp_emit_enter(ctx2);
2592 sexp_generate(ctx2, 0, 0, 0, ast);
2593 res = sexp_complete_bytecode(ctx2);
2594 if (!sexp_exceptionp(res)) {
2595 sexp_context_specific(ctx2) = SEXP_FALSE;
2596 vec = sexp_make_vector(ctx2, 0, SEXP_VOID);
2597 if (sexp_exceptionp(vec)) res = vec;
2598 else res = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, vec);
2599 }
2600 sexp_gc_release3(ctx);
2601 return res;
2602 }
2603
sexp_compile_op(sexp ctx,sexp self,sexp_sint_t n,sexp obj,sexp env)2604 sexp sexp_compile_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) {
2605 sexp_gc_var3(ast, tmp, res);
2606 sexp ctx2;
2607 if (! env) env = sexp_context_env(ctx);
2608 sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
2609 sexp_gc_preserve3(ctx, ast, tmp, res);
2610 ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
2611 if (sexp_exceptionp(ctx2)) {
2612 res = ctx2;
2613 } else {
2614 tmp = sexp_context_child(ctx);
2615 sexp_context_child(ctx) = ctx2;
2616 ast = sexp_analyze(ctx2, obj);
2617 if (sexp_exceptionp(ast)) {
2618 res = ast;
2619 } else {
2620 res = sexp_global(ctx2, SEXP_G_OPTIMIZATIONS);
2621 for ( ; sexp_pairp(res) && !sexp_exceptionp(ast); res=sexp_cdr(res))
2622 ast = sexp_apply1(ctx2, sexp_cdar(res), ast);
2623 if (sexp_exceptionp(ast)) {
2624 res = ast;
2625 } else {
2626 res = sexp_generate_op(ctx2, self, n, ast, ctx2);
2627 }
2628 }
2629 sexp_context_child(ctx) = tmp;
2630 sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2);
2631 }
2632 sexp_gc_release3(ctx);
2633 return res;
2634 }
2635
sexp_eval_op(sexp ctx,sexp self,sexp_sint_t n,sexp obj,sexp env)2636 sexp sexp_eval_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) {
2637 sexp_sint_t top;
2638 sexp ctx2;
2639 sexp_gc_var3(res, tmp, params);
2640 if (! env) env = sexp_context_env(ctx);
2641 sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
2642 sexp_gc_preserve3(ctx, res, tmp, params);
2643 top = sexp_context_top(ctx);
2644 params = sexp_context_params(ctx);
2645 sexp_context_params(ctx) = SEXP_NULL;
2646 ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
2647 tmp = sexp_context_child(ctx);
2648 sexp_context_child(ctx) = ctx2;
2649 res = sexp_exceptionp(ctx2) ? ctx2 : sexp_compile_op(ctx2, self, n, obj, env);
2650 if (! sexp_exceptionp(res))
2651 res = sexp_apply(ctx2, res, SEXP_NULL);
2652 sexp_context_child(ctx) = tmp;
2653 sexp_context_params(ctx) = params;
2654 sexp_context_top(ctx) = top;
2655 sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2);
2656 sexp_gc_release3(ctx);
2657 return res;
2658 }
2659
sexp_eval_string(sexp ctx,const char * str,sexp_sint_t len,sexp env)2660 sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) {
2661 sexp res;
2662 sexp_gc_var1(obj);
2663 sexp_gc_preserve1(ctx, obj);
2664 obj = sexp_read_from_string(ctx, str, len);
2665 res = sexp_eval(ctx, obj, env);
2666 sexp_gc_release1(ctx);
2667 return res;
2668 }
2669
sexp_scheme_init(void)2670 void sexp_scheme_init (void) {
2671 if (! scheme_initialized_p) {
2672 scheme_initialized_p = 1;
2673 sexp_init();
2674 }
2675 }
2676