src/expand/core.clj

@@ -10,6 +10,12 @@
             [expand.syntax-rules :as syntax-rules]
             [spec-dict.main :refer [dict]]))
 
+(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?)
 
 (s/def ::binding
@@ -109,7 +115,17 @@
                         :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
@@ -120,10 +136,11 @@
 
 ;; 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 +165,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 +187,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)])
@@ -242,7 +247,15 @@
 
 (defmethod expand-primitive 'syntax-rules
   [stx _ env store-atom]
-  (let [_ (s/conform ::prim-syntax-rules stx)]))
+  (let [trans (conform! ::prim-syntax-rules stx)]
+    (dbg> trans)
+    (dbg> (scm/datum->syntax
+           [:macro
+            #(let [intro (scm/new-scopeholder stx)
+                   r (syntax-rules/invoke trans %)]
+               (assert r "맞은 패턴은 찾을 수 없었다")
+               r)]
+           stx))))
 
 (defn expand
   ([stx]
@@ -252,9 +265,8 @@
      (expand (scm/rescope stx scopeholder)
              env store-atom)))
   ([stx env store-atom]
-   (tap> (inherit stx))
    (match (scm/syntax-e stx)
-     (_ :guard scm/constant?) stx
+     (_ :guard (some-fn scm/macro? scm/constant?)) stx
      (_ :guard symbol?)
      (do (lookup stx env @store-atom) ; throw if unbound
          stx)
@@ -329,16 +341,16 @@
                 :else decl)))))
 
 (comment
-  (-> "t.expand.scm"
+  (-> "t.scm"
       slurp
-      (scm/read-syntax :library? true)
+      (scm/read-syntax :library? true :throw? true)
       expand-library
       library-syntax->datum
       library->datum)
   (let [scopeholder (scm/new-scopeholder)
         env {[:global 'lambda] [:primitive 'lambda]}
         store-atom (atom {['lambda #{}] [:global 'lambda]})]
-    (expand (-> (slurp "t.expand.scm")
+    (expand (-> (slurp "t.scm")
                 (scm/read-syntax #_#_:library? true)
                 (scm/rescope scopeholder))
             env store-atom)))

src/expand/scm.clj

@@ -27,6 +27,9 @@
         (and (satisfies? ISyntax y)
              (.equals datum (syntax-e y))
              (.equals ctx (syntax-context y)))))
+  clojure.lang.IMeta
+  (meta [this]
+    {:type (class this)})
   expand.scm/ISyntax
   (syntax-e [this] datum)
   (syntax-context [this] ctx)
@@ -42,6 +45,9 @@
   ;; 진짜 나쁘다ㅋㅋㅋㅋ. 이러니까 `clojure.walk/walk`로 쓰다.
   clojure.lang.IRecord)
 
+(defn ->syntax [datum ctxt]
+  (->Syntax datum ctxt))
+
 (defn unresolved? [stx]
   ;; 지금, 콘텍스트 필드가 비어 있은 신택스 옵제크트들이
   ;; `::unresolved`로 한상 표한다. 왜냐하면 빈 집합(#{})은 이미 써서
@@ -192,7 +198,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]
@@ -276,8 +283,12 @@
   (or (number? x)
       (boolean? x)
       (string? x)
-      (macro? x)
       (list? 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,12 +1,11 @@
 (ns expand.syntax-rules
-  (:require
-   [clojure.core.match :refer [match]]
-   [clojure.spec.alpha :as s]
-   [clojure.test :as t]
-   [clojure.walk :as walk]
-   [expand.common :refer :all]
-   [expand.scm :as scm]
-   [spec-dict.main :refer [dict]]))
+  (:require [clojure.core.match :refer [match]]
+            [clojure.spec.alpha :as s]
+            [clojure.test :as t]
+            [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?)
@@ -132,3 +131,10 @@
                    (unify (scm/datum->syntax-recursive pattern)
                           (scm/datum->syntax-recursive datum)))
        scm/syntax->datum)))
+
+(defn invoke [syntax-rules datum]
+  (let [{:keys [rules keywords]} syntax-rules]
+    (some (fn [[pattern template]]
+            (some->> (unify pattern datum)
+                     (transcribe template)))
+          rules)))