[#336] Add clojure.core/intern

babashka · May 24, 2020 · 2a338c6 · 2a338c6
1 parent bdff91a
commit 2a338c6
Show file tree

Hide file tree

Showing 2 changed files with 41 additions and 0 deletions.
diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc
@@ -406,6 +406,30 @@
     (swap! env update :namespaces dissoc sym)
     nil))
 
+(defn sci-intern
+  ;; in this case the var will become unbound
+  ([ctx ns var-sym]
+   (let [ns (sci-the-ns ctx ns)
+         ns-name (sci-ns-name ns)
+         env (:env ctx)]
+     (or (get-in @env [:namespaces ns-name var-sym])
+         (let [var-name (symbol (str ns-name) (str var-sym))
+               new-var (vars/->SciVar nil var-name (meta var-sym))]
+           (vars/unbind new-var)
+           (swap! env assoc-in [:namespaces ns-name var-sym] new-var)
+           new-var))))
+  ([ctx ns var-sym val]
+   (let [ns (sci-the-ns ctx ns)
+         ns-name (sci-ns-name ns)
+         env (:env ctx)]
+     (or (when-let [v (get-in @env [:namespaces ns-name var-sym])]
+           (vars/bindRoot v val)
+           v)
+         (let [var-name (symbol (str ns-name) (str var-sym))
+               new-var (vars/->SciVar val var-name (meta var-sym))]
+           (swap! env assoc-in [:namespaces ns-name var-sym] new-var)
+           new-var)))))
+
 ;;;; End namespaces
 
 ;;;; Eval and read-string
@@ -703,6 +727,7 @@
    'instance? (copy-core-var instance?)
    'int-array (copy-core-var int-array)
    'interleave (copy-core-var interleave)
+   'intern (with-meta sci-intern {:sci.impl/op :needs-ctx})
    'into (copy-core-var into)
    'iterate (copy-core-var iterate)
    'int (copy-core-var int)

diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc
@@ -957,6 +957,22 @@
           #"\[at line 1, column 2\]"
           (sci/eval-string " (throw (Exception.))")))))
 
+(deftest intern-test
+  (testing "interning results in unbound var"
+    (when-not tu/native?
+      (is (str/includes? (str (sci/eval-string "(ns foo) (ns bar) (intern 'foo 'x) foo/x"))
+                         "Unbound"))))
+  (testing "interning existing var returns var"
+    (is (= [1 true] (sci/eval-string "(ns foo) (def ^:a x 1) (ns bar) [@(intern 'foo 'x) (:a (meta #'foo/x))]"))))
+  (testing "interning existing var with value returns same var with value"
+    (is (= [2 true]
+           (sci/eval-string
+            "(ns foo) (def ^:a x 1) (ns bar) [@(intern 'foo 'x 2) (:a (meta #'foo/x))]"))))
+  (testing "interning var copies meta from name symbol"
+    (is (true?
+         (sci/eval-string
+          "(ns foo) (ns bar) (intern 'foo (with-meta 'x {:a true}) 1) (:a (meta #'foo/x))")))))
+
 ;;;; Scratch
 
 (comment