src/expand.clj

@@ -67,6 +67,86 @@
                :ss (s/coll-of ::context))
   :ret (s/coll-of ::context :kind set?))
 
+(s/fdef new-scope
+  :args (s/cat :prefix (s/? string?))
+  :ret ::scope)
+
+
+;;; prim specs
+
+(s/def ::datum scm/datum?)
+
+(s/def ::unsyntax
+  (s/conformer
+   (fn [x]
+     (match x
+       (_ :guard scm/syntax?) (scm/syntax-e x)
+       _ ::s/invalid))))
+
+(s/def ::body
+  (s/+ ::datum))
+
+(s/def ::lambda-formals
+  (s/and ::unsyntax
+         #(or (and (list? %) (apply (every-pred scm/identifier?) %))
+              scm/improper-list?
+              scm/identifier?)))
+
+(s/def ::prim-lambda
+  (s/and ::unsyntax
+         (s/cat :keyword ::identifier
+          :formals ::lambda-formals
+          :body ::body)))
+
+
+
+(defn new-scope
+  ([] (gensym "scope__"))
+  ([prefix] (gensym (str "scope__" prefix))))
+
+#_
+(defn bind-lexical [sym denot store-atom]
+  (let [bind [:lexical sym (gensym)]]
+    (swap! store-atom #(assoc % [sym scopes] bind))
+    {bind denot}))
+
+#_
+(s/fdef binding-form
+  :args (s/cat :binds (s/coll-of (s/tuple symbol? ::denotation))
+               :store-atom #(instance? clojure.lang.Atom %)
+               :datum ::datum))
+
+(defn binding-form [ident env store-atom binds f]
+  (let [scopes (conj (scm/syntax-context ident)
+                     (new-scope))
+        ident* (scm/->Syntax (scm/syntax-e ident)
+                             scopes)
+        additions (for [[sym denot] binds]
+                    [sym
+                     [:lexical sym (gensym)]
+                     denot])
+        env* (into env (for [[_sym bind denot] additions]
+                         [bind denot]))]
+    (swap! store-atom #(into % (for [[sym bind _denot] binds]
+                                 [[sym scopes] bind])))
+    (scm/datum->syntax (cons
+                        ;; 여기서 ident를 써야 할지 ident*를 써야 할지 몰라…
+                        (scm/syntax-e ident)
+                        (f ident* env*))
+                       ident)))
+
+(comment
+  (let [env {}
+        store-atom (atom {})]
+    (binding-form #scm/stx [lambda #{}]
+                  env
+                  store-atom
+                  {:x [:var]}
+                  (fn [ident* env*]
+                    (tap> {:ident* ident*
+                           :env* env*})
+                    (list (scm/datum->syntax 'x ident*))))))
+
 
 
 (defn- store-scopes
@@ -96,6 +176,37 @@
                 (throw (ex-info "unreachable" {})))
             (pos? r) (throw (ex-info "ambiguous sym" {:sym sym}))))))
 
+(declare expand)
+
+(defmulti expand-primitive
+  (fn [_datum prim-name _env _store-atom]
+    prim-name))
+
+#_
+(defmethod expand-primitive 'lambda
+  [stx _ env symtable-ref]
+  (let [{:keys [formals body]} (->> stx
+                                    scm/syntax-e
+                                    (s/conform ::prim-lambda))]
+    (concat (list 'lambda
+                  (throw (Exception. "todo2")))
+            (for [e body]
+              (expand e env* symtable-ref)))))
+
 (defn expand [stx env store-atom]
   (match (scm/syntax-e stx)
-    (x :guard scm/constant?) x))
+    (x :guard scm/constant?) x
+    (x :guard scm/identifier?)
+    (do (lookup x env @store-atom) ; throw if unbound
+        x)
+
+    ([f & xs] :seq)
+    (or (when (scm/identifier? f)
+          (match (lookup f env @store-atom)
+            [:primitive prim] (expand-primitive stx prim env store-atom)
+            #_#_[:macro trans] (expand-macro trans datum env symtable-ref scopes)
+            [:var] nil))
+        (cons (expand f env store-atom)
+              (map #(expand % env store-atom) xs)))))
+
+(defn expand-library [lib])