src/common.clj

@@ -7,3 +7,29 @@
     `(~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/syntax_rules.clj

@@ -107,19 +107,44 @@
                  (scm/datum->syntax-recursive datum))
           (update-vals scm/syntax->datum)))
 
-(defn transcribe [template unification]
+(defn strip-ellipsis [x depth]
+  (match x
+    [:ellipsis xs]
+    (if (< 0 depth)
+      [:ellipsis (map #(strip-ellipsis % (dec depth)) xs)]
+      (throw (IllegalArgumentException. "점점점은 나쁘다.")))
+    :else (if (zero? depth)
+            x
+            (throw (IllegalArgumentException.
+                    "depth는 영 아니지만 인수에 점점점이 남지 않는다.")))))
+
+(defn- transcribe-rec [template unification depth]
   (match (scm/syntax-e template)
-    (x :guard symbol?) (or (get unification x)
-                           (throw (Exception. "blah")))
+    (_ :guard ellipsis?)
+    (throw (IllegalArgumentException. "점점점은 여기 있으면 안 되다."))
+    (x :guard symbol?)
+    (match (get unification x)
+      [:ellipsis xs] [:ellipsis xs]
+      nil (throw (Exception. "nosymmm"))
+      x-val x-val)
+
+    ([x (_ :guard ellipsis?) & xs] :seq)
+    (match (transcribe-rec x unification depth)
+      [:ellipsis x*] (scm/datum->syntax x* template)
+      :else (throw (IllegalArgumentException. "점점점은 나쁘다ㅠㅠ")))
+
     ([x & xs] :seq)
-    (let [xs* (transcribe (scm/datum->syntax xs template) unification)]
+    (let [xs* (transcribe-rec depth (scm/datum->syntax xs template) unification)]
       (scm/datum->syntax
-       (cons (transcribe x unification) (scm/syntax-e xs*))
+       (cons (transcribe-rec depth x unification) (scm/syntax-e xs*))
        template))
 
     ([] :seq)
     template))
 
+(defn transcribe [template unification]
+  (transcribe-rec template unification 0))
+
 (defn transcribe*
   ([template unification]
    (-> template
@@ -132,10 +157,19 @@
        scm/syntax->datum)))
 
 (comment
-  (let [pattern 'x
-        template 'x
+  (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)))
+        #_scm/syntax->datum))
+  (let [pattern '((x y ...) ...)
+        template '(x ...)
+        datum '((1 2) (3 4 5))]
+    (-> template
+        (transcribe* (unify (scm/datum->syntax-recursive pattern)
+                            (scm/datum->syntax-recursive datum)))
+        #_scm/syntax->datum))
+  (unify* '((x y ...) ...)
+          '((1 2 3) (3 4))))

test/expand/syntax_rules_test.clj

@@ -20,7 +20,7 @@
            (sut/unify* '(x y) '(1 2 3))))
   (t/is (= nil
            (sut/unify* '((x y) ...)
-                  '((1 2) (1 2 3)))))
+                       '((1 2) (1 2 3)))))
   (t/is (= '{x (1 2 3)}
            (sut/unify* 'x '(1 2 3))))
   (t/is (= '{x [:ellipsis (1 2 3)]}
@@ -33,7 +33,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 +41,8 @@
   (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 3 6)
+           (sut/transcribe* '(x ...)
+                             '((x _ ...) ...)
+                             '((1 2) (3 4 5) (6 7 8 9))))))