src/expand.clj

@@ -5,19 +5,33 @@
             [clojure.set :as set]))
 
 (def primitives
-  #{'let 'let-syntax 'letrec 'lambda 'syntax-rules 'if})
+  #{'let 'let-syntax 'letrec 'lambda 'syntax-rules 'if 'define
+    'define-syntax})
 
 (s/def ::binding
   #(match %
      [:lexical sym uniq] (and (symbol? sym) (symbol? uniq))
      [:global sym] (symbol? sym)))
 
-(s/def ::pattern any?)
+(s/def ::pattern
+  (s/or :var symbol?
+        :list (s/coll-of ::pattern :kind sequential?)
+        :lit ::literal))
 
-(s/def ::template any?)
+(s/def ::literal (some-fn string? boolean? number? char?))
+
+(s/def ::template
+  (s/or :var symbol?
+        :lit ::literal
+        :list (s/and (s/* ::template-element) sequential?)))
+
+(s/def ::template-element
+  (s/cat :template ::template :ellipsis (s/? #{'...})))
 
 (s/def ::rule
-  (s/tuple ::pattern ::template))
+  (s/and sequential?
+         (s/cat :pattern ::pattern
+                :template ::template)))
 
 (s/def ::transformer
   (dict {:rules (s/coll-of ::rule :kind sequential?)}))
@@ -38,6 +52,44 @@
             (s/map-of (s/coll-of ::scope :kind set?)
                       ::binding)))
 
+(s/def ::formals
+  (s/coll-of symbol? :kind sequential?))
+
+(s/def ::body
+  (s/+ any?))
+
+(s/def ::prim-lambda
+  (s/cat :keyword symbol?
+         :formals ::formals
+         :body ::body))
+
+(s/def ::prim-let
+  (s/cat :keyword symbol?
+         :bindings (s/coll-of #(and (sequential? %)
+                                    (= 2 (count %))
+                                    (symbol? (first %)))
+                              :kind sequential?)
+         :body ::body))
+
+(s/def ::prim-let-syntax ::prim-let)
+
+(s/def ::prim-syntax-rules
+  (s/cat :keyword symbol
+         :keywords (s/coll-of symbol?)
+         :rules (s/* ::rule)))
+
+(defn parse-pattern [pat]
+  (cond (seq? pat)
+        (loop [xs pat
+               acc {:type :list :leading []}]
+          (match xs
+            ([x '... & ys] :seq) (-> acc
+                                     (assoc :ellipsis x :trailing (seq ys))
+                                     (update :leading seq))
+            ([] :seq) (update acc :leading seq)
+            ([x & ys] :seq) (recur ys (update acc :leading #(conj % x)))))
+        (symbol? pat) pat))
+
 
 
 (defn symtable-for-env [env]
@@ -46,9 +98,12 @@
           [x {#{} [:global x]}])))
 
 (def scheme-base-env
-  (into {[:global 'λ] [:primitive 'lambda]}
-        (for [p primitives]
-          [[:global p] [:primitive p]])))
+  (merge
+   {[:global 'λ] [:primitive 'lambda]}
+   (into {} (for [p primitives]
+              [[:global p] [:primitive p]]))
+   (into {} (for [b '(+ - * / car cdr cons)]
+              [[:global b] [:var]]))))
 
 (defn nearest [[sym scopes] ss]
   (when-some [xs (->> ss
@@ -90,7 +145,7 @@
 
 (defmethod expand-primitive 'lambda
   [datum _ env symtable-ref scopes]
-  (let [[_ formals & body] datum
+  (let [{:keys [formals body]} (s/conform ::prim-lambda datum)
         scopes* (conj scopes (new-scope))
         env* (apply merge env
                     (for [x formals]
@@ -100,18 +155,34 @@
             (for [e body]
               (expand e env* symtable-ref scopes*)))))
 
+(defmethod expand-primitive 'let
+  [datum _ env symtable-ref scopes]
+  (let [{:keys [bindings body]} (s/conform ::prim-let datum)
+        scopes* (conj scopes (new-scope))
+        env* (apply merge env
+                    (for [[x _] bindings]
+                      (bind-lexical [x scopes*]
+                                    [:var] symtable-ref)))]
+    (concat (list 'let bindings)
+            (for [e body]
+              (expand e env* symtable-ref scopes*)))))
+
 (defn expand
   ([datum]
    (expand
     datum scheme-base-env (atom (symtable-for-env scheme-base-env)) #{}))
   ([datum env symtable-ref scopes]
    (match datum
+     ;; literals
      (x :guard (some-fn boolean? number?)) x
+     ;; variables
      (x :guard symbol?)
      (do (lookup [x scopes] env @symtable-ref)
          x)
-     ([(f :guard symbol?) & xs] :seq)
+     ;;
+     ([f & xs] :seq)
      (match (lookup [f scopes] env @symtable-ref)
        [:primitive prim] (expand-primitive
-                          datum prim env symtable-ref scopes)))))
-
+                          datum prim env symtable-ref scopes)
+       _ (cons (expand f env symtable-ref scopes)
+               (map #(expand % env symtable-ref scopes) xs))))))

test/expand_test.clj

@@ -18,9 +18,66 @@
            (sut/nearest ['x #{0 1 2}]
                         [#{0} #{0 1} #{0 3}]))))
 
+(t/deftest parse-pattern-test
+  (t/testing "list"
+    (t/are [l e t x] (= [l e t]
+                        ((juxt :leading :ellipsis :trailing)
+                         (sut/parse-pattern x)))
+      nil nil nil '()
+      '(a) nil nil '(a)
+      '(a b) nil nil '(a b)
+      '(a) 'b nil '(a b ...)
+      '(a) 'b '(c) '(a b ... c)
+      '(a) 'b '(c d) '(a b ... c d)))
+  (t/testing "simple data"
+    (t/is (= 'a (sut/parse-pattern 'a)))))
+
 (t/deftest expand-test
   (t/testing "unbound symbol"
     (t/is (thrown? Exception (sut/expand 'x))))
-  (t/testing "identity fn"
+  (t/testing "lambda"
     (t/is (= '(lambda (x) x)
-             (sut/expand '(λ (x) x))))))
+             (sut/expand '(λ (x) x)))))
+  (t/testing "let"
+    (t/is (= '(let ((x 123)
+                    (y 456))
+                (+ x y))
+             (sut/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)))))))
+
+(t/deftest prim-lambda-spec
+  (t/is (s/valid? ::sut/prim-lambda '(lambda (x) x)))
+  (t/is (s/valid? ::sut/prim-lambda '(lambda (x) (display x) (newline)))))
+
+(t/deftest prim-let-spec
+  (t/is (s/valid? ::sut/prim-let '(let ((x 123)
+                                        (y 456))
+                                    (+ x y)))))
+
+(t/deftest prim-let-syntax-spec
+  (t/is (s/valid? ::sut/prim-let-syntax
+                  '(let-syntax ((m (syntax-rules ()
+                                     ((m) 123))))
+                     (m)))))
+
+(t/deftest template-spec
+  (t/is (s/valid? ::sut/template '(x ... y)))
+  (t/is (s/valid? ::sut/template 123))
+  (t/is (s/valid? ::sut/template '(x y ... z ... a b c))))
+
+(t/deftest pattern-spec
+  (t/is (s/valid? ::sut/pattern '(m))))
+
+(t/deftest rule-spec
+  (t/is (s/valid? ::sut/rule '((m) 123))))
+
+(t/deftest prim-syntax-rules-spec
+  (t/is (s/valid? ::sut/prim-syntax-rules
+                  '(syntax-rules
+                    ()
+                    ((m) 123)))))