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