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

parameters now check for thread-specific overrides (still need to set these in parameterize)

Browse source
This commit is contained in:
Alex Shinn 2010-09-24 07:23:43 +09:00
parent 2e7ffacb9f
commit b95a7cac42
8 changed files with 90 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile
View file

@ -203,6 +203,9 @@ test-sort: chibi-scheme$(EXE)
test-records: chibi-scheme$(EXE) test-records: chibi-scheme$(EXE)
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/record-tests.scm LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/record-tests.scm
test-weak: chibi-scheme$(EXE)
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/weak-tests.scm
test-libs: chibi-scheme$(EXE) test-libs: chibi-scheme$(EXE)
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm

27
eval.c
View file

@ -1496,7 +1496,7 @@ sexp sexp_make_primitive_env (sexp ctx, sexp version) {
op = sexp_copy_opcode(ctx, &opcodes[i]); op = sexp_copy_opcode(ctx, &opcodes[i]);
if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) {
sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1);
sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); sexp_opcode_data(op) = sexp_env_ref(e, sym, SEXP_FALSE);
} }
sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op), -1), op); sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op), -1), op);
} }
@ -1587,18 +1587,31 @@ sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir,
return SEXP_VOID; return SEXP_VOID;
} }
sexp sexp_load_standard_parameters (sexp ctx, sexp e) { static void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) {
sexp param = sexp_env_ref(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;
}
}
sexp sexp_load_standard_parameters (sexp ctx, sexp env) {
/* add io port and interaction env parameters */ /* add io port and interaction env parameters */
sexp p = sexp_make_input_port(ctx, stdin, SEXP_FALSE); sexp_gc_var1(p);
sexp_gc_preserve1(ctx, p);
p = sexp_make_input_port(ctx, stdin, SEXP_FALSE);
sexp_port_no_closep(p) = 1; sexp_port_no_closep(p) = 1;
sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p); sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p);
p = sexp_make_output_port(ctx, stdout, SEXP_FALSE); p = sexp_make_output_port(ctx, stdout, SEXP_FALSE);
sexp_port_no_closep(p) = 1; sexp_port_no_closep(p) = 1;
sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p); sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p);
p = sexp_make_output_port(ctx, stderr, SEXP_FALSE); p = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
sexp_port_no_closep(p) = 1; sexp_port_no_closep(p) = 1;
sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p); sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p);
sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env);
sexp_gc_release1(ctx);
return SEXP_VOID; return SEXP_VOID;
} }

1
include/chibi/eval.h
View file

@ -67,6 +67,7 @@ enum sexp_opcode_names {
SEXP_OP_DROP, SEXP_OP_DROP,
SEXP_OP_GLOBAL_REF, SEXP_OP_GLOBAL_REF,
SEXP_OP_GLOBAL_KNOWN_REF, SEXP_OP_GLOBAL_KNOWN_REF,
SEXP_OP_PARAMETER_REF,
SEXP_OP_STACK_REF, SEXP_OP_STACK_REF,
SEXP_OP_LOCAL_REF, SEXP_OP_LOCAL_REF,
SEXP_OP_LOCAL_SET, SEXP_OP_LOCAL_SET,

5
include/chibi/sexp.h
View file

@ -342,8 +342,8 @@ struct sexp_struct {
#endif #endif
char tailp, tracep, timeoutp, waitp; char tailp, tracep, timeoutp, waitp;
sexp_uint_t pos, depth, last_fp; sexp_uint_t pos, depth, last_fp;
sexp bc, lambda, stack, env, fv, parent, child, globals, sexp bc, lambda, stack, env, fv, parent, child,
proc, name, specific, event; globals, params, proc, name, specific, event;
} context; } context;
} value; } value;
}; };
@ -771,6 +771,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#define sexp_context_tailp(x) (sexp_field(x, context, SEXP_CONTEXT, tailp)) #define sexp_context_tailp(x) (sexp_field(x, context, SEXP_CONTEXT, tailp))
#define sexp_context_tracep(x) (sexp_field(x, context, SEXP_CONTEXT, tracep)) #define sexp_context_tracep(x) (sexp_field(x, context, SEXP_CONTEXT, tracep))
#define sexp_context_globals(x) (sexp_field(x, context, SEXP_CONTEXT, globals)) #define sexp_context_globals(x) (sexp_field(x, context, SEXP_CONTEXT, globals))
#define sexp_context_params(x) (sexp_field(x, context, SEXP_CONTEXT, params))
#define sexp_context_last_fp(x) (sexp_field(x, context, SEXP_CONTEXT, last_fp)) #define sexp_context_last_fp(x) (sexp_field(x, context, SEXP_CONTEXT, last_fp))
#define sexp_context_refuel(x) (sexp_field(x, context, SEXP_CONTEXT, refuel)) #define sexp_context_refuel(x) (sexp_field(x, context, SEXP_CONTEXT, refuel))
#define sexp_context_ip(x) (sexp_field(x, context, SEXP_CONTEXT, ip)) #define sexp_context_ip(x) (sexp_field(x, context, SEXP_CONTEXT, ip))

17
main.c
View file

@ -22,6 +22,11 @@
#define exit_failure() exit(70) #define exit_failure() exit(70)
#endif #endif
static sexp sexp_param_ref (sexp ctx, sexp env, sexp name) {
sexp res=sexp_env_ref(env, name, SEXP_FALSE);
return sexp_opcodep(res) ? sexp_cdr(sexp_opcode_data(res)) : SEXP_VOID;
}
static void repl (sexp ctx) { static void repl (sexp ctx) {
sexp in, out, err; sexp in, out, err;
sexp_gc_var4(obj, tmp, res, env); sexp_gc_var4(obj, tmp, res, env);
@ -31,9 +36,9 @@ static void repl (sexp ctx) {
sexp_env_define(ctx, sexp_context_env(ctx), sexp_env_define(ctx, sexp_context_env(ctx),
sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env);
sexp_context_tracep(ctx) = 1; sexp_context_tracep(ctx) = 1;
in = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); in = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL));
out = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE); out = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL));
err = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE); err = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL));
sexp_port_sourcep(in) = 1; sexp_port_sourcep(in) = 1;
while (1) { while (1) {
sexp_write_string(ctx, "> ", out); sexp_write_string(ctx, "> ", out);
@ -88,10 +93,16 @@ static sexp sexp_load_standard_repl_env (sexp ctx, sexp env, sexp k) {
sexp p, res = sexp_load_standard_env(ctx, env, k); sexp p, res = sexp_load_standard_env(ctx, env, k);
#if SEXP_USE_GREEN_THREADS #if SEXP_USE_GREEN_THREADS
p = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); p = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE);
if (sexp_opcodep(p)) p = sexp_opcode_data(p);
if (sexp_pairp(p)) p = sexp_cdr(p);
if (sexp_portp(p)) fcntl(sexp_port_fileno(p), F_SETFL, O_NONBLOCK); if (sexp_portp(p)) fcntl(sexp_port_fileno(p), F_SETFL, O_NONBLOCK);
p = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE); p = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE);
if (sexp_opcodep(p)) p = sexp_opcode_data(p);
if (sexp_pairp(p)) p = sexp_cdr(p);
if (sexp_portp(p)) fcntl(sexp_port_fileno(p), F_SETFL, O_NONBLOCK); if (sexp_portp(p)) fcntl(sexp_port_fileno(p), F_SETFL, O_NONBLOCK);
p = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE); p = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE);
if (sexp_opcodep(p)) p = sexp_opcode_data(p);
if (sexp_pairp(p)) p = sexp_cdr(p);
if (sexp_portp(p)) fcntl(sexp_port_fileno(p), F_SETFL, O_NONBLOCK); if (sexp_portp(p)) fcntl(sexp_port_fileno(p), F_SETFL, O_NONBLOCK);
#endif #endif
return res; return res;

32
opcodes.c
View file

@ -11,9 +11,14 @@
#define _FN2OPTP(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, rt, a1, a2, SEXP_FALSE, s, d, f) #define _FN2OPTP(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, rt, a1, a2, SEXP_FALSE, s, d, f)
#define _FN3(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, rt, a1, a2, a3, s, d, f) #define _FN3(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, rt, a1, a2, a3, s, d, f)
#define _FN4(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, rt, a1, a2, a3, s, d, f) #define _FN4(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, rt, a1, a2, a3, s, d, f)
#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, t, SEXP_FALSE, SEXP_FALSE, 0, n, a, 0) #define _PARAM(n, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_PARAMETER_REF, 0, 1, t, t, SEXP_FALSE, SEXP_FALSE, 0, n, SEXP_FALSE, 0)
static struct sexp_opcode_struct opcodes[] = { static struct sexp_opcode_struct opcodes[] = {
_PARAM("current-input-port", _I(SEXP_IPORT)),
_PARAM("current-output-port", _I(SEXP_OPORT)),
_PARAM("current-error-port", _I(SEXP_OPORT)),
_PARAM("current-exception-handler", _I(SEXP_PROCEDURE)),
_PARAM("interaction-environment", _I(SEXP_ENV)),
_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "car", 0, NULL), _OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "car", 0, NULL),
_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-car!", 0, NULL), _OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-car!", 0, NULL),
_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "cdr", 0, NULL), _OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "cdr", 0, NULL),
@ -81,14 +86,14 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJ
_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL),
_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"*current-output-port*", NULL), _OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"current-output-port", NULL),
_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, SEXP_VOID, _I(SEXP_OPORT), SEXP_FALSE, SEXP_FALSE, 0, "newline", (sexp)"*current-output-port*", NULL), _OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, SEXP_VOID, _I(SEXP_OPORT), SEXP_FALSE, SEXP_FALSE, 0, "newline", (sexp)"current-output-port", NULL),
_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"*current-input-port*", NULL), _OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"current-input-port", NULL),
_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"*current-input-port*", NULL), _OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"current-input-port", NULL),
_FN1OPTP(_I(SEXP_OBJECT), _I(SEXP_IPORT), "read", (sexp)"*current-input-port*", sexp_read_op), _FN1OPTP(_I(SEXP_OBJECT), _I(SEXP_IPORT), "read", (sexp)"current-input-port", sexp_read_op),
_FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"*current-output-port*", sexp_write_op), _FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"current-output-port", sexp_write_op),
_FN2OPTP(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"*current-output-port*", sexp_display_op), _FN2OPTP(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"current-output-port", sexp_display_op),
_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), _FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "flush-output", (sexp)"current-output-port", sexp_flush_output_op),
_FN2(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op), _FN2(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op),
_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "list?", 0, sexp_listp_op), _FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "list?", 0, sexp_listp_op),
_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "identifier?", 0, sexp_identifierp_op), _FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "identifier?", 0, sexp_identifierp_op),
@ -106,8 +111,8 @@ _FN1(SEXP_VOID, _I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op),
_FN0(_I(SEXP_ENV), "make-environment", 0, sexp_make_env_op), _FN0(_I(SEXP_ENV), "make-environment", 0, sexp_make_env_op),
_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op), _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op),
_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op),
_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "eval", (sexp)"*interaction-environment*", sexp_eval_op), _FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "eval", (sexp)"interaction-environment", sexp_eval_op),
_FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"*interaction-environment*", sexp_load_op), _FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"interaction-environment", sexp_load_op),
_FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%env-copy!", 0, sexp_env_copy_op), _FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%env-copy!", 0, sexp_env_copy_op),
_FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op), _FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op),
_FN1(_I(SEXP_OBJECT), _I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op), _FN1(_I(SEXP_OBJECT), _I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op),
@ -122,11 +127,6 @@ _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), _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), _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_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos),
_PARAM("current-input-port", (sexp)"*current-input-port*", _I(SEXP_IPORT)),
_PARAM("current-output-port", (sexp)"*current-output-port*", _I(SEXP_OPORT)),
_PARAM("current-error-port", (sexp)"*current-error-port*", _I(SEXP_OPORT)),
_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", _I(SEXP_PROCEDURE)),
_PARAM("interaction-environment", (sexp)"*interaction-environment*", _I(SEXP_ENV)),
_FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_make_output_string_port_op), _FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_make_output_string_port_op),
_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_make_input_string_port_op), _FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_make_input_string_port_op),
_FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), _FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op),

11
sexp.c
View file

@ -111,7 +111,7 @@ static struct sexp_type_struct _sexp_type_specs[] = {
{SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, "sequence", SEXP_FALSE, SEXP_FALSE, NULL}, {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, "sequence", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, "literal", SEXP_FALSE, SEXP_FALSE, NULL}, {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, "literal", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, "stack", SEXP_FALSE, SEXP_FALSE, NULL}, {SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, "stack", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_CONTEXT, sexp_offsetof(context, bc), 12, 12, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, "context", SEXP_FALSE, SEXP_FALSE, NULL}, {SEXP_CONTEXT, sexp_offsetof(context, bc), 13, 13, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, "context", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, "cpointer", SEXP_FALSE, SEXP_FALSE, NULL}, {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, "cpointer", SEXP_FALSE, SEXP_FALSE, NULL},
}; };
@ -263,10 +263,10 @@ void sexp_init_context_globals (sexp ctx) {
sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote", -1); sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote", -1);
sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote", -1); sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote", -1);
sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL) = sexp_intern(ctx, "unquote-splicing", -1); sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL) = sexp_intern(ctx, "unquote-splicing", -1);
sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL) = sexp_intern(ctx, "*current-input-port*", -1); sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL) = sexp_intern(ctx, "current-input-port", -1);
sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL) = sexp_intern(ctx, "*current-output-port*", -1); sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL) = sexp_intern(ctx, "current-output-port", -1);
sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL) = sexp_intern(ctx, "*current-error-port*", -1); sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL) = sexp_intern(ctx, "current-error-port", -1);
sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL) = sexp_intern(ctx, "*interaction-environment*", -1); sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL) = sexp_intern(ctx, "interaction-environment", -1);
sexp_global(ctx, SEXP_G_EMPTY_VECTOR) = sexp_alloc_type(ctx, vector, SEXP_VECTOR); sexp_global(ctx, SEXP_G_EMPTY_VECTOR) = sexp_alloc_type(ctx, vector, SEXP_VECTOR);
sexp_vector_length(sexp_global(ctx, SEXP_G_EMPTY_VECTOR)) = 0; sexp_vector_length(sexp_global(ctx, SEXP_G_EMPTY_VECTOR)) = 0;
#if ! SEXP_USE_GLOBAL_TYPES #if ! SEXP_USE_GLOBAL_TYPES
@ -318,6 +318,7 @@ sexp sexp_make_context (sexp ctx, size_t size) {
sexp_context_name(res) = sexp_context_specific(res) = SEXP_FALSE; sexp_context_name(res) = sexp_context_specific(res) = SEXP_FALSE;
sexp_context_fv(res) = SEXP_NULL; sexp_context_fv(res) = SEXP_NULL;
sexp_context_saves(res) = NULL; sexp_context_saves(res) = NULL;
sexp_context_params(res) = SEXP_NULL;
sexp_context_depth(res)=sexp_context_tracep(res)=sexp_context_pos(res)=0; sexp_context_depth(res)=sexp_context_tracep(res)=sexp_context_pos(res)=0;
sexp_context_tailp(res) = 1; sexp_context_tailp(res) = 1;
#if SEXP_USE_GREEN_THREADS #if SEXP_USE_GREEN_THREADS

29
vm.c
View file

@ -206,7 +206,14 @@ static void generate_opcode_app (sexp ctx, sexp app) {
inv_default = 1; inv_default = 1;
} else { } else {
emit_push(ctx, sexp_opcode_data(op)); emit_push(ctx, sexp_opcode_data(op));
if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); if (sexp_opcode_opt_param_p(op)) {
#if SEXP_USE_GREEN_THREADS
emit(ctx, SEXP_OP_PARAMETER_REF);
emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op));
sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), sexp_opcode_data(op));
#endif
emit(ctx, SEXP_OP_CDR);
}
sexp_context_depth(ctx)++; sexp_context_depth(ctx)++;
num_args++; num_args++;
} }
@ -273,6 +280,11 @@ static void generate_opcode_app (sexp ctx, sexp app) {
break; break;
case SEXP_OPC_PARAMETER: case SEXP_OPC_PARAMETER:
emit_push(ctx, sexp_opcode_data(op)); emit_push(ctx, sexp_opcode_data(op));
#if SEXP_USE_GREEN_THREADS
emit(ctx, SEXP_OP_PARAMETER_REF);
emit_word(ctx, (sexp_uint_t)op);
sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), op);
#endif
emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR));
break; break;
default: default:
@ -782,7 +794,20 @@ sexp sexp_vm (sexp ctx, sexp proc) {
_PUSH(sexp_cdr(_WORD0)); _PUSH(sexp_cdr(_WORD0));
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case SEXP_OP_STACK_REF: /* `pick' in forth */ #if SEXP_USE_GREEN_THREADS
case SEXP_OP_PARAMETER_REF:
_ALIGN_IP();
tmp2 = _WORD0;
ip += sizeof(sexp);
for (tmp1=sexp_context_params(ctx); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
if (sexp_car(tmp1) == tmp2) {
_PUSH(sexp_car(tmp1));
goto loop;
}
_PUSH(sexp_opcode_data(tmp2));
break;
#endif
case SEXP_OP_STACK_REF:
_ALIGN_IP(); _ALIGN_IP();
stack[top] = stack[top - _SWORD0]; stack[top] = stack[top - _SWORD0];
ip += sizeof(sexp); ip += sizeof(sexp);