oh my god we did it lol

src/expand/core.clj

@@ -132,7 +132,12 @@
          (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
@@ -200,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)]
@@ -219,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]
@@ -237,20 +245,35 @@
 (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 [{:keys [bindings body]} (conform! ::prim-let-syntax stx)]
-    (assert (list? bindings))
-    (assert (list? body))
+    (assert (sequential? bindings))
+    (assert (sequential? body))
     (let [bindings* (for [{:keys [rhs lhs]} bindings]
                       {:rhs rhs
-                       :lhs (expand lhs env store-atom)})]
+                       :lhs (-> (scm/rescope lhs stx)
+                                (expand env store-atom))})]
       (binding-form
        stx env store-atom
        (for [{:keys [rhs lhs]} bindings*]
@@ -261,16 +284,23 @@
        (fn [scopeholder env*]
          (concat (list 'let-syntax
                        (for [{:keys [rhs lhs]} bindings*]
-                         (list (scm/rescope rhs scopeholder) lhs)))))))))
+                         (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 [trans (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 %)]
+             r (syntax-rules/invoke % trans intro lf)]
          (assert r "맞은 패턴은 찾을 수 없었다")
          r)]
      stx)))
@@ -284,6 +314,7 @@
              env store-atom)))
   ([stx env store-atom]
    (match (scm/syntax-e stx)
+     [:primitive _] stx
      (_ :guard (some-fn scm/macro? scm/constant?)) stx
      (_ :guard symbol?)
      (do (lookup stx env @store-atom) ; throw if unbound
@@ -295,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))))))
@@ -376,9 +412,7 @@
       expand-library
       library-syntax->datum
       library->datum
-      #_#_#_(nth 3)
-      (nth 1)
-      scm/macro?)
+      clojure.pprint/pprint)
   (let [scopeholder (scm/new-scopeholder)
         env {[:global 'lambda] [:primitive 'lambda]}
         store-atom (atom {['lambda #{}] [:global 'lambda]})]

src/expand/scm.clj

@@ -45,9 +45,6 @@
   ;; 진짜 나쁘다ㅋㅋㅋㅋ. 이러니까 `clojure.walk/walk`로 쓰다.
   clojure.lang.IRecord)
 
-(defn ->syntax [datum ctxt]
-  (->Syntax datum ctxt))
-
 (defn unresolved? [stx]
   ;; 지금, 콘텍스트 필드가 비어 있은 신택스 옵제크트들이
   ;; `::unresolved`로 한상 표한다. 왜냐하면 빈 집합(#{})은 이미 써서
@@ -294,7 +291,7 @@
   (or (number? x)
       (boolean? x)
       (string? x)
-      (list? x)
+      (seq? x)
       (symbol? x)
       (improper-list? x)
       (and (syntax? x) (-> x syntax-e datum?))))

src/expand/syntax_rules.clj

@@ -91,35 +91,39 @@
                  (scm/datum->syntax-recursive datum))
           (update-vals scm/syntax->datum)))
 
-(defn transcribe [template unification]
-  (match (scm/syntax-e template)
-    (_ :guard ellipsis?)
-    (throw (IllegalArgumentException. "점점점은 여기 있으면 안 되다."))
+(defn transcribe
+  ([template unification]
+   (match (scm/syntax-e template)
+     (_ :guard ellipsis?)
+     (throw (IllegalArgumentException. "점점점은 여기 있으면 안 되다."))
 
-    (x :guard symbol?)
-    (or (get unification x)
-        (throw (Exception. "nosymmm")))
+     (x :guard symbol?)
+     (or (get unification x)
+         template
+         #_(throw (Exception. "nosymmm")))
 
-    (_ :guard scm/constant?)
-    template
+     (_ :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 (_ :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 x unification) (scm/syntax-e xs*))
-       template))
+     ([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))
+     ([] :seq)
+     template)))
 
 (defn transcribe*
   ([template unification]
@@ -132,9 +136,11 @@
                           (scm/datum->syntax-recursive datum)))
        scm/syntax->datum)))
 
-(defn invoke [syntax-rules datum]
+(defn invoke [datum syntax-rules scopeholder lookup]
   (let [{:keys [rules keywords]} syntax-rules]
-    (some (fn [[pattern template]]
-            (some->> (unify pattern datum)
-                     (transcribe template)))
+    (some (fn [rule]
+            (let [[pattern template] (scm/syntax-e rule)]
+              (when-let [unif (unify pattern datum)]
+                (transcribe (scm/rescope template scopeholder)
+                            unif))))
           rules)))

t.scm

@@ -1,6 +1,8 @@
-(define-library (blah)
+(define-library (t)
   (import (primitives+builtins))
   (begin
-    (syntax-rules ()
-      ((_ test body ...)
-       (if test (begin body ...))))))
+    (let-syntax ((when (syntax-rules ()
+                         ((_ test body ...)
+                          (if test (begin body ...))))))
+      (when #t
+        (display "blah")))))

u.scm

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