Lisp in Small Pieces of Clojure - chapter one

eval.clj

(ns ^{:doc "Evaluator from ch1 of lisp in small pieces. Warning:
  NON-IDIOMATIC clojure!"}
  lisp.chapter1.eval
  (:refer-clojure :exclude [extend]))

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

;; -- runtime support, environments are represented as a seq of pairs,
;; -- stored in an atom. Non-idiomatic but faithful to the book.

(defn lookup
  "Lookup symbol id in environment env. Environment is atom containing
  seq of pairs."
  [id env]
  (letfn [(lookup* [id r]
            (let [[[k v] & n] r]
              (if (= k id)
                v
                (if n
                  (lookup* id n)
                  (wrong "No such binding: " id)))))]
    (lookup* id @env)))

(defn update!
  "Mutate environment to set id to v. Assumes id already exists."
  [id env v]
  (letfn [(update [r id v]
            (if (seq r)
              (if (= (ffirst r) id)
                (cons [id v] (rest r))
                (cons (first r) (update (rest r) id v)))
              (wrong "No such binding" id)))]
    (swap! env update id v)
    v))

(defn- extend*
  "Extend environment (internal), return extended env."
  [r ns vs]
  (cond
   (seq? ns) (if (not (empty? ns))
               (if (seq? vs)
                 (cons [(first ns) (first vs)]
                       (extend* r (rest ns) (rest vs)))
                 (wrong "Too few values"))
               (if (empty? ns)
                 r
                 (wrong "Too many values")))
   (symbol? vs) (cons [ns vs] r)))

(defn extend [env ns vs]
  (atom (extend* @env ns vs)))

(def env-init (atom '()))

;; -- the interpreter, relies on underlying clojure for values of
;; -- booleans, and so on (and for read, obivously)

(declare evlis eprogn make-function invoke)

(defn evaluate
  "Evaluate form e in environment r."
  [e r]
  (if (not (seq? e))
    ; atom
    (if (symbol? e)
      (lookup e r)
      e) ; implicit quote
    ; list
    (case (first e)
      quote (second e)
      if (let [[c t f] (rest e)] (if (evaluate c r) (evaluate t r) (evaluate f r)))
      begin (eprogn (rest e) r)
      set! (let [[k v] (rest e)] (update! k r (evaluate v r)))
      lambda (let [[args & es] (rest e)] (make-function args es r))
      ;else 
      (invoke (evaluate (first e) r)
              (evlis (rest e) r)))))

(defn eprogn
  "Evaluate expressions es sequentially in environment r. Return last value."
  [es r]
  (if (seq es)
    (last (map #(evaluate % r) es))
   '()))

(defn evlis
  "Evaluate expressions and return list of values."
  [as r]
  (map #(evaluate % r) as))

(defn invoke
  "Function represented as fn that takes a single list argument."
  [f args]
  (if (fn? f)
    (f args)
    (wrong "Not a function")))

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

;; -- the global environment

(def env-global env-init)

(defmacro definitial
  ([name]
     `(do
        (swap! env-global #(cons ['~name 'void] %))
        '~name))
  ([name value]
     `(do
        (swap! env-global #(cons ['~name ~value] %))
        '~name)))

(defmacro defprimitive [name value arity]
  `(definitial ~name
     (fn [values#]
       (if (= ~arity (count values#))
         (apply ~value values#) ;; clojure's apply
         (wrong "Incorrect arity" (list '~name values#))))))

;; These don't hide clojure's own true and false though as they're
;; handled directly be the clojure reader and will pass right through
;; the implicit quoting in the evaluator. (They're not even symbols as
;; they're never exposed to the evaluator as anything other than a
;; boolean.) So it's an approach different again from that of special
;; forms #t and #f which are added to the evaluator at one point in
;; chapter one.
(definitial t true)
(definitial f false)
(definitial nil '())

;; As we have no way of extending the global environment yet. 
(definitial foo)
(definitial bar)
(definitial fib)
(definitial fact)

;; Let's provide a more traditional cons cell to the child lisp
;; otherwise clojure's immutability doesn't give us an easy means of
;; providing our lisp with a set-cdr!
(defprotocol MutableCons
  (mcar [self])
  (mcdr [self])
  (mset-car! [self val])
  (mset-cdr! [self val]))

;; ...and use some real shonk to get a low-level mutable type.
;; This is as ugly as it looks but we're single-threaded only
;; and this is expressly a toy and nothing more.
(deftype Cell [^{:unsynchronized-mutable true} a ^{:unsynchronized-mutable true} b]
  MutableCons
  (mcar [self] a)
  (mcdr [self] b)
  (mset-car! [self val] (set! a val))
  (mset-cdr! [self val] (set! b val))

  Object
  (toString [self] (str "(" a " . " b ")")))

(defn mcons [a b]
  (Cell. a b))

;; Expose a few lisp basics
(defprimitive cons mcons 2)
(defprimitive car mcar 1)
(defprimitive cdr mcdr 1)
(defprimitive set-car! mset-car! 2)
(defprimitive set-cdr! mset-cdr! 2)
(defprimitive + + 2)
(defprimitive - - 2)
(defprimitive eq? = 2)
(defprimitive < < 2)

;; And finally a dumb repl...
(defn chapter1-scheme []
  (loop []
    (print "\n> ")
    (flush)
    (pr (evaluate (read) env-global))
    (flush)
    (recur)))

(comment

  ;; we have mutable cons cells, but printing leaves much to be desired
  (set! foo (cons 1 2))
  ;; => #<Cell (1 . 2)>
  (set-cdr! foo (cons 2 nil))
  ;; => #<Cell (2 . )>
  foo
  ;; => #<Cell (1 . (2 . ))>
  
  ;; truthiness is parasitic on the underlying lisp, in clojure 0 is truthy
  (if 0 (quote truthy) (quote falsey))
  ;; => truthy

  (begin (set! bar 1) (set! bar 2) bar)
  ;; => 2

  ((lambda (x) (+ x 1)) 12)
  ;; => 13

  (set! fib (lambda (x) (if (< x 2) 1 (+ (fib (- x 1)) (fib (- x 2))))))
  ;; => #<eval$make_function$fn__576 lisp.chapter1.eval$make_function$fn__576@5702cbd3>
  (fib 8)
  ;; => 34
  
  )

;; And a few modifications suggested by exercises...

;; Exercise 1.1
(defn invoke-traced
  "Function represented as fn that takes a single list argument."
  [f args]
  (if (fn? f)
    (do
      (println "Called with: " args)
      (let [ret (f args)]
        (println ";=> " ret)
        ret))
    (wrong "Not a function")))

(defn evaluate-traced
  "Evaluate form e in environment r."
  [e r]
  (if (not (seq? e))
    ; atom
    (if (symbol? e) (lookup e r) e)
    ; list
    (case (first e)
      quote (second e)
      if (let [[c t f] (rest e)] (if (evaluate c r) (evaluate t r) (evaluate f r)))
      begin (eprogn (rest e) r)
      set! (let [[k v] (rest e)] (update! k r (evaluate v r)))
      lambda (let [[args & es] (rest e)] (make-function args es r))
      ;else 
      (invoke-traced (evaluate (first e) r)
              (evlis (rest e) r)))))

(defn chapter1-scheme-traced []
  (loop []
    (print "\n> ")
    (flush)
    (pr (evaluate-traced (read) env-global))
    (flush)
    (recur)))

;; NB - this modification requires changes all the way up, through
;; evalute to the repl function which is a limitation of the current
;; design. Clearly the functions themselves could be parameterised
;; but a neater approach is suggested by the common example of
;; an interpreter that's often used in expositions of monads.
;;
;; See "The essence of functional programming" by Wadler
;; for a particularly complete example.
;;
;; http://homepages.inf.ed.ac.uk/wadler/topics/monads.html

(defn -main [& args]
  (chapter1-scheme))