diff --git a/src/expand.clj b/src/expand.clj index 5726a0f..0f74589 100644 --- a/src/expand.clj +++ b/src/expand.clj @@ -67,19 +67,25 @@ #(match % [:var] true [:primitive p] (primitives p) - [:macro trans] ;; 나쁜 - (contains? trans :rules))) + [: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 symbol? - (s/map-of (s/coll-of ::scope :kind set?) - ::binding))) + (s/map-of (s/tuple symbol? (s/coll-of ::scope :kind set?)) + ::binding)) (s/def ::formals (s/coll-of symbol? :kind sequential?)) @@ -111,9 +117,9 @@ (defn symtable-for-env [env] - (into {} + (into (hash-map) (for [[[_ x] _] env] - [x {#{} [:global x]}]))) + [[x #{}] [:global x]]))) (defmacro meta-syntax-rules [kws & body] `(s/conform ::prim-syntax-rules @@ -142,13 +148,20 @@ 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 [[sym scopes] env symtable] - (let [ss (get symtable sym)] - (let [xs (nearest [sym scopes] (keys ss)) + (let [ss (symtable-scopes symtable sym)] + (let [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 ss (first xs)) + (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})))))) @@ -168,37 +181,81 @@ (defn bind-lexical [[sym scopes] denot symtable-ref] (let [bind [:lexical sym (gensym)]] - (swap! symtable-ref #(assoc-in % [sym scopes] bind)) + (swap! symtable-ref #(assoc % [sym scopes] bind)) {bind denot})) -(defn symtable [[sym scopes] bind] - {sym {scopes bind}}) +(defn make-symtable [[sym scopes] bind] + {[sym scopes] bind}) + +(defn bind-lexical* [[sym scopes] denot] + (let [bind [:lexical sym (gensym)]] + {:symtable (make-symtable [sym scopes] bind) + :env {bind denot}})) (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))))) + ([f g] {}) + ([f g a] a) + ([f g a b] (and a b {:env (merge-with f (:env a) (:env b)) + :symtable (merge-with g (:symtable a) (:symtable b))})) + ([f g a b & xs] (reduce #(merge-unify-with f g %1 %2) (cons a (cons b xs))))) + +(defn- report-conflict [x y] + (throw (ex-info "너무 정의합니다" + {:x x :y y}))) (defn- merge-unify [& xs] - (apply merge-unify-with (fn [_ x] x) xs)) + (apply merge-unify-with report-conflict report-conflict xs)) -(defn- unify* [pattern datum env symtable-ref scopes] +(comment + (let [scopes #{1} + symtab (symtable-for-env scheme-base-env) + env scheme-base-env + {symtab* :symtable env* :env} + (unify 'x '(1 2 3) env symtab scopes)] + (lookup ['x #{1}] (merge env env*) (merge symtab symtab*))) + (let [scopes #{1} + symtab (symtable-for-env scheme-base-env) + env scheme-base-env + {symtab* :symtable env* :env} + (unify '(x ...) '(1 2 3) env symtab scopes)] + #_(lookup ['x #{1}] (merge env env*) (merge symtab symtab*)) + symtab*)) + +(defn- unify* [pattern datum env symtable scopes bound] (match [pattern datum] - [[:wildcard _] _] {} + [[:wildcard _] _] {:env {} :symtable {}} - [[:var x] _] (symtable [x scopes] ))) + [[:var x] _] + (bind-lexical* [x scopes] [:syntax datum]) + + [[:list {:leading leading + :trailing nil + :ellipsis ellipsis}] + (_ :guard seq?)] + (let [[leading-datum ellipsis-datum] (split-at (count leading) datum)] + #dbg (+ 0 0) + (todo)) + + [[:list {:leading leading}] + (_ :guard seq?)] + (when (= (count datum) + (count leading)) + (->> (map #(unify* %1 %2 env symtable scopes) + leading datum) + (apply merge-unify))))) (defn unify ([pattern datum] (unify* (s/conform ::pattern pattern) datum scheme-base-env (symtable-for-env scheme-base-env) - #{})) - ([pattern datum env symtable-ref scopes] - (unify* (s/conform ::pattern pattern) datum env symtable-ref scopes))) + #{} + (atom {}))) + ([pattern datum env symtable scopes] + (unify* (s/conform ::pattern pattern) datum env symtable scopes + (atom {})))) ;;; expand