From cecbb1b183bfa3b69e18cf6e6ed04d4fedfa2f00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Mon, 21 Sep 2026 06:09:03 -0600 Subject: [PATCH] expand2 --- deps.edn | 3 +- src/data_readers.clj | 1 + src/expand.clj | 616 +++---------------------- src/old.clj | 593 ++++++++++++++++++++++++ src/r7rs.ebnf | 19 + src/scm.clj | 63 +++ test/{expand_test.clj => old_test.clj} | 6 +- 7 files changed, 735 insertions(+), 566 deletions(-) create mode 100644 src/data_readers.clj create mode 100644 src/old.clj create mode 100644 src/r7rs.ebnf create mode 100644 src/scm.clj rename test/{expand_test.clj => old_test.clj} (98%) diff --git a/deps.edn b/deps.edn index 45bd11e..63fc463 100644 --- a/deps.edn +++ b/deps.edn @@ -7,7 +7,8 @@ org.clojure/data.csv {:mvn/version "1.1.1"} com.rpl/specter {:mvn/version "1.1.6"} io.github.msyds/spec-dict - {:git/sha "531d629b7f05f37232261cf9e8927a4b5915714f"}} + {:git/sha "531d629b7f05f37232261cf9e8927a4b5915714f"} + instaparse/instaparse {:mvn/version "1.5.0"}} :paths ["src" "resources" "test"] :aliases {:test {:extra-deps {lambdaisland/kaocha {:mvn/version "1.91.1392"}} diff --git a/src/data_readers.clj b/src/data_readers.clj new file mode 100644 index 0000000..89545d7 --- /dev/null +++ b/src/data_readers.clj @@ -0,0 +1 @@ +{scm/stx scm/stx-reader} diff --git a/src/expand.clj b/src/expand.clj index 13d00ae..37cc8d4 100644 --- a/src/expand.clj +++ b/src/expand.clj @@ -1,80 +1,40 @@ (ns expand - (:require - [clojure.core.match :refer [match]] - [clojure.pprint :as pprint] - [clojure.set :as set] - [clojure.spec.alpha :as s] - [clojure.walk] - [spec-dict.main :refer [dict]])) + (:require [clojure.core.match :refer [match]] + [clojure.pprint] + [clojure.set :as set] + [clojure.spec.alpha :as s] + [clojure.walk] + [spec-dict.main :refer [dict]] + [scm])) -(defmacro todo - ([] `(throw (ex-info "todo" {}))) - ([fmt & xs] - `(throw (ex-info (format (str "todo: " ~fmt) ~@xs) - {})))) - -(def primitives - '#{let let-syntax letrec lambda syntax-rules if define - define-syntax begin}) - -(def builtins - '#{+ * / - car cdr write display newline cons list}) +(s/def ::scope symbol?) (s/def ::binding #(match % [:lexical sym uniq] (and (symbol? sym) (symbol? uniq)) [:global sym] (symbol? sym))) -(s/def ::pattern - (s/or :wildcard #{'_} - :var (s/and symbol? (complement #{'... '_})) - :lit ::literal - :list (s/and seq? - (s/cat :leading (s/* ::pattern) - :rest (s/? (s/cat :ellipsis #{'...} - :trailing (s/* ::pattern)))) - (s/conformer - (fn [pat] - (if-some [{:keys [ellipsis trailing]} (:rest pat)] - (let [{:keys [leading]} pat] - (if-some [variadic (last leading)] - {:leading (vec (butlast leading)) - :ellipsis variadic - :trailing trailing} - ::s/invalid)) - pat)))))) +(s/def ::context (s/coll-of ::scope :kind set?)) -(s/def ::literal (some-fn string? boolean? number? char?)) +;; this is an inefficient representation. since we often want to +;; compute the submap of entries with a symbol 'x' but any scope, it +;; would be best to 'curry' the map, as Symbol → Scopes → +;; Binding. however, this is a bit more error-prone and cumbersome for +;; a prototype. +(s/def ::store + (s/map-of (s/tuple symbol? (s/coll-of ::scope :kind set?)) + ::binding)) -(defn literal? [x] - (s/valid? ::literal x)) +(def primitives + "A set of symbols to be defined as primitive syntax exposed by + (scheme base)." + '#{let let-syntax letrec lambda syntax-rules if define + define-syntax begin}) -(s/def ::datum any?) - -(declare variable?) - -(s/def ::template - (s/or :var ::variable - :lit ::literal - :list (s/and (s/* ::template-element) sequential?))) - -(s/def ::template-element - (s/& (s/cat :template ::template :ellipsis (s/? #{'...})) - (s/conformer - (fn [{:keys [ellipsis template]}] - (if ellipsis - [:ellipsis template] - template))))) - -(s/def ::rule - (s/and sequential? - (s/cat :pattern ::pattern - :template ::template))) - -;; cf. `::prim-syntax-rules` -(s/def ::transformer - (dict {:rules (s/coll-of ::rule :kind sequential?)} - ^:opt {:keywords (s/coll-of symbol?)})) +(def builtins + "A set of symbols to be defined as variables exposed by (scheme + base)." + '#{+ * / - car cdr write display newline cons list}) (s/def ::denotation #(match % @@ -87,518 +47,50 @@ (s/def ::environment (s/map-of ::binding ::denotation)) -(s/def ::scope symbol?) +(s/def ::syntax scm/syntax?) -(s/def ::scope-set (s/coll-of ::scope :kind set?)) +(s/def ::identifier + (s/and ::syntax + #(symbol? (scm/stx-datum %)))) -;; this is an inefficient representation. since we often want to -;; compute the submap of entries with a symbol 'x' but any scope, it -;; would be best to 'curry' the table, as Symbol → Scopes → -;; Binding. however, this is a bit more error-prone and cumbersome for -;; a prototype. -(s/def ::symtable - (s/map-of (s/tuple symbol? (s/coll-of ::scope :kind set?)) - ::binding)) +(s/fdef expand + :args (s/cat :syntax ::syntax + :env ::environment + :store ::store) + :ret ::syntax) -(s/def ::formals - (s/coll-of symbol? :kind sequential?)) - -(s/def ::body - (s/+ any?)) - -(declare destructure-variable) - -(defprotocol IVariable - (variable-symbol [this]) - (variable-scopes [this])) - -(deftype Variable [symbol scopes] - Object - (equals [x y] - (if-some [[y-symbol y-scopes] (destructure-variable y)] - (and (.equals symbol y-symbol) - (.equals scopes y-scopes)) - false)) - IVariable - (variable-symbol [this] symbol) - (variable-scopes [this] scopes)) - -(def ^:dynamic *print-variable-scopes* true) - -;; does not respect `*print-dup*` lol -(defmethod print-method Variable [this writer] - (binding [*out* writer] - (if *print-variable-scopes* - (pr [(variable-symbol this) (variable-scopes this)]) - (pr (variable-symbol this))))) - -(defmethod clojure.pprint/simple-dispatch expand.Variable [x] - (clojure.pprint/simple-dispatch - (if *print-variable-scopes* - [(variable-symbol x) (variable-scopes x)] - (variable-symbol x)))) - -(s/def ::variable - (s/conformer - (fn [x] - (match x - (_ :guard symbol?) (->Variable x nil) - (_ :guard #(instance? Variable %)) - (if (symbol? (variable-symbol x)) - (let [r (s/conform ::scope-set (variable-scopes x))] - (if (s/invalid? r) - ::s/invalid - (->Variable (variable-symbol x) (variable-scopes x)))) - ::s/invalid) - [sym scopes] (let [r (s/conform (s/nilable ::scope-set) scopes)] - (if (and (symbol? sym) (not (s/invalid? r))) - (->Variable sym r) - ::s/invalid)) - :else ::s/invalid)))) - -(defn variable? [x] - (s/valid? ::variable x)) - -(defn normalise-variale [v] - (let [r (s/conform ::variable v)] - (when-not (s/invalid? r) - r))) - -(defn destructure-variable [v] - (let [r (s/conform ::variable v)] - (when-not (s/invalid? r) - [(variable-symbol r) (variable-scopes r)]))) - -#_ -(defn variable-scopes [v] - (when-some [[_ scopes] (destructure-variable v)] - scopes)) - -#_ -(defn variable-symbol [v] - (when-some [[s _] (destructure-variable v)] - s)) - -(defn offer-scopes - "variable v는 안 resolve되면 v와 scopes는 붙음." - [v scopes] - (let [[sym existing-scopes] (destructure-variable v)] - (->Variable sym (or existing-scopes scopes)))) - -(s/def ::prim-lambda - (s/cat :keyword ::variable - :formals ::formals - :body ::body)) - -(s/def ::prim-let - (s/cat :keyword ::variable - :bindings (s/coll-of #(and (sequential? %) - (= 2 (count %)) - (symbol? (first %))) - :kind sequential?) - :body ::body)) - -(s/def ::prim-let-syntax ::prim-let) - -;; cf. `::transformer` -(s/def ::prim-syntax-rules - (s/and seq? (s/cat :keyword ::variable - :keywords (s/coll-of symbol?) - :rules (s/* ::rule)))) - -(s/def ::prim-if - (s/and seq? (s/cat :keyword ::variable - :condition ::datum - :consequent ::datum - :alternative (s/? ::datum)))) - -(s/def ::prim-begin - (s/and seq? (s/cat :keyword ::variable - :body (s/+ ::datum)))) +(s/fdef lookup + :args (s/cat :ident ::identifier + :env ::environment + :store ::store)) -(defn symtable-for-env [env] - (into (hash-map) - (for [[[_ x] _] env] - [[x #{}] [:global x]]))) +(defn- store-scopes + "Gather the set of scope-sets associated with a given symbol." + [store sym] + (into #{} (for [[[x scopes] _] store + :when (= sym x)] + scopes))) -(defmacro meta-syntax-rules [kws & body] - `(s/conform ::prim-syntax-rules - (list 'syntax-rules '~kws - ~@(map (fn [x] `(quote ~x)) body)))) - -(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] +(defn nearest [ctx ss] (when-some [xs (->> ss - (filter #(set/subset? % scopes)) + (filter #(set/subset? % ctx)) (group-by count) seq)] (second (apply max-key first xs)))) -(defn- symtable-scopes - "Gather the set of scope-sets associated with a given symbol." - [symtable sym] - (into #{} (for [[[x scopes] _] symtable - :when (= sym x)] - scopes))) - -(defn lookup [variable env symtable] - (let [[sym scopes] (or (destructure-variable variable) - (throw (ex-info "not a var" {:var variable}))) - ss (symtable-scopes symtable sym)] - (let [xs (nearest [sym scopes] ss) +(defn lookup [ident env store] + (let [sym (scm/stx-datum ident) + scopes (scm/stx-context ident) + ss (store-scopes store sym)] + (let [xs (nearest scopes ss) r (compare (count xs) 1)] (cond (neg? r) (throw (ex-info "undefined sym" {:sym sym})) (zero? r) - (or (get env (or (get symtable [sym (first xs)]) + (or (get env (or (get store [sym (first xs)]) (throw (ex-info "unreachable" {})))) (throw (ex-info "unreachable" {}))) (pos? r) (throw (ex-info "ambiguous sym" {:sym sym})))))) -(comment - (let [st (atom (:symtable scheme-base))] - {:e (expand '(lambda (x y) x) (:env scheme-base) st #{}) - :st @st})) - -(defmulti expand-primitive - (fn [_datum prim-name _env _symtable-ref _scopes] - prim-name)) - -(defn new-scope - ([] (gensym "scope__")) - ([prefix] (gensym (str "scope__" prefix)))) - -(defn bind-lexical [[sym scopes] denot symtable-ref] - (let [bind [:lexical sym (gensym)]] - (swap! symtable-ref #(assoc % [sym scopes] bind)) - {bind denot})) - -(defn make-symtable [[sym scopes] bind] - {[sym scopes] bind}) - - - -(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)) - -(comment - (let [scopes #{1} - 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 (: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))) - -(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 :expand/pattern pattern) datum)) - -(defn unification->env [unification symtable-ref scopes] - (into {} - (doall (for [[k v] unification] - (bind-lexical [k scopes] [:syntax v] - symtable-ref))))) - -(defn unify-trans - "`unify`로 모든 trans의 패턴은 datum을 맞음. datum으로 맞은 패턴은 - 없으면 nil을 결과할 것입나다. - - 걸과의 모습은 [rule unification]입니다. 여기서 rule이 최초 맞은 - trans의 rule이고, unification이 `unify`의 결과입니다." - [trans datum] - (some (fn [{:keys [pattern template] - :as rule}] - (when-some [unif (unify* pattern datum)] - [rule unif])) - (:rules trans))) - -(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)) - - -;;; expand - -(declare expand) - -(defmethod expand-primitive 'lambda - [datum _ env symtable-ref scopes] - (let [{:keys [formals body]} (s/conform ::prim-lambda datum) - scopes* (conj scopes (new-scope)) - env* (apply merge env - (for [x formals] - (bind-lexical [x scopes*] - [:var] symtable-ref)))] - (concat (list 'lambda - (for [x formals] - (offer-scopes x scopes*))) - (for [e body] - (expand e env* symtable-ref scopes*))))) - -(defmethod expand-primitive 'let - [datum _ env symtable-ref scopes] - (let [{:keys [bindings body]} (s/conform ::prim-let datum) - scopes* (conj scopes (new-scope)) - env* (apply merge env - (for [[x _] bindings] - (bind-lexical [x scopes*] - [:var] symtable-ref)))] - (concat (list 'let - (for [[k v] bindings] - (list (offer-scopes k scopes*) v))) - (for [e body] - (expand e env* symtable-ref scopes*))))) - -(defmethod expand-primitive 'let-syntax - [datum _ env symtable-ref scopes] - (let [{:keys [bindings body]} (s/conform ::prim-let-syntax datum) - scopes* (conj scopes (new-scope)) - env* (apply merge env - (for [[x rhs] bindings] - (let [trans (->> (expand rhs env symtable-ref scopes) - (s/conform ::prim-syntax-rules))] - (assert (not (s/invalid? trans))) - (bind-lexical - [x scopes*] - [:macro trans] - symtable-ref))))] - (concat (list 'let-syntax bindings) - (for [e body] - (expand e env* symtable-ref scopes*))))) - -(defmethod expand-primitive 'syntax-rules - [datum _ env symtable-ref scopes] - (assert (s/valid? ::prim-syntax-rules datum)) - (let [scopes* (conj scopes (new-scope)) - keywords (nth datum 1) - rules (nthrest datum 2)] - (concat (list 'syntax-rules - keywords) - (for [[pattern template] rules] - (list pattern (resolve-template template scopes*)))))) - -(defmethod expand-primitive 'if - [datum _ env symtable-ref scopes] - (let [{:keys [condition consequent alternative]} - (s/conform ::prim-if datum) - ex #(expand % env symtable-ref scopes)] - (concat (list 'if (ex condition) - (ex consequent)) - (some-> alternative ex)))) - -(defmethod expand-primitive 'begin - [datum _ env symtable-ref scopes] - (let [{:keys [body]} (s/conform ::prim-begin datum)] - (cons 'begin (map #(expand % env symtable-ref scopes) body)))) - -(comment - (let [env (:env scheme-base-env) - [_ trans] (get env [:global 'and]) - datum '(and 12 34) - symtable-ref (atom (symtable-for-env env)) - scopes #{1}] - (expand-macro - trans datum - env symtable-ref scopes))) - -(defn expand-macro [trans datum env symtable-ref scopes] - (let [[rule unif] - (-> (unify-trans trans datum) - (or (throw - (ex-info - "데이텀을 맞은 패턴은 찾을 수 없었습니다" - {:trans trans :datum datum})))) - scopes* (conj scopes (new-scope)) - env* (merge env (unification->env unif symtable-ref scopes*))] - (expand (transcribe (:template rule) env* @symtable-ref scopes*) - env ;; 아마도 `env*`를 써야 되고 `env`를 안 써야 될까? - symtable-ref - scopes))) - -(defn expand - ([datum] - (expand - datum (:env scheme-base) (atom (:symtable scheme-base)) #{})) - ([datum env symtable-ref scopes] - (match datum - ;; literals - (x :guard literal?) x - ;; variables (both resolved and unresolved) - (x :guard variable?) - (let [x* (offer-scopes x scopes)] - (lookup x* env @symtable-ref) ; throw if unbound - x*) - - ;; lists - ([f & xs] :seq) - (or (when-let [v (and (variable? f) - (offer-scopes f scopes))] - (match (lookup v env @symtable-ref) - [:primitive prim] (expand-primitive - datum prim env symtable-ref scopes) - [:macro trans] (expand-macro trans datum env symtable-ref scopes) - [:var] nil)) - (cons (expand f env symtable-ref scopes) - (map #(expand % env symtable-ref scopes) xs)))))) - - - -(defn regensym - "Renumber the gensyms created by `new-scope` found in datum, - starting from zero." - [datum] - (let [c (atom {})] - (clojure.walk/postwalk - (fn [x] - (if (instance? Variable x) - (let [[sym scopes] (destructure-variable x) - syms (swap! - c - #(let [r (set/difference scopes - (set (keys %)))] - (into % - (map-indexed - (fn [n a] - [a (symbol (str "s" (+ (count %) n)))]) - r))))] - #_(->Variable sym (set (map #(get syms %) scopes))) - [sym (set (map #(get syms %) scopes))]) - x)) - datum))) - -(defn unscope - "Remove all scopes from the variables found in datum." - [datum] - (clojure.walk/postwalk - (fn [x] - (if (instance? Variable x) - (variable-symbol x) - x)) - datum)) - -(defn us-expand [datum] - (unscope (expand datum))) - -(defn rg-expand [datum] - (regensym (expand datum))) +(defn expand [stx env store-atom]) diff --git a/src/old.clj b/src/old.clj new file mode 100644 index 0000000..7f30ae6 --- /dev/null +++ b/src/old.clj @@ -0,0 +1,593 @@ +(ns old + (:require [clojure.core.match :refer [match]] + [clojure.pprint :as pprint] + [clojure.set :as set] + [clojure.spec.alpha :as s] + [clojure.walk] + [spec-dict.main :refer [dict]])) + +(defmacro todo + ([] `(throw (ex-info "todo" {}))) + ([fmt & xs] + `(throw (ex-info (format (str "todo: " ~fmt) ~@xs) + {})))) + +(def primitives + '#{let let-syntax letrec lambda syntax-rules if define + define-syntax begin}) + +(def builtins + '#{+ * / - car cdr write display newline cons list}) + +(s/def ::binding + #(match % + [:lexical sym uniq] (and (symbol? sym) (symbol? uniq)) + [:global sym] (symbol? sym))) + +(s/def ::pattern + (s/or :wildcard #{'_} + :var (s/and symbol? (complement #{'... '_})) + :lit ::literal + :list (s/and seq? + (s/cat :leading (s/* ::pattern) + :rest (s/? (s/cat :ellipsis #{'...} + :trailing (s/* ::pattern)))) + (s/conformer + (fn [pat] + (if-some [{:keys [ellipsis trailing]} (:rest pat)] + (let [{:keys [leading]} pat] + (if-some [variadic (last leading)] + {:leading (vec (butlast leading)) + :ellipsis variadic + :trailing trailing} + ::s/invalid)) + pat)))))) + +(s/def ::literal (some-fn string? boolean? number? char?)) + +(defn literal? [x] + (s/valid? ::literal x)) + +(s/def ::datum any?) + +(declare variable?) + +(s/def ::template + (s/or :var ::variable + :lit ::literal + :list (s/and (s/* ::template-element) sequential?))) + +(s/def ::template-element + (s/& (s/cat :template ::template :ellipsis (s/? #{'...})) + (s/conformer + (fn [{:keys [ellipsis template]}] + (if ellipsis + [:ellipsis template] + template))))) + +(s/def ::rule + (s/and sequential? + (s/cat :pattern ::pattern + :template ::template))) + +;; cf. `::prim-syntax-rules` +(s/def ::transformer + (dict {:rules (s/coll-of ::rule :kind sequential?)} + ^:opt {:keywords (s/coll-of symbol?)})) + +(s/def ::denotation + #(match % + [:var] true + [:primitive p] (primitives p) + ;; 나쁜 + [:macro trans] (contains? trans :rules) + [:syntax datum] true)) + +(s/def ::environment + (s/map-of ::binding ::denotation)) + +(s/def ::scope symbol?) + +(s/def ::scope-set (s/coll-of ::scope :kind set?)) + +;; this is an inefficient representation. since we often want to +;; compute the submap of entries with a symbol 'x' but any scope, it +;; would be best to 'curry' the table, as Symbol → Scopes → +;; Binding. however, this is a bit more error-prone and cumbersome for +;; a prototype. +(s/def ::symtable + (s/map-of (s/tuple symbol? (s/coll-of ::scope :kind set?)) + ::binding)) + +(s/def ::formals + (s/coll-of symbol? :kind sequential?)) + +(s/def ::body + (s/+ any?)) + +(declare destructure-variable) + +(defprotocol IVariable + (variable-symbol [this]) + (variable-scopes [this])) + +(deftype Variable [symbol scopes] + Object + (equals [x y] + (if-some [[y-symbol y-scopes] (destructure-variable y)] + (and (.equals symbol y-symbol) + (.equals scopes y-scopes)) + false)) + IVariable + (variable-symbol [this] symbol) + (variable-scopes [this] scopes)) + +(def ^:dynamic *print-variable-scopes* true) + +;; does not respect `*print-dup*` lol +(defmethod print-method Variable [this writer] + (binding [*out* writer] + (if *print-variable-scopes* + (pr [(variable-symbol this) (variable-scopes this)]) + (pr (variable-symbol this))))) + +(defmethod clojure.pprint/simple-dispatch old.Variable [x] + (clojure.pprint/simple-dispatch + (if *print-variable-scopes* + [(variable-symbol x) (variable-scopes x)] + (variable-symbol x)))) + +(s/def ::variable + (s/conformer + (fn [x] + (match x + (_ :guard symbol?) (->Variable x nil) + (_ :guard #(instance? Variable %)) + (if (symbol? (variable-symbol x)) + (let [r (s/conform ::scope-set (variable-scopes x))] + (if (s/invalid? r) + ::s/invalid + (->Variable (variable-symbol x) (variable-scopes x)))) + ::s/invalid) + [sym scopes] (let [r (s/conform (s/nilable ::scope-set) scopes)] + (if (and (symbol? sym) (not (s/invalid? r))) + (->Variable sym r) + ::s/invalid)) + :else ::s/invalid)))) + +(defn variable? [x] + (s/valid? ::variable x)) + +(defn normalise-variale [v] + (let [r (s/conform ::variable v)] + (when-not (s/invalid? r) + r))) + +(defn destructure-variable [v] + (let [r (s/conform ::variable v)] + (when-not (s/invalid? r) + [(variable-symbol r) (variable-scopes r)]))) + +#_ +(defn variable-scopes [v] + (when-some [[_ scopes] (destructure-variable v)] + scopes)) + +#_ +(defn variable-symbol [v] + (when-some [[s _] (destructure-variable v)] + s)) + +(defn offer-scopes + "variable v는 안 resolve되면 v와 scopes는 붙음." + [v scopes] + (let [[sym existing-scopes] (destructure-variable v)] + (->Variable sym (or existing-scopes scopes)))) + +(s/def ::prim-lambda + (s/cat :keyword ::variable + :formals ::formals + :body ::body)) + +(s/def ::prim-let + (s/cat :keyword ::variable + :bindings (s/coll-of #(and (sequential? %) + (= 2 (count %)) + (symbol? (first %))) + :kind sequential?) + :body ::body)) + +(s/def ::prim-let-syntax ::prim-let) + +;; cf. `::transformer` +(s/def ::prim-syntax-rules + (s/and seq? (s/cat :keyword ::variable + :keywords (s/coll-of symbol?) + :rules (s/* ::rule)))) + +(s/def ::prim-if + (s/and seq? (s/cat :keyword ::variable + :condition ::datum + :consequent ::datum + :alternative (s/? ::datum)))) + +(s/def ::prim-begin + (s/and seq? (s/cat :keyword ::variable + :body (s/+ ::datum)))) + + + +(defn symtable-for-env [env] + (into (hash-map) + (for [[[_ x] _] env] + [[x #{}] [:global x]]))) + +(defmacro meta-syntax-rules [kws & body] + `(s/conform ::prim-syntax-rules + (list 'syntax-rules '~kws + ~@(map (fn [x] `(quote ~x)) body)))) + +(defn define-global [env-ref symtable-ref sym denot] + (swap! env-ref #(assoc % [:global sym] denot)) + (swap! symtable-ref #(assoc % [sym #{}] [:global sym]))) + +(declare expand) + +(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]))) + +(defn 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 + (filter #(set/subset? % scopes)) + (group-by count) + seq)] + (second (apply max-key first xs)))) + +(defn- symtable-scopes + "Gather the set of scope-sets associated with a given symbol." + [symtable sym] + (into #{} (for [[[x scopes] _] symtable + :when (= sym x)] + scopes))) + +(defn lookup [variable env symtable] + (let [[sym scopes] (or (destructure-variable variable) + (throw (ex-info "not a var" {:var variable}))) + ss (symtable-scopes symtable sym) + xs (nearest [sym scopes] ss) + r (compare (count xs) 1)] + (cond (neg? r) (throw (ex-info "undefined sym" {:sym sym})) + (zero? r) + (or (get env (or (get symtable [sym (first xs)]) + (throw (ex-info "unreachable" {})))) + (throw (ex-info "unreachable" {}))) + (pos? r) (throw (ex-info "ambiguous sym" {:sym sym}))))) + +(comment + (let [{:keys [symtable env]} (scheme-base) + st (atom symtable)] + {:e (expand '(lambda (x y) x) env st #{}) + :st @st})) + +(defmulti expand-primitive + (fn [_datum prim-name _env _symtable-ref _scopes] + prim-name)) + +(defn new-scope + ([] (gensym "scope__")) + ([prefix] (gensym (str "scope__" prefix)))) + +(defn bind-lexical [[sym scopes] denot symtable-ref] + (let [bind [:lexical sym (gensym)]] + (swap! symtable-ref #(assoc % [sym scopes] bind)) + {bind denot})) + +(defn make-symtable [[sym scopes] bind] + {[sym scopes] bind}) + + + +(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 unification->env [unification symtable-ref scopes] + (into {} + (doall (for [[k v] unification] + (bind-lexical [k scopes] [:syntax v] + symtable-ref))))) + +(defn unify-trans + "`unify`로 모든 trans의 패턴은 datum을 맞음. datum으로 맞은 패턴은 + 없으면 nil을 결과할 것입나다. + + 걸과의 모습은 [rule unification]입니다. 여기서 rule이 최초 맞은 + trans의 rule이고, unification이 `unify`의 결과입니다." + [trans datum] + (some (fn [{:keys [pattern template] + :as rule}] + (when-some [unif (unify* pattern datum)] + [rule unif])) + (:rules trans))) + +(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)) + + +;;; expand + +(declare expand) + +(defmethod expand-primitive 'lambda + [datum _ env symtable-ref scopes] + (let [{:keys [formals body]} (s/conform ::prim-lambda datum) + scopes* (conj scopes (new-scope)) + env* (apply merge env + (for [x formals] + (bind-lexical [x scopes*] + [:var] symtable-ref)))] + (concat (list 'lambda + (for [x formals] + (offer-scopes x scopes*))) + (for [e body] + (expand e env* symtable-ref scopes*))))) + +(defmethod expand-primitive 'let + [datum _ env symtable-ref scopes] + (let [{:keys [bindings body]} (s/conform ::prim-let datum) + scopes* (conj scopes (new-scope)) + env* (apply merge env + (for [[x _] bindings] + (bind-lexical [x scopes*] + [:var] symtable-ref)))] + (concat (list 'let + (for [[k v] bindings] + (list (offer-scopes k scopes*) v))) + (for [e body] + (expand e env* symtable-ref scopes*))))) + +(defmethod expand-primitive 'let-syntax + [datum _ env symtable-ref scopes] + (let [{:keys [bindings body]} (s/conform ::prim-let-syntax datum) + scopes* (conj scopes (new-scope)) + env* (apply merge env + (for [[x rhs] bindings] + (let [trans (->> (expand rhs env symtable-ref scopes) + (s/conform ::prim-syntax-rules))] + (assert (not (s/invalid? trans))) + (bind-lexical + [x scopes*] + [:macro trans] + symtable-ref))))] + (concat (list 'let-syntax bindings) + (for [e body] + (expand e env* symtable-ref scopes*))))) + +(defmethod expand-primitive 'syntax-rules + [datum _ env symtable-ref scopes] + (assert (s/valid? ::prim-syntax-rules datum)) + (let [scopes* (conj scopes (new-scope)) + keywords (nth datum 1) + rules (nthrest datum 2)] + (concat (list 'syntax-rules + keywords) + (for [[pattern template] rules] + (list pattern (resolve-template template scopes*)))))) + +(defmethod expand-primitive 'if + [datum _ env symtable-ref scopes] + (let [{:keys [condition consequent alternative]} + (s/conform ::prim-if datum) + ex #(expand % env symtable-ref scopes)] + (concat (list 'if (ex condition) + (ex consequent)) + (some-> alternative ex)))) + +(defmethod expand-primitive 'begin + [datum _ env symtable-ref scopes] + (let [{:keys [body]} (s/conform ::prim-begin datum)] + (cons 'begin (map #(expand % env symtable-ref scopes) body)))) + +(comment + (let [env (:env scheme-base-env) + [_ trans] (get env [:global 'and]) + datum '(and 12 34) + symtable-ref (atom (symtable-for-env env)) + scopes #{1}] + (expand-macro + trans datum + env symtable-ref scopes))) + +(defn expand-macro [trans datum env symtable-ref scopes] + (let [[rule unif] + (-> (unify-trans trans datum) + (or (throw + (ex-info + "데이텀을 맞은 패턴은 찾을 수 없었습니다" + {:trans trans :datum datum})))) + scopes* (conj scopes (new-scope)) + env* (merge env (unification->env unif symtable-ref scopes*))] + (expand (transcribe (:template rule) env* @symtable-ref scopes*) + env ;; 아마도 `env*`를 써야 되고 `env`를 안 써야 될까? + symtable-ref + scopes))) + +(defn expand + ([datum] + (let [{:keys [env symtable]} (scheme-base)] + (expand + datum env (atom symtable) #{}))) + ([datum env symtable-ref scopes] + (match datum + ;; literals + (x :guard literal?) x + ;; variables (both resolved and unresolved) + (x :guard variable?) + (let [x* (offer-scopes x scopes)] + (lookup x* env @symtable-ref) ; throw if unbound + x*) + + ;; lists + ([f & xs] :seq) + (or (when-let [v (and (variable? f) + (offer-scopes f scopes))] + (match (lookup v env @symtable-ref) + [:primitive prim] (expand-primitive + datum prim env symtable-ref scopes) + [:macro trans] (expand-macro trans datum env symtable-ref scopes) + [:var] nil)) + (cons (expand f env symtable-ref scopes) + (map #(expand % env symtable-ref scopes) xs)))))) + + + +(defn regensym + "Renumber the gensyms created by `new-scope` found in datum, + starting from zero." + [datum] + (let [c (atom {})] + (clojure.walk/postwalk + (fn [x] + (if (instance? Variable x) + (let [[sym scopes] (destructure-variable x) + syms (swap! + c + #(let [r (set/difference scopes + (set (keys %)))] + (into % + (map-indexed + (fn [n a] + [a (symbol (str "s" (+ (count %) n)))]) + r))))] + #_(->Variable sym (set (map #(get syms %) scopes))) + [sym (set (map #(get syms %) scopes))]) + x)) + datum))) + +(defn unscope + "Remove all scopes from the variables found in datum." + [datum] + (clojure.walk/postwalk + (fn [x] + (if (instance? Variable x) + (variable-symbol x) + x)) + datum)) + +(defn us-expand [datum] + (unscope (expand datum))) + +(defn rg-expand [datum] + (regensym (expand datum))) diff --git a/src/r7rs.ebnf b/src/r7rs.ebnf new file mode 100644 index 0000000..14dd8ce --- /dev/null +++ b/src/r7rs.ebnf @@ -0,0 +1,19 @@ +program = datum* + +(* tokens *) +boolean = #"#(t(rue)?|f(alse)?)" +semicolon = ';' + +(* datum *) +datum = simple-datum + + = boolean + +(* atmosphere *) +atmosphere = whitespace | comment | directive +whitespace = intraline-whitespace | line-ending +intraline-whitespace = #"[ \t\f]" +line-ending = #"[\r\n]|\r\n" +comment = #"[^\n\r]*" +intertoken-space = atmosphere* +directive = #"#!(no-)?fold-case" \ No newline at end of file diff --git a/src/scm.clj b/src/scm.clj new file mode 100644 index 0000000..5636493 --- /dev/null +++ b/src/scm.clj @@ -0,0 +1,63 @@ +(ns scm + (:require [instaparse.core :as insta] + [clojure.java.io :as io] + [clojure.core.match :refer [match]]) + (:refer-clojure :exclude [read])) + + +;;; syntax objects + +(defprotocol IStx + (stx-datum [this]) + (stx-context [this])) + +(defn syntax? [x] + (instance? IStx x)) + +(deftype Stx [datum ctx] + Object + (equals [x y] + (or (identical? x y) + (and (instance? IStx y) + (.equals datum (stx-datum y)) + (.equals ctx (stx-context y))))) + IStx + (stx-datum [this] datum) + (stx-context [this] ctx)) + +(def ^:dynamic *print-ctx?* true) + +;; does not respect `*print-dup*` lol +(defmethod print-method Stx [this writer] + (binding [*out* writer] + (pr (tagged-literal + 'scm/stx + (if *print-ctx?* + [(stx-datum this) (stx-context this)] + (stx-datum this)))))) + +(defmethod clojure.pprint/simple-dispatch Stx [x] + (clojure.pprint/simple-dispatch + (tagged-literal + 'scm/stx + (if *print-ctx?* + [(stx-datum x) (stx-context x)] + (stx-datum x))))) + +(defn stx-reader [[datum ctx]] + (->Stx datum ctx)) + + +;;; r⁷rs reader + +(insta/defparser r7rs-parser (io/resource "r7rs.ebnf")) + +(defn read [s & {:as opts}] + (->> (insta/parse r7rs-parser s opts) + (insta/transform + {:boolean (fn [x] + [:boolean + (match x + (:or "#t" "#true") true + (:or "#f" "#false") false)])}))) + diff --git a/test/expand_test.clj b/test/old_test.clj similarity index 98% rename from test/expand_test.clj rename to test/old_test.clj index fc591d7..1b115cb 100644 --- a/test/expand_test.clj +++ b/test/old_test.clj @@ -1,16 +1,16 @@ -(ns expand-test +(ns old-test (:require [clojure.core.match :refer [match]] [clojure.spec.alpha :as s] [clojure.test :as t] - [expand :as sut])) + [old :as sut])) (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] + #_(t/is (= [:primitive 'lambda] (sut/lookup ['lambda #{}] sut/scheme-base-env (sut/symtable-for-env sut/scheme-base-env))))