refactor var. c api no longer supports converters.
This commit is contained in:
parent
c3106a9608
commit
7ffcbb7a7d
|
@ -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)
|
||||
}
|
||||
|
|
|
@ -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)
|
||||
|
|
3
src/gc.c
3
src/gc.c
|
@ -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
142
src/var.c
|
@ -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);
|
||||
}
|
||||
}
|
||||
|
|
Loading…
Reference in New Issue