Chapter 1 from Lisp in Small Pieces

lisp_ch1.clj

(ns lisp-ch1)

(def self-evaluating?
  (some-fn number? string? char?
           true? false? vector?))

(defn -atom? [s]
  (or (self-evaluating? s)
      (symbol? s)))

(defn -wrong [& msg]
  (throw (RuntimeException. (apply str msg))))

(defn -eprogn [[head & tail] env]
  (if tail
    (do (evaluate head env)
        (recur tail env))
    (evaluate head env)))

(defn -extend [env names values]
  (let [bindings @env]
    (atom
     (if (symbol? names)
       (assoc bindings names values)
       (if (= (count names) (count values))
         (merge bindings (zipmap names values))
         (-wrong "Too few values"))))))

(defn -make-function [params body env]
  (fn [values]
    (-eprogn body (-extend env params values))))

(defn -invoke [f args]
  (if (fn? f)
    (f args)
    (-wrong "Not a function " f)))

(defn evaluate
  [expr env]
  (if (-atom? expr)
    (cond (symbol? expr) (expr @env)
          (self-evaluating? expr) expr
          :else (-wrong "Cannot evaluate " expr))
    (let [[head & [second third fourth :as tail]] expr]
      (condp = head
        'quote  second
        'if     (if (evaluate second env)
                  (evaluate third env)
                  (evaluate fourth env))
        'begin  (-eprogn tail env)
        'set!   (let [value (evaluate third env)]
                  (swap! env assoc second value)
                  value)
        'lambda (-make-function second (rest tail) env)
        (-invoke (evaluate head env)
                 (map #(evaluate % env) tail))))))

(comment
  (evaluate 'a (atom '{a 42}))

  (evaluate '(quote a) (atom '{a 42}))

  (evaluate '(begin (quote a) (quote b))
            (atom '{a 42}))

  (evaluate 42 (atom '{a 42}))

  (evaluate true (atom '{a 42}))

  (evaluate '(set! b 36) (atom '{a 42}))

  (evaluate '(begin (set! b a) (set! a 108))
            (atom '{a 42}))
)

(defmacro bind [env name value]
  `(assoc ~env (quote ~name) ~value))

(defmacro primitive [env name f arity]
  `(bind ~env ~name
         (fn [values#]
           (let [len# (count values#)]
             (if (= ~arity len#)
               (apply ~f values#)
               (-wrong "Wrong number of args passed to "
                      ~'name
                      ", expected "
                      ~arity
                      ", got "
                      len#))))))

(defmacro predicate [env name f arity]
  `(primitive ~env ~name
              (fn [values#]
                (or (apply ~f values#)
                    nil))
              ~arity))

(defmacro defenv [& decls]
  `(atom
    (-> {}
        ~@decls)))

(def globals
  (defenv
     (bind |f| nil)
     (bind |t| true)
     (primitive cons cons 2)
     (primitive car first 1)
     (primitive cdr rest 1)
     (primitive + + 2)
     (primitive - - 2)
     (primitive remainder rem 2)
     (primitive quotient quot 2)
     (primitive display #(print %) 1)
     (primitive newline #(println) 0)     
     (predicate <= <= 2)
     (predicate >= >= 2)
     (predicate = = 2)
     (predicate > > 2)
     (predicate < < 2)
     (primitive * * 2)
     (predicate symbol? symbol? 1)
     (predicate eq? = 2)))

(comment
  (evaluate '|t| globals)
  (evaluate '|f| globals)
  (evaluate '(+ 1 2) globals)
  (evaluate '(car (quote (1 2))) globals)
  (evaluate '(cdr (quote (1 2))) globals)
  (evaluate '(cons 0 (quote (1 2))) globals)
  (evaluate '(begin (set! pi 3.14) pi) globals)
  (evaluate '(begin (set! make-adder
                          (lambda (n)
                            (lambda (x)
                              (+ x n))))
                    (set! add100 (make-adder 100))
                    (add100 42))
            globals)
)