src/expand.clj

@@ -232,6 +232,14 @@
           (for [x [condition consequent alternative]]
             (expand x env store-atom)))))
 
+(defmethod expand-primitive 'let-syntax
+  [stx _ env store-atom]
+  (let [_ (s/conform ::prim-let-syntax stx)]))
+
+(defmethod expand-primitive 'syntax-rules
+  [stx _ env store-atom]
+  (let [_ (s/conform ::prim-syntax-rules stx)]))
+
 (defn expand
   ([stx]
    (let [scopeholder (scm/new-scopeholder)

src/expand/syntax_rules.clj

@@ -0,0 +1,69 @@
+(ns expand.syntax-rules)
+
+(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 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))

src/scm.clj

@@ -5,7 +5,7 @@
             [clojure.pprint]
             [instaparse.core :as insta]
             [clojure.spec.alpha :as s])
-  (:import (clojure.lang ILookup)))
+  (:import (clojure.lang ILookup IReduce IReduceInit)))
 
 
 ;;; syntax objects
@@ -18,7 +18,8 @@
   (satisfies? ISyntax x))
 
 (deftype Syntax [datum ctx]
-  :load-ns true ; 왜?
+  ;; 여기 이것은 왜 있으냐?
+  :load-ns true
   Object
   (equals [x y]
     (or (identical? x y)
@@ -27,7 +28,15 @@
              (.equals ctx (syntax-context y)))))
   scm/ISyntax
   (syntax-e [this] datum)
-  (syntax-context [this] ctx))
+  (syntax-context [this] ctx)
+  clojure.lang.Seqable
+  (seq [_] (seq {:datum datum
+                 :ctx ctx}))
+  clojure.lang.IPersistentCollection
+  (count [_] 2)
+  (cons [this o] (cons o (seq this)))
+  ;; 진짜 나쁘다ㅋㅋㅋㅋ. 이러니까 `clojure.walk/walk`로 쓰다.
+  clojure.lang.IRecord)
 
 (defn unresolved? [stx]
   ;; 지금, 콘텍스트 필드가 비어 있은 신택스 옵제크트들이
@@ -238,10 +247,16 @@
       (string? x)
       (boolean? x)))
 
+(defn macro? [x]
+  (match x
+    [:macro f] (fn? x)
+    :else false))
+
 (defn datum? [x]
   (or (number? x)
       (boolean? x)
       (string? x)
+      (macro? x)
       (list? x)
       (symbol? x)
       (improper-list? x)