From 8d06aa58d580037611f8651d4c15299128c9e79e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Mon, 21 Sep 2026 06:08:08 -0600 Subject: [PATCH] --- src/expand.clj | 104 +++++++++++++++++++++++++++++-------------- test/expand_test.clj | 10 ++--- 2 files changed, 75 insertions(+), 39 deletions(-) diff --git a/src/expand.clj b/src/expand.clj index 041686a..13d00ae 100644 --- a/src/expand.clj +++ b/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 diff --git a/test/expand_test.clj b/test/expand_test.clj index e883360..fc591d7 100644 --- a/test/expand_test.clj +++ b/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")