src/expand.clj

@@ -54,7 +54,7 @@
 (declare variable?)
 
 (s/def ::template
-  (s/or :var variable?
+  (s/or :var ::variable
         :lit ::literal
         :list (s/and (s/* ::template-element) sequential?)))
 
@@ -228,25 +228,63 @@
               (list 'syntax-rules '~kws
                     ~@(map (fn [x] `(quote ~x)) body))))
 
-(def scheme-base-env
-  (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 define-global [env-ref symtable-ref sym denot]
+  (swap! env-ref #(assoc % [:global sym] denot))
+  (swap! symtable-ref #(assoc % [sym #{}] [:global sym])))
+
+(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])))
+
+(def 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
@@ -276,8 +314,8 @@
             (pos? r) (throw (ex-info "ambiguous sym" {:sym sym}))))))
 
 (comment
-  (let [st (atom (symtable-for-env scheme-base-env))]
-    {:e (expand '(lambda (x y) x) scheme-base-env st #{})
+  (let [st (atom (:symtable scheme-base))]
+    {:e (expand '(lambda (x y) x) (:env scheme-base) st #{})
      :st @st}))
 
 (defmulti expand-primitive
@@ -313,14 +351,14 @@
 
 (comment
   (let [scopes #{1}
-        symtab (symtable-for-env scheme-base-env)
-        env scheme-base-env
+        symtab (:symtable scheme-base)
+        env (:env scheme-base)
         {symtab* :symtable env* :env}
         (unify 'x '(1 2 3) env symtab scopes)]
     (lookup ['x #{1}] (merge env env*) (merge symtab symtab*)))
   (let [scopes #{1}
-        env scheme-base-env
-        symtable-ref (atom (symtable-for-env scheme-base-env))]
+        env (:env scheme-base)
+        symtable-ref (atom (:symtable scheme-base-env))]
     (-> (unify '(a b c ...) '(1 2 3 4 5 6))
         (unification->env symtable-ref scopes)))
   (expand '(and 456 123)))
@@ -383,14 +421,14 @@
   (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]
-    (mapcat #(match %
-               [:ellipsis _] (todo "점점점")
-               :else [(transcribe % env symtable scopes)])
-            xs)))
+    (do (tap> xs)
+        (map #(transcribe % env symtable scopes) xs))))
 
 (defn resolve-template [template scopes]
   (clojure.walk/postwalk
@@ -475,8 +513,8 @@
     (cons 'begin (map #(expand % env symtable-ref scopes) body))))
 
 (comment
-  (let [env scheme-base-env
-        [_ trans] (get scheme-base-env [:global 'and])
+  (let [env (:env scheme-base-env)
+        [_ trans] (get env [:global 'and])
         datum '(and 12 34)
         symtable-ref (atom (symtable-for-env env))
         scopes #{1}]
@@ -501,7 +539,7 @@
 (defn expand
   ([datum]
    (expand
-    datum scheme-base-env (atom (symtable-for-env scheme-base-env)) #{}))
+    datum (:env scheme-base) (atom (:symtable scheme-base)) #{}))
   ([datum env symtable-ref scopes]
    (match datum
      ;; literals

test/expand_test.clj

@@ -5,11 +5,9 @@
    [clojure.test :as t]
    [expand :as sut]))
 
-(t/deftest scheme-base-env-test
-  (t/is (s/valid? ::sut/environment sut/scheme-base-env)))
-
-(t/deftest symtable-for-env-test
-  (t/is (s/valid? ::sut/symtable (sut/symtable-for-env sut/scheme-base-env))))
+(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]
@@ -93,7 +91,7 @@
                                    (λ (x)
                                       (m))))))
             "`when` does not capture caller's scope")
-      #_(t/is (= '(if 123 (begin (display "hello")
+      (t/is (= '(if 123 (begin (display "hello")
                                (newline)))
                (sut/us-expand '(when 123
                                  (display "hello")