청소

src/data_readers.clj

@@ -1 +1 @@
-{scm/stx scm/stx-reader}
+{scm/stx expand.scm/stx-reader}

src/expand/common.clj

@@ -1,4 +1,4 @@
-(ns common)
+(ns expand.common)
 
 (defmacro inherit [& syms]
   (let [f (if (<= 8 (count syms))

src/expand/core.clj

@@ -1,14 +1,14 @@
-(ns expand
+(ns expand.core
   (:require [clojure.core.match :refer [match]]
+            [clojure.java.io :as io]
             [clojure.pprint]
             [clojure.set :as set]
             [clojure.spec.alpha :as s]
             [clojure.walk]
-            [spec-dict.main :refer [dict]]
-            [scm]
-            [clojure.java.io :as io]
-            [expand.syntax-rules :as syntax-rules])
-  (:use [common]))
+            [expand.common :refer :all]
+            [expand.scm :as scm]
+            [expand.syntax-rules :as syntax-rules]
+            [spec-dict.main :refer [dict]]))
 
 (s/def ::scope scm/scope?)
 
@@ -329,7 +329,7 @@
                 :else decl)))))
 
 (comment
-  (-> "t.scm"
+  (-> "t.expand.scm"
       slurp
       (scm/read-syntax :library? true)
       expand-library
@@ -338,7 +338,7 @@
   (let [scopeholder (scm/new-scopeholder)
         env {[:global 'lambda] [:primitive 'lambda]}
         store-atom (atom {['lambda #{}] [:global 'lambda]})]
-    (expand (-> (slurp "t.scm")
+    (expand (-> (slurp "t.expand.scm")
                 (scm/read-syntax #_#_:library? true)
                 (scm/rescope scopeholder))
             env store-atom)))

src/expand/scm.clj

@@ -1,4 +1,4 @@
-(ns scm
+(ns expand.scm
   (:refer-clojure :exclude [read])
   (:require [clojure.core.match :refer [match]]
             [clojure.java.io :as io]
@@ -27,7 +27,7 @@
         (and (satisfies? ISyntax y)
              (.equals datum (syntax-e y))
              (.equals ctx (syntax-context y)))))
-  scm/ISyntax
+  expand.scm/ISyntax
   (syntax-e [this] datum)
   (syntax-context [this] ctx)
   clojure.lang.Seqable
@@ -169,7 +169,7 @@
 
 ;;; r⁷rs reader
 
-(insta/defparser r7rs-parser (io/resource "r7rs.ebnf"))
+(insta/defparser r7rs-parser (io/resource "expand/scm/r7rs.ebnf"))
 
 (defn read
   "text에서 Scheme 데이텀 한 개를 받는다.

src/expand/syntax_rules.clj

@@ -1,18 +1,18 @@
 (ns expand.syntax-rules
-  (:require [clojure.core.match :refer [match]]
-            [clojure.spec.alpha :as s]
-            [spec-dict.main :refer [dict]]
-            [scm]
-            [clojure.test :as t]
-            [clojure.walk :as walk])
-  (:use [common]))
+  (:require
+   [clojure.core.match :refer [match]]
+   [clojure.spec.alpha :as s]
+   [clojure.test :as t]
+   [clojure.walk :as walk]
+   [expand.common :refer :all]
+   [expand.scm :as scm]
+   [spec-dict.main :refer [dict]]))
 
 (s/def ::pattern scm/datum?)
 (s/def ::template scm/datum?)
 
 (defn- report-conflict [x y]
-  (throw (ex-info "너무 정의합니다"
-                  {:x x :y y})))
+  (throw (ex-info "정의는 너무 많다" {:x x :y y})))
 
 (defn- merge-unify-with
   ([f] {})
@@ -23,43 +23,6 @@
 (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 wildcard? [x]
   (or (= '_ x)
       (and (scm/syntax? x) (-> x scm/syntax-e wildcard?))))
@@ -169,21 +132,3 @@
                    (unify (scm/datum->syntax-recursive pattern)
                           (scm/datum->syntax-recursive datum)))
        scm/syntax->datum)))
-
-(comment
-  (let [pattern '(x ...)
-        template '(x ...)
-        datum '(1 2 3)]
-    (-> template
-        (transcribe* (unify (scm/datum->syntax-recursive pattern)
-                            (scm/datum->syntax-recursive datum)))
-        #_scm/syntax->datum))
-  (let [pattern '((x y ...) ...)
-        template '(x ...)
-        datum '((1 2) (3 4 5))]
-    (-> template
-        (transcribe* (unify (scm/datum->syntax-recursive pattern)
-                            (scm/datum->syntax-recursive datum)))
-        #_scm/syntax->datum))
-  (unify* '((x y ...) ...)
-          '((1 2 3) (3 4))))

src/old.clj

@@ -1,593 +0,0 @@
-(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

@@ -1,92 +0,0 @@
-program = <intertoken-space> datum*
-
-(* tokens *)
-boolean = #"#(t(rue)?|f(alse)?)" <intertoken-space>
-semicolon = ';'
-left-paren = '(' <intertoken-space>
-right-paren = ')' <intertoken-space>
-dot = '.' <intertoken-space>
-
-(* datum *)
-datum-start = <intertoken-space> datum
-
-datum = simple-datum | compound-datum
-<simple-datum> = boolean | symbol | number | string
-<compound-datum> = any-list
-
-(* list *)
-<any-list> = list | improper-list
-list = <left-paren> datum* <right-paren>
-improper-list = <left-paren> datum+ <dot> datum <right-paren>
-
-(* symbol *)
-symbol = ordinary-symbol <intertoken-space>
-<ordinary-symbol> = #"[\p{Lu}\p{Ll}\p{Lt}\p{Lm}\p{Lo}\p{Nl}\p{No}\p{Pd}\p{Pc}\p{Sc}\p{Po}\p{Sm}\p{Sk}\p{So}\p{Co}\u200c\u200d&&[^;|\".,#]][\p{Lu}\p{Ll}\p{Lt}\p{Lm}\p{Lo}\p{Nl}\p{No}\p{Pd}\p{Pc}\p{Sc}\p{Po}\p{Sm}\p{Sk}\p{So}\p{Co}\u200c\u200d\p{Nd}\p{Me}\p{Mc}.&&[^;|\",#]]*"
-
-(* number *)
-number = num-10 <intertoken-space>
-
-num-10 = sign uinteger-10
-<uinteger-10> = #"[0-9]+"
-
-sign = ('+' | '-')?
-exactness = ('#i' | '#e')?
-
-(* string *)
-string = <'"'> string-element* <'"'> <intertoken-space>
-<string-element> = #'[^"\\]' | '\\"' | '\\\\'
-
-(* 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"
-
-(* library *)
-library-start = <intertoken-space> library
-library = <left-paren> <"define-library"> <intertoken-space>
-          library-name
-          library-declaration*
-          <right-paren>
-library-name = <left-paren> library-name-part+ <intertoken-space> <right-paren>
-<library-name-part> = symbol | uinteger-10
-<library-declaration>
-  = export-declaration
-  | import-declaration
-  | begin-declaration
-
-export-declaration =
-  <left-paren> <'export'> <intertoken-space> export-spec*
-  <right-paren>
-<export-spec> = symbol
-
-import-declaration =
-  <left-paren> <'import'> <intertoken-space> import-set+ <right-paren>
-
-<import-set>
-  = library-name
-  | import-only
-  | import-except
-  | import-prefix
-  | import-rename
-
-import-only = 
-  <left-paren> <'only'> <intertoken-space> import-set symbol+ <right-paren>
-import-except =
-  <left-paren> <'except'> <intertoken-space> import-set symbol+ <right-paren>
-import-prefix =
-  <left-paren> <'prefix'> <intertoken-space> import-set symbol+ <right-paren>
-import-rename =
-  <left-paren> <'rename'> <intertoken-space>
-  import-set
-  (<left-paren> symbol symbol <right-paren>)+
-  <right-paren>
-
-begin-declaration =
-  <left-paren>
-  <'begin'> <intertoken-space>
-  datum*
-  <right-paren>

src/unhygienic.clj

@@ -1,106 +0,0 @@
-(ns unhygienic
-  (:require [clojure.core.match :refer [match]]
-            [clojure.spec.alpha :as s]
-            [expand]))
-
-(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 (fn [_ x] x) 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 #(when-some [r (unify* ellipsis %)]
-                        (->> r
-                             (map (fn [[k v]] [k (list v)]))
-                             (into {}))))
-                (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))
-
-
-
-(comment
-  (transcribe (unify '((a ...) ...)
-                     '((1 2) (3 4) (5 6)))
-              '(begin (a ...) ...))
-  (strip-ellipsis
-   '[:ellipsis ([:ellipsis (1 2)] [:ellipsis (3 4)] [:ellipsis (5 6)])]
-   2))
-
-(defn- strip-ellipsis [unif ellipsis-depth]
-  (match unif
-    [:ellipsis p]
-    (if (< 0 ellipsis-depth)
-      (map #(strip-ellipsis % (dec ellipsis-depth)) p)
-      (throw (ex-info "나쁜 점점점" {})))
-    :else unif))
-
-(defn- transcribe*
-  ([unification template]
-   (transcribe* 0 unification template))
-  ([ellipsis-depth unification template]
-   (match template
-     [:lit l] l
-
-     [:var x]
-     (match (get unification x)
-       ([:ellipsis _] :as p)
-       (strip-ellipsis p ellipsis-depth)
-
-       ;; unhygenic but it's demo }:)
-       (_ :guard nil?) x
-
-       p p)
-
-     [:list ts]
-     (->> (for [t ts]
-            (match t
-              [:ellipsis t*] (transcribe* (inc ellipsis-depth) unification t*)
-              :else [(transcribe* ellipsis-depth unification t)]))
-          (apply concat)))))
-
-(defn transcribe [unification template]
-  (transcribe* 0 unification (s/conform :expand/template template)))
-
-(comment
-  (transcribe-transformer scheme-and '(and 1 2)))
-
-(defn transcribe-transformer [trans datum]
-  (some (fn [{:keys [pattern template]}]
-          (when-some [unification (unify* pattern datum)]
-            (let [r (transcribe* unification template)]
-              (assert r)
-              r)))
-        (:rules trans)))