a

resources/expand/scm/r7rs.ebnf

@@ -20,9 +20,14 @@ list = <left-paren> datum* <right-paren>
 improper-list = <left-paren> datum+ <dot> datum <right-paren>
 
 (* symbol *)
-symbol = ordinary-symbol <intertoken-space>
+symbol
+  = ordinary-symbol <intertoken-space>
+  | peculiar-symbol <intertoken-space>
+
 <ordinary-symbol> = #"[\p{Lu}\p{Ll}\p{Lt}\p{Lm}\p{Lo}\p{Nl}\p{No}\p{Pd}\p{Pc}\p{Sc}\p{Po}\p{Sm}\p{Sk}\p{So}\p{Co}\u200c\u200d&&[^;|\".,#]][\p{Lu}\p{Ll}\p{Lt}\p{Lm}\p{Lo}\p{Nl}\p{No}\p{Pd}\p{Pc}\p{Sc}\p{Po}\p{Sm}\p{Sk}\p{So}\p{Co}\u200c\u200d\p{Nd}\p{Me}\p{Mc}.&&[^;|\",#]]*"
 
+<peculiar-symbol> = '...'
+
 (* number *)
 number = num-10 <intertoken-space>
 

resources/scm/scheme/base.scm

@@ -5,5 +5,5 @@
   (begin
     (define-syntax when
       (syntax-rules ()
-        ((_ test body)
-         (if test (begin body)))))))
+        ((_ test body ...)
+         (if test (begin body ...)))))))

src/common.clj

@@ -1,9 +0,0 @@
-(ns common)
-
-(defmacro inherit [& syms]
-  (let [f (if (<= 8 (count syms))
-            `hash-map
-            `array-map)]
-    `(~f ~@(mapcat #(list (keyword %) %)
-                   syms))))
-

src/data_readers.clj

@@ -1 +1 @@
-{scm/stx scm/stx-reader}
+{scm/stx expand.scm/stx-reader}

src/expand/common.clj

@@ -0,0 +1,35 @@
+(ns expand.common)
+
+(defmacro inherit [& syms]
+  (let [f (if (<= 8 (count syms))
+            `hash-map
+            `array-map)]
+    `(~f ~@(mapcat #(list (keyword %) %)
+                   syms))))
+
+(defmacro todo
+  ([]
+   `(throw (Exception. "todo")))
+  ([fmt & xs]
+   `(throw (Exception (format (str "todo: " ~fmt) ~@xs)))))
+
+(defn dbg> [x]
+  (tap> x)
+  x)
+
+(defmacro dbg [x]
+  `(let [x*# ~x
+         {line# :line column# :column} ~(meta &form)]
+     (tap> (vary-meta
+            (list (symbol (format "%s:%s:%s"
+                                  (str *ns*)
+                                  line#
+                                  column#))
+                  x*#)
+            (fn [m#]
+              (merge m#
+                     #:dbg {:line line#
+                            :column column#
+                            :ns *ns*
+                            :file (or *source-path* *file*)}))))
+     x*#))

src/expand/core.clj

@@ -1,14 +1,21 @@
-(ns expand
+(ns expand.core
   (:require [clojure.core.match :refer [match]]
+            [clojure.java.io :as io]
             [clojure.pprint]
             [clojure.set :as set]
             [clojure.spec.alpha :as s]
             [clojure.walk]
+            [expand.common :refer :all]
+            [expand.scm :as scm]
+            [expand.syntax-rules :as syntax-rules]
             [spec-dict.main :refer [dict]]
-            [scm]
-            [clojure.java.io :as io]
-            [expand.syntax-rules :as syntax-rules])
-  (:use [common]))
+            [clojure.walk :as walk]))
+
+(defn- conform! [spec x]
+  (let [r (s/conform spec x)]
+    (assert (not (s/invalid? r))
+            (s/explain-str spec x))
+    r))
 
 (s/def ::scope scm/scope?)
 
@@ -43,8 +50,7 @@
   #(match %
      [:var] true
      [:primitive p] (primitives p)
-     ;; 나쁜
-     [:macro trans] (contains? trans :rules)
+     [:macro form trans] (ifn? trans)
      [:syntax datum] true))
 
 (s/def ::environment
@@ -109,21 +115,37 @@
                         :kind sequential?))
                 :body ::body)))
 
-(s/def ::prim-let-syntax ::prim-let)
+(s/def ::prim-let-syntax
+  (s/and ::unsyntax
+         (s/cat :keyword ::identifier
+                :bindings
+                (s/and ::unsyntax
+                       (s/coll-of
+                        (s/and ::unsyntax
+                               (s/cat :rhs ::identifier
+                                      :lhs scm/datum+compilation?))
+                        :kind sequential?))
+                :body ::body)))
 
 (s/def ::prim-if
   (s/and ::unsyntax
          (s/cat :keyword ::identifier
                 :condition ::datum
                 :consequent ::datum
-                :alternative ::datum)))
+                :alternative (s/? ::datum))))
+
+(s/def ::prim-begin
+  (s/and ::unsyntax
+         (s/cat :keyword ::identifier
+                :body ::body)))
 
 ;; cf. `::transformer`
 (s/def ::prim-syntax-rules
-  (s/and seq? (s/cat :keyword ::identifier
-                     :keywords (s/and ::unsyntax
-                                      (s/coll-of ::identifier))
-                     :rules (s/* ::datum))))
+  (s/and ::unsyntax
+         (s/cat :keyword ::identifier
+                :keywords (s/and ::unsyntax
+                                 (s/coll-of ::identifier))
+                :rules (s/* ::datum))))
 
 
 
@@ -148,17 +170,6 @@
     (scm/datum->syntax (f scopeholder* env*)
                        scopeholder)))
 
-(comment
-  (let [env {}
-        store-atom (atom {})]
-    (binding-form #scm/stx [lambda #{}]
-                  env
-                  store-atom
-                  {:x [:var]}
-                  (fn [ident* env*]
-                    (tap> (inherit ident* env*))
-                    (list (scm/datum->syntax 'x ident*))))))
-
 
 
 (defn- store-scopes
@@ -181,7 +192,6 @@
         ss (store-scopes store sym)
         xs (nearest scopes ss)
         r (compare (count xs) 1)]
-    (tap> (inherit ident env store))
     (cond (neg? r) (throw (ex-info "undefined sym" {:sym sym}))
           (zero? r)
           (or (get env (or (get store [sym (first xs)])
@@ -195,6 +205,9 @@
   (fn [_datum prim-name _env _store-atom]
     prim-name))
 
+(defmethod expand-primitive :default [_ p _ _]
+  (throw (ex-info "정의뒨 프림" {:name p})))
+
 (defmethod expand-primitive 'lambda
   [stx _ env store-atom]
   (let [{:keys [formals body]} (s/conform ::prim-lambda stx)]
@@ -214,7 +227,7 @@
 (defmethod expand-primitive 'let
   [stx _ env store-atom]
   (let [{:keys [bindings body]} (s/conform ::prim-let stx)]
-    (assert (list? bindings))
+    (assert (seq? bindings))
     (binding-form
      stx env store-atom
      (doall (for [{:keys [rhs]} bindings]
@@ -222,7 +235,9 @@
      (fn [scopeholder env*]
        (concat (list 'let
                      (for [{:keys [rhs lhs]} bindings]
-                       (list (scm/rescope rhs scopeholder) lhs)))
+                       (list (scm/rescope rhs scopeholder)
+                             ;; todo: 여기에 expand함
+                             lhs)))
                (for [x body]
                  (expand (scm/rescope x scopeholder)
                          env* store-atom)))))))
@@ -230,19 +245,65 @@
 (defmethod expand-primitive 'if
   [stx _ env store-atom]
   (let [{:keys [condition consequent alternative]}
-        (s/conform ::prim-if stx)]
-    (assert ((every-pred scm/datum?) condition consequent alternative))
-    (cons 'if
-          (for [x [condition consequent alternative]]
-            (expand x env store-atom)))))
+        (conform! ::prim-if stx)]
+    (assert (scm/datum? condition))
+    (assert (scm/datum? consequent))
+    (assert (or (nil? consequent) (scm/datum? consequent)))
+    (-> (concat (list 'if
+                      (expand condition env store-atom)
+                      (expand consequent env store-atom))
+                (when alternative
+                  (list (expand alternative env store-atom))))
+        (scm/datum->syntax stx))))
+
+(defmethod expand-primitive 'begin
+  [stx _ env store-atom]
+  (let [{:keys [body]} (conform! ::prim-begin stx)]
+    (assert (sequential? body))
+    (-> (cons 'begin
+              (for [x body]
+                (expand x env store-atom)))
+        (scm/datum->syntax stx))))
 
 (defmethod expand-primitive 'let-syntax
   [stx _ env store-atom]
-  (let [_ (s/conform ::prim-let-syntax stx)]))
+  (let [{:keys [bindings body]} (conform! ::prim-let-syntax stx)]
+    (assert (sequential? bindings))
+    (assert (sequential? body))
+    (let [bindings* (for [{:keys [rhs lhs]} bindings]
+                      {:rhs rhs
+                       :lhs (-> (scm/rescope lhs stx)
+                                (expand env store-atom))})]
+      (binding-form
+       stx env store-atom
+       (for [{:keys [rhs lhs]} bindings*]
+         (let [lhs* (expand lhs env store-atom)]
+           (assert (scm/macro? lhs*)
+                   "let-syntax의 왼쪽은 마크로 아니다.")
+           [(scm/syntax-e rhs) lhs*]))
+       (fn [scopeholder env*]
+         (concat (list 'let-syntax
+                       (for [{:keys [rhs lhs]} bindings*]
+                         (list (scm/rescope rhs scopeholder) lhs)))
+                 (for [e body]
+                   (-> e
+                       (scm/rescope scopeholder)
+                       (expand
+                        env* store-atom)))))))))
 
 (defmethod expand-primitive 'syntax-rules
   [stx _ env store-atom]
-  (let [_ (s/conform ::prim-syntax-rules stx)]))
+  (let [trans (conform! ::prim-syntax-rules stx)
+        store @store-atom
+        lf #(lookup (dbg> %) env store)]
+    (scm/datum->syntax
+     [:macro
+      stx
+      #(let [intro (scm/new-scopeholder stx)
+             r (syntax-rules/invoke % trans intro lf)]
+         (assert r "맞은 패턴은 찾을 수 없었다")
+         r)]
+     stx)))
 
 (defn expand
   ([stx]
@@ -252,9 +313,9 @@
      (expand (scm/rescope stx scopeholder)
              env store-atom)))
   ([stx env store-atom]
-   (tap> (inherit stx))
    (match (scm/syntax-e stx)
-     (_ :guard scm/constant?) stx
+     [:primitive _] stx
+     (_ :guard (some-fn scm/macro? scm/constant?)) stx
      (_ :guard symbol?)
      (do (lookup stx env @store-atom) ; throw if unbound
          stx)
@@ -265,8 +326,13 @@
                       (scm/rescope stx)
                       (lookup env @store-atom))
              [:primitive prim] (expand-primitive stx prim env store-atom)
-             #_#_[:macro trans]
-             (expand-macro trans datum env symtable-ref scopes)
+             (macro :guard scm/macro?)
+             (or (-> ((scm/macro-fn macro)
+                      (-> (for [x (cons f xs)]
+                            (scm/rescope x stx))
+                          (scm/datum->syntax stx)))
+                     (expand env store-atom))
+                 (throw (Exception. "wtf")))
              [:var] nil))
          (for [x (cons f xs)]
            (expand (scm/rescope x stx) env store-atom))))))
@@ -317,24 +383,46 @@
                   [:import & xs] (cons 'import xs)
                   [:export & xs] (cons 'export xs))))))
 
+(defn macro->datum [macro]
+  (match macro
+    [:macro stx _] (scm/syntax->datum stx)))
+
 (defn library-syntax->datum [lib]
   (update lib :library/declarations
           (fn [decls]
             (for [decl decls]
               (match decl
-                [:begin & xs] (->> xs
-                                   (map scm/syntax->datum)
-                                   (cons :begin)
-                                   vec)
+                [:begin & xs]
+                (->> xs
+                     (map scm/syntax->datum)
+                     (map (fn [x]
+                            (walk/prewalk
+                             #(if (scm/macro? %)
+                                (dbg> (scm/macro-form %))
+                                %)
+                             x)))
+                     (cons :begin)
+                     vec)
                 :else decl)))))
 
+(defn -main []
+  (clojure.pprint/with-pprint-dispatch
+    clojure.pprint/code-dispatch
+    (-> (slurp *in*)
+        (scm/read-syntax :library? true :throw? true)
+        expand-library
+        #_library-syntax->datum
+        library->datum
+        clojure.pprint/pprint)))
+
 (comment
   (-> "t.scm"
       slurp
-      (scm/read-syntax :library? true)
+      (scm/read-syntax :library? true :throw? true)
       expand-library
       library-syntax->datum
-      library->datum)
+      library->datum
+      clojure.pprint/pprint)
   (let [scopeholder (scm/new-scopeholder)
         env {[:global 'lambda] [:primitive 'lambda]}
         store-atom (atom {['lambda #{}] [:global 'lambda]})]

src/expand/scm.clj

@@ -1,4 +1,4 @@
-(ns scm
+(ns expand.scm
   (:refer-clojure :exclude [read])
   (:require [clojure.core.match :refer [match]]
             [clojure.java.io :as io]
@@ -27,7 +27,10 @@
         (and (satisfies? ISyntax y)
              (.equals datum (syntax-e y))
              (.equals ctx (syntax-context y)))))
-  scm/ISyntax
+  clojure.lang.IMeta
+  (meta [this]
+    {:type (class this)})
+  expand.scm/ISyntax
   (syntax-e [this] datum)
   (syntax-context [this] ctx)
   clojure.lang.Seqable
@@ -55,7 +58,9 @@
   ;; top-level scope를 짓겠는다. 그때 nil/#{}는 `::unresolved`를
   ;; 대신하고 하나의 scope를 이루어진 집합은 #{}를 대신하겠는다.
   #_(= (syntax-context stx) ::unresolved)
-  (empty? (syntax-context stx)))
+  (let [x (syntax-context stx)]
+    (or (nil? x)
+        (and (coll? x) (empty? x)))))
 
 (defn resolved? [stx]
   (not (unresolved? stx)))
@@ -167,7 +172,7 @@
 
 ;;; r⁷rs reader
 
-(insta/defparser r7rs-parser (io/resource "r7rs.ebnf"))
+(insta/defparser r7rs-parser (io/resource "expand/scm/r7rs.ebnf"))
 
 (defn read
   "text에서 Scheme 데이텀 한 개를 받는다.
@@ -190,7 +195,8 @@
                        instaparse)]
     (if (insta/failure? r)
       (if throw?
-        (throw (ex-info "reader error" {:err r}))
+        (throw (ex-info (pr-str (insta/get-failure r))
+                        {:err r}))
         r)
       (insta/transform
        {:boolean (fn [x]
@@ -267,15 +273,30 @@
 
 (defn macro? [x]
   (match x
-    [:macro f] (fn? x)
+    [:macro _ f] (ifn? x)
+    (_ :guard syntax?) (-> x syntax-e macro?)
     :else false))
 
+(defn macro-form [macro]
+  (match macro
+    [:macro stx _] stx
+    (_ :guard syntax?) (-> macro syntax-e macro-form)))
+
+(defn macro-fn [macro]
+  (match macro
+    [:macro _ f] f
+    (_ :guard syntax?) (-> macro syntax-e macro-fn)))
+
 (defn datum? [x]
   (or (number? x)
       (boolean? x)
       (string? x)
-      (macro? x)
-      (list? x)
+      (seq? x)
       (symbol? x)
       (improper-list? x)
       (and (syntax? x) (-> x syntax-e datum?))))
+
+(defn datum+compilation? [x]
+  (if (syntax? x)
+    (-> x syntax-e datum+compilation?)
+    (or (macro? x) (datum? x))))

src/expand/syntax_rules.clj

@@ -1,18 +1,17 @@
 (ns expand.syntax-rules
   (:require [clojure.core.match :refer [match]]
             [clojure.spec.alpha :as s]
-            [spec-dict.main :refer [dict]]
-            [scm]
             [clojure.test :as t]
-            [clojure.walk :as walk])
-  (:use [common]))
+            [clojure.walk :as walk]
+            [expand.common :refer :all]
+            [expand.scm :as scm]
+            [spec-dict.main :refer [dict]]))
 
 (s/def ::pattern scm/datum?)
 (s/def ::template scm/datum?)
 
 (defn- report-conflict [x y]
-  (throw (ex-info "너무 정의합니다"
-                  {:x x :y y})))
+  (throw (ex-info "정의는 너무 많다" {:x x :y y})))
 
 (defn- merge-unify-with
   ([f] {})
@@ -23,43 +22,6 @@
 (defn- merge-unify [& xs]
   (apply merge-unify-with report-conflict xs))
 
-#_
-(defn- unify* [pattern datum]
-  (match [pattern datum]
-    [[:wildcard _] _] {}
-    [[:var x] _] {x datum}
-    
-    [[:list {:leading leading
-             :trailing nil
-             :ellipsis ellipsis}]
-     (_ :guard seq?)]
-    (let [[leading-datum ellipsis-datum] (split-at (count leading) datum)]
-      (merge-unify
-       (apply merge-unify (map #(unify* %1 %2)
-                               leading
-                               leading-datum))
-       (some->> ellipsis-datum
-                (map #(some-> (unify* ellipsis %)
-                              (update-vals list)))
-                (apply merge-unify-with concat)
-                (map (fn [[k v]]
-                       [k [:ellipsis v]]))
-                (into {}))))
-
-    [[:list {:leading leading}]
-     (_ :guard seq?)]
-    (when (= (count datum)
-             (count leading))
-      (->> (map #(unify* %1 %2) leading datum)
-           (apply merge-unify)))
-
-    ;; no match
-    :else nil))
-
-#_
-(defn unify [pattern datum]
-  (unify* (s/conform ::pattern pattern) datum))
-
 (defn wildcard? [x]
   (or (= '_ x)
       (and (scm/syntax? x) (-> x scm/syntax-e wildcard?))))
@@ -68,20 +30,45 @@
   (or (= '... x)
       (and (scm/syntax? x) (-> x scm/syntax-e ellipsis?))))
 
+(defn pattern-vars [pattern]
+  ;; 안 예쁘는데ㅠㅠ
+  (let [vs (atom #{})]
+    (walk/prewalk (fn [x]
+                    (when (and (scm/identifier? x)
+                               (not (wildcard? x))
+                               (not (ellipsis? x)))
+                      (swap! vs #(conj % x)))
+                    x)
+                  pattern)
+    @vs))
+
 (defn unify [pattern datum]
   (match [(scm/syntax-e pattern) (scm/syntax-e datum)]
     [(_ :guard wildcard?) _] {}
     [(x :guard symbol?) _] {x datum}
 
+    [(_ :guard scm/constant?)
+     (_ :guard scm/constant?)]
+    (when (= pattern datum) {})
+
     [([p (_ :guard ellipsis?) & ps] :seq)
      (ds :guard seq?)]
-    (let [ds-end (take-last (count ps) ds)
-          ds-start (drop-last (count ps) ds)]
+    (let [ds-end (or (take-last (count ps) ds)
+                     (list))
+          ds-start (or (drop-last (count ps) ds)
+                       (list))]
       (merge-unify
        (some->> ds
                 (map #(some-> (unify p %)
                               (update-vals list)))
-                (apply merge-unify-with concat)
+                (apply merge-unify-with concat
+                       ;; 여기에 이 map이 없으면 ds 빌 때 `unify`는
+                       ;; {}을 생성할 잘못되게 것이다. 그때
+                       ;; variable들은 bound을 안 될 것이다. 대신에
+                       ;; empty ellipsis로 bind해야 한다.
+                       (into {}
+                             (for [v (pattern-vars p)]
+                               [(scm/syntax-e v) (list)])))
                 (map (fn [[k v]]
                        [k [:ellipsis v]]))
                 (into {}))))
@@ -91,14 +78,11 @@
     (merge-unify (unify p d)
                  (unify (scm/datum->syntax ps pattern)
                         (scm/datum->syntax ds datum)))
+
     [([] :seq)
      ([] :seq)]
     {}
 
-    [(_ :guard scm/constant?)
-     (_ :guard scm/constant?)]
-    (when (= pattern datum) {})
-
     ;; no match
     :else nil))
 
@@ -107,18 +91,39 @@
                  (scm/datum->syntax-recursive datum))
           (update-vals scm/syntax->datum)))
 
-(defn transcribe [template unification]
-  (match (scm/syntax-e template)
-    (x :guard symbol?) (or (get unification x)
-                           (throw (Exception. "blah")))
-    ([x & xs] :seq)
-    (let [xs* (transcribe (scm/datum->syntax xs template) unification)]
-      (scm/datum->syntax
-       (cons (transcribe x unification) (scm/syntax-e xs*))
-       template))
+(defn transcribe
+  ([template unification]
+   (match (scm/syntax-e template)
+     (_ :guard ellipsis?)
+     (throw (IllegalArgumentException. "점점점은 여기 있으면 안 되다."))
 
-    ([] :seq)
-    template))
+     (x :guard symbol?)
+     (or (get unification x)
+         template
+         #_(throw (Exception. "nosymmm")))
+
+     (_ :guard scm/constant?)
+     template
+
+     ([x (_ :guard ellipsis?) & xs] :seq)
+     (match (transcribe x unification)
+       [:ellipsis x*] (let [xs* (transcribe (scm/datum->syntax xs template)
+                                            unification)]
+                        (scm/datum->syntax
+                         (concat x* (scm/syntax-e xs*))
+                         template))
+       :else (throw (IllegalArgumentException. "점점점은 나쁘다ㅠㅠ")))
+
+     ([x & xs] :seq)
+     (let [xs* (transcribe (scm/datum->syntax xs template) unification)]
+       (scm/datum->syntax
+        (cons (transcribe (scm/rescope x template)
+                          unification)
+              (scm/syntax-e xs*))
+        template))
+
+     ([] :seq)
+     template)))
 
 (defn transcribe*
   ([template unification]
@@ -131,11 +136,11 @@
                           (scm/datum->syntax-recursive datum)))
        scm/syntax->datum)))
 
-(comment
-  (let [pattern 'x
-        template 'x
-        datum '(1 2 3)]
-    (-> template
-        (transcribe* (unify (scm/datum->syntax-recursive pattern)
-                            (scm/datum->syntax-recursive datum)))
-        #_scm/syntax->datum)))
+(defn invoke [datum syntax-rules scopeholder lookup]
+  (let [{:keys [rules keywords]} syntax-rules]
+    (some (fn [rule]
+            (let [[pattern template] (scm/syntax-e rule)]
+              (when-let [unif (unify pattern datum)]
+                (transcribe (scm/rescope template scopeholder)
+                            unif))))
+          rules)))

src/old.clj

@@ -1,593 +0,0 @@
-(ns old
-  (:require [clojure.core.match :refer [match]]
-            [clojure.pprint :as pprint]
-            [clojure.set :as set]
-            [clojure.spec.alpha :as s]
-            [clojure.walk]
-            [spec-dict.main :refer [dict]]))
-
-(defmacro todo
-  ([] `(throw (ex-info "todo" {})))
-  ([fmt & xs]
-   `(throw (ex-info (format (str "todo: " ~fmt) ~@xs)
-                    {}))))
-
-(def primitives
-  '#{let let-syntax letrec lambda syntax-rules if define
-     define-syntax begin})
-
-(def builtins
-  '#{+ * / - car cdr write display newline cons list})
-
-(s/def ::binding
-  #(match %
-     [:lexical sym uniq] (and (symbol? sym) (symbol? uniq))
-     [:global sym] (symbol? sym)))
-
-(s/def ::pattern
-  (s/or :wildcard #{'_}
-        :var (s/and symbol? (complement #{'... '_}))
-        :lit ::literal
-        :list (s/and seq?
-                     (s/cat :leading (s/* ::pattern)
-                            :rest (s/? (s/cat :ellipsis #{'...}
-                                              :trailing (s/* ::pattern))))
-                     (s/conformer
-                      (fn [pat]
-                        (if-some [{:keys [ellipsis trailing]} (:rest pat)]
-                          (let [{:keys [leading]} pat]
-                            (if-some [variadic (last leading)]
-                              {:leading (vec (butlast leading))
-                               :ellipsis variadic
-                               :trailing trailing}
-                              ::s/invalid))
-                          pat))))))
-
-(s/def ::literal (some-fn string? boolean? number? char?))
-
-(defn literal? [x]
-  (s/valid? ::literal x))
-
-(s/def ::datum any?)
-
-(declare variable?)
-
-(s/def ::template
-  (s/or :var ::variable
-        :lit ::literal
-        :list (s/and (s/* ::template-element) sequential?)))
-
-(s/def ::template-element
-  (s/& (s/cat :template ::template :ellipsis (s/? #{'...}))
-       (s/conformer
-          (fn [{:keys [ellipsis template]}]
-            (if ellipsis
-              [:ellipsis template]
-              template)))))
-
-(s/def ::rule
-  (s/and sequential?
-         (s/cat :pattern ::pattern
-                :template ::template)))
-
-;; cf. `::prim-syntax-rules`
-(s/def ::transformer
-  (dict {:rules (s/coll-of ::rule :kind sequential?)}
-        ^:opt {:keywords (s/coll-of symbol?)}))
-
-(s/def ::denotation
-  #(match %
-     [:var] true
-     [:primitive p] (primitives p)
-     ;; 나쁜
-     [:macro trans] (contains? trans :rules)
-     [:syntax datum] true))
-
-(s/def ::environment
-  (s/map-of ::binding ::denotation))
-
-(s/def ::scope symbol?)
-
-(s/def ::scope-set (s/coll-of ::scope :kind set?))
-
-;; this is an inefficient representation. since we often want to
-;; compute the submap of entries with a symbol 'x' but any scope, it
-;; would be best to 'curry' the table, as Symbol → Scopes →
-;; Binding. however, this is a bit more error-prone and cumbersome for
-;; a prototype.
-(s/def ::symtable
-  (s/map-of (s/tuple symbol? (s/coll-of ::scope :kind set?))
-            ::binding))
-
-(s/def ::formals
-  (s/coll-of symbol? :kind sequential?))
-
-(s/def ::body
-  (s/+ any?))
-
-(declare destructure-variable)
-
-(defprotocol IVariable
-  (variable-symbol [this])
-  (variable-scopes [this]))
-
-(deftype Variable [symbol scopes]
-  Object
-  (equals [x y]
-    (if-some [[y-symbol y-scopes] (destructure-variable y)]
-      (and (.equals symbol y-symbol)
-           (.equals scopes y-scopes))
-      false))
-  IVariable
-  (variable-symbol [this] symbol)
-  (variable-scopes [this] scopes))
-
-(def ^:dynamic *print-variable-scopes* true)
-
-;; does not respect `*print-dup*` lol
-(defmethod print-method Variable [this writer]
-  (binding [*out* writer]
-    (if *print-variable-scopes*
-      (pr [(variable-symbol this) (variable-scopes this)])
-      (pr (variable-symbol this)))))
-
-(defmethod clojure.pprint/simple-dispatch old.Variable [x]
-  (clojure.pprint/simple-dispatch
-   (if *print-variable-scopes*
-     [(variable-symbol x) (variable-scopes x)]
-     (variable-symbol x))))
-
-(s/def ::variable
-  (s/conformer
-   (fn [x]
-     (match x
-       (_ :guard symbol?) (->Variable x nil)
-       (_ :guard #(instance? Variable %))
-       (if (symbol? (variable-symbol x))
-         (let [r (s/conform ::scope-set (variable-scopes x))]
-           (if (s/invalid? r)
-             ::s/invalid
-             (->Variable (variable-symbol x) (variable-scopes x))))
-         ::s/invalid)
-       [sym scopes] (let [r (s/conform (s/nilable ::scope-set) scopes)]
-                      (if (and (symbol? sym) (not (s/invalid? r)))
-                        (->Variable sym r)
-                        ::s/invalid))
-       :else ::s/invalid))))
-
-(defn variable? [x]
-  (s/valid? ::variable x))
-
-(defn normalise-variale [v]
-  (let [r (s/conform ::variable v)]
-    (when-not (s/invalid? r)
-      r)))
-
-(defn destructure-variable [v]
-  (let [r (s/conform ::variable v)]
-    (when-not (s/invalid? r)
-      [(variable-symbol r) (variable-scopes r)])))
-
-#_
-(defn variable-scopes [v]
-  (when-some [[_ scopes] (destructure-variable v)]
-    scopes))
-
-#_
-(defn variable-symbol [v]
-  (when-some [[s _] (destructure-variable v)]
-    s))
-
-(defn offer-scopes
-  "variable v는 안 resolve되면 v와 scopes는 붙음."
-  [v scopes]
-  (let [[sym existing-scopes] (destructure-variable v)]
-    (->Variable sym (or existing-scopes scopes))))
-
-(s/def ::prim-lambda
-  (s/cat :keyword ::variable
-         :formals ::formals
-         :body ::body))
-
-(s/def ::prim-let
-  (s/cat :keyword ::variable
-         :bindings (s/coll-of #(and (sequential? %)
-                                    (= 2 (count %))
-                                    (symbol? (first %)))
-                              :kind sequential?)
-         :body ::body))
-
-(s/def ::prim-let-syntax ::prim-let)
-
-;; cf. `::transformer`
-(s/def ::prim-syntax-rules
-  (s/and seq? (s/cat :keyword ::variable
-                     :keywords (s/coll-of symbol?)
-                     :rules (s/* ::rule))))
-
-(s/def ::prim-if
-  (s/and seq? (s/cat :keyword ::variable
-                     :condition ::datum
-                     :consequent ::datum
-                     :alternative (s/? ::datum))))
-
-(s/def ::prim-begin
-  (s/and seq? (s/cat :keyword ::variable
-                     :body (s/+ ::datum))))
-
-
-
-(defn symtable-for-env [env]
-  (into (hash-map)
-        (for [[[_ x] _] env]
-          [[x #{}] [:global x]])))
-
-(defmacro meta-syntax-rules [kws & body]
-  `(s/conform ::prim-syntax-rules
-              (list 'syntax-rules '~kws
-                    ~@(map (fn [x] `(quote ~x)) body))))
-
-(defn define-global [env-ref symtable-ref sym denot]
-  (swap! env-ref #(assoc % [:global sym] denot))
-  (swap! symtable-ref #(assoc % [sym #{}] [:global sym])))
-
-(declare expand)
-
-(defn define-macro [env-ref symtable-ref sym trans]
-  (let [trans (->> (expand trans @env-ref symtable-ref #{})
-                   (s/conform ::prim-syntax-rules))]
-    (assert (not (s/invalid? trans)))
-    (define-global
-      env-ref
-      symtable-ref
-      sym
-      [:macro trans])))
-
-(defn scheme-base []
-  (let [env-ref (atom {})
-        symtable-ref (atom {})]
-    (define-global env-ref symtable-ref
-      'λ [:primitive 'lambda])
-    (doseq [p primitives]
-      (define-global env-ref symtable-ref
-        p [:primitive p]))
-    (doseq [b builtins]
-      (define-global env-ref symtable-ref
-        b [:var]))
-    (define-macro env-ref symtable-ref
-      'and '(syntax-rules ()
-             ((_) false)
-             ((_ a) a)
-             ((_ a b ...)
-              (if a (and b ...) a))))
-    (define-macro env-ref symtable-ref
-      'when '(syntax-rules ()
-              ((_ test body)
-               (if test body))
-              ((_ test body ...)
-               (if test (begin body)))))
-    {:env @env-ref
-     :symtable @symtable-ref})
-  #_(merge
-     {[:global 'λ] [:primitive 'lambda]
-      [:global 'and] [:macro
-                      (meta-syntax-rules ()
-                        ((_) false)
-                        ((_ a) a)
-                        ((_ a b ...)
-                         (if a (and b ...) a)))]
-      [:global 'when] [:macro
-                       (meta-syntax-rules ()
-                         ((_ test body)
-                          (if test body))
-                         ((_ test body ...)
-                          (if test (begin body))))]}
-     (into {} (for [p primitives]
-                [[:global p] [:primitive p]]))
-     (into {} (for [b builtins]
-                [[:global b] [:var]]))))
-
-(defn nearest [[sym scopes] ss]
-  (when-some [xs (->> ss
-                      (filter #(set/subset? % scopes))
-                      (group-by count)
-                      seq)]
-    (second (apply max-key first xs))))
-
-(defn- symtable-scopes
-  "Gather the set of scope-sets associated with a given symbol."
-  [symtable sym]
-  (into #{} (for [[[x scopes] _] symtable
-                  :when (= sym x)]
-              scopes)))
-
-(defn lookup [variable env symtable]
-  (let [[sym scopes] (or (destructure-variable variable)
-                         (throw (ex-info "not a var" {:var variable})))
-        ss (symtable-scopes symtable sym)
-        xs (nearest [sym scopes] ss)
-        r (compare (count xs) 1)]
-    (cond (neg? r) (throw (ex-info "undefined sym" {:sym sym}))
-          (zero? r)
-          (or (get env (or (get symtable [sym (first xs)])
-                           (throw (ex-info "unreachable" {}))))
-              (throw (ex-info "unreachable" {})))
-          (pos? r) (throw (ex-info "ambiguous sym" {:sym sym})))))
-
-(comment
-  (let [{:keys [symtable env]} (scheme-base)
-        st (atom symtable)]
-    {:e (expand '(lambda (x y) x) env st #{})
-     :st @st}))
-
-(defmulti expand-primitive
-  (fn [_datum prim-name _env _symtable-ref _scopes]
-    prim-name))
-
-(defn new-scope
-  ([] (gensym "scope__"))
-  ([prefix] (gensym (str "scope__" prefix))))
-
-(defn bind-lexical [[sym scopes] denot symtable-ref]
-  (let [bind [:lexical sym (gensym)]]
-    (swap! symtable-ref #(assoc % [sym scopes] bind))
-    {bind denot}))
-
-(defn make-symtable [[sym scopes] bind]
-  {[sym scopes] bind})
-
-
-
-(defn- report-conflict [x y]
-  (throw (ex-info "너무 정의합니다"
-                  {:x x :y y})))
-
-(defn- merge-unify-with
-  ([f] {})
-  ([f a] a)
-  ([f a b] (and a b (merge-with f a b)))
-  ([f a b & xs] (reduce #(merge-unify-with f %1 %2) (cons a (cons b xs)))))
-
-(defn- merge-unify [& xs]
-  (apply merge-unify-with report-conflict xs))
-
-(defn- unify* [pattern datum]
-  (match [pattern datum]
-    [[:wildcard _] _] {}
-    [[:var x] _] {x datum}
-    
-    [[:list {:leading leading
-             :trailing nil
-             :ellipsis ellipsis}]
-     (_ :guard seq?)]
-    (let [[leading-datum ellipsis-datum] (split-at (count leading) datum)]
-      (merge-unify
-       (apply merge-unify (map #(unify* %1 %2)
-                               leading
-                               leading-datum))
-       (some->> ellipsis-datum
-                (map #(some-> (unify* ellipsis %)
-                              (update-vals list)))
-                (apply merge-unify-with concat)
-                (map (fn [[k v]]
-                       [k [:ellipsis v]]))
-                (into {}))))
-
-    [[:list {:leading leading}]
-     (_ :guard seq?)]
-    (when (= (count datum)
-             (count leading))
-      (->> (map #(unify* %1 %2) leading datum)
-           (apply merge-unify)))
-
-    ;; no match
-    :else nil))
-
-(defn unify [pattern datum]
-  (unify* (s/conform ::pattern pattern) datum))
-
-(defn unification->env [unification symtable-ref scopes]
-  (into {}
-        (doall (for [[k v] unification]
-                 (bind-lexical [k scopes] [:syntax v]
-                               symtable-ref)))))
-
-(defn unify-trans
-  "`unify`로 모든 trans의 패턴은 datum을 맞음. datum으로 맞은 패턴은
-  없으면 nil을 결과할 것입나다.
-
-  걸과의 모습은 [rule unification]입니다. 여기서 rule이 최초 맞은
-  trans의 rule이고, unification이 `unify`의 결과입니다."
-  [trans datum]
-  (some (fn [{:keys [pattern template]
-              :as rule}]
-          (when-some [unif (unify* pattern datum)]
-            [rule unif]))
-        (:rules trans)))
-
-(defn transcribe [template env symtable scopes]
-  (match template
-    [:var x] (let [x* (offer-scopes x scopes)]
-               (match (lookup x* env symtable)
-                 [:syntax [:ellipsis fuckoffmanjustshadowit]] (todo "점점점")
-                 [:syntax syn] syn
-                 :else x*))
-    [:ellipsis _] (todo "점점점")
-    [:lit x] x
-    [:list xs]
-    (do (tap> xs)
-        (map #(transcribe % env symtable scopes) xs))))
-
-(defn resolve-template [template scopes]
-  (clojure.walk/postwalk
-   #(if (variable? %)
-      (offer-scopes % scopes)
-      %)
-   template))
-
-
-;;; expand
-
-(declare expand)
-
-(defmethod expand-primitive 'lambda
-  [datum _ env symtable-ref scopes]
-  (let [{:keys [formals body]} (s/conform ::prim-lambda datum)
-        scopes* (conj scopes (new-scope))
-        env* (apply merge env
-                    (for [x formals]
-                      (bind-lexical [x scopes*]
-                                    [:var] symtable-ref)))]
-    (concat (list 'lambda
-                  (for [x formals]
-                    (offer-scopes x scopes*)))
-            (for [e body]
-              (expand e env* symtable-ref scopes*)))))
-
-(defmethod expand-primitive 'let
-  [datum _ env symtable-ref scopes]
-  (let [{:keys [bindings body]} (s/conform ::prim-let datum)
-        scopes* (conj scopes (new-scope))
-        env* (apply merge env
-                    (for [[x _] bindings]
-                      (bind-lexical [x scopes*]
-                                    [:var] symtable-ref)))]
-    (concat (list 'let
-                  (for [[k v] bindings]
-                    (list (offer-scopes k scopes*) v)))
-            (for [e body]
-              (expand e env* symtable-ref scopes*)))))
-
-(defmethod expand-primitive 'let-syntax
-  [datum _ env symtable-ref scopes]
-  (let [{:keys [bindings body]} (s/conform ::prim-let-syntax datum)
-        scopes* (conj scopes (new-scope))
-        env* (apply merge env
-                    (for [[x rhs] bindings]
-                      (let [trans (->> (expand rhs env symtable-ref scopes)
-                                       (s/conform ::prim-syntax-rules))]
-                        (assert (not (s/invalid? trans)))
-                        (bind-lexical
-                         [x scopes*]
-                         [:macro trans]
-                         symtable-ref))))]
-    (concat (list 'let-syntax bindings)
-            (for [e body]
-              (expand e env* symtable-ref scopes*)))))
-
-(defmethod expand-primitive 'syntax-rules
-  [datum _ env symtable-ref scopes]
-  (assert (s/valid? ::prim-syntax-rules datum))
-  (let [scopes* (conj scopes (new-scope))
-        keywords (nth datum 1)
-        rules (nthrest datum 2)]
-    (concat (list 'syntax-rules
-                  keywords)
-            (for [[pattern template] rules]
-              (list pattern (resolve-template template scopes*))))))
-
-(defmethod expand-primitive 'if
-  [datum _ env symtable-ref scopes]
-  (let [{:keys [condition consequent alternative]}
-        (s/conform ::prim-if datum)
-        ex #(expand % env symtable-ref scopes)]
-    (concat (list 'if (ex condition)
-                  (ex consequent))
-            (some-> alternative ex))))
-
-(defmethod expand-primitive 'begin
-  [datum _ env symtable-ref scopes]
-  (let [{:keys [body]} (s/conform ::prim-begin datum)]
-    (cons 'begin (map #(expand % env symtable-ref scopes) body))))
-
-(comment
-  (let [env (:env scheme-base-env)
-        [_ trans] (get env [:global 'and])
-        datum '(and 12 34)
-        symtable-ref (atom (symtable-for-env env))
-        scopes #{1}]
-    (expand-macro
-     trans datum
-     env symtable-ref scopes)))
-
-(defn expand-macro [trans datum env symtable-ref scopes]
-  (let [[rule unif]
-        (-> (unify-trans trans datum)
-            (or (throw
-                 (ex-info
-                  "데이텀을 맞은 패턴은 찾을 수 없었습니다"
-                  {:trans trans :datum datum}))))
-        scopes* (conj scopes (new-scope))
-        env* (merge env (unification->env unif symtable-ref scopes*))]
-    (expand (transcribe (:template rule) env* @symtable-ref scopes*)
-            env ;; 아마도 `env*`를 써야 되고 `env`를 안 써야 된가?
-            symtable-ref
-            scopes)))
-
-(defn expand
-  ([datum]
-   (let [{:keys [env symtable]} (scheme-base)]
-     (expand
-      datum env (atom symtable) #{})))
-  ([datum env symtable-ref scopes]
-   (match datum
-     ;; literals
-     (x :guard literal?) x
-     ;; variables (both resolved and unresolved)
-     (x :guard variable?)
-     (let [x* (offer-scopes x scopes)]
-       (lookup x* env @symtable-ref) ; throw if unbound
-       x*)
-
-     ;; lists
-     ([f & xs] :seq)
-     (or (when-let [v (and (variable? f)
-                           (offer-scopes f scopes))]
-           (match (lookup v env @symtable-ref)
-             [:primitive prim] (expand-primitive
-                                datum prim env symtable-ref scopes)
-             [:macro trans] (expand-macro trans datum env symtable-ref scopes)
-             [:var] nil))
-         (cons (expand f env symtable-ref scopes)
-               (map #(expand % env symtable-ref scopes) xs))))))
-
-
-
-(defn regensym
-  "Renumber the gensyms created by `new-scope` found in datum,
-  starting from zero."
-  [datum]
-  (let [c (atom {})]
-    (clojure.walk/postwalk
-     (fn [x]
-       (if (instance? Variable x)
-         (let [[sym scopes] (destructure-variable x)
-               syms (swap!
-                     c
-                     #(let [r (set/difference scopes
-                                              (set (keys %)))]
-                        (into %
-                              (map-indexed
-                               (fn [n a]
-                                 [a (symbol (str "s" (+ (count %) n)))])
-                               r))))]
-           #_(->Variable sym (set (map #(get syms %) scopes)))
-           [sym (set (map #(get syms %) scopes))])
-         x))
-     datum)))
-
-(defn unscope
-  "Remove all scopes from the variables found in datum."
-  [datum]
-  (clojure.walk/postwalk
-   (fn [x]
-     (if (instance? Variable x)
-       (variable-symbol x)
-       x))
-   datum))
-
-(defn us-expand [datum]
-  (unscope (expand datum)))
-
-(defn rg-expand [datum]
-  (regensym (expand datum)))

src/unhygienic.clj

@@ -1,106 +0,0 @@
-(ns unhygienic
-  (:require [clojure.core.match :refer [match]]
-            [clojure.spec.alpha :as s]
-            [expand]))
-
-(defn- merge-unify-with
-  ([f] {})
-  ([f a] a)
-  ([f a b] (and a b (merge-with f a b)))
-  ([f a b & xs] (reduce #(merge-unify-with f %1 %2) (cons a (cons b xs)))))
-
-(defn- merge-unify [& xs]
-  (apply merge-unify-with (fn [_ x] x) xs))
-
-(defn- unify* [pattern datum]
-  (match [pattern datum]
-    [[:wildcard _] _] {}
-    [[:var x] _] {x datum}
-    
-    [[:list {:leading leading
-             :trailing nil
-             :ellipsis ellipsis}]
-     (_ :guard seq?)]
-    (let [[leading-datum ellipsis-datum] (split-at (count leading) datum)]
-      (merge-unify
-       (apply merge-unify (map #(unify* %1 %2)
-                               leading
-                               leading-datum))
-       (some->> ellipsis-datum
-                (map #(when-some [r (unify* ellipsis %)]
-                        (->> r
-                             (map (fn [[k v]] [k (list v)]))
-                             (into {}))))
-                (apply merge-unify-with concat)
-                (map (fn [[k v]]
-                       [k [:ellipsis v]]))
-                (into {}))))
-
-    [[:list {:leading leading}]
-     (_ :guard seq?)]
-    (when (= (count datum)
-             (count leading))
-      (->> (map #(unify* %1 %2) leading datum)
-           (apply merge-unify)))
-
-    ;; no match
-    :else nil))
-
-(defn unify [pattern datum]
-  (unify* (s/conform :expand/pattern pattern) datum))
-
-
-
-(comment
-  (transcribe (unify '((a ...) ...)
-                     '((1 2) (3 4) (5 6)))
-              '(begin (a ...) ...))
-  (strip-ellipsis
-   '[:ellipsis ([:ellipsis (1 2)] [:ellipsis (3 4)] [:ellipsis (5 6)])]
-   2))
-
-(defn- strip-ellipsis [unif ellipsis-depth]
-  (match unif
-    [:ellipsis p]
-    (if (< 0 ellipsis-depth)
-      (map #(strip-ellipsis % (dec ellipsis-depth)) p)
-      (throw (ex-info "나쁜 점점점" {})))
-    :else unif))
-
-(defn- transcribe*
-  ([unification template]
-   (transcribe* 0 unification template))
-  ([ellipsis-depth unification template]
-   (match template
-     [:lit l] l
-
-     [:var x]
-     (match (get unification x)
-       ([:ellipsis _] :as p)
-       (strip-ellipsis p ellipsis-depth)
-
-       ;; unhygenic but it's demo }:)
-       (_ :guard nil?) x
-
-       p p)
-
-     [:list ts]
-     (->> (for [t ts]
-            (match t
-              [:ellipsis t*] (transcribe* (inc ellipsis-depth) unification t*)
-              :else [(transcribe* ellipsis-depth unification t)]))
-          (apply concat)))))
-
-(defn transcribe [unification template]
-  (transcribe* 0 unification (s/conform :expand/template template)))
-
-(comment
-  (transcribe-transformer scheme-and '(and 1 2)))
-
-(defn transcribe-transformer [trans datum]
-  (some (fn [{:keys [pattern template]}]
-          (when-some [unification (unify* pattern datum)]
-            (let [r (transcribe* unification template)]
-              (assert r)
-              r)))
-        (:rules trans)))

t.scm

@@ -1,4 +1,14 @@
-(define-library (blah)
+(define-library (t)
   (import (primitives+builtins))
   (begin
-    (lambda (x) x)))
+    (let-syntax ((when (syntax-rules ()
+                         ((_ test body ...)
+                          (if test (begin body ...))))))
+      (when #t
+        (display "blah")
+        (newline)))
+    (let ((x 123))
+      (let-syntax ((m (syntax-rules ()
+                        ((_) x))))
+        (lambda (x)
+          (m))))))

test/expand/core_test.clj

@@ -1,8 +1,9 @@
-(ns expand-test
-  (:require [expand :as sut]
-            [clojure.test :as t]
-            [clojure.spec.alpha :as s]
-            [scm]))
+(ns expand.core-test
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.test :as t]
+   [expand.core :as sut]
+   [expand.scm :as scm]))
 
 (t/deftest nearest-test
   (t/is (= '#{#{a b}}

test/expand/scm_test.clj

@@ -1,7 +1,7 @@
-(ns scm-test
-  (:require [scm :as sut]
-            [clojure.test :as t])
-  (:import scm.ISyntax scm.Syntax))
+(ns expand.scm-test
+  (:require [clojure.test :as t]
+            [expand.scm :as sut])
+  (:import (expand.scm ISyntax Syntax)))
 
 (t/deftest read-test
   (t/testing "boolean"
@@ -11,6 +11,7 @@
     (t/is (= false (sut/read "#false"))))
   (t/testing "symbol"
     (t/is (= 'abc (sut/read "abc")))
+    (t/is (= '... (sut/read "...")))
     (t/is (= 'truth-nuke (sut/read "truth-nuke"))))
   (t/testing "list"
     (t/is (= (list) (sut/read "()")))
@@ -63,8 +64,8 @@
   (t/is (= 123 (sut/syntax-e #scm/stx [123 #{}]))))
 
 (t/deftest unresolved?-test
-  (t/is (sut/unresolved? (scm/->Syntax 123 nil)))
+  (t/is (sut/unresolved? (sut/->Syntax 123 nil)))
   (t/is (sut/unresolved? #scm/stx 123)))
 
 (t/deftest resolved?-test
-  (t/is (sut/resolved? (scm/->Syntax 123 '#{a}))))
+  (t/is (sut/resolved? (sut/->Syntax 123 '#{a}))))

test/expand/syntax_rules_test.clj

@@ -2,25 +2,87 @@
   (:require [expand.syntax-rules :as sut]
             [clojure.core.match :refer [match]]
             [clojure.test :as t]
-            [clojure.walk :as walk]))
+            [clojure.walk :as walk]
+            [expand.scm :as scm]))
+
+(defmacro broken-is [form]
+  `(t/is (not ~form)
+         "(expected failure, broken)"))
+
+(defn- pattern-vars [p]
+  (->> p
+       scm/datum->syntax-recursive
+       sut/pattern-vars
+       (map #(if (scm/syntax? %)
+               (scm/syntax-e %)
+               %))
+       (into #{})))
+
+(t/deftest pattern-vars-test
+  (t/testing "no variables"
+    (t/are [x] (= #{} (pattern-vars x))
+      '()
+      '(_ ...)
+      123
+      true
+      '(123 456)
+      '(() ())
+      '(_ (_ _) ... _)))
+  (t/is (= '#{a b c}
+           (pattern-vars '(a b c))))
+  (t/is (= '#{a c}
+           (pattern-vars '(a _ c))))
+  (t/is (= '#{a c}
+           (pattern-vars '(a ... _ c))))
+  (t/is (= '#{a b}
+           (pattern-vars '((a b) ...)))))
 
 (t/deftest unify-test
-  (t/is (= '{x (1 2 3)}
-           (sut/unify* 'x '(1 2 3))))
-  (t/is (= '{x 1 y 2}
-           (sut/unify* '(x y) '(1 2))))
-  (t/is (= '{x [:ellipsis (1 2 3 4)]}
-           (sut/unify* '(x ...) '(1 2 3 4))))
-  (t/is (= '{x [:ellipsis (1 3)]
-             y [:ellipsis (2 4)]}
-           (sut/unify* '((x y) ...) '((1 2) (3 4)))))
-  (t/is (= nil
-           (sut/unify* '(x y z) '(1 2))))
-  (t/is (= nil
-           (sut/unify* '(x y) '(1 2 3))))
-  (t/is (= nil
-           (sut/unify* '((x y) ...)
-                  '((1 2) (1 2 3)))))
+  (t/testing "variable"
+    (t/is (= '{x (1 2 3)}
+             (sut/unify* 'x '(1 2 3)))))
+  (t/testing "wildcard"
+    (t/is (= {}
+             (sut/unify* '_ '(1 2 3))))
+    (t/is (= {}
+             (sut/unify* '(_ _) '(1 2))))
+    (t/is (= nil
+             (sut/unify* '(_ _ _) '(1 2)))))
+  (t/testing "constants"
+    (t/is (= {}
+             (sut/unify* 123 123)))
+    (t/is (= nil
+             (sut/unify* 123 456)))
+    (t/is (= nil
+             (sut/unify* true 456)))
+    (t/is (= {}
+             (sut/unify* true true))))
+  (t/testing "known-length lists"
+    (t/is (= '{x 1 y 2}
+             (sut/unify* '(x y) '(1 2))))
+    (t/is (= nil
+             (sut/unify* '(x y z) '(1 2))))
+    (t/is (= nil
+             (sut/unify* '(x y) '(1 2 3))))
+    (t/is (= '{a 1 b 2 c 3 d 4 e 5}
+             (sut/unify* '((a b) (c d e)) '((1 2) (3 4 5))))))
+  (t/testing "trailing ellipsis"
+    (t/is (= '{x [:ellipsis (1 2 3 4)]}
+             (sut/unify* '(x ...) '(1 2 3 4))))
+    (t/is (= '{x [:ellipsis (1 3)]
+               y [:ellipsis (2 4)]}
+             (sut/unify* '((x y) ...) '((1 2) (3 4)))))
+    (t/is (= nil
+             (sut/unify* '((x y) ...)
+                         '((1 2) (1 2 3)))))
+    (t/testing "ellipsis matches empty list"
+      (t/is (= '{x [:ellipsis ()]}
+               (sut/unify* '(x ...)
+                           '())))
+      (t/is (= '{x [:ellipsis ()]
+                 y [:ellipsis ()]}
+               (sut/unify* '((x y) ...)
+                           '())))))
   (t/is (= '{x (1 2 3)}
            (sut/unify* 'x '(1 2 3))))
   (t/is (= '{x [:ellipsis (1 2 3)]}
@@ -33,7 +95,7 @@
   (t/is (= '{x [:ellipsis (1 3)]
              y [:ellipsis (2 4)]}
            (sut/unify* '((x y) ...)
-                  '((1 2) (3 4))))))
+                       '((1 2) (3 4))))))
 
 (t/deftest transcribe-test
   (t/is (= 123
@@ -41,4 +103,39 @@
   (t/is (= 4
            (sut/transcribe* 'x '(x y) '(4 5))))
   (t/is (= '(3 2 1)
-           (sut/transcribe* '(z y x) '(x y z) '(1 2 3)))))
+           (sut/transcribe* '(z y x) '(x y z) '(1 2 3))))
+  (t/is (= '(1 2 3)
+           (sut/transcribe* '(x ...)
+                            '(x ...)
+                            '(1 2 3))))
+  (t/is (= 123
+           (sut/transcribe* 123
+                            '_
+                            '(1 2 3 4 5))))
+  (t/is (= '(111 3 4 5)
+           (sut/transcribe* '(111 x ...)
+                            '(1 2 x ...)
+                            '(1 2 3 4 5))))
+  (t/is (= '(111 3 4 5 333)
+           (sut/transcribe* '(111 x ... 333)
+                            '(1 2 x ...)
+                            '(1 2 3 4 5))))
+  (t/is (= '(3 4 5 3 4 5)
+           (sut/transcribe* '(x ... x ...)
+                            '(1 2 x ...)
+                            '(1 2 3 4 5))))
+  (t/is (= '(1 3 6)
+           (sut/transcribe* '(x ...)
+                            '((x _ ...) ...)
+                            '((1 2) (3 4 5) (6 7 8 9)))))
+  (t/testing "preservation of lexical context"
+    ;; 나는 테스트를 더 작성하고 싶지만 너무 귀찮을겠다…ㅠㅠ
+    (t/is (= '#{A}
+             (scm/syntax-context
+              (sut/transcribe
+               #scm/stx [(#scm/stx [x #{A}])
+                         #{A}]
+               (sut/unify #scm/stx [(#scm/stx [x #{A}])
+                                    #{A}]
+                          #scm/stx [(#scm/stx [123 #{A}])
+                                    #{A}])))))))

test/old_test.clj

@@ -1,152 +0,0 @@
-(ns old-test
-  (:require
-   [clojure.core.match :refer [match]]
-   [clojure.spec.alpha :as s]
-   [clojure.test :as t]
-   [old :as sut]))
-
-(t/deftest scheme-base-test
-  (t/is (s/valid? ::sut/environment (:env sut/scheme-base)))
-  (t/is (s/valid? ::sut/symtable (:symtable sut/scheme-base))))
-
-(t/deftest nearest-test
-  #_(t/is (= [:primitive 'lambda]
-           (sut/lookup ['lambda #{}]
-                       sut/scheme-base-env
-                       (sut/symtable-for-env sut/scheme-base-env))))
-  (t/is (= [#{0 1}]
-           (sut/nearest ['x #{0 1 2}]
-                        [#{0} #{0 1} #{0 3}]))))
-
-(t/deftest pattern-spec
-  (t/testing "var"
-    (let [pattern-var? #(match (s/conform ::pattern %)
-                          [:var _] true
-                          _ false)]
-      (t/is (pattern-var? 'abc))
-      (t/is (not (pattern-var? '_)))
-      (t/is (not (pattern-var? '...)))))
-  (t/testing "list"
-    (t/are [l e t x] (= [l e t]
-                        ((juxt :leading :ellipsis :trailing)
-                         (s/conform ::pattern x)))
-      nil nil nil '()
-      '(a) nil nil '(a)
-      '(a b) nil nil '(a b)
-      '(a) 'b nil '(a b ...)
-      '(a) 'b '(c) '(a b ... c)
-      '(a) 'b '(c d) '(a b ... c d))
-    (t/are [p] (s/invalid? ::pattern p)
-      '... '(...) '(... a b c)
-      '(a ... b ...)))
-  (t/testing "simple data"
-    (t/is (= 'a (s/conform ::patern 'a)))))
-
-(t/deftest expand-test
-  (t/testing "unbound symbol"
-    (t/is (thrown? Exception (sut/expand 'x))))
-  (t/testing "lambda"
-    (t/is (= '(lambda (x) x)
-             (sut/us-expand '(λ (x) x)))))
-  (t/testing "let-syntax"
-    (t/is (= '(let-syntax ((m (syntax-rules
-                               ()
-                               ((m) 123))))
-                456)
-             (sut/expand
-              '(let-syntax ((m (syntax-rules
-                                ()
-                                ((m) 123))))
-                 456)))))
-  (t/testing "let"
-    (t/is (= '(let ((x 123)
-                    (y 456))
-                (+ x y))
-             (sut/us-expand
-              '(let ((x 123)
-                     (y 456))
-                 (+ x y))))))
-  (t/testing "application"
-    (t/is (= '(lambda (f x) (f x))
-             (sut/us-expand '(lambda (f x) (f x))))))
-  (t/testing "macros"
-    (t/testing "when"
-      (t/is (= '(let ((x 123)) (if x 456))
-               (sut/us-expand '(let ((x 123))
-                                 (when x 456)))))
-      (t/is (= '(let (([body #{s0}] 123))
-                  (if [body #{s0}]
-                    456))
-               (sut/rg-expand '(let ((body 123))
-                                 (when body 456))))
-            "`when` does not clobber caller's scope")
-      (t/is (= '(let (([x #{s0}] 123))
-                  (let-syntax ((m (syntax-rules () ((m) x))))
-                    (lambda ([x #{s1 s2 s0}])
-                            [x #{s0 s3}])))
-               (sut/rg-expand '(let ((x 123))
-                                 (let-syntax ((m (syntax-rules
-                                                  ()
-                                                  ((m) x))))
-                                   (λ (x)
-                                      (m))))))
-            "`when` does not capture caller's scope")
-      (t/is (= '(if 123 (begin (display "hello")
-                               (newline)))
-               (sut/us-expand '(when 123
-                                 (display "hello")
-                                 (newline))))
-            "`when` captures multiple"))))
-
-(t/deftest prim-lambda-spec
-  (t/is (s/valid? ::sut/prim-lambda '(lambda (x) x)))
-  (t/is (s/valid? ::sut/prim-lambda '(lambda (x) (display x) (newline)))))
-
-(t/deftest prim-let-spec
-  (t/is (s/valid? ::sut/prim-let '(let ((x 123)
-                                        (y 456))
-                                    (+ x y)))))
-
-(t/deftest prim-let-syntax-spec
-  (t/is (s/valid? ::sut/prim-let-syntax
-                  '(let-syntax ((m (syntax-rules ()
-                                     ((m) 123))))
-                     (m)))))
-
-(t/deftest template-spec
-  (t/is (s/valid? ::sut/template '(x ... y)))
-  (t/is (s/valid? ::sut/template 123))
-  (t/is (= '[:list [[:var x]
-                    [:ellipsis [:var y]]
-                    [:ellipsis [:var z]]
-                    [:var a]
-                    [:var b]
-                    [:var c]]]
-           (s/conform ::sut/template '(x y ... z ... a b c)))))
-
-(t/deftest pattern-spec
-  (t/is (s/valid? ::sut/pattern '(m))))
-
-(t/deftest rule-spec
-  (t/is (s/valid? ::sut/rule '((m) 123))))
-
-(t/deftest prim-syntax-rules-spec
-  (t/is (s/valid? ::sut/prim-syntax-rules
-                  '(syntax-rules
-                    ()
-                    ((m) 123)))))
-
-(t/deftest unify-test
-  (t/are [result pattern datum] (= result (sut/unify pattern datum))
-    {'a 123 'b 456} '(a b) '(123 456)
-    nil '(a b) 123
-
-    '{b [:ellipsis ([:ellipsis (1 2)] [:ellipsis (3 4)])]}
-    '((b ...) ...)
-    '((1 2) (3 4))
-
-    {} '_ 123)
-  (t/testing "non-matches"
-    (t/are [pattern datum] (= nil (sut/unify pattern datum))
-      '(a b c) '(1 2)
-      '(a b c) '(1 2))))

test/unhygienic_test.clj

@@ -1,30 +0,0 @@
-(ns unhygienic-test
-  (:require [unhygienic :as sut]
-            [clojure.test :as t]))
-
-(t/deftest unify-test
-  (t/are [result pattern datum] (= result (sut/unify pattern datum))
-    {'a 123 'b 456} '(a b) '(123 456)
-    nil '(a b) 123
-
-    '{b [:ellipsis ([:ellipsis (1 2)] [:ellipsis (3 4)])]}
-    '((b ...) ...)
-    '((1 2) (3 4))
-
-    {} '_ 123)
-  (t/testing "non-matches"
-    (t/are [pattern datum] (= nil (sut/unify pattern datum))
-      '(a b c) '(1 2)
-      '(a b c) '(1 2))))
-
-(t/deftest transcribe-test
-  (t/are [result datum pattern template]
-      (= result (sut/transcribe (sut/unify pattern datum) template))
-    '(1 a 2 b) '((1 2) (a b))
-    '((x y) ...) '(x ... y ...)
-
-    '(1 2 3 4) '(1 2 3 4)
-    '(x ...) '(x ...)
-
-    '(concat (1 2) (3 4) (5 6)) '((1 2) (3 4) (5 6))
-    '((a ...) ...) '(concat (a ...) ...)))

u.scm

@@ -0,0 +1,4 @@
+(define-library (t)
+  (import (primitives+builtins))
+  (begin
+    (display "blah")))