import prims

resources/scm/scheme/base.scm

@@ -0,0 +1,3 @@
+(define-library (scheme base)
+  (export lambda)
+  (import (scheme primitives)))

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

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

t.scm

@@ -1 +1,4 @@
-(lambda (x) x)
+(define-library (blah)
+  (import (primitives+builtins))
+  (begin
+    (lambda (x) x)))

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