diff --git a/src/expand.clj b/src/expand.clj index 8c5b265..69039ab 100644 --- a/src/expand.clj +++ b/src/expand.clj @@ -233,7 +233,6 @@ scopes))) (defn lookup [variable env symtable] - (tap> [variable env symtable]) (let [[sym scopes] (or (destructure-variable variable) (throw (ex-info "not a var" {:var variable}))) ss (symtable-scopes symtable sym)] @@ -256,8 +255,8 @@ prim-name)) (defn new-scope - ([] (gensym)) - ([prefix] (gensym prefix))) + ([] (gensym "scope__")) + ([prefix] (gensym (str "scope__" prefix)))) (defn bind-lexical [[sym scopes] denot symtable-ref] (let [bind [:lexical sym (gensym)]] @@ -447,7 +446,6 @@ (expand datum scheme-base-env (atom (symtable-for-env scheme-base-env)) #{})) ([datum env symtable-ref scopes] - (tap> datum) (match datum ;; literals (x :guard literal?) x @@ -459,11 +457,37 @@ ;; lists ([f & xs] :seq) - (if (variable? f) - (do (tap> f) - (match (lookup (offer-scopes f scopes) env @symtable-ref) + (or (when-some [v (and (variable? f) + (offer-scopes f scopes))] + (match (lookup v env @symtable-ref) [:primitive prim] (expand-primitive datum prim env symtable-ref scopes) - [:macro trans] (expand-macro trans datum env symtable-ref scopes))) - (cons (expand f env symtable-ref scopes) - (map #(expand % env symtable-ref scopes) xs)))))) + [:macro trans] (expand-macro trans datum env symtable-ref scopes) + [:var] nil)) + (cons (expand f env symtable-ref scopes) + (map #(expand % env symtable-ref scopes) xs)))))) + + + +(defn beautify + "Renumber the gensyms created by `new-scope` found in datum, + starting from zero." + [datum] + (let [c (atom 0)] + (walk/postwalk (fn [x] + (if (and (symbol? x) + (clojure.string/starts-with? + (name x) + "scope__")) + (symbol (str "s" (first (swap-vals! c inc)))) + x)) + datum))) + +(defn unscope + "Remove all scopes from the variables found in datum." + [datum] + (walk/postwalk (fn [x] + (if (instance? Variable x) + (variable-symbol x) + x)) + datum)) diff --git a/test/expand_test.clj b/test/expand_test.clj index 7aa1b03..e53bfc8 100644 --- a/test/expand_test.clj +++ b/test/expand_test.clj @@ -43,12 +43,15 @@ (t/testing "simple data" (t/is (= 'a (s/conform ::patern 'a))))) +(defn- us-expand [datum] + (sut/unscope (sut/expand datum))) + (t/deftest expand-test (t/testing "unbound symbol" (t/is (thrown? Exception (sut/expand 'x)))) (t/testing "lambda" (t/is (= '(lambda (x) x) - (sut/expand '(λ (x) x))))) + (us-expand '(λ (x) x))))) #_(t/testing "syntax-rules" (t/is (= '(lambda (x) x) (sut/expand @@ -59,13 +62,13 @@ (t/is (= '(let ((x 123) (y 456)) (+ x y)) - (sut/expand + (us-expand '(let ((x 123) (y 456)) (+ x y)))))) (t/testing "application" (t/is (= '(lambda (f x) (f x)) - (sut/expand '(lambda (f x) (f x))))))) + (us-expand '(lambda (f x) (f x))))))) (t/deftest prim-lambda-spec (t/is (s/valid? ::sut/prim-lambda '(lambda (x) x)))