diff --git a/include/picrin/var.h b/include/picrin/var.h index 9926c092..d3bbaf4e 100644 --- a/include/picrin/var.h +++ b/include/picrin/var.h @@ -12,17 +12,18 @@ extern "C" { 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_var_new(pic_state *, pic_value); +struct pic_var *pic_var_new(pic_state *, pic_value, struct pic_proc * /* = NULL */); -pic_value pic_var_ref(pic_state *, const char *); -void pic_var_set(pic_state *, const char *, pic_value); -void pic_var_push(pic_state *, const char *, pic_value); -void pic_var_pop(pic_state *, const char *); +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) } diff --git a/piclib/prelude.scm b/piclib/prelude.scm index d31363a2..0a4db18b 100644 --- a/piclib/prelude.scm +++ b/piclib/prelude.scm @@ -373,40 +373,7 @@ ;;; parameter (define-library (picrin parameter) (import (scheme base) - (picrin macro) - (picrin var) - (picrin attribute) - (picrin dictionary)) - - (define (single? x) - (and (list? x) (= (length x) 1))) - - (define (double? x) - (and (list? x) (= (length x) 2))) - - (define (%make-parameter init conv) - (let ((var (make-var (conv init)))) - (define (parameter . args) - (cond - ((null? args) - (var-ref var)) - ((single? args) - (var-set! var (conv (car args)))) - ((double? args) - (var-set! var ((cadr args) (car args)))) - (else - (error "invalid arguments for parameter")))) - - (dictionary-set! (attribute parameter) '@@var var) - - parameter)) - - (define (make-parameter init . conv) - (let ((conv - (if (null? conv) - (lambda (x) x) - (car conv)))) - (%make-parameter init conv))) + (picrin macro)) (define-syntax with (ir-macro-transformer @@ -420,9 +387,6 @@ (,after) result)))))) - (define (var-of parameter) - (dictionary-ref (attribute parameter) '@@var)) - (define-syntax parameterize (ir-macro-transformer (lambda (form inject compare) @@ -431,12 +395,13 @@ (let ((vars (map car formal)) (vals (map cadr formal))) `(with - (lambda () ,@(map (lambda (var val) `(var-push! (var-of ,var) ,val)) vars vals)) - (lambda () ,@(map (lambda (var) `(var-pop! (var-of ,var))) vars)) + (lambda () + ,@(map (lambda (var val) `(parameter-push! ,var ,val)) vars vals)) + (lambda () + ,@(map (lambda (var) `(parameter-pop! ,var)) vars)) ,@body)))))) - (export make-parameter - parameterize)) + (export parameterize)) ;;; Record Type (define-library (picrin record) @@ -742,16 +707,6 @@ ;;; 6.13. Input and output -(import (picrin port)) - -(define current-input-port (make-parameter standard-input-port)) -(define current-output-port (make-parameter standard-output-port)) -(define current-error-port (make-parameter standard-error-port)) - -(export current-input-port - current-output-port - current-error-port) - (define (call-with-port port proc) (dynamic-wind (lambda () #f) diff --git a/src/gc.c b/src/gc.c index e673f045..3d28aa96 100644 --- a/src/gc.c +++ b/src/gc.c @@ -469,6 +469,9 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) 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: { diff --git a/src/port.c b/src/port.c index 6f9b6673..de01f62e 100644 --- a/src/port.c +++ b/src/port.c @@ -11,6 +11,7 @@ #include "picrin/port.h" #include "picrin/string.h" #include "picrin/blob.h" +#include "picrin/var.h" pic_value pic_eof_object() @@ -42,7 +43,7 @@ pic_stdout(pic_state *pic) return pic_port_ptr(pic_apply(pic, proc, pic_nil_value())); } -static pic_value +static struct pic_port * port_new_stdport(pic_state *pic, xFILE *file, short dir) { struct pic_port *port; @@ -51,7 +52,7 @@ port_new_stdport(pic_state *pic, xFILE *file, short dir) port->file = file; port->flags = dir | PIC_PORT_TEXT; port->status = PIC_PORT_OPEN; - return pic_obj_value(port); + return port; } struct pic_port * @@ -688,12 +689,22 @@ pic_port_flush(pic_state *pic) void pic_init_port(pic_state *pic) { + struct pic_port *STDIN, *STDOUT, *STDERR; + + STDIN = port_new_stdport(pic, xstdin, PIC_PORT_IN); + STDOUT = port_new_stdport(pic, xstdout, PIC_PORT_OUT); + STDERR = port_new_stdport(pic, xstderr, PIC_PORT_OUT); + pic_deflibrary ("(picrin port)") { - pic_define(pic, "standard-input-port", port_new_stdport(pic, xstdin, PIC_PORT_IN)); - pic_define(pic, "standard-output-port", port_new_stdport(pic, xstdout, PIC_PORT_OUT)); - pic_define(pic, "standard-error-port", port_new_stdport(pic, xstderr, PIC_PORT_OUT)); + pic_define(pic, "standard-input-port", pic_obj_value(STDIN)); + pic_define(pic, "standard-output-port", pic_obj_value(STDOUT)); + pic_define(pic, "standard-error-port", pic_obj_value(STDERR)); } + pic_define(pic, "current-input-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDIN), NULL))); + pic_define(pic, "current-output-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDOUT), NULL))); + pic_define(pic, "current-error-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDERR), NULL))); + pic_defun(pic, "input-port?", pic_port_input_port_p); pic_defun(pic, "output-port?", pic_port_output_port_p); pic_defun(pic, "textual-port?", pic_port_textual_port_p); diff --git a/src/var.c b/src/var.c index 9cbb00e5..2524350f 100644 --- a/src/var.c +++ b/src/var.c @@ -6,115 +6,63 @@ #include "picrin/var.h" #include "picrin/pair.h" -static pic_value -var_ref(pic_state *pic, struct pic_var *var) -{ - return pic_car(pic, var->stack); -} - -static void -var_set(pic_state *pic, struct pic_var *var, pic_value value) -{ - pic_set_car(pic, var->stack, value); -} - -static void -var_push(pic_state *pic, struct pic_var *var, pic_value value) -{ - var->stack = pic_cons(pic, value, var->stack); -} - -static void -var_pop(pic_state *pic, struct pic_var *var) -{ - var->stack = pic_cdr(pic, var->stack); -} - struct pic_var * -pic_var_new(pic_state *pic, pic_value init) +pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv) { struct pic_var *var; var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR); var->stack = pic_nil_value(); + var->conv = conv; - var_push(pic, var, init); + pic_var_push(pic, var, init); return var; } pic_value -pic_var_ref(pic_state *pic, const char *name) +pic_var_ref(pic_state *pic, struct pic_var *var) { - pic_value v; - struct pic_var *var; - - v = pic_ref(pic, name); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - - return var_ref(pic, var); + return pic_car(pic, var->stack); } void -pic_var_set(pic_state *pic, const char *name, pic_value value) +pic_var_set(pic_state *pic, struct pic_var *var, pic_value value) { - pic_value v; - struct pic_var *var; - - v = pic_ref(pic, name); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - - var_set(pic, var, 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, const char *name, pic_value value) +pic_var_push(pic_state *pic, struct pic_var *var, pic_value value) { - pic_value v; - struct pic_var *var; - - v = pic_ref(pic, name); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - - var_push(pic, var, 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, const char *name) +pic_var_pop(pic_state *pic, struct pic_var *var) { - pic_value v; - struct pic_var *var; - - v = pic_ref(pic, name); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - - var_pop(pic, var); + var->stack = pic_cdr(pic, var->stack); } static pic_value -pic_var_make_var(pic_state *pic) +pic_var_make_parameter(pic_state *pic) { + struct pic_proc *conv = NULL; pic_value init; - pic_get_args(pic, "o", &init); + pic_get_args(pic, "o|l", &init, &conv); - return pic_obj_value(pic_var_new(pic, init)); + return pic_obj_value(pic_var_new(pic, init, conv)); } static pic_value -pic_var_var_ref(pic_state *pic) +pic_var_parameter_ref(pic_state *pic) { struct pic_var *var; pic_value v; @@ -125,11 +73,11 @@ pic_var_var_ref(pic_state *pic) var = pic_var_ptr(v); - return var_ref(pic, var); + return pic_var_ref(pic, var); } static pic_value -pic_var_var_set(pic_state *pic) +pic_var_parameter_set(pic_state *pic) { struct pic_var *var; pic_value v, val; @@ -139,12 +87,12 @@ pic_var_var_set(pic_state *pic) pic_assert_type(pic, v, var); var = pic_var_ptr(v); - var_set(pic, var, val); + pic_var_set(pic, var, val); return pic_none_value(); } static pic_value -pic_var_var_push(pic_state *pic) +pic_var_parameter_push(pic_state *pic) { struct pic_var *var; pic_value v, val; @@ -154,12 +102,12 @@ pic_var_var_push(pic_state *pic) pic_assert_type(pic, v, var); var = pic_var_ptr(v); - var_push(pic, var, val); + pic_var_push(pic, var, val); return pic_none_value(); } static pic_value -pic_var_var_pop(pic_state *pic) +pic_var_parameter_pop(pic_state *pic) { struct pic_var *var; pic_value v; @@ -169,18 +117,18 @@ pic_var_var_pop(pic_state *pic) pic_assert_type(pic, v, var); var = pic_var_ptr(v); - var_pop(pic, var); + pic_var_pop(pic, var); return pic_none_value(); } void pic_init_var(pic_state *pic) { - pic_deflibrary ("(picrin var)") { - pic_defun(pic, "make-var", pic_var_make_var); - pic_defun(pic, "var-ref", pic_var_var_ref); - pic_defun(pic, "var-set!", pic_var_var_set); - pic_defun(pic, "var-push!", pic_var_var_push); - pic_defun(pic, "var-pop!", pic_var_var_pop); + pic_deflibrary ("(picrin parameter)") { + 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); } } diff --git a/src/vm.c b/src/vm.c index 7dc788cc..8e2ddb6c 100644 --- a/src/vm.c +++ b/src/vm.c @@ -712,6 +712,15 @@ 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);