refactor var. c api no longer supports converters.

This commit is contained in:
Yuichi Nishiwaki 2014-07-12 22:30:50 +09:00
parent c3106a9608
commit 7ffcbb7a7d
4 changed files with 75 additions and 112 deletions

View File

@ -12,16 +12,15 @@ extern "C" {
struct pic_var {
PIC_OBJECT_HEADER
pic_value value;
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_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 *, const char *);
void pic_var_set(pic_state *, const char *, pic_value);
#if defined(__cplusplus)
}

View File

@ -410,10 +410,34 @@
(import (scheme base)
(scheme cxr)
(picrin macro)
(picrin core-syntax))
(picrin core-syntax)
(picrin var))
;; 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))))
(lambda 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"))))))
(define (make-parameter init . conv)
(let ((conv
(if (null? conv)
(lambda (x) x)
(car conv))))
(%make-parameter init conv)))
(define-syntax parameterize
(er-macro-transformer
@ -432,11 +456,12 @@
,@bindings
(,(r 'let) ((,(r 'result) (begin ,@body)))
,@(map (lambda (var)
`(,(r 'parameter-set!) ,var ,(r (gensym var))))
`(,var ,(r (gensym var)) (,(r 'lambda) (x) x)))
vars)
,(r 'result))))))))
(export parameterize))
(export make-parameter
parameterize))
;;; Record Type
(define-library (picrin record)

View File

@ -476,9 +476,6 @@ 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);
}
break;
}
case PIC_TT_IREP: {

142
src/var.c
View File

@ -14,158 +14,100 @@ var_ref(pic_state *pic, struct pic_var *var)
}
static void
var_set_force(pic_state *pic, struct pic_var *var, pic_value value)
var_set(pic_state *pic, struct pic_var *var, pic_value value)
{
UNUSED(pic);
var->value = value;
}
static void
var_set(pic_state *pic, struct pic_var *var, pic_value value)
{
if (var->conv) {
value = pic_apply1(pic, var->conv, value);
}
var_set_force(pic, var, value);
}
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_set(pic, var, init);
var->value = init;
return var;
}
static pic_value
var_call(pic_state *pic)
pic_value
pic_var_ref(pic_state *pic, const char *name)
{
struct pic_proc *proc;
pic_value v;
struct pic_var *var;
pic_value v;
int c;
proc = pic_get_proc(pic);
v = pic_ref(pic, name);
c = pic_get_args(pic, "|o", &v);
if (c == 0) {
var = pic_var_ptr(proc->env->regs[0]);
return var_ref(pic, var);
}
else if (c == 1) {
var = pic_var_ptr(proc->env->regs[0]);
pic_assert_type(pic, v, var);
var_set(pic, var, v);
return pic_none_value();
}
else {
pic_abort(pic, "logic flaw");
}
UNREACHABLE();
var = pic_var_ptr(v);
return var_ref(pic, var);
}
struct pic_proc *
pic_wrap_var(pic_state *pic, struct pic_var *var)
{
struct pic_proc *proc;
proc = pic_proc_new(pic, var_call, "<var-procedure>");
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)
void
pic_var_set(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_set(pic, var, value);
}
static pic_value
pic_var_make_parameter(pic_state *pic)
pic_var_make_var(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_value v;
pic_get_args(pic, "l", &proc);
pic_get_args(pic, "o", &v);
pic_assert_type(pic, v, var);
var = pic_var_ptr(v);
var = pic_unwrap_var(pic, proc);
return var_ref(pic, var);
}
static pic_value
pic_var_parameter_set(pic_state *pic)
pic_var_var_set(pic_state *pic)
{
struct pic_proc *proc;
struct pic_var *var;
pic_value v;
pic_value v, val;
pic_get_args(pic, "lo", &proc, &v);
pic_get_args(pic, "oo", &v, &val);
pic_assert_type(pic, v, var);
var = pic_var_ptr(v);
var_set(pic, var, val);
var = pic_unwrap_var(pic, proc);
/* no convert */
var_set_force(pic, var, v);
return pic_none_value();
}
static pic_value
pic_var_parameter_converter(pic_state *pic)
{
struct pic_proc *proc;
struct pic_var *var;
pic_get_args(pic, "l", &proc);
var = pic_unwrap_var(pic, proc);
if (var->conv) {
return pic_obj_value(var->conv);
}
else {
return pic_false_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);
}
}