src/expand.clj

@@ -49,9 +49,7 @@
 
 (s/def ::syntax scm/syntax?)
 
-(s/def ::identifier
-  (s/and ::syntax
-         #(symbol? (scm/syntax-e %))))
+(s/def ::identifier scm/identifier?)
 
 (s/fdef expand
   :args (s/cat :stx ::syntax
@@ -64,6 +62,11 @@
                :env ::environment
                :store ::store))
 
+(s/fdef nearest
+  :args (s/cat :ctx ::context
+               :ss (s/coll-of ::context))
+  :ret (s/coll-of ::context :kind set?))
+
 
 
 (defn- store-scopes
@@ -74,11 +77,11 @@
               scopes)))
 
 (defn nearest [ctx ss]
-  (when-some [xs (->> ss
-                      (filter #(set/subset? % ctx))
-                      (group-by count)
-                      seq)]
-    (second (apply max-key first xs))))
+  (let [xs (->> ss
+                (filter #(set/subset? % ctx))
+                (group-by count)
+                seq)]
+    (set (some->> xs (apply max-key first) second))))
 
 (defn lookup [ident env store]
   (let [sym (scm/syntax-e ident)

src/scm.clj

@@ -121,10 +121,10 @@
 (defn read
   "`read` 작업의 결과로 생성된 콘텍스트 필드는 초기에 비어 있다. 이후
   `expand/expand` 작업을 통해 콘택스트 필드를 패울 수 있다."
-  [& {:keys [syntax? instaparse]
-      :or {syntax? false
-           instaparse {}}}]
-  (let [r (insta/parse r7rs-parser (slurp *in*)
+  [text & {:keys [syntax? instaparse]
+           :or {syntax? false
+                instaparse {}}}]
+  (let [r (insta/parse r7rs-parser text
                        :start :datum-start
                        instaparse)]
     (if (insta/failure? r)
@@ -139,7 +139,9 @@
         ;; 과정할 수 있었더다. 작업 한 개만으로 syntax object들 다
         ;; 만들 수 있어서 이럼은 더 좋다.
         :datum (fn [x]
-                 (datum->syntax x))
+                 (if syntax?
+                   (datum->syntax x)
+                   x))
         :number identity
         :symbol symbol
         :string (fn [& els]
@@ -159,5 +161,5 @@
                   (sign (parse-long digits)))}
        r))))
 
-(defn read-syntax [& {:as opts}]
-  (read (merge {:syntax? true} opts)))
+(defn read-syntax [text & {:as opts}]
+  (read text (merge {:syntax? true} opts)))

test/expand_test.clj

@@ -0,0 +1,17 @@
+(ns expand-test
+  (:require [expand :as sut]
+            [clojure.test :as t]))
+
+(t/deftest nearest-test
+  (t/is (= '#{#{a b}}
+           (sut/nearest '#{a b c}
+                        '[#{a} #{a b} #{a d}]))
+        "unambiguous")
+  (t/is (= '#{#{a b} #{a c}}
+           (sut/nearest
+            '#{a b c} '[#{a} #{a b} #{a c}]))
+        "ambiguous")
+  (t/is (= #{}
+           (sut/nearest
+            '#{a b c} '[#{d} #{d e} #{f}]))
+        "undefined"))

test/scm_test.clj

@@ -0,0 +1,40 @@
+(ns scm-test
+  (:require [scm :as sut]
+            [clojure.test :as t]))
+
+(t/deftest read-test
+  (t/testing "boolean"
+    (t/is (= true (sut/read "#t")))
+    (t/is (= true (sut/read "#true")))
+    (t/is (= false (sut/read "#f")))
+    (t/is (= false (sut/read "#false"))))
+  (t/testing "symbol"
+    (t/is (= 'abc (sut/read "abc")))
+    (t/is (= 'truth-nuke (sut/read "truth-nuke"))))
+  (t/testing "list"
+    (t/is (= (list 1 2 3) (sut/read "(1 2 3)")))
+    (t/is (= (sut/improper-list 1 2 3) (sut/read "(1 2 . 3)")))))
+
+(t/deftest read-syntax-test
+  (t/is (sut/unresolved? (sut/read-syntax "123")))
+  (t/is (sut/unresolved? (sut/read-syntax "(1 2 3)"))))
+
+(t/deftest improper-list?-test
+  (t/is (sut/improper-list? (sut/improper-list 1 2 3))))
+
+(t/deftest improper-list-test
+  (t/is (= [1 2] (:initial (sut/improper-list 1 2 3))))
+  (t/is (= 3 (:dot (sut/improper-list 1 2 3)))))
+
+(t/deftest constant?-test
+  (t/is (sut/constant? 123))
+  (t/is (sut/constant? #scm/stx 123)))
+
+(t/deftest syntax-test
+  (t/is (not (sut/syntax? 123)))
+  (t/is (sut/syntax? #scm/stx 123))
+  (t/is (sut/syntax? #scm/stx [123 #{}]))
+  (t/is (= 123 (sut/syntax-e #scm/stx [123 #{}]))))
+
+(t/deftest resolved?-test
+  (t/is (sut/unresolved? #scm/stx 123)))