diff --git a/src/expand.clj b/src/expand.clj index c3d4d00..6f07e4c 100644 --- a/src/expand.clj +++ b/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]) diff --git a/src/scm.clj b/src/scm.clj index 140a70a..8c6aa9e 100644 --- a/src/scm.clj +++ b/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?)))) diff --git a/test/expand_test.clj b/test/expand_test.clj index 781eccf..7d6d24f 100644 --- a/test/expand_test.clj +++ b/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)))