diff --git a/boot.c b/boot.c index 6fa13d94..1dd344e8 100644 --- a/boot.c +++ b/boot.c @@ -300,6 +300,34 @@ my $src = <<'EOL'; `(,(r 'begin) ,@(cdr clause))) ,(loop (cdr clauses))))))))))) + (define (dynamic-bind parameters values body) + (let* ((old-bindings + (current-dynamic-environment)) + (binding + (let ((dict (dictionary))) + (for-each + (lambda (parameter value) + (dictionary-set! dict parameter (list (parameter value #f)))) + parameters + values) + dict)) + (new-bindings + (cons binding old-bindings))) + (dynamic-wind + (lambda () (current-dynamic-environment new-bindings)) + body + (lambda () (current-dynamic-environment old-bindings))))) + + (define-syntax parameterize + (er-macro-transformer + (lambda (form r compare) + (let ((formal (cadr form)) + (body (cddr form))) + `(,(r 'dynamic-bind) + (list ,@(map car formal)) + (list ,@(map cadr formal)) + (,(r 'lambda) () ,@body)))))) + (define-syntax letrec-syntax (er-macro-transformer (lambda (form r c) @@ -322,6 +350,7 @@ my $src = <<'EOL'; and or cond case else => do when unless + parameterize let-syntax letrec-syntax syntax-error)) @@ -668,6 +697,34 @@ const char pic_boot[] = " `(,(r 'begin) ,@(cdr clause)))\n" " ,(loop (cdr clauses)))))))))))\n" "\n" +" (define (dynamic-bind parameters values body)\n" +" (let* ((old-bindings\n" +" (current-dynamic-environment))\n" +" (binding\n" +" (let ((dict (dictionary)))\n" +" (for-each\n" +" (lambda (parameter value)\n" +" (dictionary-set! dict parameter (list (parameter value #f))))\n" +" parameters\n" +" values)\n" +" dict))\n" +" (new-bindings\n" +" (cons binding old-bindings)))\n" +" (dynamic-wind\n" +" (lambda () (current-dynamic-environment new-bindings))\n" +" body\n" +" (lambda () (current-dynamic-environment old-bindings)))))\n" +"\n" +" (define-syntax parameterize\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((formal (cadr form))\n" +" (body (cddr form)))\n" +" `(,(r 'dynamic-bind)\n" +" (list ,@(map car formal))\n" +" (list ,@(map cadr formal))\n" +" (,(r 'lambda) () ,@body))))))\n" +"\n" " (define-syntax letrec-syntax\n" " (er-macro-transformer\n" " (lambda (form r c)\n" @@ -690,6 +747,7 @@ const char pic_boot[] = " and or\n" " cond case else =>\n" " do when unless\n" +" parameterize\n" " let-syntax letrec-syntax\n" " syntax-error))\n" ; diff --git a/gc.c b/gc.c index 9e669de4..2d61be7f 100644 --- a/gc.c +++ b/gc.c @@ -15,7 +15,6 @@ #include "picrin/error.h" #include "picrin/macro.h" #include "picrin/lib.h" -#include "picrin/var.h" #include "picrin/data.h" #include "picrin/dict.h" #include "picrin/record.h" @@ -462,14 +461,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) gc_mark_object(pic, (struct pic_object *)lib->env); break; } - case PIC_TT_VAR: { - struct pic_var *var = (struct pic_var *)obj; - gc_mark(pic, var->stack); - if (var->conv) { - gc_mark_object(pic, (struct pic_object *)var->conv); - } - break; - } case PIC_TT_IREP: { struct pic_irep *irep = (struct pic_irep *)obj; size_t i; @@ -699,9 +690,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) xh_destroy(&lib->exports); break; } - case PIC_TT_VAR: { - break; - } case PIC_TT_IREP: { struct pic_irep *irep = (struct pic_irep *)obj; pic_free(pic, irep->code); diff --git a/include/picrin.h b/include/picrin.h index 3007db00..8719b79e 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -144,6 +144,7 @@ void pic_close(pic_state *); void pic_add_feature(pic_state *, const char *); void pic_define(pic_state *, const char *, pic_value); /* automatic export */ +bool pic_defined_p(pic_state *, struct pic_lib *, const char *); pic_value pic_ref(pic_state *, struct pic_lib *, const char *); void pic_set(pic_state *, struct pic_lib *, const char *, pic_value); pic_value pic_funcall(pic_state *pic, const char *name, pic_list args); @@ -216,6 +217,8 @@ static inline void pic_warn(pic_state *pic, const char *msg) const char *pic_errmsg(pic_state *); +struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *); + struct pic_port *pic_stdin(pic_state *); struct pic_port *pic_stdout(pic_state *); struct pic_port *pic_stderr(pic_state *); diff --git a/include/picrin/value.h b/include/picrin/value.h index 18637de1..0523c688 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -121,7 +121,6 @@ enum pic_tt { PIC_TT_SENV, PIC_TT_MACRO, PIC_TT_LIB, - PIC_TT_VAR, PIC_TT_IREP, PIC_TT_DATA, PIC_TT_DICT, @@ -266,8 +265,6 @@ pic_type_repr(enum pic_tt tt) return "macro"; case PIC_TT_LIB: return "lib"; - case PIC_TT_VAR: - return "var"; case PIC_TT_IREP: return "irep"; case PIC_TT_DATA: diff --git a/include/picrin/var.h b/include/picrin/var.h deleted file mode 100644 index 4c1ba7c5..00000000 --- a/include/picrin/var.h +++ /dev/null @@ -1,32 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_VAR_H -#define PICRIN_VAR_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_var { - PIC_OBJECT_HEADER - pic_value stack; - struct pic_proc *conv; -}; - -#define pic_var_p(o) (pic_type(o) == PIC_TT_VAR) -#define pic_var_ptr(o) ((struct pic_var *)pic_ptr(o)) - -struct pic_var *pic_make_var(pic_state *, pic_value, struct pic_proc * /* = NULL */); - -pic_value pic_var_ref(pic_state *, struct pic_var *); -void pic_var_set(pic_state *, struct pic_var *, pic_value); -void pic_var_push(pic_state *, struct pic_var *, pic_value); -void pic_var_pop(pic_state *, struct pic_var *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/port.c b/port.c index 94641c06..6b27040d 100644 --- a/port.c +++ b/port.c @@ -11,7 +11,6 @@ #include "picrin/port.h" #include "picrin/string.h" #include "picrin/blob.h" -#include "picrin/var.h" pic_value pic_eof_object() diff --git a/var.c b/var.c index a91245ef..20b12995 100644 --- a/var.c +++ b/var.c @@ -3,53 +3,91 @@ */ #include "picrin.h" -#include "picrin/var.h" #include "picrin/pair.h" +#include "picrin/proc.h" +#include "picrin/dict.h" -struct pic_var * +static pic_value +var_lookup(pic_state *pic, pic_value var) +{ + pic_value val, env; + struct pic_dict *binding; + + val = pic_ref(pic, pic->PICRIN_BASE, "current-dynamic-environment"); + if (pic_eq_p(val, var)) { + return pic_false_value(); + } + + env = pic_apply0(pic, pic_proc_ptr(val)); + while (! pic_nil_p(env)) { + pic_assert_type(pic, pic_car(pic, env), dict); + + binding = pic_dict_ptr(pic_car(pic, env)); + if (pic_dict_has(pic, binding, var)) { + return pic_dict_ref(pic, binding, var); + } + env = pic_cdr(pic, env); + } + + return pic_false_value(); +} + +static pic_value +var_call(pic_state *pic) +{ + struct pic_proc *self = pic_get_proc(pic); + pic_value val, tmp, box, conv; + size_t n; + + n = pic_get_args(pic, "|oo", &val, &tmp); + + box = var_lookup(pic, pic_obj_value(self)); + if (! pic_test(box)) { + box = pic_attr_ref(pic, self, "@@box"); + } + + switch (n) { + case 0: + return pic_car(pic, box); + + case 1: + conv = pic_attr_ref(pic, self, "@@converter"); + if (pic_test(conv)) { + pic_assert_type(pic, conv, proc); + + val = pic_apply1(pic, pic_proc_ptr(conv), val); + } + pic_set_car(pic, box, val); + + return pic_none_value(); + + case 2: + assert(pic_false_p(tmp)); + + conv = pic_attr_ref(pic, self, "@@converter"); + if (pic_test(conv)) { + pic_assert_type(pic, conv, proc); + + return pic_apply1(pic, pic_proc_ptr(conv), val); + } else { + return val; + } + } + UNREACHABLE(); +} + +struct pic_proc * pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv) { - struct pic_var *var; + struct pic_proc *var; - var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR); - var->stack = pic_nil_value(); - var->conv = conv; - - pic_var_push(pic, var, init); + var = pic_make_proc(pic, var_call, ""); + pic_attr_set(pic, var, "@@box", pic_list1(pic, init)); + pic_attr_set(pic, var, "@@converter", conv ? pic_obj_value(conv) : pic_false_value()); return var; } -pic_value -pic_var_ref(pic_state *pic, struct pic_var *var) -{ - return pic_car(pic, var->stack); -} - -void -pic_var_set(pic_state *pic, struct pic_var *var, pic_value value) -{ - if (var->conv != NULL) { - value = pic_apply1(pic, var->conv, value); - } - pic_set_car(pic, var->stack, value); -} - -void -pic_var_push(pic_state *pic, struct pic_var *var, pic_value value) -{ - if (var->conv != NULL) { - value = pic_apply1(pic, var->conv, value); - } - var->stack = pic_cons(pic, value, var->stack); -} - -void -pic_var_pop(pic_state *pic, struct pic_var *var) -{ - var->stack = pic_cdr(pic, var->stack); -} - static pic_value pic_var_make_parameter(pic_state *pic) { @@ -61,72 +99,12 @@ pic_var_make_parameter(pic_state *pic) return pic_obj_value(pic_make_var(pic, init, conv)); } -static pic_value -pic_var_parameter_ref(pic_state *pic) -{ - struct pic_var *var; - pic_value v; - - pic_get_args(pic, "o", &v); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - - return pic_var_ref(pic, var); -} - -static pic_value -pic_var_parameter_set(pic_state *pic) -{ - struct pic_var *var; - pic_value v, val; - - pic_get_args(pic, "oo", &v, &val); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - pic_var_set(pic, var, val); - return pic_none_value(); -} - -static pic_value -pic_var_parameter_push(pic_state *pic) -{ - struct pic_var *var; - pic_value v, val; - - pic_get_args(pic, "oo", &v, &val); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - pic_var_push(pic, var, val); - return pic_none_value(); -} - -static pic_value -pic_var_parameter_pop(pic_state *pic) -{ - struct pic_var *var; - pic_value v; - - pic_get_args(pic, "o", &v); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - pic_var_pop(pic, var); - return pic_none_value(); -} - void pic_init_var(pic_state *pic) { + pic_define(pic, "current-dynamic-environment", pic_false_value()); + pic_defun(pic, "make-parameter", pic_var_make_parameter); - pic_defun(pic, "parameter-ref", pic_var_parameter_ref); - pic_defun(pic, "parameter-set!", pic_var_parameter_set); - pic_defun(pic, "parameter-push!", pic_var_parameter_push); - pic_defun(pic, "parameter-pop!", pic_var_parameter_pop); + + pic_set(pic, pic->PICRIN_BASE, "current-dynamic-environment", pic_obj_value(pic_make_var(pic, pic_nil_value(), NULL))); } diff --git a/vm.c b/vm.c index f0139de6..05ddda7c 100644 --- a/vm.c +++ b/vm.c @@ -15,7 +15,6 @@ #include "picrin/port.h" #include "picrin/irep.h" #include "picrin/blob.h" -#include "picrin/var.h" #include "picrin/lib.h" #include "picrin/macro.h" #include "picrin/error.h" @@ -425,6 +424,12 @@ pic_define(pic_state *pic, const char *name, pic_value val) pic_export(pic, sym); } +bool +pic_defined_p(pic_state *pic, struct pic_lib *lib, const char *name) +{ + return pic_find_rename(pic, lib->env, pic_intern_cstr(pic, name), NULL); +} + pic_value pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) { @@ -439,6 +444,20 @@ pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) return xh_val(xh_get_int(&pic->globals, rename), pic_value); } +void +pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) +{ + pic_sym sym, rename; + + sym = pic_intern_cstr(pic, name); + + if (! pic_find_rename(pic, lib->env, sym, &rename)) { + pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); + } + + xh_put_int(&pic->globals, rename, &val); +} + pic_value pic_funcall(pic_state *pic, const char *name, pic_list args) { @@ -806,15 +825,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) L_CALL: x = pic->sp[-c.u.i]; if (! pic_proc_p(x)) { - - if (pic_var_p(x)) { - if (c.u.i != 1) { - pic_errorf(pic, "invalid call-sequence for var object"); - } - POP(); - PUSH(pic_var_ref(pic, pic_var_ptr(x))); - NEXT; - } pic_errorf(pic, "invalid application: ~s", x); } proc = pic_proc_ptr(x);