diff --git a/include/picrin.h b/include/picrin.h index 0e673dca..2bf9f9fd 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -135,11 +135,12 @@ void pic_define(pic_state *, const char *, pic_value); /* automatic export */ pic_value pic_ref(pic_state *, const char *); void pic_set(pic_state *, const char *, pic_value); +pic_value pic_funcall(pic_state *pic, const char *name, pic_list args); + struct pic_proc *pic_get_proc(pic_state *); int pic_get_args(pic_state *, const char *, ...); void pic_defun(pic_state *, const char *, pic_func_t); void pic_defmacro(pic_state *, const char *, struct pic_proc *); -void pic_defvar(pic_state *, const char *, pic_value); bool pic_equal_p(pic_state *, pic_value, pic_value); diff --git a/include/picrin/pair.h b/include/picrin/pair.h index 64d5d1cb..1f7fccfa 100644 --- a/include/picrin/pair.h +++ b/include/picrin/pair.h @@ -21,6 +21,8 @@ struct pic_pair { pic_value pic_cons(pic_state *, pic_value, pic_value); pic_value pic_car(pic_state *, pic_value); pic_value pic_cdr(pic_state *, pic_value); +void pic_set_car(pic_state *, pic_value, pic_value); +void pic_set_cdr(pic_state *, pic_value, pic_value); bool pic_list_p(pic_value); pic_value pic_list1(pic_state *, pic_value); diff --git a/include/picrin/var.h b/include/picrin/var.h index bc098200..9926c092 100644 --- a/include/picrin/var.h +++ b/include/picrin/var.h @@ -11,21 +11,18 @@ extern "C" { struct pic_var { PIC_OBJECT_HEADER - pic_value value; - struct pic_proc *conv; + pic_value stack; }; #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_proc *); +struct pic_var *pic_var_new(pic_state *, pic_value); -struct pic_proc *pic_wrap_var(pic_state *, struct pic_var *); -struct pic_var *pic_unwrap_var(pic_state *, struct pic_proc *); - -pic_value pic_var_ref(pic_state *, struct pic_var *); -void pic_var_set(pic_state *, struct pic_var *, pic_value); -void pic_var_set_force(pic_state *, struct pic_var *, pic_value); +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 *); #if defined(__cplusplus) } diff --git a/piclib/built-in.scm b/piclib/built-in.scm index c57aef21..e2131ab2 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -410,33 +410,70 @@ (import (scheme base) (scheme cxr) (picrin macro) - (picrin core-syntax)) + (picrin core-syntax) + (picrin var) + (picrin attribute) + (picrin dictionary)) - ;; reopen (pircin parameter) - ;; see src/var.c + (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))) + + (define-syntax with + (ir-macro-transformer + (lambda (form inject compare) + (let ((before (car (cdr form))) + (after (car (cdr (cdr form)))) + (body (cdr (cdr (cdr form))))) + `(begin + (,before) + (let ((result (begin ,@body))) + (,after) + result)))))) + + (define (var-of parameter) + (dictionary-ref (attribute parameter) '@@var)) (define-syntax parameterize - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (cadr form)) - (body (cddr form))) - (let ((vars (map car bindings)) - (gensym (lambda (var) - (string->symbol - (string-append - "parameterize-" - (symbol->string var)))))) - `(,(r 'let) (,@(map (lambda (var) - `(,(r (gensym var)) (,var))) - vars)) - ,@bindings - (,(r 'let) ((,(r 'result) (begin ,@body))) - ,@(map (lambda (var) - `(,(r 'parameter-set!) ,var ,(r (gensym var)))) - vars) - ,(r 'result)))))))) + (ir-macro-transformer + (lambda (form inject compare) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + (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)) + ,@body)))))) - (export parameterize)) + (export make-parameter + parameterize)) ;;; Record Type (define-library (picrin record) @@ -950,6 +987,16 @@ ;;; 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 ea3c35b3..97532671 100644 --- a/src/gc.c +++ b/src/gc.c @@ -475,10 +475,7 @@ 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->value); - if (var->conv) { - gc_mark_object(pic, (struct pic_object *)var->conv); - } + gc_mark(pic, var->stack); break; } case PIC_TT_IREP: { diff --git a/src/pair.c b/src/pair.c index bb4ef0bb..499b7bb5 100644 --- a/src/pair.c +++ b/src/pair.c @@ -45,6 +45,32 @@ pic_cdr(pic_state *pic, pic_value obj) return pair->cdr; } +void +pic_set_car(pic_state *pic, pic_value obj, pic_value val) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_error(pic, "pair required"); + } + pair = pic_pair_ptr(obj); + + pair->car = val; +} + +void +pic_set_cdr(pic_state *pic, pic_value obj, pic_value val) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_error(pic, "pair required"); + } + pair = pic_pair_ptr(obj); + + pair->cdr = val; +} + bool pic_list_p(pic_value obj) { diff --git a/src/port.c b/src/port.c index 2da85177..8a3534bc 100644 --- a/src/port.c +++ b/src/port.c @@ -306,7 +306,7 @@ pic_port_open_output_string(pic_state *pic) static pic_value pic_port_get_output_string(pic_state *pic) { - struct pic_port *port = pic_stdout(pic);; + struct pic_port *port = pic_stdout(pic); pic_get_args(pic, "|p", &port); @@ -353,7 +353,7 @@ pic_port_open_output_bytevector(pic_state *pic) static pic_value pic_port_get_output_bytevector(pic_state *pic) { - struct pic_port *port = pic_stdout(pic);; + struct pic_port *port = pic_stdout(pic); long endpos; char *buf; @@ -684,9 +684,11 @@ pic_port_flush(pic_state *pic) void pic_init_port(pic_state *pic) { - pic_defvar(pic, "current-input-port", port_new_stdport(pic, xstdin, PIC_PORT_IN)); - pic_defvar(pic, "current-output-port", port_new_stdport(pic, xstdout, PIC_PORT_OUT)); - pic_defvar(pic, "current-error-port", 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_defun(pic, "input-port?", pic_port_input_port_p); pic_defun(pic, "output-port?", pic_port_output_port_p); diff --git a/src/var.c b/src/var.c index e667966d..9cbb00e5 100644 --- a/src/var.c +++ b/src/var.c @@ -3,175 +3,184 @@ */ #include "picrin.h" -#include "picrin/proc.h" #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, struct pic_proc *conv /* = NULL */) +pic_var_new(pic_state *pic, pic_value init) { struct pic_var *var; var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR); - var->value = pic_undef_value(); - var->conv = conv; + var->stack = pic_nil_value(); - pic_var_set(pic, var, init); + var_push(pic, var, init); return var; } pic_value -pic_var_ref(pic_state *pic, struct pic_var *var) +pic_var_ref(pic_state *pic, const char *name) { - UNUSED(pic); - return var->value; + 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); } void -pic_var_set(pic_state *pic, struct pic_var *var, pic_value value) +pic_var_set(pic_state *pic, const char *name, pic_value value) { - if (var->conv) { - value = pic_apply1(pic, var->conv, value); - } - pic_var_set_force(pic, var, 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); } void -pic_var_set_force(pic_state *pic, struct pic_var *var, pic_value value) -{ - UNUSED(pic); - var->value = value; -} - -static struct pic_var * -get_var_from_proc(pic_state *pic, struct pic_proc *proc) +pic_var_push(pic_state *pic, const char *name, pic_value value) { pic_value v; + struct pic_var *var; - if (! pic_proc_func_p(proc)) { - goto typeerror; - } - if (pic_proc_cv_size(pic, proc) != 1) { - goto typeerror; - } - v = pic_proc_cv_ref(pic, proc, 0); - if (! pic_var_p(v)) { - goto typeerror; - } - return pic_var_ptr(v); + v = pic_ref(pic, name); - typeerror: - pic_errorf(pic, "expected parameter, but got ~s", v); + pic_assert_type(pic, v, var); + + var = pic_var_ptr(v); + + var_push(pic, var, value); +} + +void +pic_var_pop(pic_state *pic, const char *name) +{ + 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); } static pic_value -var_call(pic_state *pic) +pic_var_make_var(pic_state *pic) { - struct pic_proc *proc; - struct pic_var *var; - pic_value v; - int c; - - proc = pic_get_proc(pic); - - c = pic_get_args(pic, "|o", &v); - if (c == 0) { - var = pic_var_ptr(proc->env->regs[0]); - return pic_var_ref(pic, var); - } - else if (c == 1) { - var = pic_var_ptr(proc->env->regs[0]); - - pic_var_set(pic, var, v); - return pic_none_value(); - } - else { - pic_abort(pic, "logic flaw"); - } - UNREACHABLE(); -} - -struct pic_proc * -pic_wrap_var(pic_state *pic, struct pic_var *var) -{ - struct pic_proc *proc; - - proc = pic_proc_new(pic, var_call, ""); - pic_proc_cv_init(pic, proc, 1); - pic_proc_cv_set(pic, proc, 0, pic_obj_value(var)); - return proc; -} - -struct pic_var * -pic_unwrap_var(pic_state *pic, struct pic_proc *proc) -{ - return get_var_from_proc(pic, proc); -} - -static pic_value -pic_var_make_parameter(pic_state *pic) -{ - struct pic_proc *conv = NULL; - struct pic_var *var; pic_value init; - pic_get_args(pic, "o|l", &init, &conv); + pic_get_args(pic, "o", &init); - var = pic_var_new(pic, init, conv); - return pic_obj_value(pic_wrap_var(pic, var)); + return pic_obj_value(pic_var_new(pic, init)); } static pic_value -pic_var_parameter_ref(pic_state *pic) +pic_var_var_ref(pic_state *pic) { - struct pic_proc *proc; - struct pic_var *var; - - pic_get_args(pic, "l", &proc); - - var = get_var_from_proc(pic, proc); - return pic_var_ref(pic, var); -} - -static pic_value -pic_var_parameter_set(pic_state *pic) -{ - struct pic_proc *proc; struct pic_var *var; pic_value v; - pic_get_args(pic, "lo", &proc, &v); + pic_get_args(pic, "o", &v); - var = get_var_from_proc(pic, proc); - /* no convert */ - pic_var_set_force(pic, var, v); + pic_assert_type(pic, v, var); + + var = pic_var_ptr(v); + + return var_ref(pic, var); +} + +static pic_value +pic_var_var_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); + var_set(pic, var, val); return pic_none_value(); } static pic_value -pic_var_parameter_converter(pic_state *pic) +pic_var_var_push(pic_state *pic) { - struct pic_proc *proc; struct pic_var *var; + pic_value v, val; - pic_get_args(pic, "l", &proc); + pic_get_args(pic, "oo", &v, &val); - var = get_var_from_proc(pic, proc); - if (var->conv) { - return pic_obj_value(var->conv); - } - else { - return pic_false_value(); - } + pic_assert_type(pic, v, var); + + var = pic_var_ptr(v); + var_push(pic, var, val); + return pic_none_value(); +} + +static pic_value +pic_var_var_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); + var_pop(pic, var); + return pic_none_value(); } void pic_init_var(pic_state *pic) { - 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); /* no convert */ - pic_defun(pic, "parameter-converter", pic_var_parameter_converter); + 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); } } diff --git a/src/vm.c b/src/vm.c index 9e4509f4..0063cb92 100644 --- a/src/vm.c +++ b/src/vm.c @@ -427,7 +427,7 @@ pic_ref(pic_state *pic, const char *name) gid = global_ref(pic, name); if (gid == SIZE_MAX) { - pic_error(pic, "symbol not defined"); + pic_errorf(pic, "symbol \"%s\" not defined", name); } return pic->globals[gid]; } @@ -444,6 +444,18 @@ pic_set(pic_state *pic, const char *name, pic_value value) pic->globals[gid] = value; } +pic_value +pic_funcall(pic_state *pic, const char *name, pic_list args) +{ + pic_value proc; + + proc = pic_ref(pic, name); + + pic_assert_type(pic, proc, proc); + + return pic_apply(pic, pic_proc_ptr(proc), args); +} + void pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) { @@ -453,15 +465,6 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) pic_define(pic, name, pic_obj_value(proc)); } -void -pic_defvar(pic_state *pic, const char *name, pic_value init) -{ - struct pic_var *var; - - var = pic_var_new(pic, init, NULL); - pic_define(pic, name, pic_obj_value(pic_wrap_var(pic, var))); -} - static void vm_push_env(pic_state *pic) {