diff --git a/resources/scm/scheme/base.scm b/resources/scm/scheme/base.scm new file mode 100644 index 0000000..b0f0755 --- /dev/null +++ b/resources/scm/scheme/base.scm @@ -0,0 +1,3 @@ +(define-library (scheme base) + (export lambda) + (import (scheme primitives))) diff --git a/src/expand.clj b/src/expand.clj index 6aeaa64..8db34bf 100644 --- a/src/expand.clj +++ b/src/expand.clj @@ -5,7 +5,8 @@ [clojure.spec.alpha :as s] [clojure.walk] [spec-dict.main :refer [dict]] - [scm])) + [scm] + [clojure.java.io :as io])) (defmacro inherit [& syms] (let [f (if (<= 8 (count syms)) @@ -34,13 +35,13 @@ (def primitives "A set of symbols to be defined as primitive syntax exposed by - (scheme base)." + (primitives+builtins)." '#{let let-syntax letrec lambda syntax-rules if define define-syntax begin}) (def builtins - "A set of symbols to be defined as variables exposed by (scheme - base)." + "A set of symbols to be defined as variables exposed by + (primitives+builtins)." '#{+ * / - car cdr write display newline cons list}) (s/def ::denotation @@ -152,18 +153,18 @@ (set (some->> xs (apply max-key first) second)))) (defn lookup [ident env store] - (tap> (inherit ident env store)) (let [sym (scm/syntax-e ident) scopes (scm/syntax-context ident) - ss (store-scopes store sym)] - (let [xs (nearest scopes ss) - r (compare (count xs) 1)] - (cond (neg? r) (throw (ex-info "undefined sym" {:sym sym})) - (zero? r) - (or (get env (or (get store [sym (first xs)]) - (throw (ex-info "unreachable" {})))) - (throw (ex-info "unreachable" {}))) - (pos? r) (throw (ex-info "ambiguous sym" {:sym sym})))))) + ss (store-scopes store sym) + xs (nearest scopes ss) + r (compare (count xs) 1)] + (tap> (inherit ident env store)) + (cond (neg? r) (throw (ex-info "undefined sym" {:sym sym})) + (zero? r) + (or (get env (or (get store [sym (first xs)]) + (throw (ex-info "unreachable" {})))) + (throw (ex-info "unreachable" {}))) + (pos? r) (throw (ex-info "ambiguous sym" {:sym sym}))))) (declare expand) @@ -187,25 +188,75 @@ (expand (scm/rescope x scopeholder) env* store-atom))))))) -(defn expand [stx env store-atom] - (match (scm/syntax-e stx) - (_ :guard scm/constant?) stx - (_ :guard symbol?) - (do (lookup stx env @store-atom) ; throw if unbound - stx) +(defn expand + ([stx] + (let [scopeholder (scm/new-scopeholder) + env {} + store-atom (atom {})] + (expand (scm/rescope stx scopeholder) + env store-atom))) + ([stx env store-atom] + (tap> (inherit stx)) + (match (scm/syntax-e stx) + (_ :guard scm/constant?) stx + (_ :guard symbol?) + (do (lookup stx env @store-atom) ; throw if unbound + stx) - ([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))))) + ([f & xs] :seq) + (or (when (scm/identifier? f) + (match (-> f + (scm/rescope stx) + (lookup env @store-atom)) + [:primitive prim] (expand-primitive stx prim env store-atom) + #_#_[:macro trans] + (expand-macro trans datum env symtable-ref scopes) + [:var] nil)) + (for [x (cons f xs)] + (expand (scm/rescope x stx) env store-atom)))))) -(defn expand-library [lib]) +(defn import-primitives+builtins [scopeholder env-atom store-atom] + (let [scopes (scm/syntax-context scopeholder) + additions (concat (for [p primitives] + [p + [:global p] + [:primitive p]]) + (for [b builtins] + [b + [:global b] + [:var]]))] + (swap! env-atom #(into % (for [[_sym bind denot] additions] + [bind denot]))) + (swap! store-atom #(into % (for [[sym bind _denot] additions] + [[sym scopes] bind]))))) + +(defn expand-library [lib] + (let [scopeholder (scm/new-scopeholder) + env-atom (atom {}) + store-atom (atom {})] + (update + lib + :library/declarations + (fn [decls] + (for [decl decls] + (match decl + [:import import-name] + (do (if (= import-name '(primitives+builtins)) + (import-primitives+builtins scopeholder env-atom store-atom) + (throw (Exception. "todo"))) + decl) + [:begin & xs] + (->> (for [x xs] + (expand (scm/rescope x scopeholder) + @env-atom store-atom)) + (cons :begin) + vec))))))) (comment + (-> "t.scm" + slurp + (scm/read-syntax :library? true) + expand-library) (let [scopeholder (scm/new-scopeholder) env {[:global 'lambda] [:primitive 'lambda]} store-atom (atom {['lambda #{}] [:global 'lambda]})] diff --git a/src/scm.clj b/src/scm.clj index ebe7f1e..574ee79 100644 --- a/src/scm.clj +++ b/src/scm.clj @@ -135,7 +135,7 @@ 키워드 인수: • :syntax? 참이면 syntax object를 생성함. `read` 작업의 결과로 - 생성된 콘텍스트 필드는 초기에 비어 있다. 이후 `expand/expand` + 생성된 콘텍스트 필드는 초기에 비어 있다. 이후 `expand/expand**` 작업을 통해 콘택스트 필드를 채울 수 있다. • :library? 참이면 R⁷RS define-library form으로 파싱하고, 그렇지 않으면 데이텀으로 파싱함. @@ -148,9 +148,7 @@ instaparse {}}}] (let [r (insta/parse r7rs-parser text :start (if library? :library-start :datum-start) - instaparse) - #_#_scopeholder (when syntax? - (->Syntax nil #{(new-scope "toplevel_")}))] + instaparse)] (if (insta/failure? r) (if throw? (throw (ex-info "reader error" {:err r})) @@ -173,7 +171,6 @@ ;; 과정할 수 있었더다. 작업 한 개만으로 syntax object들 다 ;; 만들 수 있어서 이럼은 더 좋다. :datum #(if syntax? - #_(datum->syntax % scopeholder) (datum->syntax %) %) :number identity diff --git a/t.scm b/t.scm index ca37804..e9f1fb8 100644 --- a/t.scm +++ b/t.scm @@ -1 +1,4 @@ -(lambda (x) x) +(define-library (blah) + (import (primitives+builtins)) + (begin + (lambda (x) x))) diff --git a/test/expand_test.clj b/test/expand_test.clj index 7d6d24f..e1312a0 100644 --- a/test/expand_test.clj +++ b/test/expand_test.clj @@ -32,10 +32,9 @@ '{[: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]})))) +(t/deftest expand-test) ;;; specs