init

src/expand.clj

@@ -0,0 +1,129 @@
+(ns expand
+  (:require [clojure.spec.alpha :as s]
+            [clojure.core.match :refer [match]]
+            [spec-dict.main :refer [dict]]
+            [clojure.set :as set]))
+
+(def primitives
+  #{'let 'let-syntax 'letrec 'lambda 'syntax-rules 'if})
+
+(s/def ::binding
+  #(match %
+     [:lexical sym uniq] (and (symbol? sym) (symbol? uniq))
+     [:global sym] (symbol? sym)))
+
+(s/def ::pattern any?)
+
+(s/def ::template any?)
+
+(s/def ::rule
+  (s/tuple ::pattern ::template))
+
+(s/def ::transformer
+  (dict {:rules (s/coll-of ::rule :kind sequential?)}))
+
+(s/def ::denotation
+  #(match %
+     [:var] true
+     [:primitive p] (primitives p)
+     [:macro trans] (s/valid? ::transformer trans)))
+
+(s/def ::environment
+  (s/map-of ::binding ::denotation))
+
+(s/def ::scope symbol?)
+
+(s/def ::symtable
+  (s/map-of symbol?
+            (s/map-of (s/coll-of ::scope :kind set?)
+                      ::binding)))
+
+
+
+(defn symtable-for-env [env]
+  (into {}
+        (for [[[_ x] _] env]
+          [x {#{} [:global x]}])))
+
+(def scheme-base-env
+  (into {[:global 'λ] [:primitive 'lambda]}
+        (for [p primitives]
+          [[:global p] [:primitive p]])))
+
+(defn nearest [[sym scopes] ss]
+  (when-some [xs (->> ss
+                      (filter #(set/subset? % scopes))
+                      (group-by count)
+                      seq)]
+    (second (apply max-key first xs))))
+
+(defn lookup [[sym scopes] env symtable]
+  (let [ss (get symtable sym)]
+    (let [xs (nearest [sym scopes] (keys ss))
+          r (compare (count xs) 1)]
+      (cond (neg? r) (throw (ex-info "undefined sym" {:sym sym}))
+            (zero? r)
+            (or (get env (or (get ss (first xs))
+                             (throw (ex-info "unreachable" {}))))
+                (throw (ex-info "unreachable" {})))
+            (pos? r) (throw (ex-info "ambiguous sym" {:sym sym}))))))
+
+(comment
+  (let [st (atom (symtable-for-env scheme-base-env))]
+    {:e (expand '(lambda (x y) x) scheme-base-env st #{})
+     :st @st}))
+
+(defmulti expand-primitive
+  (fn [_datum prim-name _env _symtable-ref _scopes]
+    prim-name))
+
+(defn new-scope
+  ([] (gensym))
+  ([prefix] (gensym prefix)))
+
+(defn bind-lexical [[sym scopes] denot symtable-ref]
+  (let [bind [:lexical sym (gensym)]]
+    (swap! symtable-ref #(assoc-in % [sym scopes] bind))
+    {bind denot}))
+
+(defmethod expand-primitive 'lambda
+  [datum _ env symtable-ref scopes]
+  (let [[_ formals & body] datum
+        scopes* (conj scopes (new-scope))
+        env* (apply merge env
+                    (for [x formals]
+                      (bind-lexical [x scopes*]
+                                    [:var] symtable-ref)))]
+    (concat (list 'lambda formals)
+            (for [e body]
+              (expand e env* symtable-ref scopes*)))))
+
+(comment (assert (lookup ['lambda #{}]
+                         scheme-base-env
+                         (symtable-for-env scheme-base-env))))
+
+(comment
+  (nearest ['x #{0 1 2}]
+           #{#{0}
+             #{0 1}
+             #{0 3}}))
+
+(comment
+  (expand 'x)
+  (expand '(lambda (x) x)))
+
+(defn expand
+  ([datum]
+   (expand
+    datum scheme-base-env (atom (symtable-for-env scheme-base-env)) #{}))
+  ([datum env symtable-ref scopes]
+   (match datum
+     (x :guard (some-fn boolean? number?)) x
+     (x :guard symbol?)
+     (do (lookup [x scopes] env @symtable-ref)
+         x)
+     ([(f :guard symbol?) & xs] :seq)
+     (match (lookup [f scopes] env @symtable-ref)
+       [:primitive prim] (expand-primitive
+                          datum prim env symtable-ref scopes)))))
+