Merge branch 'refactor-var'
This commit is contained in:
commit
435e4eb7fe
|
@ -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);
|
||||
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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)
|
||||
}
|
||||
|
|
|
@ -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)
|
||||
|
|
5
src/gc.c
5
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: {
|
||||
|
|
26
src/pair.c
26
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)
|
||||
{
|
||||
|
|
12
src/port.c
12
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);
|
||||
|
|
243
src/var.c
243
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, "<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)
|
||||
{
|
||||
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);
|
||||
}
|
||||
}
|
||||
|
|
23
src/vm.c
23
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)
|
||||
{
|
||||
|
|
Loading…
Reference in New Issue