expand2

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"}}

src/data_readers.clj

@@ -0,0 +1 @@
+{scm/stx scm/stx-reader}

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])

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)))

src/r7rs.ebnf

@@ -0,0 +1,19 @@
+program = <intertoken-space> datum*
+
+(* tokens *)
+boolean = #"#(t(rue)?|f(alse)?)" <intertoken-space>
+semicolon = ';'
+
+(* datum *)
+datum = simple-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 = <semicolon> #"[^\n\r]*"
+intertoken-space = atmosphere*
+directive = #"#!(no-)?fold-case"

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)])})))
+

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))))