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])

src/scm.clj

@@ -29,6 +29,17 @@
   (syntax-context [this] ctx))
 
 (defn unresolved? [stx]
+  ;; 지금, 콘텍스트 필드가 비어 있은 신택스 옵제크트들이
+  ;; `::unresolved`로 한상 표한다. 왜냐하면 빈 집합(#{})은 이미 써서
+  ;; top-level scope를 나타낸다.
+  ;;
+  ;; 나는 이 방법이 좋지 않다고 생각하기 시작햇는다.
+  ;;
+  ;; `expand/expand`에서 집합 대신에 `::unresolved`를 받은 것은 귀찮다.
+  ;;
+  ;; 더 좋은 방법은 생각하고 있다. 모든 라이브러리나 프로그램은
+  ;; top-level scope를 짓겠는다. 그때 nil/#{}는 `::unresolved`를
+  ;; 대신하고 하나의 scope를 이루어진 집합은 #{}를 대신하겠는다.
   (= (syntax-context stx) ::unresolved))
 
 (defn resolved? [stx]
@@ -119,8 +130,16 @@
 (insta/defparser r7rs-parser (io/resource "r7rs.ebnf"))
 
 (defn read
-  "`read` 작업의 결과로 생성된 콘텍스트 필드는 초기에 비어 있다. 이후
-  `expand/expand` 작업을 통해 콘택스트 필드를 패울 수 있다."
+  "text에서 Scheme 데이텀 한 개를 받는다.
+
+  키워드 인수:
+  • :syntax? 참이면 syntax object를 생성함. `read` 작업의 결과로
+    생성된 콘텍스트 필드는 초기에 비어 있다. 이후 `expand/expand`
+    작업을 통해 콘택스트 필드를 채울 수 있다.
+  • :library? 참이면 R⁷RS define-library form으로 파싱하고, 그렇지
+    않으면 데이텀으로 파싱함.
+  • :throw? 참이면 파싱이 실패할 경우 예외를 팔생.
+  • :instaparse `instaparse.core/parse`에 전달할 키워드 인수."
   [text & {:keys [syntax? instaparse library? throw?]
            :or {syntax? false
                 library? false
@@ -175,3 +194,15 @@
 
 (defn read-syntax [text & {:as opts}]
   (read text (merge {:syntax? true} opts)))
+
+
+;;; specs
+
+(defn datum? [x]
+  (or (number? x)
+      (boolean? x)
+      (string? x)
+      (list? x)
+      (symbol? x)
+      (improper-list? x)
+      (and (syntax? x) (-> x syntax-e datum?))))

test/expand_test.clj

@@ -1,6 +1,8 @@
 (ns expand-test
   (:require [expand :as sut]
-            [clojure.test :as t]))
+            [clojure.test :as t]
+            [clojure.spec.alpha :as s]
+            [scm]))
 
 (t/deftest nearest-test
   (t/is (= '#{#{a b}}
@@ -30,4 +32,25 @@
                        '{[:lexical x A] [:var]
                          [:lexical x B] [:primitive lambda]}
                        '{[x #{a b}] [:lexical x A]
-                         [x #{a}] [:lexical x B]}))))
+                         [
+
+                          ;;; specsx #{a}
+                          ] [:lexical x B]}))))
+
+
+;;; specs
+
+(t/deftest spec-lambda-formals-test
+  (t/are [x] (s/valid? ::sut/lambda-formals x)
+    #scm/stx ()
+    #scm/stx (#scm/stx a #scm/stx b)
+    #scm/stx xs
+    (scm/datum->syntax
+     (scm/improper-list #scm/stx a
+                        #scm/stx b))))
+
+(t/deftest spec-prim-lambda-test
+  (t/are [x] (s/valid? ::sut/prim-lambda x)
+    #scm/stx (#scm/stx lambda
+              #scm/stx (#scm/stx a)
+              #scm/stx a)))