From cf3188eafaa54f174fd0b88791d84fc740dad8b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Thu, 24 Sep 2026 11:59:09 -0600 Subject: [PATCH] oh my god we did it lol --- src/expand/core.clj | 70 +++++++++++++++++++++++++++---------- src/expand/scm.clj | 5 +-- src/expand/syntax_rules.clj | 62 +++++++++++++++++--------------- t.scm | 10 +++--- u.scm | 4 +++ 5 files changed, 97 insertions(+), 54 deletions(-) create mode 100644 u.scm diff --git a/src/expand/core.clj b/src/expand/core.clj index 7c0cde5..230acf6 100644 --- a/src/expand/core.clj +++ b/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]})] diff --git a/src/expand/scm.clj b/src/expand/scm.clj index 34eba5e..3d9dd63 100644 --- a/src/expand/scm.clj +++ b/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?)))) diff --git a/src/expand/syntax_rules.clj b/src/expand/syntax_rules.clj index fb4bdec..4039f96 100644 --- a/src/expand/syntax_rules.clj +++ b/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))) diff --git a/t.scm b/t.scm index 280d79f..4958c82 100644 --- a/t.scm +++ b/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"))))) diff --git a/u.scm b/u.scm new file mode 100644 index 0000000..639f526 --- /dev/null +++ b/u.scm @@ -0,0 +1,4 @@ +(define-library (t) + (import (primitives+builtins)) + (begin + (display "blah")))