From 90526500c9486b9d18abf076f9bcd836bc581d75 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Tue, 22 Sep 2026 07:17:30 -0600 Subject: [PATCH] --- src/expand.clj | 19 +++++++++++-------- src/scm.clj | 16 +++++++++------- test/expand_test.clj | 17 +++++++++++++++++ test/scm_test.clj | 40 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 77 insertions(+), 15 deletions(-) create mode 100644 test/expand_test.clj create mode 100644 test/scm_test.clj diff --git a/src/expand.clj b/src/expand.clj index 8433847..c3d4d00 100644 --- a/src/expand.clj +++ b/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) diff --git a/src/scm.clj b/src/scm.clj index 2071e00..c66ea2c 100644 --- a/src/scm.clj +++ b/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))) diff --git a/test/expand_test.clj b/test/expand_test.clj new file mode 100644 index 0000000..426c895 --- /dev/null +++ b/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")) diff --git a/test/scm_test.clj b/test/scm_test.clj new file mode 100644 index 0000000..ea05bf8 --- /dev/null +++ b/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)))