Merge pull request #898 from pyrmont/feature.redefs

Support redefinable `def` and `defmacro` bindings using `:redef`

src/boot/boot.janet

@@ -1952,7 +1952,7 @@
     (def h (in t 0))
     (def s (in specs h))
     (def entry (or (dyn h) {}))
-    (def m (entry :value))
+    (def m (if (entry :redef) (in (entry :value) 0) (entry :value)))
     (def m? (entry :macro))
     (cond
       s (s t)
@@ -3080,12 +3080,13 @@
               (x :ref) (string :var " (" (type (in (x :ref) 0)) ")")
               (x :macro) :macro
               (x :module) (string :module " (" (x :kind) ")")
+              (x :redef) (type (in (x :value) 0))
               (type (x :value)))
             "\n"))
   (def sm (x :source-map))
   (def d (x :doc))
   (print "\n\n"
-         (when d bind-type)
+         bind-type
          (when-let [[path line col] sm]
            (string "    " path (when (and line col) (string " on line " line ", column " col))))
          (when sm "\n")
@@ -3143,7 +3144,7 @@
   (loop [module-set :in [[root-env] module/cache]
          module :in module-set
          value :in module]
-    (let [check (or (get value :ref) (get value :value))]
+    (let [check (or (value :ref) (if (value :redef) (in (value :value) 0) (value :value)))]
       (when (= check x)
         (print-module-entry value)
         (set found true)
@@ -3536,7 +3537,8 @@
 
 (defn- run-main
   [env subargs arg]
-  (if-let [main (get (in env 'main) :value)]
+  (if-let [entry (in env 'main)
+           main (if (entry :redef) (in (entry :value) 0) (entry :value))]
     (let [thunk (compile [main ;subargs] env arg)]
       (if (function? thunk) (thunk) (error (thunk :error))))))
 
@@ -3581,6 +3583,7 @@
                -e code : Execute a string of janet
                -E code arguments... : Evaluate  an expression as a short-fn with arguments
                -d : Set the debug flag in the REPL
+               -D : Use redefinable def bindings
                -r : Enter the REPL after running all scripts
                -R : Disables loading profile.janet when JANET_PROFILE is present
                -p : Keep on executing if there is a top-level error (persistent)
@@ -3631,6 +3634,7 @@
              (error (get thunk :error)))
            math/inf)
      "d" (fn [&] (set debug-flag true) 1)
+     "D" (fn [&] (setdyn :redefs true) 1)
      "w" (fn [i &] (set warn-level (get-lint-level i)) 2)
      "x" (fn [i &] (set error-level (get-lint-level i)) 2)
      "R" (fn [&] (setdyn :profilepath nil) 1)})

src/core/compile.c

@@ -238,6 +238,10 @@ JanetSlot janetc_resolve(
             case JANET_BINDING_DEF:
             case JANET_BINDING_MACRO: /* Macro should function like defs when not in calling pos */
                 ret = janetc_cslot(binding.value);
+                if (binding.dynamic) {
+                    ret.flags |= JANET_SLOT_REF | JANET_SLOT_NAMED | JANET_SLOTTYPE_ANY;
+                    ret.flags &= ~JANET_SLOT_CONSTANT;
+                }
                 break;
             case JANET_BINDING_VAR: {
                 ret = janetc_cslot(binding.value);

src/core/specials.c

@@ -331,14 +331,36 @@ static int defleaf(
         JanetTable *entry = janet_table_clone(tab);
         janet_table_put(entry, janet_ckeywordv("source-map"),
                         janet_wrap_tuple(janetc_make_sourcemap(c)));
-        JanetSlot valsym = janetc_cslot(janet_ckeywordv("value"));
-        JanetSlot tabslot = janetc_cslot(janet_wrap_table(entry));
+
+        int is_redef = 0;
+        Janet meta_redef = janet_table_get(entry, janet_ckeywordv("redef"));
+        if (janet_truthy(meta_redef)) {
+            is_redef = 1;
+        } else if (janet_checktype(meta_redef, JANET_NIL) && janet_truthy(janet_dyn("redefs"))) {
+            janet_table_put(entry, janet_ckeywordv("redef"), janet_wrap_true());
+            is_redef = 1;
+        }
+
+        if (is_redef) {
+            JanetBinding binding = janet_resolve_ext(c->env, sym);
+            JanetArray *ref;
+            if (janet_checktype(binding.value, JANET_ARRAY)) {
+                ref = janet_unwrap_array(binding.value);
+            } else {
+                ref = janet_array(1);
+                janet_array_push(ref, janet_wrap_nil());
+            }
+            janet_table_put(entry, janet_ckeywordv("value"), janet_wrap_array(ref));
+            JanetSlot refslot = janetc_cslot(janet_wrap_array(ref));
+            janetc_emit_ssu(c, JOP_PUT_INDEX, refslot, s, 0, 0);
+        } else {
+            JanetSlot valsym = janetc_cslot(janet_ckeywordv("value"));
+            JanetSlot tabslot = janetc_cslot(janet_wrap_table(entry));
+            janetc_emit_sss(c, JOP_PUT, tabslot, valsym, s, 0);
+        }
 
         /* Add env entry to env */
         janet_table_put(c->env, janet_wrap_symbol(sym), janet_wrap_table(entry));
-
-        /* Put value in table when evaulated */
-        janetc_emit_sss(c, JOP_PUT, tabslot, valsym, s, 0);
     }
     return namelocal(c, sym, 0, s);
 }

src/core/util.c

@@ -604,7 +604,8 @@ JanetBinding janet_resolve_ext(JanetTable *env, const uint8_t *sym) {
     JanetBinding binding = {
         JANET_BINDING_NONE,
         janet_wrap_nil(),
-        JANET_BINDING_DEP_NONE
+        JANET_BINDING_DEP_NONE,
+        JANET_BINDING_STATIC
     };
 
     /* Check environment for entry */
@@ -627,6 +628,8 @@ JanetBinding janet_resolve_ext(JanetTable *env, const uint8_t *sym) {
         binding.deprecation = JANET_BINDING_DEP_NORMAL;
     }
 
+    binding.dynamic = janet_truthy(janet_table_get(entry_table, janet_ckeywordv("redef")));
+
     if (!janet_checktype(
                 janet_table_get(entry_table, janet_ckeywordv("macro")),
                 JANET_NIL)) {
@@ -649,7 +652,15 @@ JanetBinding janet_resolve_ext(JanetTable *env, const uint8_t *sym) {
 
 JanetBindingType janet_resolve(JanetTable *env, const uint8_t *sym, Janet *out) {
     JanetBinding binding = janet_resolve_ext(env, sym);
-    *out = binding.value;
+    if (binding.dynamic) {
+        if (janet_checktype(binding.value, JANET_ARRAY)) {
+            *out = janet_array_peek(janet_unwrap_array(binding.value));
+        } else {
+            *out = janet_wrap_nil();
+        }
+    } else {
+        *out = binding.value;
+    }
     return binding.type;
 }
 

src/include/janet.h

@@ -1791,6 +1791,9 @@ typedef struct {
         JANET_BINDING_DEP_NORMAL,
         JANET_BINDING_DEP_STRICT,
     } deprecation;
+    enum {
+        JANET_BINDING_STATIC,
+        JANET_BINDING_DYNAMIC } dynamic;
 } JanetBinding;
 
 JANET_API void janet_def(JanetTable *env, const char *name, Janet val, const char *documentation);

test/suite0000.janet

@@ -295,6 +295,31 @@
     (++ i))
   (assert (= i 6) "when macro"))
 
+# Dynamic defs
+
+(def staticdef1 0)
+(defn staticdef1-inc [] (+ 1 staticdef1))
+(assert (= 1 (staticdef1-inc)) "before redefinition without :redef")
+(def staticdef1 1)
+(assert (= 1 (staticdef1-inc)) "after redefinition without :redef")
+(def dynamicdef1 :redef 0)
+(defn dynamicdef1-inc [] (+ 1 dynamicdef1))
+(assert (= 1 (dynamicdef1-inc)) "before redefinition with :redef")
+(def dynamicdef1 :redef 1)
+(assert (= 2 (dynamicdef1-inc)) "after redefinition with :redef")
+(setdyn :redefs true)
+(def staticdef2 {:redef false} 0)
+(defn staticdef2-inc [] (+ 1 staticdef2))
+(assert (= 1 (staticdef2-inc)) "before redefinition with :redef false")
+(def staticdef2 {:redef false} 1)
+(assert (= 1 (staticdef2-inc)) "after redefinition with :redef false")
+(def dynamicdef2 0)
+(defn dynamicdef2-inc [] (+ 1 dynamicdef2))
+(assert (= 1 (dynamicdef2-inc)) "before redefinition with dyn :redefs")
+(def dynamicdef2 1)
+(assert (= 2 (dynamicdef2-inc)) "after redefinition with dyn :redefs")
+(setdyn :redefs nil)
+
 # Denormal tables and structs
 
 (assert (= (length {1 2 nil 3}) 1) "nil key struct literal")