Merge branch 'callable-var'

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)
 }

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)

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: {

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);

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);
   }
 }

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);