From 83e042fb81a09dd7f71e9ae54bf5747a0cfbdbf0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Wed, 23 Sep 2026 16:25:33 -0600 Subject: [PATCH] --- src/expand.clj | 8 +++++ src/expand/syntax_rules.clj | 69 +++++++++++++++++++++++++++++++++++++ src/scm.clj | 21 +++++++++-- 3 files changed, 95 insertions(+), 3 deletions(-) create mode 100644 src/expand/syntax_rules.clj diff --git a/src/expand.clj b/src/expand.clj index a90eb9a..e7c80d1 100644 --- a/src/expand.clj +++ b/src/expand.clj @@ -232,6 +232,14 @@ (for [x [condition consequent alternative]] (expand x env store-atom))))) +(defmethod expand-primitive 'let-syntax + [stx _ env store-atom] + (let [_ (s/conform ::prim-let-syntax stx)])) + +(defmethod expand-primitive 'syntax-rules + [stx _ env store-atom] + (let [_ (s/conform ::prim-syntax-rules stx)])) + (defn expand ([stx] (let [scopeholder (scm/new-scopeholder) diff --git a/src/expand/syntax_rules.clj b/src/expand/syntax_rules.clj new file mode 100644 index 0000000..c816015 --- /dev/null +++ b/src/expand/syntax_rules.clj @@ -0,0 +1,69 @@ +(ns expand.syntax-rules) + +(defn- report-conflict [x y] + (throw (ex-info "너무 정의합니다" + {:x x :y y}))) + +(defn- merge-unify-with + ([f] {}) + ([f a] a) + ([f a b] (and a b (merge-with f a b))) + ([f a b & xs] (reduce #(merge-unify-with f %1 %2) (cons a (cons b xs))))) + +(defn- merge-unify [& xs] + (apply merge-unify-with report-conflict xs)) + +(defn- unify* [pattern datum] + (match [pattern datum] + [[:wildcard _] _] {} + [[:var x] _] {x datum} + + [[:list {:leading leading + :trailing nil + :ellipsis ellipsis}] + (_ :guard seq?)] + (let [[leading-datum ellipsis-datum] (split-at (count leading) datum)] + (merge-unify + (apply merge-unify (map #(unify* %1 %2) + leading + leading-datum)) + (some->> ellipsis-datum + (map #(some-> (unify* ellipsis %) + (update-vals list))) + (apply merge-unify-with concat) + (map (fn [[k v]] + [k [:ellipsis v]])) + (into {})))) + + [[:list {:leading leading}] + (_ :guard seq?)] + (when (= (count datum) + (count leading)) + (->> (map #(unify* %1 %2) leading datum) + (apply merge-unify))) + + ;; no match + :else nil)) + +(defn unify [pattern datum] + (unify* (s/conform ::pattern pattern) datum)) + +(defn transcribe [template env symtable scopes] + (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] + (do (tap> xs) + (map #(transcribe % env symtable scopes) xs)))) + +(defn resolve-template [template scopes] + (clojure.walk/postwalk + #(if (variable? %) + (offer-scopes % scopes) + %) + template)) diff --git a/src/scm.clj b/src/scm.clj index 8b2d4a1..0e041de 100644 --- a/src/scm.clj +++ b/src/scm.clj @@ -5,7 +5,7 @@ [clojure.pprint] [instaparse.core :as insta] [clojure.spec.alpha :as s]) - (:import (clojure.lang ILookup))) + (:import (clojure.lang ILookup IReduce IReduceInit))) ;;; syntax objects @@ -18,7 +18,8 @@ (satisfies? ISyntax x)) (deftype Syntax [datum ctx] - :load-ns true ; 왜? + ;; 여기 이것은 왜 있으냐? + :load-ns true Object (equals [x y] (or (identical? x y) @@ -27,7 +28,15 @@ (.equals ctx (syntax-context y))))) scm/ISyntax (syntax-e [this] datum) - (syntax-context [this] ctx)) + (syntax-context [this] ctx) + clojure.lang.Seqable + (seq [_] (seq {:datum datum + :ctx ctx})) + clojure.lang.IPersistentCollection + (count [_] 2) + (cons [this o] (cons o (seq this))) + ;; 진짜 나쁘다ㅋㅋㅋㅋ. 이러니까 `clojure.walk/walk`로 쓰다. + clojure.lang.IRecord) (defn unresolved? [stx] ;; 지금, 콘텍스트 필드가 비어 있은 신택스 옵제크트들이 @@ -238,10 +247,16 @@ (string? x) (boolean? x))) +(defn macro? [x] + (match x + [:macro f] (fn? x) + :else false)) + (defn datum? [x] (or (number? x) (boolean? x) (string? x) + (macro? x) (list? x) (symbol? x) (improper-list? x)