Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Add variable transformers

Browse source
This commit is contained in:
Daphne Preston-Kendal 2021-12-30 10:34:54 +01:00
parent e97a2debe1
commit d17764be29
5 changed files with 64 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
eval.c
View file

@ -399,6 +399,18 @@ static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) {
return mac;
}
sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc) {
sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, base_proc);
if (sexp_procedure_variable_transformer_p(base_proc))
return base_proc;
sexp vt_proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE);
sexp_procedure_flags(vt_proc) = (char) (sexp_uint_t) sexp_make_fixnum (sexp_unbox_fixnum(sexp_procedure_flags(base_proc)) | SEXP_PROC_VARIABLE_TRANSFORMER);
sexp_procedure_num_args(vt_proc) = sexp_procedure_num_args(base_proc);
sexp_procedure_code(vt_proc) = sexp_procedure_code(base_proc);
sexp_procedure_vars(vt_proc) = sexp_procedure_vars(base_proc);
return vt_proc;
}
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);
@ -766,6 +778,22 @@ static sexp analyze_seq (sexp ctx, sexp ls, int depth, int defok) {
return res;
}
static sexp analyze_macro_once (sexp ctx, sexp x, sexp op, int depth) {
sexp res;
sexp_gc_var1(tmp);
sexp_gc_preserve1(ctx, tmp);
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);
res = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx));
if (!sexp_exceptionp(res) && !sexp_exceptionp(sexp_context_exception(ctx)))
res = sexp_apply(res, sexp_macro_proc(op), tmp);
if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(x)))
sexp_exception_source(res) = sexp_pair_source(sexp_car(tmp));
sexp_gc_release1(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);
@ -783,13 +811,24 @@ static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
return res;
}
static sexp analyze_set (sexp ctx, sexp x, int depth) {
static sexp analyze_set (sexp ctx, sexp x, int depth, int defok) {
sexp res, varenv;
sexp_gc_var2(ref, value);
sexp_gc_preserve2(ctx, ref, value);
sexp_gc_var4(ref, value, cell, op);
sexp_gc_preserve4(ctx, ref, value, cell, op);
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 {
cell = sexp_env_cell(ctx, sexp_context_env(ctx), sexp_cadr(x), 0);
op = cell ? sexp_cdr(cell) : NULL;
if (op && sexp_macrop(op)) {
if (!sexp_procedure_variable_transformer_p(sexp_macro_proc(op))) {
res = sexp_compile_error(ctx, "can't mutate a syntax keyword", sexp_cadr(x));
} else {
res = analyze_macro_once(ctx, x, op, depth);
if (!sexp_exceptionp(res))
res = analyze(ctx, res, depth, defok);
}
} else {
ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv);
if (sexp_refp(ref) && sexp_lambdap(sexp_ref_loc(ref)))
@ -807,7 +846,8 @@ static sexp analyze_set (sexp ctx, sexp x, int depth) {
sexp_set_source(res) = sexp_pair_source(x);
}
}
sexp_gc_release2(ctx);
}
sexp_gc_release4(ctx);
return res;
}
@ -1051,22 +1091,6 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x, int depth) {
return analyze_let_syntax_aux(ctx, x, 1, depth);
}
static sexp analyze_macro_once (sexp ctx, sexp x, sexp op, int depth) {
sexp res;
sexp_gc_var1(tmp);
sexp_gc_preserve1(ctx, tmp);
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);
res = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx));
if (!sexp_exceptionp(res) && !sexp_exceptionp(sexp_context_exception(ctx)))
res = sexp_apply(res, sexp_macro_proc(op), tmp);
if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(x)))
sexp_exception_source(res) = sexp_pair_source(sexp_car(tmp));
sexp_gc_release1(ctx);
return res;
}
static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
sexp op;
sexp_gc_var4(res, tmp, x, cell);
@ -1100,7 +1124,7 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
: sexp_compile_error(ctx, "unexpected define", x);
break;
case SEXP_CORE_SET:
res = analyze_set(ctx, x, depth); break;
res = analyze_set(ctx, x, depth, defok); break;
case SEXP_CORE_LAMBDA:
res = analyze_lambda(ctx, x, depth); break;
case SEXP_CORE_IF:

1
include/chibi/eval.h
View file

@ -128,6 +128,7 @@ SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from
SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars);
SEXP_API sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc);
SEXP_API 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_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
#if SEXP_USE_AUTO_FORCE

2
include/chibi/sexp.h
View file

@ -270,6 +270,7 @@ typedef int sexp_sint_t;
#define SEXP_PROC_NONE ((sexp_uint_t)0)
#define SEXP_PROC_VARIADIC ((sexp_uint_t)1)
#define SEXP_PROC_UNUSED_REST ((sexp_uint_t)2)
#define SEXP_PROC_VARIABLE_TRANSFORMER ((sexp_uint_t)4)
#ifdef SEXP_USE_INTTYPES
@ -1146,6 +1147,7 @@ SEXP_API unsigned long long sexp_bignum_to_uint(sexp x);
#define sexp_procedure_flags(x) (sexp_field(x, procedure, SEXP_PROCEDURE, flags))
#define sexp_procedure_variadic_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_VARIADIC)
#define sexp_procedure_unused_rest_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_UNUSED_REST)
#define sexp_procedure_variable_transformer_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_VARIABLE_TRANSFORMER)
#define sexp_procedure_code(x) (sexp_field(x, procedure, SEXP_PROCEDURE, bc))
#define sexp_procedure_vars(x) (sexp_field(x, procedure, SEXP_PROCEDURE, vars))
#define sexp_procedure_source(x) sexp_bytecode_source(sexp_procedure_code(x))

1
opcodes.c
View file

@ -197,6 +197,7 @@ _FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "memq", 0, sexp_memq_op),
_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "assq", 0, sexp_assq_op),
_FN3(_I(SEXP_SYNCLO), _I(SEXP_ENV), SEXP_NULL, _I(SEXP_OBJECT), "make-syntactic-closure", 0, sexp_make_synclo_op),
_FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos),
_FN1(_I(SEXP_PROCEDURE), _I(SEXP_PROCEDURE), "make-variable-transformer", 0, sexp_make_variable_transformer_op),
_FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_open_output_string_op),
_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_open_input_string_op),
_FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op),

2
sexp.c
View file

@ -2190,6 +2190,8 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out, sexp_sint_t bound) {
#endif
case SEXP_PROCEDURE:
sexp_write_string(ctx, "#<procedure ", out);
if (sexp_procedure_variable_transformer_p(obj))
sexp_write_string(ctx, "(variable-transformer) ", out);
x = sexp_bytecode_name(sexp_procedure_code(obj));
sexp_write_one(ctx, sexp_synclop(x) ? sexp_synclo_expr(x): x, out, bound+1);
sexp_write_string(ctx, " ", out);