mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
2621 lines
91 KiB
C
2621 lines
91 KiB
C
/* eval.c -- evaluator library implementation */
|
|
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
|
|
/* BSD-style license: http://synthcode.com/license.txt */
|
|
|
|
#include "chibi/eval.h"
|
|
|
|
#if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM || SEXP_USE_STATIC_LIBS
|
|
#include "opt/opcode_names.h"
|
|
#endif
|
|
|
|
/************************************************************************/
|
|
|
|
static int scheme_initialized_p = 0;
|
|
|
|
static sexp analyze (sexp ctx, sexp x, int depth, int defok);
|
|
|
|
#if SEXP_USE_MODULES
|
|
sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env);
|
|
sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file);
|
|
sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n);
|
|
#endif
|
|
|
|
sexp sexp_compile_error (sexp ctx, const char *message, sexp o) {
|
|
sexp exn;
|
|
sexp_gc_var3(sym, irritants, msg);
|
|
sexp_gc_preserve3(ctx, sym, irritants, msg);
|
|
irritants = sexp_list1(ctx, o);
|
|
msg = sexp_c_string(ctx, message, -1);
|
|
exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1),
|
|
msg, irritants, SEXP_FALSE,
|
|
(sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE));
|
|
sexp_gc_release3(ctx);
|
|
return exn;
|
|
}
|
|
|
|
void sexp_warn (sexp ctx, const char *msg, sexp x) {
|
|
sexp_gc_var1(out);
|
|
int strictp = sexp_truep(sexp_global(ctx, SEXP_G_STRICT_P));
|
|
sexp_gc_preserve1(ctx, out);
|
|
out = sexp_current_error_port(ctx);
|
|
if (sexp_not(out)) { /* generate a throw-away port */
|
|
out = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
|
|
sexp_port_no_closep(out) = 1;
|
|
}
|
|
if (sexp_oportp(out)) {
|
|
sexp_write_string(ctx, strictp ? "ERROR: " : "WARNING: ", out);
|
|
sexp_write_string(ctx, msg, out);
|
|
sexp_write(ctx, x, out);
|
|
sexp_write_char(ctx, '\n', out);
|
|
if (strictp) sexp_stack_trace(ctx, out);
|
|
}
|
|
sexp_gc_release1(ctx);
|
|
if (strictp) exit(1);
|
|
}
|
|
|
|
sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res) {
|
|
sexp x, ignore = (res && sexp_exceptionp(res)) ? sexp_exception_irritants(res) : SEXP_NULL;
|
|
if (sexp_envp(from)) from = sexp_env_bindings(from);
|
|
for (x=from; sexp_pairp(x) && x!=to; x=sexp_env_next_cell(x))
|
|
if (sexp_cdr(x) == SEXP_UNDEF && sexp_car(x) != ignore
|
|
&& !sexp_synclop(sexp_car(x))
|
|
&& sexp_not(sexp_memq(ctx, sexp_car(x), ignore)))
|
|
sexp_warn(ctx, "reference to undefined variable: ", sexp_car(x));
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
sexp sexp_maybe_wrap_error (sexp ctx, sexp obj) {
|
|
sexp_gc_var2(tmp, res);
|
|
if (sexp_exceptionp(obj)) {
|
|
sexp_gc_preserve2(ctx, tmp, res);
|
|
tmp = obj;
|
|
tmp = sexp_list1(ctx, tmp);
|
|
res = sexp_make_trampoline(ctx, SEXP_FALSE, tmp);
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
return obj;
|
|
}
|
|
|
|
/********************** environment utilities ***************************/
|
|
|
|
static sexp sexp_env_cell_loc1 (sexp env, sexp key, int localp, sexp *varenv) {
|
|
sexp ls;
|
|
do {
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
|
if (sexp_car(ls) == key) {
|
|
if (varenv) *varenv = env;
|
|
return sexp_cdr(ls);
|
|
}
|
|
#endif
|
|
for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
|
if (sexp_car(ls) == key) {
|
|
if (varenv) *varenv = env;
|
|
return ls;
|
|
}
|
|
if (localp) break;
|
|
env = sexp_env_parent(env);
|
|
} while (env && sexp_envp(env));
|
|
return NULL;
|
|
}
|
|
|
|
static sexp sexp_env_cell_loc (sexp ctx, sexp env, sexp key, int localp, sexp *varenv) {
|
|
sexp cell, ls = sexp_vectorp(sexp_context_specific(ctx)) ? sexp_memq(ctx, sexp_id_name(key), sexp_context_fv(ctx)) : SEXP_NULL;
|
|
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
|
|
if (sexp_envp(sexp_car(ls))) {
|
|
env = sexp_car(ls);
|
|
break;
|
|
}
|
|
cell = sexp_env_cell_loc1(env, key, localp, varenv);
|
|
while (!cell && key && sexp_synclop(key)) {
|
|
if (!sexp_pairp(ls) && sexp_not(sexp_memq(ctx, sexp_synclo_expr(key), sexp_synclo_free_vars(key))))
|
|
env = sexp_synclo_env(key);
|
|
key = sexp_synclo_expr(key);
|
|
cell = sexp_env_cell_loc1(env, key, localp, varenv);
|
|
}
|
|
return cell;
|
|
}
|
|
|
|
sexp sexp_env_cell (sexp ctx, sexp env, sexp key, int localp) {
|
|
return sexp_env_cell_loc(ctx, env, key, localp, NULL);
|
|
}
|
|
|
|
static sexp sexp_env_undefine (sexp ctx, sexp env, sexp key) {
|
|
sexp ls1=NULL, ls2;
|
|
for (ls2=sexp_env_bindings(env); sexp_pairp(ls2);
|
|
ls1=ls2, ls2=sexp_env_next_cell(ls2))
|
|
if (sexp_car(ls2) == key) {
|
|
if (ls1) sexp_env_next_cell(ls1) = sexp_env_next_cell(ls2);
|
|
else sexp_env_bindings(env) = sexp_env_next_cell(ls2);
|
|
return SEXP_TRUE;
|
|
}
|
|
return SEXP_FALSE;
|
|
}
|
|
|
|
sexp sexp_env_cell_define (sexp ctx, sexp env, sexp key,
|
|
sexp value, sexp *varenv) {
|
|
sexp_gc_var2(cell, ls);
|
|
while (sexp_env_lambda(env) || sexp_env_syntactic_p(env))
|
|
env = sexp_env_parent(env);
|
|
if (varenv) *varenv = env;
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
/* remove any existing renamed definition */
|
|
for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
|
if (sexp_car(ls) == key) {
|
|
sexp_car(ls) = SEXP_FALSE;
|
|
break;
|
|
}
|
|
#endif
|
|
for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
|
if (sexp_car(ls) == key) {
|
|
sexp_cdr(ls) = value;
|
|
return ls;
|
|
}
|
|
sexp_gc_preserve2(ctx, cell, ls);
|
|
sexp_env_push(ctx, env, cell, key, value);
|
|
sexp_gc_release2(ctx);
|
|
return cell;
|
|
}
|
|
|
|
static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key,
|
|
sexp value, sexp *varenv) {
|
|
sexp cell = sexp_env_cell_loc(ctx, env, key, 0, varenv);
|
|
if (!cell) cell = sexp_env_cell_define(ctx, env, key, value, varenv);
|
|
return cell;
|
|
}
|
|
|
|
sexp sexp_env_ref (sexp ctx, sexp env, sexp key, sexp dflt) {
|
|
sexp cell = sexp_env_cell(ctx, env, key, 0);
|
|
return (cell ? sexp_cdr(cell) : dflt);
|
|
}
|
|
|
|
sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) {
|
|
sexp cell, tmp, res = SEXP_VOID;
|
|
if (sexp_immutablep(env))
|
|
return sexp_user_exception(ctx, NULL, "immutable binding", key);
|
|
cell = sexp_env_cell(ctx, env, key, 1);
|
|
if (!cell) {
|
|
while (sexp_env_syntactic_p(env) && sexp_env_parent(env))
|
|
env = sexp_env_parent(env);
|
|
sexp_env_push(ctx, env, tmp, key, value);
|
|
} else if (sexp_immutablep(cell)) {
|
|
res = sexp_user_exception(ctx, NULL, "immutable binding", key);
|
|
} else if (sexp_syntacticp(value) && !sexp_syntacticp(sexp_cdr(cell))) {
|
|
sexp_env_undefine(ctx, env, key);
|
|
sexp_env_push(ctx, env, tmp, key, value);
|
|
} else {
|
|
sexp_cdr(cell) = value;
|
|
}
|
|
return res;
|
|
}
|
|
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
sexp sexp_env_rename (sexp ctx, sexp env, sexp key, sexp value) {
|
|
sexp tmp;
|
|
sexp_env_push_rename(ctx, env, tmp, key, value);
|
|
return SEXP_VOID;
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_env_exports_op (sexp ctx, sexp self, sexp_sint_t n, sexp env) {
|
|
sexp ls;
|
|
sexp_gc_var1(res);
|
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
|
sexp_gc_preserve1(ctx, res);
|
|
res = SEXP_NULL;
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
|
sexp_push(ctx, res, sexp_cadr(ls));
|
|
#endif
|
|
for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls))
|
|
if (sexp_env_value(ls) != SEXP_UNDEF)
|
|
sexp_push(ctx, res, sexp_car(ls));
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
|
|
sexp_gc_var2(e, tmp);
|
|
sexp_gc_preserve2(ctx, e, tmp);
|
|
e = sexp_alloc_type(ctx, env, SEXP_ENV);
|
|
sexp_env_parent(e) = env;
|
|
sexp_env_bindings(e) = SEXP_NULL;
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
sexp_env_renames(e) = SEXP_NULL;
|
|
#endif
|
|
for ( ; sexp_pairp(vars); vars = sexp_cdr(vars))
|
|
sexp_env_push(ctx, e, tmp, sexp_car(vars), value);
|
|
sexp_gc_release2(ctx);
|
|
return e;
|
|
}
|
|
|
|
sexp sexp_extend_synclo_env (sexp ctx, sexp env) {
|
|
sexp e1, e2;
|
|
sexp_gc_var1(e);
|
|
sexp_gc_preserve1(ctx, e);
|
|
e = env;
|
|
if (sexp_pairp(sexp_context_fv(ctx))) {
|
|
e = sexp_alloc_type(ctx, env, SEXP_ENV);
|
|
for (e1=env, e2=NULL; e1; e1=sexp_env_parent(e1)) {
|
|
e2 = e2 ? (sexp_env_parent(e2) = sexp_alloc_type(ctx, env, SEXP_ENV)) : e;
|
|
sexp_env_bindings(e2) = sexp_env_bindings(e1);
|
|
sexp_env_syntactic_p(e2) = 1;
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
sexp_env_renames(e2) = sexp_env_renames(e1);
|
|
#endif
|
|
}
|
|
if (!e2) { return sexp_global(ctx, SEXP_G_OOM_ERROR); }
|
|
sexp_env_parent(e2) = sexp_context_env(ctx);
|
|
}
|
|
sexp_gc_release1(ctx);
|
|
return e;
|
|
}
|
|
|
|
static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) {
|
|
sexp_gc_var1(res);
|
|
sexp_gc_preserve1(ctx, res);
|
|
for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls))
|
|
sexp_push(ctx, res, sexp_car(ls));
|
|
if (!sexp_nullp(ls))
|
|
res = sexp_cons(ctx, ls, res);
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp sexp_flatten_dot (sexp ctx, sexp ls) {
|
|
return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls));
|
|
}
|
|
|
|
int sexp_param_index (sexp ctx, sexp lambda, sexp name) {
|
|
sexp ls;
|
|
int i;
|
|
while (1) {
|
|
ls = sexp_lambda_params(lambda);
|
|
for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++)
|
|
if (sexp_car(ls) == name)
|
|
return i;
|
|
if (ls == name)
|
|
return i;
|
|
ls = sexp_lambda_locals(lambda);
|
|
for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--)
|
|
if (sexp_car(ls) == name)
|
|
return i-4;
|
|
if (sexp_synclop(name))
|
|
name = sexp_synclo_expr(name);
|
|
else
|
|
break;
|
|
}
|
|
sexp_warn(ctx, "can't happen: no argument: ", name);
|
|
return -10000;
|
|
}
|
|
|
|
/************************* bytecode utilities ***************************/
|
|
|
|
void sexp_shrink_bcode (sexp ctx, sexp_uint_t i) {
|
|
sexp tmp;
|
|
if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) {
|
|
tmp = sexp_alloc_bytecode(ctx, i);
|
|
if (!sexp_exceptionp(tmp)) {
|
|
sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx));
|
|
sexp_bytecode_length(tmp) = i;
|
|
sexp_bytecode_literals(tmp)
|
|
= sexp_bytecode_literals(sexp_context_bc(ctx));
|
|
sexp_bytecode_source(tmp)
|
|
= sexp_bytecode_source(sexp_context_bc(ctx));
|
|
memcpy(sexp_bytecode_data(tmp),
|
|
sexp_bytecode_data(sexp_context_bc(ctx)),
|
|
i);
|
|
sexp_context_bc(ctx) = tmp;
|
|
}
|
|
}
|
|
}
|
|
|
|
void sexp_expand_bcode (sexp ctx, sexp_sint_t size) {
|
|
sexp tmp;
|
|
if ((sexp_sint_t)sexp_bytecode_length(sexp_context_bc(ctx))
|
|
< (sexp_unbox_fixnum(sexp_context_pos(ctx)))+size) {
|
|
tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2);
|
|
if (sexp_exceptionp(tmp)) {
|
|
sexp_context_exception(ctx) = tmp;
|
|
} else {
|
|
sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx));
|
|
sexp_bytecode_length(tmp)
|
|
= sexp_bytecode_length(sexp_context_bc(ctx))*2;
|
|
sexp_bytecode_literals(tmp)
|
|
= sexp_bytecode_literals(sexp_context_bc(ctx));
|
|
sexp_bytecode_source(tmp)
|
|
= sexp_bytecode_source(sexp_context_bc(ctx));
|
|
memcpy(sexp_bytecode_data(tmp),
|
|
sexp_bytecode_data(sexp_context_bc(ctx)),
|
|
sexp_bytecode_length(sexp_context_bc(ctx)));
|
|
sexp_context_bc(ctx) = tmp;
|
|
}
|
|
}
|
|
}
|
|
|
|
void sexp_emit (sexp ctx, unsigned char c) {
|
|
sexp_expand_bcode(ctx, 1);
|
|
if (sexp_exceptionp(sexp_context_exception(ctx)))
|
|
return;
|
|
sexp_bytecode_data(sexp_context_bc(ctx))[sexp_unbox_fixnum(sexp_context_pos(ctx))] = c;
|
|
sexp_context_pos(ctx) = sexp_fx_add(sexp_context_pos(ctx), SEXP_ONE);
|
|
}
|
|
|
|
sexp sexp_complete_bytecode (sexp ctx) {
|
|
sexp bc;
|
|
sexp_emit_return(ctx);
|
|
sexp_shrink_bcode(ctx, sexp_unbox_fixnum(sexp_context_pos(ctx)));
|
|
bc = sexp_context_bc(ctx);
|
|
if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */
|
|
if (sexp_nullp(sexp_cdr(sexp_bytecode_literals(bc))))
|
|
sexp_bytecode_literals(bc) = sexp_car(sexp_bytecode_literals(bc));
|
|
else if (sexp_nullp(sexp_cddr(sexp_bytecode_literals(bc))))
|
|
sexp_cdr(sexp_bytecode_literals(bc)) = sexp_cadr(sexp_bytecode_literals(bc));
|
|
else
|
|
sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc));
|
|
if (sexp_exceptionp(sexp_bytecode_literals(bc)))
|
|
return sexp_bytecode_literals(bc);
|
|
}
|
|
sexp_bytecode_max_depth(bc) = sexp_unbox_fixnum(sexp_context_max_depth(ctx));
|
|
#if SEXP_USE_FULL_SOURCE_INFO
|
|
if (sexp_bytecode_source(bc) && sexp_pairp(sexp_bytecode_source(bc))) {
|
|
sexp_bytecode_source(bc) = sexp_nreverse(ctx, sexp_bytecode_source(bc));
|
|
sexp_bytecode_source(bc) = sexp_list_to_vector(ctx, sexp_bytecode_source(bc));
|
|
}
|
|
#endif
|
|
sexp_bless_bytecode(ctx, bc);
|
|
if (sexp_exceptionp(sexp_context_exception(ctx)))
|
|
return sexp_context_exception(ctx);
|
|
return bc;
|
|
}
|
|
|
|
sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags,
|
|
sexp num_args, sexp bc, sexp vars) {
|
|
sexp proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE);
|
|
sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags;
|
|
sexp_procedure_num_args(proc) = sexp_unbox_fixnum(num_args);
|
|
sexp_procedure_code(proc) = bc;
|
|
sexp_procedure_vars(proc) = vars;
|
|
return proc;
|
|
}
|
|
|
|
static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) {
|
|
sexp mac = sexp_alloc_type(ctx, macro, SEXP_MACRO);
|
|
sexp_macro_env(mac) = e;
|
|
sexp_macro_proc(mac) = p;
|
|
return mac;
|
|
}
|
|
|
|
sexp sexp_make_synclo_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv, sexp expr) {
|
|
sexp res;
|
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
|
if (! (sexp_symbolp(expr) || sexp_pairp(expr) || sexp_synclop(expr)))
|
|
return expr;
|
|
res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO);
|
|
if (SEXP_USE_FLAT_SYNTACTIC_CLOSURES && sexp_synclop(expr)) {
|
|
sexp_synclo_env(res) = sexp_synclo_env(expr);
|
|
sexp_synclo_free_vars(res) = sexp_synclo_free_vars(expr);
|
|
sexp_synclo_expr(res) = sexp_synclo_expr(expr);
|
|
} else {
|
|
sexp_synclo_env(res) = env;
|
|
sexp_synclo_free_vars(res) = fv;
|
|
sexp_synclo_expr(res) = expr;
|
|
}
|
|
return res;
|
|
}
|
|
|
|
/* internal AST */
|
|
|
|
sexp sexp_make_lambda (sexp ctx, sexp params) {
|
|
sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
|
|
sexp_lambda_name(res) = SEXP_FALSE;
|
|
sexp_lambda_params(res) = params;
|
|
sexp_lambda_fv(res) = SEXP_NULL;
|
|
sexp_lambda_sv(res) = SEXP_NULL;
|
|
sexp_lambda_locals(res) = SEXP_NULL;
|
|
sexp_lambda_defs(res) = SEXP_NULL;
|
|
sexp_lambda_return_type(res) = SEXP_FALSE;
|
|
sexp_lambda_param_types(res) = SEXP_NULL;
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_make_ref (sexp ctx, sexp name, sexp cell) {
|
|
sexp res = sexp_alloc_type(ctx, ref, SEXP_REF);
|
|
sexp_ref_name(res) = name;
|
|
sexp_ref_cell(res) = cell;
|
|
return res;
|
|
}
|
|
|
|
static sexp sexp_make_set (sexp ctx, sexp var, sexp value) {
|
|
sexp res = sexp_alloc_type(ctx, set, SEXP_SET);
|
|
sexp_set_var(res) = var;
|
|
sexp_set_value(res) = value;
|
|
return res;
|
|
}
|
|
|
|
static sexp sexp_make_cnd (sexp ctx, sexp test, sexp pass, sexp fail) {
|
|
sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND);
|
|
sexp_cnd_test(res) = test;
|
|
sexp_cnd_pass(res) = pass;
|
|
sexp_cnd_fail(res) = fail;
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_make_lit (sexp ctx, sexp value) {
|
|
sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT);
|
|
sexp_lit_value(res) = value;
|
|
return res;
|
|
}
|
|
|
|
/****************************** contexts ******************************/
|
|
|
|
#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE)
|
|
|
|
static void sexp_add_path (sexp ctx, const char *str) {
|
|
const char *colon;
|
|
if (str && *str) {
|
|
colon = strchr(str, ':');
|
|
if (colon)
|
|
sexp_add_path(ctx, colon+1);
|
|
else
|
|
colon = str + strlen(str);
|
|
sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), SEXP_VOID);
|
|
sexp_car(sexp_global(ctx, SEXP_G_MODULE_PATH))
|
|
= sexp_c_string(ctx, str, colon-str);
|
|
sexp_immutablep(sexp_global(ctx, SEXP_G_MODULE_PATH)) = 1;
|
|
}
|
|
}
|
|
|
|
#if ! SEXP_USE_NATIVE_X86
|
|
static void sexp_init_eval_context_bytecodes (sexp ctx) {
|
|
sexp_gc_var3(tmp, vec, ctx2);
|
|
sexp_gc_preserve3(ctx, tmp, vec, ctx2);
|
|
sexp_emit(ctx, SEXP_OP_RESUMECC);
|
|
sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = sexp_complete_bytecode(ctx);
|
|
ctx2 = sexp_make_child_context(ctx, NULL);
|
|
sexp_emit(ctx2, SEXP_OP_DONE);
|
|
tmp = sexp_complete_bytecode(ctx2);
|
|
vec = sexp_make_vector(ctx, 0, SEXP_VOID);
|
|
sexp_global(ctx, SEXP_G_FINAL_RESUMER)
|
|
= sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec);
|
|
sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER)))
|
|
= sexp_intern(ctx, "final-resumer", -1);
|
|
sexp_gc_release3(ctx);
|
|
}
|
|
#endif
|
|
|
|
void sexp_init_eval_context_globals (sexp ctx) {
|
|
const char* user_path;
|
|
ctx = sexp_make_child_context(ctx, NULL);
|
|
#if ! SEXP_USE_NATIVE_X86
|
|
sexp_init_eval_context_bytecodes(ctx);
|
|
#endif
|
|
sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL;
|
|
sexp_add_path(ctx, sexp_default_module_path);
|
|
user_path = getenv(SEXP_MODULE_PATH_VAR);
|
|
if (!user_path) user_path = sexp_default_user_module_path;
|
|
sexp_add_path(ctx, user_path);
|
|
#if SEXP_USE_GREEN_THREADS
|
|
sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)
|
|
= sexp_user_exception(ctx, SEXP_FALSE, "I/O would block", SEXP_NULL);
|
|
sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR)
|
|
= sexp_user_exception(ctx, SEXP_FALSE, "I/O would block once", SEXP_NULL);
|
|
sexp_global(ctx, SEXP_G_THREAD_TERMINATE_ERROR)
|
|
= sexp_user_exception(ctx, SEXP_FALSE, "thread terminated", SEXP_NULL);
|
|
sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL;
|
|
sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL;
|
|
sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO;
|
|
sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE;
|
|
sexp_global(ctx, SEXP_G_ATOMIC_P) = SEXP_FALSE;
|
|
#endif
|
|
}
|
|
|
|
sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size) {
|
|
sexp_gc_var1(res);
|
|
res = sexp_make_context(ctx, size, max_size);
|
|
if (!res || sexp_exceptionp(res))
|
|
return res;
|
|
if (ctx) sexp_gc_preserve1(ctx, res);
|
|
sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_SEVEN));
|
|
sexp_context_specific(res) = sexp_make_vector(res, SEXP_SEVEN, SEXP_ZERO);
|
|
sexp_context_lambda(res) = SEXP_FALSE;
|
|
sexp_context_fv(res) = SEXP_NULL;
|
|
sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE);
|
|
if (sexp_exceptionp(sexp_context_env(res))) {
|
|
res = sexp_context_env(res);
|
|
} else if (sexp_exceptionp(sexp_context_specific(res))) {
|
|
res = sexp_context_specific(res);
|
|
} else if (sexp_exceptionp(sexp_context_bc(res))) {
|
|
res = sexp_context_bc(res);
|
|
} else {
|
|
sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE;
|
|
sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE;
|
|
sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL;
|
|
sexp_bytecode_source(sexp_context_bc(res)) = SEXP_NULL;
|
|
if ((! stack) || (stack == SEXP_FALSE)) {
|
|
stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK);
|
|
if (sexp_exceptionp(stack)) {
|
|
if (ctx) sexp_gc_release1(ctx);
|
|
return stack;
|
|
} else {
|
|
sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE;
|
|
sexp_stack_top(stack) = 0;
|
|
}
|
|
}
|
|
sexp_context_stack(res) = stack;
|
|
if (! ctx) sexp_init_eval_context_globals(res);
|
|
if (ctx) {
|
|
sexp_context_params(res) = sexp_context_params(ctx);
|
|
sexp_context_tracep(res) = sexp_context_tracep(ctx);
|
|
sexp_context_dk(res) = sexp_context_dk(ctx);
|
|
sexp_gc_release1(ctx);
|
|
} else {
|
|
/* TODO: make the root a global (with friendly error in/out) */
|
|
sexp_context_dk(res) = sexp_make_vector(res, SEXP_FOUR, SEXP_FALSE);
|
|
sexp_vector_set(sexp_context_dk(res), SEXP_ZERO, SEXP_ZERO);
|
|
}
|
|
}
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_make_child_context (sexp ctx, sexp lambda) {
|
|
sexp res = sexp_make_eval_context(ctx,
|
|
sexp_context_stack(ctx),
|
|
sexp_context_env(ctx),
|
|
0,
|
|
sexp_context_max_size(ctx));
|
|
if (! sexp_exceptionp(res)) {
|
|
sexp_context_lambda(res) = lambda;
|
|
sexp_context_top(res) = sexp_context_top(ctx);
|
|
sexp_context_fv(res) = sexp_context_fv(ctx);
|
|
sexp_context_tracep(res) = sexp_context_tracep(ctx);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
/**************************** identifiers *****************************/
|
|
|
|
sexp sexp_id_name (sexp x) {
|
|
while (sexp_synclop(x)) x = sexp_synclo_expr(x);
|
|
return x;
|
|
}
|
|
|
|
int sexp_idp (sexp x) {
|
|
return sexp_symbolp(sexp_id_name(x));
|
|
}
|
|
|
|
sexp sexp_identifierp_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
|
return sexp_make_boolean(sexp_idp(x));
|
|
}
|
|
|
|
sexp sexp_syntactic_closure_expr_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
|
return (sexp_synclop(x) ? sexp_synclo_expr(x) : x);
|
|
}
|
|
|
|
#if SEXP_USE_READER_LABELS
|
|
static int sexp_cyclic_synclop(sexp x) {
|
|
sexp ls1, ls2;
|
|
if (!sexp_pairp(x))
|
|
return 0;
|
|
for (ls1=x, ls2=sexp_id_name(sexp_cdr(ls1));
|
|
sexp_pairp(ls2) && sexp_pairp(sexp_id_name(sexp_cdr(ls2)));
|
|
ls1=sexp_id_name(sexp_cdr(ls1)),
|
|
ls2=sexp_id_name(sexp_cdr(sexp_id_name(sexp_cdr(ls2))))) {
|
|
if (ls1 == ls2 || ls1 == sexp_id_name(sexp_car(ls2)))
|
|
return 1;
|
|
}
|
|
for (ls1=x, ls2=sexp_id_name(sexp_car(ls1));
|
|
sexp_pairp(ls2) && sexp_pairp(sexp_id_name(sexp_car(ls2)));
|
|
ls1=sexp_id_name(sexp_car(ls1)),
|
|
ls2=sexp_id_name(sexp_car(sexp_id_name(sexp_car(ls2))))) {
|
|
if (ls1 == ls2 || ls1 == sexp_id_name(sexp_cdr(ls2)))
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
#else
|
|
#define sexp_cyclic_synclop(x) 0
|
|
#endif
|
|
|
|
sexp sexp_strip_synclos_bound (sexp ctx, sexp x, int depth) {
|
|
int i;
|
|
sexp_gc_var3(res, kar, kdr);
|
|
if (depth <= 0) return x;
|
|
sexp_gc_preserve3(ctx, res, kar, kdr);
|
|
x = sexp_id_name(x);
|
|
if (sexp_pairp(x) && !sexp_cyclic_synclop(x)) {
|
|
kar = sexp_strip_synclos_bound(ctx, sexp_car(x), depth-1);
|
|
kdr = sexp_strip_synclos_bound(ctx, sexp_cdr(x), depth-1);
|
|
res = sexp_cons(ctx, kar, kdr);
|
|
sexp_pair_source(res) = sexp_pair_source(x);
|
|
sexp_immutablep(res) = 1;
|
|
} else {
|
|
if (sexp_vectorp(x))
|
|
for (i = 0; i < sexp_vector_length(x); ++i)
|
|
sexp_vector_set(x, sexp_make_fixnum(i), sexp_strip_synclos_bound(ctx, sexp_vector_ref(x, sexp_make_fixnum(i)), depth-1));
|
|
res = x;
|
|
}
|
|
sexp_gc_release3(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_strip_synclos (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
|
return sexp_strip_synclos_bound(ctx, x, SEXP_STRIP_SYNCLOS_BOUND);
|
|
}
|
|
|
|
sexp sexp_identifier_eq_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp id1, sexp e2, sexp id2) {
|
|
sexp cell1, cell2;
|
|
cell1 = sexp_env_cell(ctx, e1, id1, 0);
|
|
cell2 = sexp_env_cell(ctx, e2, id2, 0);
|
|
if (cell1 && (cell1 == cell2))
|
|
return SEXP_TRUE;
|
|
else if (!cell1 && !cell2 && (id1 == id2))
|
|
return SEXP_TRUE;
|
|
/* If the symbols are the same and the cells are either unbound or
|
|
* (optionally) bound to top-level variables, consider them the
|
|
* same. Local (non-toplevel) bindings must still match exactly.
|
|
*/
|
|
while (sexp_synclop(id1))
|
|
id1 = sexp_synclo_expr(id1);
|
|
while (sexp_synclop(id2))
|
|
id2 = sexp_synclo_expr(id2);
|
|
if ((id1 == id2)
|
|
&& ((!cell1 && !cell2)
|
|
#if !SEXP_USE_STRICT_TOPLEVEL_BINDINGS
|
|
|| ((!cell1 || (!sexp_lambdap(sexp_cdr(cell1)) &&
|
|
!sexp_env_cell_syntactic_p(cell1))) &&
|
|
(!cell2 || (!sexp_lambdap(sexp_cdr(cell2)) &&
|
|
!sexp_env_cell_syntactic_p(cell2))))
|
|
#endif
|
|
))
|
|
return SEXP_TRUE;
|
|
return SEXP_FALSE;
|
|
}
|
|
|
|
/************************* the compiler ***************************/
|
|
|
|
static int lambda_envp(sexp ctx) {
|
|
sexp env;
|
|
for (env=sexp_context_env(ctx); env && sexp_envp(env); env=sexp_env_parent(env))
|
|
if (sexp_env_lambda(env))
|
|
return 1;
|
|
return 0;
|
|
}
|
|
|
|
static int nondefp(sexp x) {
|
|
sexp ls;
|
|
if (sexp_pairp(x) || sexp_cndp(x))
|
|
return 1;
|
|
if (sexp_seqp(x))
|
|
for (ls=sexp_seq_ls(x); sexp_pairp(ls); ls=sexp_cdr(ls))
|
|
if (nondefp(sexp_car(ls)))
|
|
return 1;
|
|
return 0;
|
|
}
|
|
|
|
static sexp analyze_list (sexp ctx, sexp x, int depth, int defok) {
|
|
sexp_gc_var2(res, tmp);
|
|
sexp_gc_preserve2(ctx, res, tmp);
|
|
for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) {
|
|
sexp_push(ctx, res, SEXP_FALSE);
|
|
tmp = analyze(ctx, sexp_car(x), depth, defok);
|
|
if (sexp_exceptionp(tmp)) {
|
|
res = tmp;
|
|
break;
|
|
} else {
|
|
if (lambda_envp(ctx) && nondefp(tmp)) defok = -1; /* -1 to warn */
|
|
sexp_pair_source(res) = sexp_pair_source(x);
|
|
sexp_car(res) = tmp;
|
|
}
|
|
}
|
|
if (sexp_pairp(res)) res = sexp_nreverse(ctx, res);
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp analyze_app (sexp ctx, sexp x, int depth) {
|
|
sexp p, res, tmp;
|
|
res = analyze_list(ctx, x, depth, 0);
|
|
if (sexp_lambdap(sexp_car(res))) { /* fill in lambda names */
|
|
p=sexp_lambda_params(sexp_car(res));
|
|
for (tmp=sexp_cdr(res); sexp_pairp(tmp)&&sexp_pairp(p); tmp=sexp_cdr(tmp), p=sexp_cdr(p))
|
|
if (sexp_lambdap(sexp_car(tmp)))
|
|
sexp_lambda_name(sexp_car(tmp)) = sexp_car(p);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
static sexp analyze_seq (sexp ctx, sexp ls, int depth, int defok) {
|
|
sexp_gc_var2(res, tmp);
|
|
sexp_gc_preserve2(ctx, res, tmp);
|
|
if (sexp_nullp(ls))
|
|
res = SEXP_VOID;
|
|
else if (sexp_nullp(sexp_cdr(ls)))
|
|
res = analyze(ctx, sexp_car(ls), depth, defok);
|
|
else {
|
|
res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
|
|
sexp_seq_source(res) = sexp_pair_source(ls);
|
|
tmp = analyze_list(ctx, ls, depth, defok);
|
|
if (sexp_exceptionp(tmp))
|
|
res = tmp;
|
|
else
|
|
sexp_seq_ls(res) = tmp;
|
|
}
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
|
|
sexp env = sexp_context_env(ctx), res;
|
|
sexp_gc_var1(cell);
|
|
sexp_gc_preserve1(ctx, cell);
|
|
cell = sexp_env_cell_loc(ctx, env, x, 0, varenv);
|
|
if (! cell) {
|
|
cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv);
|
|
}
|
|
if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) {
|
|
res = sexp_compile_error(ctx, "invalid use of syntax as value", x);
|
|
} else {
|
|
res = sexp_make_ref(ctx, sexp_car(cell), cell);
|
|
}
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp analyze_set (sexp ctx, sexp x, int depth) {
|
|
sexp res, varenv;
|
|
sexp_gc_var2(ref, value);
|
|
sexp_gc_preserve2(ctx, ref, value);
|
|
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))
|
|
&& sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) {
|
|
res = sexp_compile_error(ctx, "bad set! syntax", x);
|
|
} else {
|
|
ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv);
|
|
if (sexp_lambdap(sexp_ref_loc(ref)))
|
|
sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
|
|
value = analyze(ctx, sexp_caddr(x), depth, 0);
|
|
if (sexp_exceptionp(ref)) {
|
|
res = ref;
|
|
} else if (sexp_exceptionp(value)) {
|
|
res = value;
|
|
} else if (sexp_immutablep(sexp_ref_cell(ref))
|
|
|| (varenv && sexp_immutablep(varenv))) {
|
|
res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x));
|
|
} else {
|
|
res = sexp_make_set(ctx, ref, value);
|
|
sexp_set_source(res) = sexp_pair_source(x);
|
|
}
|
|
}
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
|
|
#define sexp_return(res, val) do {res=val; goto cleanup;} while (0)
|
|
|
|
static sexp analyze_lambda (sexp ctx, sexp x, int depth) {
|
|
int trailing_non_procs;
|
|
sexp name, ls, ctx3;
|
|
sexp_gc_var6(res, body, tmp, value, defs, ctx2);
|
|
sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2);
|
|
/* verify syntax */
|
|
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))))
|
|
sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x));
|
|
for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls))
|
|
if (! sexp_idp(sexp_car(ls)))
|
|
sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x));
|
|
else if (sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls))))
|
|
sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x));
|
|
/* build lambda and analyze body */
|
|
res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x)));
|
|
if (sexp_exceptionp(res)) sexp_return(res, res);
|
|
sexp_lambda_source(res) = sexp_pair_source(x);
|
|
if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res))))
|
|
sexp_lambda_source(res) = sexp_pair_source(sexp_cdr(x));
|
|
if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res))))
|
|
sexp_lambda_source(res) = sexp_pair_source(sexp_cddr(x));
|
|
ctx2 = sexp_make_child_context(ctx, res);
|
|
if (sexp_exceptionp(ctx2)) sexp_return(res, ctx2);
|
|
tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res));
|
|
sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res);
|
|
if (sexp_exceptionp(sexp_context_env(ctx2))) sexp_return(res, sexp_context_env(ctx2));
|
|
sexp_env_lambda(sexp_context_env(ctx2)) = res;
|
|
body = analyze_seq(ctx2, sexp_cddr(x), depth, 1);
|
|
if (sexp_exceptionp(body)) sexp_return(res, body);
|
|
/* delayed analyze internal defines */
|
|
trailing_non_procs = 0;
|
|
defs = SEXP_NULL;
|
|
for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
|
tmp = sexp_car(ls);
|
|
ctx3 = sexp_cdr(tmp);
|
|
if (sexp_pairp(sexp_caar(tmp))) {
|
|
name = sexp_caaar(tmp);
|
|
tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp));
|
|
tmp = sexp_cons(ctx3, SEXP_VOID, tmp);
|
|
sexp_pair_source(tmp) = sexp_pair_source(sexp_caar(ls));
|
|
value = analyze_lambda(ctx3, tmp, depth);
|
|
} else {
|
|
name = sexp_caar(tmp);
|
|
value = analyze(ctx3, sexp_cadar(tmp), depth, 0);
|
|
}
|
|
if (sexp_exceptionp(value)) sexp_return(res, value);
|
|
if (sexp_lambdap(value)) sexp_lambda_name(value) = name;
|
|
tmp = analyze_var_ref(ctx3, name, NULL);
|
|
if (sexp_exceptionp(tmp)) sexp_return(res, tmp);
|
|
tmp = sexp_make_set(ctx3, tmp, value);
|
|
if (sexp_exceptionp(tmp)) sexp_return(res, tmp);
|
|
sexp_push(ctx3, defs, tmp);
|
|
if (!sexp_lambdap(value)) trailing_non_procs = 1;
|
|
if (trailing_non_procs || !SEXP_USE_UNBOXED_LOCALS)
|
|
sexp_insert(ctx3, sexp_lambda_sv(res), name);
|
|
}
|
|
if (sexp_pairp(defs)) {
|
|
if (! sexp_seqp(body)) {
|
|
tmp = sexp_alloc_type(ctx2, seq, SEXP_SEQ);
|
|
sexp_seq_ls(tmp) = sexp_list1(ctx2, body);
|
|
body = tmp;
|
|
}
|
|
sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body));
|
|
if (sexp_exceptionp(sexp_seq_ls(body))) sexp_return(res, sexp_seq_ls(body));
|
|
}
|
|
if (sexp_exceptionp(body)) res = body;
|
|
else sexp_lambda_body(res) = body;
|
|
cleanup:
|
|
sexp_gc_release6(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp analyze_if (sexp ctx, sexp x, int depth) {
|
|
sexp res, fail_expr;
|
|
sexp_gc_var3(test, pass, fail);
|
|
sexp_gc_preserve3(ctx, test, pass, fail);
|
|
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
|
|
res = sexp_compile_error(ctx, "bad if syntax", x);
|
|
} else {
|
|
test = analyze(ctx, sexp_cadr(x), depth, 0);
|
|
pass = analyze(ctx, sexp_caddr(x), depth, 0);
|
|
fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
|
|
fail = analyze(ctx, fail_expr, depth, 0);
|
|
res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
|
|
sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail));
|
|
if (sexp_cndp(res)) sexp_cnd_source(res) = sexp_pair_source(x);
|
|
}
|
|
sexp_gc_release3(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp analyze_define (sexp ctx, sexp x, int depth) {
|
|
sexp name, res, varenv;
|
|
sexp_gc_var4(ref, value, tmp, env);
|
|
sexp_gc_preserve4(ctx, ref, value, tmp, env);
|
|
env = sexp_context_env(ctx);
|
|
while (sexp_env_syntactic_p(env) && sexp_env_parent(env))
|
|
env = sexp_env_parent(env);
|
|
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
|
|
res = sexp_compile_error(ctx, "bad define syntax", x);
|
|
} else {
|
|
name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x));
|
|
if (! sexp_idp(name)) {
|
|
res = sexp_compile_error(ctx, "can't define a non-symbol", x);
|
|
} else if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) {
|
|
sexp_env_push(ctx, env, tmp, name, sexp_context_lambda(ctx));
|
|
sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name);
|
|
tmp = sexp_cons(ctx, sexp_cdr(x), ctx);
|
|
sexp_pair_source(sexp_cdr(x)) = sexp_pair_source(x);
|
|
sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp);
|
|
res = SEXP_VOID;
|
|
} else {
|
|
#if SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS
|
|
if (sexp_synclop(name)) name = sexp_synclo_expr(name);
|
|
#endif
|
|
sexp_env_cell_define(ctx, env, name, SEXP_VOID, &varenv);
|
|
if (sexp_pairp(sexp_cadr(x))) {
|
|
tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x));
|
|
tmp = sexp_cons(ctx, SEXP_VOID, tmp);
|
|
sexp_pair_source(tmp) = sexp_pair_source(x);
|
|
value = analyze_lambda(ctx, tmp, depth);
|
|
} else
|
|
value = analyze(ctx, sexp_caddr(x), depth, 0);
|
|
tmp = sexp_env_cell_loc(ctx, env, name, 0, &varenv);
|
|
ref = sexp_make_ref(ctx, name, tmp);
|
|
if (sexp_exceptionp(ref)) {
|
|
res = ref;
|
|
} else if (sexp_exceptionp(value)) {
|
|
res = value;
|
|
} else if (varenv && sexp_immutablep(varenv)) {
|
|
res = sexp_compile_error(ctx, "immutable binding", name);
|
|
} else {
|
|
if (sexp_lambdap(value)) sexp_lambda_name(value) = name;
|
|
res = sexp_make_set(ctx, ref, value);
|
|
if (sexp_setp(res)) sexp_set_source(res) = sexp_pair_source(x);
|
|
}
|
|
}
|
|
}
|
|
sexp_gc_release4(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx, int localp) {
|
|
sexp res = SEXP_VOID, name;
|
|
sexp_gc_var2(mac, tmp);
|
|
sexp_gc_preserve2(eval_ctx, mac, tmp);
|
|
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
|
if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls))
|
|
&& sexp_idp(sexp_caar(ls)) && sexp_nullp(sexp_cddar(ls)))) {
|
|
res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_pairp(ls) ? sexp_car(ls) : ls);
|
|
break;
|
|
}
|
|
if (sexp_idp(sexp_cadar(ls)))
|
|
mac = sexp_env_ref(eval_ctx, sexp_context_env(eval_ctx), sexp_cadar(ls), SEXP_FALSE);
|
|
else
|
|
mac = sexp_eval(eval_ctx, sexp_cadar(ls), NULL);
|
|
if (sexp_procedurep(mac))
|
|
mac = sexp_make_macro(eval_ctx, mac, sexp_context_env(eval_ctx));
|
|
if (!(sexp_macrop(mac)||sexp_corep(mac))) {
|
|
res = (sexp_exceptionp(mac) ? mac
|
|
: sexp_compile_error(eval_ctx, "non-procedure macro", mac));
|
|
break;
|
|
}
|
|
name = sexp_caar(ls);
|
|
if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx)))
|
|
name = sexp_synclo_expr(name);
|
|
if (sexp_macrop(mac) && sexp_pairp(sexp_cadar(ls)))
|
|
sexp_macro_source(mac) = sexp_pair_source(sexp_cadar(ls));
|
|
if (localp)
|
|
sexp_env_push(eval_ctx, sexp_context_env(bind_ctx), tmp, name, mac);
|
|
else
|
|
sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac);
|
|
#if !SEXP_USE_STRICT_TOPLEVEL_BINDINGS
|
|
if (localp)
|
|
sexp_env_cell_syntactic_p(sexp_env_cell(eval_ctx, sexp_context_env(bind_ctx), name, 0)) = 1;
|
|
#endif
|
|
}
|
|
sexp_gc_release2(eval_ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp analyze_define_syntax (sexp ctx, sexp x) {
|
|
sexp res;
|
|
sexp_gc_var1(tmp);
|
|
sexp_gc_preserve1(ctx, tmp);
|
|
tmp = sexp_list1(ctx, sexp_cdr(x));
|
|
res = sexp_exceptionp(tmp) ? tmp : analyze_bind_syntax(tmp, ctx, ctx, 0);
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp, int depth) {
|
|
sexp res;
|
|
sexp_gc_var3(env, ctx2, tmp);
|
|
sexp_gc_preserve3(ctx, env, ctx2, tmp);
|
|
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
|
|
res = sexp_compile_error(ctx, "bad let(rec)-syntax", x);
|
|
} else {
|
|
env = sexp_alloc_type(ctx, env, SEXP_ENV);
|
|
sexp_env_syntactic_p(env) = 1;
|
|
sexp_env_parent(env) = sexp_context_env(ctx);
|
|
sexp_env_bindings(env) = SEXP_NULL;
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
sexp_env_renames(env) = SEXP_NULL;
|
|
#endif
|
|
ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
|
|
sexp_context_env(ctx2) = env;
|
|
tmp = analyze_bind_syntax(sexp_cadr(x), (recp ? ctx2 : ctx), ctx2, 1);
|
|
res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x), depth, 1));
|
|
}
|
|
sexp_gc_release3(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp analyze_let_syntax (sexp ctx, sexp x, int depth) {
|
|
return analyze_let_syntax_aux(ctx, x, 0, depth);
|
|
}
|
|
|
|
static sexp analyze_letrec_syntax (sexp ctx, sexp x, int depth) {
|
|
return analyze_let_syntax_aux(ctx, x, 1, depth);
|
|
}
|
|
|
|
static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
|
|
sexp op;
|
|
sexp_gc_var4(res, tmp, x, cell);
|
|
sexp_gc_preserve4(ctx, res, tmp, x, cell);
|
|
x = object;
|
|
|
|
if (++depth > SEXP_MAX_ANALYZE_DEPTH) {
|
|
res = sexp_compile_error(ctx, "SEXP_MAX_ANALYZE_DEPTH exceeded", x);
|
|
goto error;
|
|
}
|
|
|
|
loop:
|
|
if (sexp_pairp(x)) {
|
|
cell = sexp_idp(sexp_car(x)) ? sexp_env_cell(ctx, sexp_context_env(ctx), sexp_car(x), 0) : NULL;
|
|
if (sexp_not(sexp_listp(ctx, x))
|
|
&& !(cell && sexp_macrop(sexp_cdr(cell)))) {
|
|
res = sexp_compile_error(ctx, "dotted list in source", x);
|
|
} else if (sexp_idp(sexp_car(x))) {
|
|
if (! cell) {
|
|
res = analyze_app(ctx, x, depth);
|
|
if (sexp_exceptionp(res))
|
|
sexp_warn(ctx, "exception inside undefined operator: ", sexp_car(x));
|
|
} else {
|
|
op = sexp_cdr(cell);
|
|
if (sexp_corep(op)) {
|
|
switch (sexp_core_code(op)) {
|
|
case SEXP_CORE_DEFINE:
|
|
if (defok < 0)
|
|
sexp_warn(ctx, "out of order define: ", x);
|
|
res = defok ? analyze_define(ctx, x, depth)
|
|
: sexp_compile_error(ctx, "unexpected define", x);
|
|
break;
|
|
case SEXP_CORE_SET:
|
|
res = analyze_set(ctx, x, depth); break;
|
|
case SEXP_CORE_LAMBDA:
|
|
res = analyze_lambda(ctx, x, depth); break;
|
|
case SEXP_CORE_IF:
|
|
res = analyze_if(ctx, x, depth); break;
|
|
case SEXP_CORE_BEGIN:
|
|
res = analyze_seq(ctx, sexp_cdr(x), depth, defok); break;
|
|
case SEXP_CORE_QUOTE:
|
|
case SEXP_CORE_SYNTAX_QUOTE:
|
|
if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x))))
|
|
res = sexp_compile_error(ctx, "bad quote form", x);
|
|
else
|
|
res = sexp_make_lit(ctx,
|
|
(sexp_core_code(op) == SEXP_CORE_QUOTE) ?
|
|
tmp=sexp_strip_synclos(ctx , NULL, 1, sexp_cadr(x)) :
|
|
sexp_cadr(x));
|
|
break;
|
|
case SEXP_CORE_DEFINE_SYNTAX:
|
|
if (defok < 0)
|
|
sexp_warn(ctx, "out of order define-syntax: ", x);
|
|
res = defok ? analyze_define_syntax(ctx, x)
|
|
: sexp_compile_error(ctx, "unexpected define-syntax", x);
|
|
break;
|
|
case SEXP_CORE_LET_SYNTAX:
|
|
res = analyze_let_syntax(ctx, x, depth); break;
|
|
case SEXP_CORE_LETREC_SYNTAX:
|
|
res = analyze_letrec_syntax(ctx, x, depth); break;
|
|
default:
|
|
res = sexp_compile_error(ctx, "unknown core form", op); break;
|
|
}
|
|
} else if (sexp_macrop(op)) {
|
|
tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL);
|
|
tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp);
|
|
tmp = sexp_cons(ctx, x, tmp);
|
|
x = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx));
|
|
if (!sexp_exceptionp(x) && !sexp_exceptionp(sexp_context_exception(ctx)))
|
|
x = sexp_apply(x, sexp_macro_proc(op), tmp);
|
|
if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x)))
|
|
sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp));
|
|
goto loop;
|
|
} else if (sexp_opcodep(op)) {
|
|
res = sexp_length(ctx, sexp_cdr(x));
|
|
if (sexp_unbox_fixnum(res) < sexp_opcode_num_args(op)) {
|
|
sexp_warn(ctx, "not enough args for opcode: ", x);
|
|
op = analyze_var_ref(ctx, sexp_car(x), NULL);
|
|
} else if ((sexp_unbox_fixnum(res) > sexp_opcode_num_args(op))
|
|
&& (! sexp_opcode_variadic_p(op))) {
|
|
sexp_warn(ctx, "too many args for opcode: ", x);
|
|
op = analyze_var_ref(ctx, sexp_car(x), NULL);
|
|
}
|
|
res = analyze_list(ctx, sexp_cdr(x), 0, 0);
|
|
if (! sexp_exceptionp(res)) {
|
|
/* push op, which will be a direct opcode if the call is valid */
|
|
sexp_push(ctx, res, op);
|
|
if (sexp_pairp(res))
|
|
sexp_pair_source(res) = sexp_pair_source(x);
|
|
}
|
|
} else {
|
|
res = analyze_app(ctx, x, depth);
|
|
}
|
|
}
|
|
} else {
|
|
res = analyze_app(ctx, x, depth);
|
|
if (!sexp_exceptionp(res)
|
|
&& !(sexp_pairp(sexp_car(x))
|
|
|| (sexp_synclop(sexp_car(x))
|
|
&& sexp_pairp(sexp_synclo_expr(sexp_car(x))))))
|
|
sexp_warn(ctx, "invalid operator in application: ", x);
|
|
}
|
|
} else if (sexp_idp(x)) {
|
|
res = analyze_var_ref(ctx, x, NULL);
|
|
} else if (sexp_synclop(x)) {
|
|
tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
|
|
if (sexp_pairp(sexp_synclo_free_vars(x))) {
|
|
sexp_push(ctx, sexp_context_fv(tmp), sexp_context_env(ctx));
|
|
sexp_context_fv(tmp) = sexp_append2(tmp,
|
|
sexp_synclo_free_vars(x),
|
|
sexp_context_fv(tmp));
|
|
}
|
|
sexp_context_env(tmp) = sexp_extend_synclo_env(tmp, sexp_synclo_env(x));
|
|
x = sexp_synclo_expr(x);
|
|
res = analyze(tmp, x, depth, defok);
|
|
} else if (sexp_nullp(x)) {
|
|
res = sexp_compile_error(ctx, "empty application in source", x);
|
|
} else {
|
|
if (sexp_pointerp(x)) { /* accept vectors and other literals directly, */
|
|
sexp_immutablep(x) = 1; /* but they must be immutable */
|
|
x = sexp_strip_synclos(ctx , NULL, 1, x);
|
|
}
|
|
res = x;
|
|
}
|
|
|
|
error:
|
|
if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res))
|
|
&& sexp_pairp(x))
|
|
sexp_exception_source(res) = sexp_pair_source(x);
|
|
sexp_gc_release4(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x, 0, 1);}
|
|
|
|
/********************** free varable analysis *************************/
|
|
|
|
static sexp insert_free_var (sexp ctx, sexp x, sexp fv) {
|
|
sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls;
|
|
for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls))
|
|
if ((name == sexp_ref_name(sexp_car(ls)))
|
|
&& (loc == sexp_ref_loc(sexp_car(ls))))
|
|
return fv;
|
|
return sexp_cons(ctx, x, fv);
|
|
}
|
|
|
|
static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) {
|
|
sexp_gc_var1(res);
|
|
if (sexp_nullp(fv2))
|
|
return fv1;
|
|
sexp_gc_preserve1(ctx, res);
|
|
for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1))
|
|
res = insert_free_var(ctx, sexp_car(fv1), res);
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) {
|
|
sexp_gc_var1(res);
|
|
sexp_gc_preserve1(ctx, res);
|
|
res = SEXP_NULL;
|
|
for ( ; sexp_pairp(fv); fv=sexp_cdr(fv))
|
|
if ((sexp_ref_loc(sexp_car(fv)) != lambda)
|
|
|| (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params)
|
|
== SEXP_FALSE))
|
|
sexp_push(ctx, res, sexp_car(fv));
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) {
|
|
sexp_gc_var2(fv1, fv2);
|
|
sexp_gc_preserve2(ctx, fv1, fv2);
|
|
fv1 = fv;
|
|
if (sexp_lambdap(x)) {
|
|
fv1 = sexp_free_vars(ctx, sexp_lambda_body(x), SEXP_NULL);
|
|
fv2 = sexp_flatten_dot(ctx, sexp_lambda_params(x));
|
|
fv2 = sexp_append2(ctx, sexp_lambda_locals(x), fv2);
|
|
fv2 = diff_free_vars(ctx, x, fv1, fv2);
|
|
sexp_lambda_fv(x) = fv2;
|
|
fv1 = union_free_vars(ctx, fv2, fv);
|
|
} else if (sexp_pairp(x)) {
|
|
for ( ; sexp_pairp(x); x=sexp_cdr(x))
|
|
fv1 = sexp_free_vars(ctx, sexp_car(x), fv1);
|
|
} else if (sexp_cndp(x)) {
|
|
fv1 = sexp_free_vars(ctx, sexp_cnd_test(x), fv);
|
|
fv1 = sexp_free_vars(ctx, sexp_cnd_pass(x), fv1);
|
|
fv1 = sexp_free_vars(ctx, sexp_cnd_fail(x), fv1);
|
|
} else if (sexp_seqp(x)) {
|
|
for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x))
|
|
fv1 = sexp_free_vars(ctx, sexp_car(x), fv1);
|
|
} else if (sexp_setp(x)) {
|
|
fv1 = sexp_free_vars(ctx, sexp_set_value(x), fv);
|
|
fv1 = sexp_free_vars(ctx, sexp_set_var(x), fv1);
|
|
} else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) {
|
|
fv1 = insert_free_var(ctx, x, fv);
|
|
} else if (sexp_synclop(x)) {
|
|
fv1 = sexp_free_vars(ctx, sexp_synclo_expr(x), fv);
|
|
}
|
|
sexp_gc_release2(ctx);
|
|
return fv1;
|
|
}
|
|
|
|
/************************ library procedures **************************/
|
|
|
|
sexp sexp_open_input_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
|
|
FILE *in;
|
|
int count = 0;
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path);
|
|
do {
|
|
if (count != 0) sexp_gc(ctx, NULL);
|
|
in = fopen(sexp_string_data(path), "r");
|
|
} while (!in && sexp_out_of_file_descriptors() && !count++);
|
|
if (!in)
|
|
return sexp_file_exception(ctx, self, "couldn't open input file", path);
|
|
#if SEXP_USE_GREEN_THREADS
|
|
fcntl(fileno(in), F_SETFL, O_NONBLOCK);
|
|
#endif
|
|
return sexp_make_input_port(ctx, in, path);
|
|
}
|
|
|
|
sexp sexp_open_output_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
|
|
FILE *out;
|
|
int count = 0;
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path);
|
|
do {
|
|
if (count != 0) sexp_gc(ctx, NULL);
|
|
out = fopen(sexp_string_data(path), "w");
|
|
} while (!out && sexp_out_of_file_descriptors() && !count++);
|
|
if (!out)
|
|
return sexp_file_exception(ctx, self, "couldn't open output file", path);
|
|
#if SEXP_USE_GREEN_THREADS
|
|
fcntl(fileno(out), F_SETFL, O_NONBLOCK);
|
|
#endif
|
|
return sexp_make_output_port(ctx, out, path);
|
|
}
|
|
|
|
sexp sexp_open_binary_input_file (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
|
|
sexp res = sexp_open_input_file_op(ctx, self, n, path);
|
|
if (sexp_portp(res)) sexp_port_binaryp(res) = 1;
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_open_binary_output_file (sexp ctx, sexp self, sexp_sint_t n, sexp path) {
|
|
sexp res = sexp_open_output_file_op(ctx, self, n, path);
|
|
if (sexp_portp(res)) sexp_port_binaryp(res) = 1;
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_close_port_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
|
|
sexp res = SEXP_VOID;
|
|
sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port);
|
|
/* we can't run arbitrary scheme code in the finalizer, so we need */
|
|
/* to flush and run the closer here */
|
|
if (sexp_port_customp(port)) {
|
|
if (sexp_oportp(port)) res = sexp_flush_output(ctx, port);
|
|
if (sexp_exceptionp(res)) return res;
|
|
if (sexp_applicablep(sexp_port_closer(port)))
|
|
res = sexp_apply1(ctx, sexp_port_closer(port), port);
|
|
if (sexp_exceptionp(res)) return res;
|
|
}
|
|
return sexp_finalize_port(ctx, self, n, port);
|
|
}
|
|
|
|
sexp sexp_set_port_line_op (sexp ctx, sexp self, sexp_sint_t n, sexp port, sexp line) {
|
|
sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, port);
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, line);
|
|
sexp_port_sourcep(port) = 1;
|
|
sexp_port_line(port) = sexp_unbox_fixnum(line);
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
#ifndef PLAN9
|
|
sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port) {
|
|
int fd;
|
|
sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port);
|
|
fd = sexp_port_fileno(port);
|
|
if (fd >= 0)
|
|
return sexp_make_fixnum(fd);
|
|
return SEXP_FALSE;
|
|
}
|
|
#endif
|
|
|
|
#if SEXP_USE_STATIC_LIBS
|
|
#if SEXP_USE_STATIC_LIBS_NO_INCLUDE
|
|
extern struct sexp_library_entry_t* sexp_static_libraries;
|
|
#else
|
|
#include "clibs.c"
|
|
#endif
|
|
static struct sexp_library_entry_t *sexp_find_static_library(const char *file)
|
|
{
|
|
size_t base_len;
|
|
struct sexp_library_entry_t *entry;
|
|
|
|
if (file[0] == '.' && file[1] == '/')
|
|
file += 2;
|
|
base_len = strlen(file) - strlen(sexp_so_extension);
|
|
if (strcmp(file + base_len, sexp_so_extension))
|
|
return NULL;
|
|
for (entry = &sexp_static_libraries[0]; entry->name; entry++)
|
|
if (! strncmp(file, entry->name, base_len))
|
|
return entry;
|
|
return NULL;
|
|
}
|
|
#else
|
|
#define sexp_find_static_library(path) NULL
|
|
#endif
|
|
|
|
#if SEXP_USE_DL
|
|
#ifdef __MINGW32__
|
|
#include <windows.h>
|
|
static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) {
|
|
sexp res;
|
|
sexp_init_proc init;
|
|
HINSTANCE handle = LoadLibraryA(sexp_string_data(file));
|
|
if (!handle)
|
|
return sexp_compile_error(ctx, "couldn't load dynamic library", file);
|
|
init = (sexp_init_proc) GetProcAddress(handle, "sexp_init_library");
|
|
if (!init) {
|
|
FreeLibrary(handle);
|
|
return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file);
|
|
}
|
|
res = init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER);
|
|
if (res == SEXP_ABI_ERROR) res = sexp_global(ctx, SEXP_G_ABI_ERROR);
|
|
return res;
|
|
}
|
|
#else
|
|
static sexp sexp_make_dl (sexp ctx, sexp file, void* handle) {
|
|
sexp res = sexp_alloc_type(ctx, dl, SEXP_DL);
|
|
sexp_dl_file(res) = file;
|
|
sexp_dl_handle(res) = handle;
|
|
return res;
|
|
}
|
|
static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) {
|
|
sexp_init_proc init;
|
|
sexp_gc_var2(res, old_dl);
|
|
void *handle = dlopen(sexp_string_data(file), RTLD_LAZY);
|
|
if (! handle) {
|
|
return sexp_compile_error(ctx, "couldn't load dynamic library", file);
|
|
}
|
|
init = dlsym(handle, "sexp_init_library");
|
|
if (! init) {
|
|
dlclose(handle);
|
|
return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file);
|
|
}
|
|
sexp_gc_preserve2(ctx, res, old_dl);
|
|
old_dl = sexp_context_dl(ctx);
|
|
sexp_context_dl(ctx) = sexp_make_dl(ctx, file, handle);
|
|
res = init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER);
|
|
/* If the ABI is incompatible the library may not even be able to
|
|
properly reference a global, so it returns a special immediate
|
|
which we need to translate. */
|
|
if (res == SEXP_ABI_ERROR) res = sexp_global(ctx, SEXP_G_ABI_ERROR);
|
|
sexp_context_dl(ctx) = old_dl;
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
#endif
|
|
#else
|
|
#define sexp_load_dl(ctx, file, env) SEXP_UNDEF
|
|
#endif
|
|
|
|
#if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
|
|
static sexp sexp_load_binary(sexp ctx, sexp file, sexp env) {
|
|
#if SEXP_USE_STATIC_LIBS
|
|
struct sexp_library_entry_t *entry;
|
|
#endif
|
|
sexp res = sexp_load_dl(ctx, file, env);
|
|
#if SEXP_USE_STATIC_LIBS
|
|
if (res == SEXP_UNDEF || sexp_exceptionp(res)) {
|
|
entry = sexp_find_static_library(sexp_string_data(file));
|
|
if (entry == NULL)
|
|
res = (res == SEXP_UNDEF ? sexp_compile_error(ctx, "couldn't find builtin library", file) : res);
|
|
else
|
|
res = entry->init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER);
|
|
}
|
|
#endif
|
|
return res;
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_load_op (sexp ctx, sexp self, sexp_sint_t n, sexp source, sexp env) {
|
|
#if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
|
|
const char *suffix;
|
|
#endif
|
|
sexp_gc_var5(ctx2, x, in, res, out);
|
|
if (!env) env = sexp_context_env(ctx);
|
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
|
#if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
|
|
suffix = sexp_stringp(source) ? sexp_string_data(source)
|
|
+ sexp_string_size(source) - strlen(sexp_so_extension) : "...";
|
|
if (strcmp(suffix, sexp_so_extension) == 0) {
|
|
res = sexp_load_binary(ctx, source, env);
|
|
} else {
|
|
#endif
|
|
res = SEXP_VOID;
|
|
if (sexp_iportp(source)) {
|
|
in = source;
|
|
} else {
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source);
|
|
in = sexp_open_input_file(ctx, source);
|
|
}
|
|
sexp_gc_preserve5(ctx, ctx2, x, in, res, out);
|
|
if (sexp_exceptionp(in)) {
|
|
out = sexp_current_error_port(ctx);
|
|
if (sexp_not(out)) out = sexp_current_error_port(ctx);
|
|
if (sexp_oportp(out))
|
|
sexp_print_exception(ctx, in, out);
|
|
res = in;
|
|
} else {
|
|
sexp_port_sourcep(in) = 1;
|
|
ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
|
|
sexp_context_parent(ctx2) = ctx;
|
|
sexp_context_tailp(ctx2) = 0;
|
|
while ((x=sexp_read(ctx2, in)) != (sexp) SEXP_EOF) {
|
|
res = sexp_exceptionp(x) ? x : sexp_eval(ctx2, x, env);
|
|
if (sexp_exceptionp(res))
|
|
break;
|
|
}
|
|
sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2);
|
|
if (x == SEXP_EOF)
|
|
res = SEXP_VOID;
|
|
sexp_close_port(ctx, in);
|
|
}
|
|
sexp_gc_release5(ctx);
|
|
#if SEXP_USE_DL || SEXP_USE_STATIC_LIBS
|
|
}
|
|
#endif
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_register_optimization (sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp priority) {
|
|
sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, f);
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, priority);
|
|
sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), SEXP_VOID);
|
|
sexp_car(sexp_global(ctx, SEXP_G_OPTIMIZATIONS)) = sexp_cons(ctx, priority, f);
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
#if SEXP_USE_MATH
|
|
|
|
#if SEXP_USE_BIGNUMS
|
|
#define maybe_convert_bignum(z) \
|
|
else if (sexp_bignump(z)) d = sexp_bignum_to_double(z);
|
|
#else
|
|
#define maybe_convert_bignum(z)
|
|
#endif
|
|
|
|
#if SEXP_USE_RATIOS
|
|
#define maybe_convert_ratio(z) \
|
|
else if (sexp_ratiop(z)) d = sexp_ratio_to_double(z);
|
|
#else
|
|
#define maybe_convert_ratio(z)
|
|
#endif
|
|
|
|
#if SEXP_USE_COMPLEX
|
|
#define maybe_convert_complex(z, f) \
|
|
else if (sexp_complexp(z)) return sexp_complex_normalize(f(ctx, z));
|
|
#define sexp_complex_dummy(ctx, z) 0
|
|
#else
|
|
#define maybe_convert_complex(z, f)
|
|
#endif
|
|
|
|
#define define_math_op(name, cname, f) \
|
|
sexp name (sexp ctx, sexp self, sexp_sint_t n, sexp z) { \
|
|
double d; \
|
|
if (sexp_flonump(z)) \
|
|
d = sexp_flonum_value(z); \
|
|
else if (sexp_fixnump(z)) \
|
|
d = (double)sexp_unbox_fixnum(z); \
|
|
maybe_convert_ratio(z) \
|
|
maybe_convert_bignum(z) \
|
|
maybe_convert_complex(z, f) \
|
|
else \
|
|
return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \
|
|
return sexp_make_flonum(ctx, cname(d)); \
|
|
}
|
|
|
|
#ifdef SEXP_USE_COMPLEX
|
|
#define define_complex_math_op(name, cname, f, a, b) \
|
|
sexp name (sexp ctx, sexp self, sexp_sint_t n, sexp z) { \
|
|
double d; \
|
|
if (sexp_flonump(z)) \
|
|
d = sexp_flonum_value(z); \
|
|
else if (sexp_fixnump(z)) \
|
|
d = (double)sexp_unbox_fixnum(z); \
|
|
maybe_convert_ratio(z) \
|
|
maybe_convert_bignum(z) \
|
|
maybe_convert_complex(z, f) \
|
|
else \
|
|
return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \
|
|
if (d < a || d > b) \
|
|
return sexp_complex_normalize \
|
|
(f(ctx, sexp_make_complex(ctx, z, SEXP_ZERO))); \
|
|
return sexp_make_flonum(ctx, cname(d)); \
|
|
}
|
|
#else
|
|
#define define_complex_math_op(name, cname, f, a, b) \
|
|
define_math_op(name, cname, f)
|
|
#endif
|
|
|
|
define_math_op(sexp_exp, exp, sexp_complex_exp)
|
|
define_math_op(sexp_sin, sin, sexp_complex_sin)
|
|
define_math_op(sexp_cos, cos, sexp_complex_cos)
|
|
define_math_op(sexp_tan, tan, sexp_complex_tan)
|
|
define_complex_math_op(sexp_asin, asin, sexp_complex_asin, -1, 1)
|
|
define_complex_math_op(sexp_acos, acos, sexp_complex_acos, -1, 1)
|
|
define_math_op(sexp_atan, atan, sexp_complex_atan)
|
|
|
|
#if SEXP_USE_RATIOS
|
|
#define maybe_round_ratio(ctx, q, f) \
|
|
if (sexp_ratiop(q)) return f(ctx, q);
|
|
#else
|
|
#define maybe_round_ratio(ctx, q, f)
|
|
#endif
|
|
|
|
#define define_math_rounder(name, cname, f) \
|
|
sexp name (sexp ctx, sexp self, sexp_sint_t n, sexp z) { \
|
|
maybe_round_ratio(ctx, z, f) \
|
|
if (sexp_flonump(z)) \
|
|
return sexp_make_flonum(ctx, cname(sexp_flonum_value(z))); \
|
|
else if (sexp_fixnump(z) || sexp_bignump(z)) \
|
|
return z; \
|
|
return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \
|
|
}
|
|
|
|
static double even_round (double d) {
|
|
double res = round(d);
|
|
if (fabs(d - res) == 0.5 && ((long)res & 1))
|
|
res += (res < 0) ? 1 : -1;
|
|
return res;
|
|
}
|
|
|
|
define_math_rounder(sexp_round, even_round, sexp_ratio_round)
|
|
define_math_rounder(sexp_trunc, trunc, sexp_ratio_trunc)
|
|
define_math_rounder(sexp_floor, floor, sexp_ratio_floor)
|
|
define_math_rounder(sexp_ceiling, ceil, sexp_ratio_ceiling)
|
|
|
|
sexp sexp_log (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
|
|
double d;
|
|
#if SEXP_USE_COMPLEX
|
|
sexp_gc_var1(tmp);
|
|
if (sexp_complexp(z))
|
|
return sexp_complex_log(ctx, z);
|
|
#endif
|
|
if (sexp_flonump(z))
|
|
d = sexp_flonum_value(z);
|
|
else if (sexp_fixnump(z))
|
|
d = (double)sexp_unbox_fixnum(z);
|
|
maybe_convert_ratio(z)
|
|
maybe_convert_bignum(z)
|
|
else
|
|
return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
|
|
#if SEXP_USE_COMPLEX
|
|
if (d < 0) {
|
|
sexp_gc_preserve1(ctx, tmp);
|
|
tmp = sexp_make_flonum(ctx, d);
|
|
tmp = sexp_make_complex(ctx, tmp, SEXP_ZERO);
|
|
tmp = sexp_complex_log(ctx, tmp);
|
|
sexp_gc_release1(ctx);
|
|
return tmp;
|
|
}
|
|
#endif
|
|
return sexp_make_flonum(ctx, log(d));
|
|
}
|
|
|
|
sexp sexp_inexact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
|
|
#if SEXP_USE_COMPLEX
|
|
int negativep = 0;
|
|
#endif
|
|
double d, r;
|
|
sexp_gc_var1(res);
|
|
if (sexp_flonump(z))
|
|
d = sexp_flonum_value(z);
|
|
else if (sexp_fixnump(z))
|
|
d = (double)sexp_unbox_fixnum(z);
|
|
maybe_convert_ratio(z) /* XXXX add ratio sqrt */
|
|
maybe_convert_complex(z, sexp_complex_sqrt)
|
|
else
|
|
return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
|
|
#if SEXP_USE_COMPLEX
|
|
if (d < 0) {
|
|
negativep = 1;
|
|
d = -d;
|
|
}
|
|
#endif
|
|
sexp_gc_preserve1(ctx, res);
|
|
r = sqrt(d);
|
|
if (sexp_fixnump(z)
|
|
&& (((sexp_uint_t)r*(sexp_uint_t)r)==labs(sexp_unbox_fixnum(z))))
|
|
res = sexp_make_fixnum(round(r));
|
|
else
|
|
res = sexp_make_flonum(ctx, r);
|
|
#if SEXP_USE_COMPLEX
|
|
if (negativep)
|
|
res = sexp_make_complex(ctx, SEXP_ZERO, res);
|
|
#endif
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
#if SEXP_USE_BIGNUMS
|
|
sexp sexp_exact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
|
|
sexp_gc_var2(res, rem);
|
|
sexp_gc_preserve2(ctx, res, rem);
|
|
if (sexp_bignump(z)) {
|
|
res = sexp_bignum_sqrt(ctx, z, &rem);
|
|
res = sexp_cons(ctx, res, rem);
|
|
} else {
|
|
res = sexp_inexact_sqrt(ctx, self, n, z);
|
|
if (sexp_flonump(res)) {
|
|
res = sexp_bignum_normalize(sexp_double_to_bignum(ctx, trunc(sexp_flonum_value(res))));
|
|
}
|
|
if (!sexp_exceptionp(res)) {
|
|
rem = sexp_mul(ctx, res, res);
|
|
rem = sexp_sub(ctx, z, rem);
|
|
res = sexp_cons(ctx, res, rem);
|
|
}
|
|
}
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
|
|
#if SEXP_USE_BIGNUMS
|
|
sexp_gc_var2(res, rem);
|
|
if (sexp_bignump(z)) {
|
|
sexp_gc_preserve2(ctx, res, rem);
|
|
res = sexp_bignum_sqrt(ctx, z, &rem);
|
|
rem = sexp_bignum_normalize(rem);
|
|
if (rem != SEXP_ZERO)
|
|
res = sexp_make_flonum(ctx, sexp_fixnump(res) ? sexp_unbox_fixnum(res) : sexp_bignum_to_double(res));
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
#endif
|
|
return sexp_inexact_sqrt(ctx, self, n, z);
|
|
}
|
|
|
|
#endif /* SEXP_USE_MATH */
|
|
|
|
#if SEXP_USE_RATIOS || !SEXP_USE_FLONUMS
|
|
sexp sexp_generic_expt (sexp ctx, sexp x, sexp_sint_t e) {
|
|
sexp_gc_var2(res, tmp);
|
|
sexp_gc_preserve2(ctx, res, tmp);
|
|
for (res = SEXP_ONE, tmp = x; e > 0; e >>= 1) {
|
|
if (e&1) res = sexp_mul(ctx, res, tmp);
|
|
tmp = sexp_mul(ctx, tmp, tmp);
|
|
}
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_expt_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
|
|
#if !SEXP_USE_FLONUMS
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, x);
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, e);
|
|
return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e));
|
|
#else
|
|
long double f, x1, e1;
|
|
sexp res;
|
|
#if SEXP_USE_BIGNUMS
|
|
sexp_gc_var1(tmp);
|
|
#endif
|
|
#if SEXP_USE_COMPLEX
|
|
if (sexp_complexp(x) || sexp_complexp(e))
|
|
return sexp_complex_expt(ctx, x, e);
|
|
#endif
|
|
#if SEXP_USE_BIGNUMS
|
|
if (sexp_bignump(e)) { /* bignum exponent needs special handling */
|
|
if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE))
|
|
res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */
|
|
else if (x == SEXP_ONE)
|
|
res = SEXP_ONE; /* 1.0 */
|
|
else if (sexp_flonump(x))
|
|
res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e)));
|
|
else
|
|
res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */
|
|
} else if (sexp_bignump(x)) {
|
|
res = sexp_bignum_expt(ctx, x, e);
|
|
} else {
|
|
#endif
|
|
if (sexp_fixnump(x))
|
|
x1 = sexp_unbox_fixnum(x);
|
|
else if (sexp_flonump(x))
|
|
x1 = sexp_flonum_value(x);
|
|
#if SEXP_USE_RATIOS
|
|
else if (sexp_ratiop(x)) {
|
|
if (sexp_fixnump(e)) {
|
|
return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e));
|
|
} else {
|
|
x1 = sexp_ratio_to_double(x);
|
|
}
|
|
}
|
|
#endif
|
|
else
|
|
return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
|
|
if (sexp_fixnump(e))
|
|
e1 = sexp_unbox_fixnum(e);
|
|
else if (sexp_flonump(e))
|
|
e1 = sexp_flonum_value(e);
|
|
#if SEXP_USE_RATIOS
|
|
else if (sexp_ratiop(e))
|
|
e1 = sexp_ratio_to_double(e);
|
|
#endif
|
|
else
|
|
return sexp_type_exception(ctx, self, SEXP_FIXNUM, e);
|
|
f = pow(x1, e1);
|
|
if ((f*1000.0 > SEXP_MAX_FIXNUM) || (f*1000.0 < SEXP_MIN_FIXNUM)
|
|
|| (! sexp_fixnump(x)) || (! sexp_fixnump(e)) || (e1 < 0.0)) {
|
|
#if SEXP_USE_BIGNUMS
|
|
if (sexp_fixnump(x) && sexp_fixnump(e) && (e1 >= 0.0)) {
|
|
sexp_gc_preserve1(ctx, tmp);
|
|
tmp = sexp_fixnum_to_bignum(ctx, x);
|
|
res = sexp_bignum_expt(ctx, tmp, e);
|
|
sexp_gc_release1(ctx);
|
|
} else
|
|
#endif
|
|
res = sexp_make_flonum(ctx, f);
|
|
} else
|
|
res = sexp_make_fixnum((sexp_sint_t)round(f));
|
|
#if SEXP_USE_BIGNUMS
|
|
}
|
|
#endif
|
|
return res;
|
|
#endif /* !SEXP_USE_FLONUMS */
|
|
}
|
|
|
|
#if SEXP_USE_RATIOS
|
|
sexp sexp_ratio_numerator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat) {
|
|
sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat);
|
|
return sexp_ratio_numerator(rat);
|
|
}
|
|
sexp sexp_ratio_denominator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat) {
|
|
sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat);
|
|
return sexp_ratio_denominator(rat);
|
|
}
|
|
#endif
|
|
|
|
#if SEXP_USE_COMPLEX
|
|
sexp sexp_complex_real_op (sexp ctx, sexp self, sexp_sint_t n, sexp cpx) {
|
|
sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx);
|
|
return sexp_complex_real(cpx);
|
|
}
|
|
sexp sexp_complex_imag_op (sexp ctx, sexp self, sexp_sint_t n, sexp cpx) {
|
|
sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx);
|
|
return sexp_complex_imag(cpx);
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_exact_to_inexact (sexp ctx, sexp self, sexp_sint_t n, sexp i) {
|
|
sexp_gc_var1(res);
|
|
res = i;
|
|
if (sexp_fixnump(i))
|
|
res = sexp_fixnum_to_flonum(ctx, i);
|
|
#if SEXP_USE_FLONUMS
|
|
else if (sexp_flonump(i))
|
|
res = i;
|
|
#endif
|
|
#if SEXP_USE_BIGNUMS
|
|
else if (sexp_bignump(i))
|
|
res = sexp_make_flonum(ctx, sexp_bignum_to_double(i));
|
|
#endif
|
|
#if SEXP_USE_RATIOS
|
|
else if (sexp_ratiop(i))
|
|
res = sexp_make_flonum(ctx, sexp_ratio_to_double(i));
|
|
#endif
|
|
#if SEXP_USE_COMPLEX
|
|
else if (sexp_complexp(i)) {
|
|
sexp_gc_preserve1(ctx, res);
|
|
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
|
sexp_complex_real(res) = sexp_exact_to_inexact(ctx, self, 1, sexp_complex_real(i));
|
|
sexp_complex_imag(res) = sexp_exact_to_inexact(ctx, self, 1, sexp_complex_imag(i));
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
#endif
|
|
else
|
|
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_inexact_to_exact (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
|
|
sexp_gc_var1(res);
|
|
if (sexp_exactp(z)) {
|
|
res = z;
|
|
}
|
|
#if SEXP_USE_FLONUMS
|
|
else if (sexp_flonump(z)) {
|
|
if (isinf(sexp_flonum_value(z)) || isnan(sexp_flonum_value(z))) {
|
|
res = sexp_xtype_exception(ctx, self, "exact: not a finite number", z);
|
|
} else if (sexp_flonum_value(z) != trunc(sexp_flonum_value(z))) {
|
|
#if SEXP_USE_RATIOS
|
|
res = sexp_double_to_ratio(ctx, sexp_flonum_value(z));
|
|
#else
|
|
res = sexp_xtype_exception(ctx, self, "exact: not an integer", z);
|
|
#endif
|
|
#if SEXP_USE_BIGNUMS
|
|
} else if ((sexp_flonum_value(z) > SEXP_MAX_FIXNUM)
|
|
|| sexp_flonum_value(z) < SEXP_MIN_FIXNUM) {
|
|
res = sexp_double_to_bignum(ctx, sexp_flonum_value(z));
|
|
#endif
|
|
} else {
|
|
res = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(z));
|
|
}
|
|
}
|
|
#endif
|
|
#if SEXP_USE_COMPLEX
|
|
else if (sexp_complexp(z)) {
|
|
sexp_gc_preserve1(ctx, res);
|
|
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
|
sexp_complex_real(res) = sexp_inexact_to_exact(ctx, self, 1, sexp_complex_real(z));
|
|
sexp_complex_imag(res) = sexp_inexact_to_exact(ctx, self, 1, sexp_complex_imag(z));
|
|
if (sexp_exceptionp(sexp_complex_real(res)))
|
|
res = sexp_complex_real(res);
|
|
else if (sexp_exceptionp(sexp_complex_imag(res)))
|
|
res = sexp_complex_imag(res);
|
|
else if (sexp_complex_imag(res) == SEXP_ZERO)
|
|
res = sexp_complex_real(res);
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
#endif
|
|
else {
|
|
res = sexp_type_exception(ctx, self, SEXP_FLONUM, z);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_string_cmp_op (sexp ctx, sexp self, sexp_sint_t n, sexp str1, sexp str2, sexp ci) {
|
|
sexp_sint_t len1, len2, len, diff;
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1);
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2);
|
|
len1 = sexp_string_size(str1);
|
|
len2 = sexp_string_size(str2);
|
|
len = ((len1<len2) ? len1 : len2);
|
|
if (ci==SEXP_FALSE)
|
|
diff = strncmp(sexp_string_data(str1), sexp_string_data(str2), len);
|
|
else
|
|
diff = strncasecmp(sexp_string_data(str1), sexp_string_data(str2), len);
|
|
if (! diff)
|
|
diff = len1 - len2;
|
|
return sexp_make_fixnum(diff);
|
|
}
|
|
|
|
#if SEXP_USE_UTF8_STRINGS
|
|
|
|
sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i) {
|
|
sexp off;
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
|
|
off = sexp_string_index_to_cursor(ctx, self, n, str, i);
|
|
if (sexp_exceptionp(off)) return off;
|
|
if (sexp_unbox_string_cursor(off) >= (sexp_sint_t)sexp_string_size(str))
|
|
return sexp_user_exception(ctx, self, "string-ref: index out of range", i);
|
|
return sexp_string_utf8_ref(ctx, str, off);
|
|
}
|
|
|
|
sexp sexp_read_utf8_char (sexp ctx, sexp port, int i) {
|
|
if (i >= 0x80) {
|
|
if ((i < 0xC0) || (i > 0xF7)) {
|
|
return sexp_user_exception(ctx, NULL, "read-char: invalid utf8 byte", sexp_make_fixnum(i));
|
|
} else if (i < 0xE0) {
|
|
i = ((i&0x3F)<<6) + (sexp_read_char(ctx, port)&0x3F);
|
|
} else if (i < 0xF0) {
|
|
i = ((i&0x1F)<<12) + ((sexp_read_char(ctx, port)&0x3F)<<6);
|
|
i += sexp_read_char(ctx, port)&0x3F;
|
|
} else {
|
|
i = ((i&0x0F)<<18) + ((sexp_read_char(ctx, port)&0x3F)<<12);
|
|
i += (sexp_read_char(ctx, port)&0x3F)<<6;
|
|
i += sexp_read_char(ctx, port)&0x3F;
|
|
}
|
|
}
|
|
return sexp_make_character(i);
|
|
}
|
|
|
|
void sexp_push_utf8_char (sexp ctx, int i, sexp port) {
|
|
unsigned char ch[6];
|
|
int len = sexp_utf8_char_byte_count(i);
|
|
sexp_utf8_encode_char(ch, len, i);
|
|
if (sexp_port_stream(port)) {
|
|
while (len>0)
|
|
ungetc(ch[--len], sexp_port_stream(port));
|
|
} else {
|
|
while (len>0)
|
|
sexp_port_buf(port)[--sexp_port_offset(port)] = ch[--len];
|
|
}
|
|
}
|
|
|
|
#if SEXP_USE_MUTABLE_STRINGS
|
|
|
|
void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) {
|
|
sexp b;
|
|
unsigned char *p, *q;
|
|
int i = sexp_unbox_string_cursor(index), c = sexp_unbox_character(ch),
|
|
old_len, new_len, len;
|
|
p = (unsigned char*)sexp_string_data(str) + i;
|
|
old_len = sexp_utf8_initial_byte_count(*p);
|
|
new_len = sexp_utf8_char_byte_count(c);
|
|
if (old_len != new_len) { /* resize bytes if needed */
|
|
len = sexp_string_size(str)+(new_len-old_len);
|
|
b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID);
|
|
if (! sexp_exceptionp(b)) {
|
|
q = (unsigned char*)sexp_bytes_data(b);
|
|
memcpy(q, sexp_string_data(str), i);
|
|
memcpy(q+i+new_len, p+old_len, len-i-new_len+1);
|
|
sexp_string_bytes(str) = b;
|
|
p = q + i;
|
|
}
|
|
sexp_string_size(str) += new_len - old_len;
|
|
}
|
|
sexp_utf8_encode_char(p, new_len, c);
|
|
}
|
|
|
|
sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch) {
|
|
sexp off;
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
|
|
sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch);
|
|
off = sexp_string_index_to_cursor(ctx, self, n, str, i);
|
|
if (sexp_exceptionp(off)) return off;
|
|
if (sexp_unbox_string_cursor(off) >= (sexp_sint_t)sexp_string_size(str))
|
|
return sexp_user_exception(ctx, self, "string-set!: index out of range", i);
|
|
sexp_string_utf8_set(ctx, str, off, ch);
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
#endif
|
|
#endif
|
|
|
|
#if SEXP_USE_AUTO_FORCE
|
|
sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val) {
|
|
sexp res = sexp_alloc_type(ctx, promise, SEXP_PROMISE);
|
|
sexp_promise_donep(res) = sexp_unbox_boolean(done);
|
|
sexp_promise_value(res) = val;
|
|
return res;
|
|
}
|
|
#endif
|
|
|
|
/***************************** opcodes ********************************/
|
|
|
|
#if SEXP_USE_TYPE_DEFS
|
|
|
|
sexp sexp_type_slot_offset_op (sexp ctx , sexp self, sexp_sint_t n, sexp type, sexp slot) {
|
|
sexp cpl, slots, *v;
|
|
int i, offset, len;
|
|
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, type);
|
|
cpl = sexp_type_cpl(type);
|
|
if (sexp_vectorp(cpl)) {
|
|
v = sexp_vector_data(cpl);
|
|
len = sexp_vector_length(cpl);
|
|
} else {
|
|
v = &sexp_type_slots(type);
|
|
len = 1;
|
|
}
|
|
len = sexp_vectorp(cpl) ? sexp_vector_length(cpl) : 1;
|
|
for (i=len-1; i>=0; --i)
|
|
for (slots=sexp_type_slots(v[i]), offset=0; sexp_pairp(slots); slots=sexp_cdr(slots), ++offset)
|
|
if (sexp_car(slots) == slot) {
|
|
while (--i>=0)
|
|
offset += sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(v[i])));
|
|
return sexp_make_fixnum(offset);
|
|
}
|
|
return SEXP_FALSE;
|
|
}
|
|
|
|
sexp sexp_make_type_predicate_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type) {
|
|
if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
|
|
return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE),
|
|
sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO,
|
|
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL);
|
|
}
|
|
|
|
sexp sexp_make_constructor_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type) {
|
|
sexp_uint_t type_size;
|
|
if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
|
|
type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type)));
|
|
return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR),
|
|
sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO,
|
|
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type,
|
|
sexp_make_fixnum(type_size), NULL);
|
|
}
|
|
|
|
sexp sexp_make_getter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index) {
|
|
if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
|
|
if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0))
|
|
return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
|
|
if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
|
|
return sexp_type_exception(ctx, self, SEXP_FIXNUM, index);
|
|
return
|
|
sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER),
|
|
sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO,
|
|
type, SEXP_ZERO, SEXP_ZERO, type, index, NULL);
|
|
}
|
|
|
|
sexp sexp_make_setter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index) {
|
|
sexp res;
|
|
if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
|
|
if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0))
|
|
return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
|
|
if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
|
|
return sexp_type_exception(ctx, self, SEXP_FIXNUM, index);
|
|
res
|
|
= sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER),
|
|
sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO,
|
|
type, SEXP_ZERO, SEXP_ZERO, type, index, NULL);
|
|
if (!sexp_exceptionp(res)) sexp_opcode_return_type(res) = SEXP_VOID;
|
|
return res;
|
|
}
|
|
|
|
#endif
|
|
|
|
static sexp sexp_copy_core (sexp ctx, struct sexp_core_form_struct *core) {
|
|
sexp res = sexp_alloc_type(ctx, core, SEXP_CORE);
|
|
memcpy(&(res->value), core, sizeof(core[0]));
|
|
return res;
|
|
}
|
|
|
|
static sexp sexp_copy_opcode (sexp ctx, struct sexp_opcode_struct *op) {
|
|
sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
|
|
memcpy(&(res->value), op, sizeof(op[0]));
|
|
return res;
|
|
}
|
|
|
|
sexp 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) {
|
|
sexp res;
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, num_args);
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, flags);
|
|
if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0)
|
|
|| (sexp_unbox_fixnum(op_class) >= SEXP_OPC_NUM_OP_CLASSES))
|
|
res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class);
|
|
else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0)
|
|
|| (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES))
|
|
res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code);
|
|
else {
|
|
res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
|
|
sexp_opcode_class(res) = (unsigned char)sexp_unbox_fixnum(op_class);
|
|
sexp_opcode_code(res) = (unsigned char)sexp_unbox_fixnum(code);
|
|
sexp_opcode_num_args(res) = (unsigned char)sexp_unbox_fixnum(num_args);
|
|
sexp_opcode_flags(res) = (unsigned char)sexp_unbox_fixnum(flags);
|
|
sexp_opcode_arg1_type(res) = arg1t;
|
|
sexp_opcode_arg2_type(res) = arg2t;
|
|
sexp_opcode_inverse(res) = (unsigned char)sexp_unbox_fixnum(invp);
|
|
sexp_opcode_data(res) = data;
|
|
sexp_opcode_data2(res) = data2;
|
|
sexp_opcode_func(res) = func;
|
|
sexp_opcode_name(res) = name;
|
|
#if SEXP_USE_DL
|
|
sexp_opcode_dl(res) = sexp_context_dl(ctx);
|
|
#endif
|
|
}
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
|
|
int flags, const char *fname, sexp_proc1 f, sexp data) {
|
|
sexp_gc_var1(res);
|
|
sexp_gc_preserve1(ctx, res);
|
|
#if ! SEXP_USE_EXTENDED_FCALL
|
|
if (num_args > 4)
|
|
return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit",
|
|
sexp_make_fixnum(num_args));
|
|
#endif
|
|
res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
|
|
sexp_opcode_class(res) = SEXP_OPC_FOREIGN;
|
|
#if SEXP_USE_EXTENDED_FCALL
|
|
if (num_args > 4)
|
|
sexp_opcode_code(res) = SEXP_OP_FCALLN;
|
|
else
|
|
#endif
|
|
sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1;
|
|
if (flags & 1) num_args--;
|
|
sexp_opcode_num_args(res) = num_args;
|
|
sexp_opcode_flags(res) = flags;
|
|
sexp_opcode_name(res) = sexp_c_string(ctx, name, -1);
|
|
sexp_opcode_data(res) = data;
|
|
sexp_opcode_func(res) = f;
|
|
if (fname) {
|
|
sexp_opcode_data2(res) = sexp_c_string(ctx, fname, -1);
|
|
}
|
|
#if SEXP_USE_DL
|
|
sexp_opcode_dl(res) = sexp_context_dl(ctx);
|
|
#endif
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args,
|
|
int flags, const char *fname, sexp_proc1 f, sexp data) {
|
|
sexp_gc_var2(sym, res);
|
|
sexp_gc_preserve2(ctx, sym, res);
|
|
res = sexp_make_foreign(ctx, name, num_args, flags, fname, f, data);
|
|
if (!sexp_exceptionp(res))
|
|
sexp_env_define(ctx, env, sym = sexp_intern(ctx, name, -1), res);
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_define_foreign_param_aux (sexp ctx, sexp env, const char *name,
|
|
int num_args, const char *fname, sexp_proc1 f, const char *param) {
|
|
sexp res = SEXP_FALSE;
|
|
sexp_gc_var1(tmp);
|
|
sexp_gc_preserve1(ctx, tmp);
|
|
tmp = sexp_intern(ctx, param, -1);
|
|
tmp = sexp_env_ref(ctx, env, tmp, SEXP_FALSE);
|
|
if (sexp_opcodep(tmp))
|
|
res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, fname, f, tmp);
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
/*********************** standard environment *************************/
|
|
|
|
/* The 10 core forms. Note quote can be defined as derived syntax: */
|
|
|
|
/* (define-syntax quote */
|
|
/* (lambda (expr use-env mac-env) */
|
|
/* (list */
|
|
/* (make-syntactic-closure mac-env (list) (syntax-quote syntax-quote)) */
|
|
/* (strip-syntactic-closures (car (cdr expr)))))) */
|
|
|
|
static struct sexp_core_form_struct core_forms[] = {
|
|
{SEXP_CORE_DEFINE, (sexp)"define"},
|
|
{SEXP_CORE_SET, (sexp)"set!"},
|
|
{SEXP_CORE_LAMBDA, (sexp)"lambda"},
|
|
{SEXP_CORE_IF, (sexp)"if"},
|
|
{SEXP_CORE_BEGIN, (sexp)"begin"},
|
|
{SEXP_CORE_QUOTE, (sexp)"quote"},
|
|
{SEXP_CORE_SYNTAX_QUOTE, (sexp)"syntax-quote"},
|
|
{SEXP_CORE_DEFINE_SYNTAX, (sexp)"define-syntax"},
|
|
{SEXP_CORE_LET_SYNTAX, (sexp)"let-syntax"},
|
|
{SEXP_CORE_LETREC_SYNTAX, (sexp)"letrec-syntax"},
|
|
};
|
|
|
|
sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) {
|
|
sexp e = sexp_alloc_type(ctx, env, SEXP_ENV);
|
|
sexp_env_lambda(e) = NULL;
|
|
sexp_env_parent(e) = NULL;
|
|
sexp_env_bindings(e) = SEXP_NULL;
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
sexp_env_renames(e) = SEXP_NULL;
|
|
#endif
|
|
return e;
|
|
}
|
|
|
|
sexp sexp_make_null_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) {
|
|
sexp_uint_t i;
|
|
sexp_gc_var2(e, core);
|
|
sexp_gc_preserve2(ctx, e, core);
|
|
e = sexp_make_env(ctx);
|
|
for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) {
|
|
core = sexp_copy_core(ctx, &core_forms[i]);
|
|
sexp_env_define(ctx, e, sexp_intern(ctx, (char*)sexp_core_name(core), -1), core);
|
|
sexp_core_name(core) = sexp_c_string(ctx, (char*)sexp_core_name(core), -1);
|
|
}
|
|
sexp_gc_release2(ctx);
|
|
return e;
|
|
}
|
|
|
|
sexp sexp_make_primitive_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) {
|
|
int i;
|
|
sexp_gc_var4(e, op, sym, name);
|
|
sexp_gc_preserve4(ctx, e, op, sym, name);
|
|
e = sexp_make_null_env(ctx, version);
|
|
for (i=0; sexp_primitive_opcodes[i].op_class; i++) {
|
|
op = sexp_copy_opcode(ctx, &sexp_primitive_opcodes[i]);
|
|
name = sexp_intern(ctx, (char*)sexp_opcode_name(op), -1);
|
|
sexp_opcode_name(op) = sexp_c_string(ctx, (char*)sexp_opcode_name(op), -1);
|
|
if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) {
|
|
sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1);
|
|
sexp_opcode_data(op) = sexp_env_ref(ctx, e, sym, SEXP_FALSE);
|
|
} else if (sexp_opcode_class(op) == SEXP_OPC_PARAMETER) {
|
|
sexp_opcode_data(op) = sexp_cons(ctx, name, SEXP_FALSE);
|
|
}
|
|
if (sexp_opcode_class(op) == SEXP_OPC_FOREIGN && sexp_opcode_data2(op)) {
|
|
sexp_opcode_data2(op) = sexp_c_string(ctx, (char*)sexp_opcode_data2(op), -1);
|
|
}
|
|
sexp_env_define(ctx, e, name, op);
|
|
}
|
|
sexp_gc_release4(ctx);
|
|
return e;
|
|
}
|
|
|
|
char* sexp_find_module_file_raw (sexp ctx, const char *file) {
|
|
sexp ls;
|
|
char *dir, *path;
|
|
sexp_uint_t slash, dirlen, filelen, len;
|
|
#ifdef PLAN9
|
|
#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0)
|
|
unsigned char buf[128];
|
|
#else
|
|
#define file_exists_p(path, buf) (! stat(path, buf))
|
|
struct stat buf_str;
|
|
struct stat *buf = &buf_str;
|
|
#endif
|
|
|
|
filelen = strlen(file);
|
|
|
|
ls = sexp_global(ctx, SEXP_G_MODULE_PATH);
|
|
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
|
dir = sexp_string_data(sexp_car(ls));
|
|
dirlen = sexp_string_size(sexp_car(ls));
|
|
slash = dir[dirlen-1] == '/';
|
|
len = dirlen+filelen+2-slash;
|
|
path = (char*) sexp_malloc(len);
|
|
if (! path) return NULL;
|
|
memcpy(path, dir, dirlen);
|
|
if (! slash) path[dirlen] = '/';
|
|
memcpy(path+len-filelen-1, file, filelen);
|
|
path[len-1] = '\0';
|
|
if (sexp_find_static_library(path) || file_exists_p(path, buf))
|
|
return path;
|
|
free(path);
|
|
}
|
|
|
|
return NULL;
|
|
}
|
|
|
|
sexp sexp_find_module_file (sexp ctx, const char *file) {
|
|
char* path = sexp_find_module_file_raw(ctx, file);
|
|
sexp res = sexp_c_string(ctx, path, -1);
|
|
if (path) free(path);
|
|
return res;
|
|
}
|
|
|
|
#define sexp_file_not_found "couldn't find file in module path"
|
|
|
|
sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) {
|
|
sexp res;
|
|
sexp_gc_var1(path);
|
|
sexp_gc_preserve1(ctx, path);
|
|
path = sexp_find_module_file(ctx, file);
|
|
if (sexp_stringp(path)) {
|
|
res = sexp_load(ctx, path, env);
|
|
} else {
|
|
path = sexp_c_string(ctx, file, -1);
|
|
res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path);
|
|
}
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
#if SEXP_USE_MODULES
|
|
sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
|
if (sexp_pairp(x) && sexp_stringp(sexp_car(x))) {
|
|
sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_reverse(ctx, x);
|
|
sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_reverse(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH));
|
|
}
|
|
return sexp_global(ctx, SEXP_G_MODULE_PATH);
|
|
}
|
|
sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file) {
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file);
|
|
return sexp_find_module_file(ctx, sexp_string_data(file));
|
|
}
|
|
sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env) {
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file);
|
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
|
return sexp_load_module_file(ctx, sexp_string_data(file), env);
|
|
}
|
|
sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n) {
|
|
return sexp_context_env(ctx);
|
|
}
|
|
sexp sexp_set_current_environment (sexp ctx, sexp self, sexp_sint_t n, sexp env) {
|
|
sexp oldenv;
|
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
|
oldenv = sexp_context_env(ctx);
|
|
sexp_context_env(ctx) = env;
|
|
return oldenv;
|
|
}
|
|
sexp sexp_meta_environment (sexp ctx, sexp self, sexp_sint_t n) {
|
|
return sexp_global(ctx, SEXP_G_META_ENV);
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_add_module_directory_op (sexp ctx, sexp self, sexp_sint_t n, sexp dir, sexp appendp) {
|
|
sexp ls;
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir);
|
|
if (sexp_truep(appendp)) {
|
|
if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) {
|
|
for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls))
|
|
;
|
|
sexp_cdr(ls) = sexp_list1(ctx, dir);
|
|
} else {
|
|
sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir);
|
|
}
|
|
} else {
|
|
sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir);
|
|
}
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
sexp sexp_parameter_ref (sexp ctx, sexp param) {
|
|
#if SEXP_USE_GREEN_THREADS
|
|
sexp ls;
|
|
for (ls=sexp_context_params(ctx); sexp_pairp(ls); ls=sexp_cdr(ls))
|
|
if (sexp_caar(ls) == param)
|
|
return sexp_cdar(ls);
|
|
#endif
|
|
return sexp_opcodep(param) && sexp_opcode_data(param) && sexp_pairp(sexp_opcode_data(param))
|
|
? sexp_cdr(sexp_opcode_data(param)) : SEXP_FALSE;
|
|
}
|
|
|
|
#if SEXP_USE_GREEN_THREADS
|
|
sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val) {
|
|
if (sexp_not(val)) {
|
|
return sexp_context_dk(ctx) ? sexp_context_dk(ctx) : SEXP_FALSE;
|
|
} else {
|
|
sexp_context_dk(ctx) = val;
|
|
return SEXP_VOID;
|
|
}
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n) {
|
|
sexp res = sexp_context_params(ctx);
|
|
return res ? res : SEXP_NULL;
|
|
}
|
|
|
|
sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp new) {
|
|
sexp_context_params(ctx) = new;
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) {
|
|
sexp param = sexp_env_ref(ctx, env, name, SEXP_FALSE);
|
|
if (sexp_opcodep(param)) {
|
|
if (! sexp_pairp(sexp_opcode_data(param)))
|
|
sexp_opcode_data(param) = sexp_cons(ctx, name, value);
|
|
else
|
|
sexp_cdr(sexp_opcode_data(param)) = value;
|
|
} else {
|
|
sexp_warn(ctx, "can't set non-parameter: ", name);
|
|
}
|
|
}
|
|
|
|
sexp sexp_load_standard_ports (sexp ctx, sexp env, FILE* in, FILE* out,
|
|
FILE* err, int no_close) {
|
|
sexp_gc_var1(p);
|
|
sexp_gc_preserve1(ctx, p);
|
|
if (!env) env = sexp_context_env(ctx);
|
|
if (in) {
|
|
p = sexp_make_input_port(ctx, in, SEXP_FALSE);
|
|
sexp_port_no_closep(p) = no_close;
|
|
sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p);
|
|
}
|
|
if (out) {
|
|
p = sexp_make_output_port(ctx, out, SEXP_FALSE);
|
|
sexp_port_no_closep(p) = no_close;
|
|
sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p);
|
|
}
|
|
if (err) {
|
|
p = sexp_make_output_port(ctx, err, SEXP_FALSE);
|
|
sexp_port_no_closep(p) = no_close;
|
|
sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p);
|
|
}
|
|
sexp_gc_release1(ctx);
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
|
|
int len;
|
|
char init_file[128];
|
|
sexp_gc_var3(op, tmp, sym);
|
|
sexp_gc_preserve3(ctx, op, tmp, sym);
|
|
if (!e) e = sexp_context_env(ctx);
|
|
sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1),
|
|
tmp=sexp_c_string(ctx, sexp_so_extension, -1));
|
|
sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*features*", -1), sexp_global(ctx, SEXP_G_FEATURES));
|
|
sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL;
|
|
#if SEXP_USE_SIMPLIFY
|
|
op = sexp_make_foreign(ctx, "sexp_simplify", 1, 0,
|
|
NULL, (sexp_proc1)sexp_simplify, SEXP_VOID);
|
|
tmp = sexp_cons(ctx, sexp_make_fixnum(500), op);
|
|
sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp);
|
|
#endif
|
|
sexp_global(ctx, SEXP_G_ERR_HANDLER)
|
|
= sexp_env_ref(ctx, e, sym=sexp_intern(ctx, "current-exception-handler", -1), SEXP_FALSE);
|
|
/* load init-7.scm */
|
|
len = strlen(sexp_init_file);
|
|
strncpy(init_file, sexp_init_file, len);
|
|
init_file[len] = (char)sexp_unbox_fixnum(version) + '0';
|
|
strncpy(init_file + len + 1, sexp_init_file_suffix, strlen(sexp_init_file_suffix));
|
|
init_file[len + 1 + strlen(sexp_init_file_suffix)] = 0;
|
|
tmp = sexp_load_module_file(ctx, init_file, e);
|
|
sexp_set_parameter(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e);
|
|
/* load and bind meta-7.scm env */
|
|
#if SEXP_USE_MODULES
|
|
if (!sexp_exceptionp(tmp)) {
|
|
if (!sexp_envp(tmp=sexp_global(ctx, SEXP_G_META_ENV))) {
|
|
tmp = sexp_make_env(ctx);
|
|
if (! sexp_exceptionp(tmp)) {
|
|
sexp_global(ctx, SEXP_G_META_ENV) = tmp;
|
|
sexp_env_parent(tmp) = e;
|
|
op = sexp_load_module_file(ctx, sexp_meta_file, tmp);
|
|
if (sexp_exceptionp(op))
|
|
sexp_print_exception(ctx, op, sexp_current_error_port(ctx));
|
|
}
|
|
}
|
|
if (!sexp_exceptionp(tmp)) {
|
|
sym = sexp_intern(ctx, "repl-import", -1);
|
|
tmp = sexp_env_ref(ctx, tmp, sym, SEXP_VOID);
|
|
sym = sexp_intern(ctx, "import", -1);
|
|
/* splice import in place to mutate both this env and the */
|
|
/* frozen version in the meta env) */
|
|
tmp = sexp_cons(ctx, sym, tmp);
|
|
sexp_env_next_cell(tmp) = sexp_env_next_cell(sexp_env_bindings(e));
|
|
sexp_env_next_cell(sexp_env_bindings(e)) = tmp;
|
|
}
|
|
}
|
|
#endif
|
|
sexp_gc_release3(ctx);
|
|
return sexp_exceptionp(tmp) ? tmp : e;
|
|
}
|
|
|
|
sexp sexp_make_standard_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) {
|
|
sexp_gc_var1(env);
|
|
sexp_gc_preserve1(ctx, env);
|
|
env = sexp_make_primitive_env(ctx, version);
|
|
if (! sexp_exceptionp(env)) env = sexp_load_standard_env(ctx, env, SEXP_SEVEN);
|
|
sexp_gc_release1(ctx);
|
|
return env;
|
|
}
|
|
|
|
sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
|
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
|
|
return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE;
|
|
}
|
|
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
#define sexp_same_bindingp(x, y) ((x) == (y))
|
|
#else
|
|
#define sexp_same_bindingp(x, y) (sexp_env_value(x) == sexp_env_value(y))
|
|
#endif
|
|
|
|
/* Rewrite to in place: to => empty->imports->to */
|
|
sexp sexp_env_import_op (sexp ctx, sexp self, sexp_sint_t n, sexp to, sexp from, sexp ls, sexp immutp) {
|
|
sexp oldname, newname;
|
|
sexp_gc_var3(value, oldcell, tmp);
|
|
sexp_gc_preserve3(ctx, value, oldcell, tmp);
|
|
if (! sexp_envp(to)) to = sexp_context_env(ctx);
|
|
if (! sexp_envp(from)) from = sexp_context_env(ctx);
|
|
/* create an empty imports env frame */
|
|
value = sexp_make_env(ctx);
|
|
sexp_env_parent(value) = sexp_env_parent(to);
|
|
sexp_env_parent(to) = value;
|
|
sexp_env_lambda(value) = sexp_env_lambda(to);
|
|
sexp_env_lambda(to) = NULL;
|
|
sexp_env_bindings(value) = sexp_env_bindings(to);
|
|
sexp_env_bindings(to) = SEXP_NULL;
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
sexp_env_renames(value) = sexp_env_renames(to);
|
|
sexp_env_renames(to) = SEXP_NULL;
|
|
#endif
|
|
sexp_immutablep(value) = sexp_immutablep(to);
|
|
sexp_immutablep(to) = sexp_truep(immutp);
|
|
/* import the bindings, one at a time or in bulk */
|
|
if (sexp_not(ls)) {
|
|
sexp_env_bindings(to) = sexp_env_bindings(from);
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
sexp_env_renames(to) = sexp_env_renames(from);
|
|
#endif
|
|
} else {
|
|
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
|
if (sexp_pairp(sexp_car(ls))) {
|
|
newname = sexp_caar(ls); oldname = sexp_cdar(ls);
|
|
} else {
|
|
newname = oldname = sexp_car(ls);
|
|
}
|
|
oldcell = sexp_env_cell(ctx, to, newname, 0);
|
|
value = sexp_env_cell(ctx, from, oldname, 0);
|
|
if (value) {
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
sexp_env_rename(ctx, to, newname, value);
|
|
#else
|
|
sexp_env_push(ctx, to, tmp, newname, sexp_cdr(value));
|
|
#endif
|
|
#if SEXP_USE_WARN_UNDEFS
|
|
if (oldcell
|
|
&& sexp_cdr(oldcell) != SEXP_UNDEF
|
|
&& !sexp_same_bindingp(oldcell, value))
|
|
sexp_warn(ctx, "importing already defined binding: ", newname);
|
|
} else {
|
|
sexp_warn(ctx, "importing undefined variable: ", oldname);
|
|
#endif
|
|
}
|
|
}
|
|
}
|
|
/* create a new empty frame for future defines */
|
|
value = sexp_make_env(ctx);
|
|
sexp_env_parent(value) = sexp_env_parent(to);
|
|
sexp_env_lambda(value) = sexp_env_lambda(to);
|
|
sexp_env_bindings(value) = sexp_env_bindings(to);
|
|
#if SEXP_USE_RENAME_BINDINGS
|
|
sexp_env_renames(value) = sexp_env_renames(to);
|
|
sexp_env_renames(to) = SEXP_NULL;
|
|
#endif
|
|
sexp_env_parent(to) = value;
|
|
sexp_env_bindings(to) = SEXP_NULL;
|
|
sexp_immutablep(to) = 0;
|
|
sexp_gc_release3(ctx);
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
/************************** eval interface ****************************/
|
|
|
|
sexp sexp_generate_op (sexp ctx, sexp self, sexp_sint_t n, sexp ast, sexp env) {
|
|
sexp_gc_var3(ctx2, vec, res);
|
|
if (sexp_contextp(env)) {
|
|
ctx2 = env;
|
|
} else {
|
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
|
ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
|
|
}
|
|
sexp_gc_preserve3(ctx, ctx2, vec, res);
|
|
sexp_free_vars(ctx2, ast, SEXP_NULL); /* should return SEXP_NULL */
|
|
sexp_emit_enter(ctx2);
|
|
sexp_generate(ctx2, 0, 0, 0, ast);
|
|
res = sexp_complete_bytecode(ctx2);
|
|
if (!sexp_exceptionp(res)) {
|
|
sexp_context_specific(ctx2) = SEXP_FALSE;
|
|
vec = sexp_make_vector(ctx2, 0, SEXP_VOID);
|
|
if (sexp_exceptionp(vec)) res = vec;
|
|
else res = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, vec);
|
|
}
|
|
sexp_gc_release3(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_compile_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) {
|
|
sexp_gc_var3(ast, tmp, res);
|
|
sexp ctx2;
|
|
if (! env) env = sexp_context_env(ctx);
|
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
|
sexp_gc_preserve3(ctx, ast, tmp, res);
|
|
ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
|
|
if (sexp_exceptionp(ctx2)) {
|
|
res = ctx2;
|
|
} else {
|
|
tmp = sexp_context_child(ctx);
|
|
sexp_context_child(ctx) = ctx2;
|
|
ast = sexp_analyze(ctx2, obj);
|
|
if (sexp_exceptionp(ast)) {
|
|
res = ast;
|
|
} else {
|
|
res = sexp_global(ctx2, SEXP_G_OPTIMIZATIONS);
|
|
for ( ; sexp_pairp(res) && !sexp_exceptionp(ast); res=sexp_cdr(res))
|
|
ast = sexp_apply1(ctx2, sexp_cdar(res), ast);
|
|
if (sexp_exceptionp(ast)) {
|
|
res = ast;
|
|
} else {
|
|
res = sexp_generate_op(ctx2, self, n, ast, ctx2);
|
|
}
|
|
}
|
|
sexp_context_child(ctx) = tmp;
|
|
sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2);
|
|
}
|
|
sexp_gc_release3(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_eval_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) {
|
|
sexp_sint_t top;
|
|
sexp ctx2;
|
|
sexp_gc_var3(res, tmp, params);
|
|
if (! env) env = sexp_context_env(ctx);
|
|
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
|
|
sexp_gc_preserve3(ctx, res, tmp, params);
|
|
top = sexp_context_top(ctx);
|
|
params = sexp_context_params(ctx);
|
|
sexp_context_params(ctx) = SEXP_NULL;
|
|
ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0);
|
|
tmp = sexp_context_child(ctx);
|
|
sexp_context_child(ctx) = ctx2;
|
|
res = sexp_exceptionp(ctx2) ? ctx2 : sexp_compile_op(ctx2, self, n, obj, env);
|
|
if (! sexp_exceptionp(res))
|
|
res = sexp_apply(ctx2, res, SEXP_NULL);
|
|
sexp_context_child(ctx) = tmp;
|
|
sexp_context_params(ctx) = params;
|
|
sexp_context_top(ctx) = top;
|
|
sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2);
|
|
sexp_gc_release3(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) {
|
|
sexp res;
|
|
sexp_gc_var1(obj);
|
|
sexp_gc_preserve1(ctx, obj);
|
|
obj = sexp_read_from_string(ctx, str, len);
|
|
res = sexp_eval(ctx, obj, env);
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
void sexp_scheme_init (void) {
|
|
if (! scheme_initialized_p) {
|
|
scheme_initialized_p = 1;
|
|
sexp_init();
|
|
}
|
|
}
|