Merge branch 'parameter-and-dynamic-environment'

boot.c

@@ -300,6 +300,34 @@ my $src = <<'EOL';
                             `(,(r 'begin) ,@(cdr clause)))
                        ,(loop (cdr clauses)))))))))))
 
+  (define (dynamic-bind parameters values body)
+    (let* ((old-bindings
+            (current-dynamic-environment))
+           (binding
+            (let ((dict (dictionary)))
+              (for-each
+               (lambda (parameter value)
+                 (dictionary-set! dict parameter (list (parameter value #f))))
+               parameters
+               values)
+              dict))
+           (new-bindings
+            (cons binding old-bindings)))
+      (dynamic-wind
+          (lambda () (current-dynamic-environment new-bindings))
+          body
+          (lambda () (current-dynamic-environment old-bindings)))))
+
+  (define-syntax parameterize
+    (er-macro-transformer
+     (lambda (form r compare)
+       (let ((formal (cadr form))
+             (body (cddr form)))
+         `(,(r 'dynamic-bind)
+           (list ,@(map car formal))
+           (list ,@(map cadr formal))
+           (,(r 'lambda) () ,@body))))))
+
   (define-syntax letrec-syntax
     (er-macro-transformer
      (lambda (form r c)
@@ -322,6 +350,7 @@ my $src = <<'EOL';
           and or
           cond case else =>
           do when unless
+          parameterize
           let-syntax letrec-syntax
           syntax-error))
 
@@ -668,6 +697,34 @@ const char pic_boot[] =
 "                            `(,(r 'begin) ,@(cdr clause)))\n"
 "                       ,(loop (cdr clauses)))))))))))\n"
 "\n"
+"  (define (dynamic-bind parameters values body)\n"
+"    (let* ((old-bindings\n"
+"            (current-dynamic-environment))\n"
+"           (binding\n"
+"            (let ((dict (dictionary)))\n"
+"              (for-each\n"
+"               (lambda (parameter value)\n"
+"                 (dictionary-set! dict parameter (list (parameter value #f))))\n"
+"               parameters\n"
+"               values)\n"
+"              dict))\n"
+"           (new-bindings\n"
+"            (cons binding old-bindings)))\n"
+"      (dynamic-wind\n"
+"          (lambda () (current-dynamic-environment new-bindings))\n"
+"          body\n"
+"          (lambda () (current-dynamic-environment old-bindings)))))\n"
+"\n"
+"  (define-syntax parameterize\n"
+"    (er-macro-transformer\n"
+"     (lambda (form r compare)\n"
+"       (let ((formal (cadr form))\n"
+"             (body (cddr form)))\n"
+"         `(,(r 'dynamic-bind)\n"
+"           (list ,@(map car formal))\n"
+"           (list ,@(map cadr formal))\n"
+"           (,(r 'lambda) () ,@body))))))\n"
+"\n"
 "  (define-syntax letrec-syntax\n"
 "    (er-macro-transformer\n"
 "     (lambda (form r c)\n"
@@ -690,6 +747,7 @@ const char pic_boot[] =
 "          and or\n"
 "          cond case else =>\n"
 "          do when unless\n"
+"          parameterize\n"
 "          let-syntax letrec-syntax\n"
 "          syntax-error))\n"
 ;

gc.c

@@ -15,7 +15,6 @@
 #include "picrin/error.h"
 #include "picrin/macro.h"
 #include "picrin/lib.h"
-#include "picrin/var.h"
 #include "picrin/data.h"
 #include "picrin/dict.h"
 #include "picrin/record.h"
@@ -462,14 +461,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     gc_mark_object(pic, (struct pic_object *)lib->env);
     break;
   }
-  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: {
     struct pic_irep *irep = (struct pic_irep *)obj;
     size_t i;
@@ -699,9 +690,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
     xh_destroy(&lib->exports);
     break;
   }
-  case PIC_TT_VAR: {
-    break;
-  }
   case PIC_TT_IREP: {
     struct pic_irep *irep = (struct pic_irep *)obj;
     pic_free(pic, irep->code);

include/picrin.h

@@ -144,6 +144,7 @@ void pic_close(pic_state *);
 void pic_add_feature(pic_state *, const char *);
 
 void pic_define(pic_state *, const char *, pic_value); /* automatic export */
+bool pic_defined_p(pic_state *, struct pic_lib *, const char *);
 pic_value pic_ref(pic_state *, struct pic_lib *, const char *);
 void pic_set(pic_state *, struct pic_lib *, const char *, pic_value);
 pic_value pic_funcall(pic_state *pic, const char *name, pic_list args);
@@ -216,6 +217,8 @@ static inline void pic_warn(pic_state *pic, const char *msg)
 
 const char *pic_errmsg(pic_state *);
 
+struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *);
+
 struct pic_port *pic_stdin(pic_state *);
 struct pic_port *pic_stdout(pic_state *);
 struct pic_port *pic_stderr(pic_state *);

include/picrin/value.h

@@ -121,7 +121,6 @@ enum pic_tt {
   PIC_TT_SENV,
   PIC_TT_MACRO,
   PIC_TT_LIB,
-  PIC_TT_VAR,
   PIC_TT_IREP,
   PIC_TT_DATA,
   PIC_TT_DICT,
@@ -266,8 +265,6 @@ pic_type_repr(enum pic_tt tt)
     return "macro";
   case PIC_TT_LIB:
     return "lib";
-  case PIC_TT_VAR:
-    return "var";
   case PIC_TT_IREP:
     return "irep";
   case PIC_TT_DATA:

include/picrin/var.h

@@ -1,32 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_VAR_H
-#define PICRIN_VAR_H
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-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_make_var(pic_state *, pic_value, struct pic_proc * /* = NULL */);
-
-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)
-}
-#endif
-
-#endif

port.c

@@ -11,7 +11,6 @@
 #include "picrin/port.h"
 #include "picrin/string.h"
 #include "picrin/blob.h"
-#include "picrin/var.h"
 
 pic_value
 pic_eof_object()

var.c

@@ -3,53 +3,91 @@
  */
 
 #include "picrin.h"
-#include "picrin/var.h"
 #include "picrin/pair.h"
+#include "picrin/proc.h"
+#include "picrin/dict.h"
 
-struct pic_var *
+static pic_value
+var_lookup(pic_state *pic, pic_value var)
+{
+  pic_value val, env;
+  struct pic_dict *binding;
+
+  val = pic_ref(pic, pic->PICRIN_BASE, "current-dynamic-environment");
+  if (pic_eq_p(val, var)) {
+    return pic_false_value();
+  }
+
+  env = pic_apply0(pic, pic_proc_ptr(val));
+  while (! pic_nil_p(env)) {
+    pic_assert_type(pic, pic_car(pic, env), dict);
+
+    binding = pic_dict_ptr(pic_car(pic, env));
+    if (pic_dict_has(pic, binding, var)) {
+      return pic_dict_ref(pic, binding, var);
+    }
+    env = pic_cdr(pic, env);
+  }
+
+  return pic_false_value();
+}
+
+static pic_value
+var_call(pic_state *pic)
+{
+  struct pic_proc *self = pic_get_proc(pic);
+  pic_value val, tmp, box, conv;
+  size_t n;
+
+  n = pic_get_args(pic, "|oo", &val, &tmp);
+
+  box = var_lookup(pic, pic_obj_value(self));
+  if (! pic_test(box)) {
+    box = pic_attr_ref(pic, self, "@@box");
+  }
+
+  switch (n) {
+  case 0:
+    return pic_car(pic, box);
+
+  case 1:
+    conv = pic_attr_ref(pic, self, "@@converter");
+    if (pic_test(conv)) {
+      pic_assert_type(pic, conv, proc);
+
+      val = pic_apply1(pic, pic_proc_ptr(conv), val);
+    }
+    pic_set_car(pic, box, val);
+
+    return pic_none_value();
+
+  case 2:
+    assert(pic_false_p(tmp));
+
+    conv = pic_attr_ref(pic, self, "@@converter");
+    if (pic_test(conv)) {
+      pic_assert_type(pic, conv, proc);
+
+      return pic_apply1(pic, pic_proc_ptr(conv), val);
+    } else {
+      return val;
+    }
+  }
+  UNREACHABLE();
+}
+
+struct pic_proc *
 pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv)
 {
-  struct pic_var *var;
+  struct pic_proc *var;
 
-  var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR);
-  var->stack = pic_nil_value();
-  var->conv = conv;
-
-  pic_var_push(pic, var, init);
+  var = pic_make_proc(pic, var_call, "<var-call>");
+  pic_attr_set(pic, var, "@@box", pic_list1(pic, init));
+  pic_attr_set(pic, var, "@@converter", conv ? pic_obj_value(conv) : pic_false_value());
 
   return var;
 }
 
-pic_value
-pic_var_ref(pic_state *pic, struct pic_var *var)
-{
-  return pic_car(pic, var->stack);
-}
-
-void
-pic_var_set(pic_state *pic, struct pic_var *var, pic_value 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, struct pic_var *var, pic_value 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, struct pic_var *var)
-{
-  var->stack = pic_cdr(pic, var->stack);
-}
-
 static pic_value
 pic_var_make_parameter(pic_state *pic)
 {
@@ -61,72 +99,12 @@ pic_var_make_parameter(pic_state *pic)
   return pic_obj_value(pic_make_var(pic, init, conv));
 }
 
-static pic_value
-pic_var_parameter_ref(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);
-
-  return pic_var_ref(pic, var);
-}
-
-static pic_value
-pic_var_parameter_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);
-  pic_var_set(pic, var, val);
-  return pic_none_value();
-}
-
-static pic_value
-pic_var_parameter_push(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);
-  pic_var_push(pic, var, val);
-  return pic_none_value();
-}
-
-static pic_value
-pic_var_parameter_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);
-  pic_var_pop(pic, var);
-  return pic_none_value();
-}
-
 void
 pic_init_var(pic_state *pic)
 {
+  pic_define(pic, "current-dynamic-environment", pic_false_value());
+
   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);
+
+  pic_set(pic, pic->PICRIN_BASE, "current-dynamic-environment", pic_obj_value(pic_make_var(pic, pic_nil_value(), NULL)));
 }

vm.c

@@ -15,7 +15,6 @@
 #include "picrin/port.h"
 #include "picrin/irep.h"
 #include "picrin/blob.h"
-#include "picrin/var.h"
 #include "picrin/lib.h"
 #include "picrin/macro.h"
 #include "picrin/error.h"
@@ -425,6 +424,12 @@ pic_define(pic_state *pic, const char *name, pic_value val)
   pic_export(pic, sym);
 }
 
+bool
+pic_defined_p(pic_state *pic, struct pic_lib *lib, const char *name)
+{
+  return pic_find_rename(pic, lib->env, pic_intern_cstr(pic, name), NULL);
+}
+
 pic_value
 pic_ref(pic_state *pic, struct pic_lib *lib, const char *name)
 {
@@ -439,6 +444,20 @@ pic_ref(pic_state *pic, struct pic_lib *lib, const char *name)
   return xh_val(xh_get_int(&pic->globals, rename), pic_value);
 }
 
+void
+pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
+{
+  pic_sym sym, rename;
+
+  sym = pic_intern_cstr(pic, name);
+
+  if (! pic_find_rename(pic, lib->env, sym, &rename)) {
+    pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
+  }
+
+  xh_put_int(&pic->globals, rename, &val);
+}
+
 pic_value
 pic_funcall(pic_state *pic, const char *name, pic_list args)
 {
@@ -806,15 +825,6 @@ 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);