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