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

Expose construction of foreign procedures.

Browse source
This commit is contained in:
Dimitris Papavasiliou 2022-01-02 19:49:46 +02:00
parent 6615a74609
commit 87637c0a0b
2 changed files with 33 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
include/chibi/eval.h
View file

@ -129,6 +129,7 @@ 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_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_define_foreign_proc_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
SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
@ -194,6 +195,8 @@ SEXP_API sexp sexp_define_foreign_param_aux(sexp ctx, sexp env, const char *name
#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(const char*)#f,(sexp_proc1)f,NULL)
#define sexp_define_foreign_param(c,e,s,n,f,p) sexp_define_foreign_param_aux(c,e,s,n,(const char*)#f,(sexp_proc1)f,p)
#define sexp_define_foreign_opt(c,e,s,n,f,p) sexp_define_foreign_aux(c,e,s,n,1,(const char*)#f,(sexp_proc1)f,p)
#define sexp_define_foreign_proc(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_NONE,(const char*)#f,(sexp_proc1)f,NULL)
#define sexp_define_foreign_proc_rest(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_VARIADIC,(const char*)#f,(sexp_proc1)f,NULL)
#define sexp_env_key(x) sexp_car(x)
#define sexp_env_value(x) sexp_cdr(x)

37
vm.c
View file

@ -787,18 +787,19 @@ static sexp make_param_list (sexp ctx, sexp_uint_t i) {
return res;
}
static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i, sexp_sint_t flags) {
int j = i+(flags & SEXP_PROC_VARIADIC);
sexp ls, res, env;
sexp_gc_var6(bc, params, ref, refs, lambda, ctx2);
if (i == sexp_opcode_num_args(op)) { /* return before preserving */
if (j == sexp_opcode_num_args(op)) { /* return before preserving */
if (sexp_opcode_proc(op)) return sexp_opcode_proc(op);
} else if (i < sexp_opcode_num_args(op)) {
} else if (j < sexp_opcode_num_args(op)) {
return sexp_compile_error(ctx, "not enough args for opcode", op);
} else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */
return sexp_compile_error(ctx, "too many args for opcode", op);
}
sexp_gc_preserve6(ctx, bc, params, ref, refs, lambda, ctx2);
params = make_param_list(ctx, i);
params = make_param_list(ctx, j);
lambda = sexp_make_lambda(ctx, params);
ctx2 = sexp_make_child_context(ctx, lambda);
env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda);
@ -819,8 +820,8 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
generate_opcode_app(ctx2, refs);
bc = sexp_complete_bytecode(ctx2);
sexp_bytecode_name(bc) = sexp_opcode_name(op);
res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID);
if (i == sexp_opcode_num_args(op))
res=sexp_make_procedure(ctx2, sexp_make_fixnum(flags), sexp_make_fixnum(i), bc, SEXP_VOID);
if (j == sexp_opcode_num_args(op))
sexp_opcode_proc(op) = res;
}
}
@ -828,6 +829,28 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
return res;
}
sexp sexp_make_foreign_proc(sexp ctx, const char *name, int num_args, int flags,
const char *fname, sexp_proc1 f) {
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_foreign (ctx, name, num_args+((flags & SEXP_PROC_VARIADIC)>0), 0, fname, f, NULL);
if (!sexp_exceptionp(res))
res = make_opcode_procedure (ctx, res, num_args, flags);
sexp_gc_release1(ctx);
return res;
}
sexp sexp_define_foreign_proc_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_proc(ctx, name, num_args, flags, fname, f);
if (!sexp_exceptionp(res))
sexp_env_define(ctx, env, sym = sexp_intern(ctx, name, -1), res);
sexp_gc_release2(ctx);
return res;
}
/*********************** the virtual machine **************************/
sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args) {
@ -1274,7 +1297,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
sexp_context_top(ctx) = top;
if (sexp_opcodep(tmp1)) {
/* compile non-inlined opcode applications on the fly */
tmp1 = make_opcode_procedure(ctx, tmp1, i);
tmp1 = make_opcode_procedure(ctx, tmp1, i, SEXP_PROC_NONE);
if (sexp_exceptionp(tmp1)) {
_ARG1 = tmp1;
goto call_error_handler;