From Lisp in Small Pieces chapter 2

lisp3.clj

(ns ^{:doc "The lisp_3 evaluator from ch2 of Lisp in Small Pieces"}
  lisp.chapter2.lisp3
  (:refer-clojure :exclude [extend]))

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

(defprotocol IEnvironment
  (lookup [_ k]
    "Retrieve value of k in environment."))

(defprotocol IMutableEnvironment
  
  (update! [_ k v]
    "Set internal state. Assumes binding exists for update.")

  (initialise! [_ k v]
    "Provide a new binding and initial value."))

(defprotocol IExtensibleEnvironment
  "Return new environment extending the old with supplied bindings."
  (extend [_ ks vs]))

(deftype AtomAListEnvironment [a-list]

  IEnvironment
  (lookup [_ k]
    (letfn [(lookup* [id r]
              (let [[[k v] & n] r]
                (if (= k id)
                  (if (= v :uninitialised)
                    (wrong "Uninitialised binding" id)
                    v)
                  (if n
                    (lookup* id n)
                    (wrong "No such binding: " id)))))]
      (lookup* k @a-list)))

  IMutableEnvironment
  (update! [_ k 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! a-list update k v)
      v))

  (initialise! [_ k v]
    (swap! a-list #(cons [k v] %)))

  IExtensibleEnvironment
  (extend [_ ks vs]
    (letfn [(extend* [env ks vs]
              (cond
               (seq? ks) (if (not (empty? ks))
                                  (if (seq? vs)
                                    (cons [(first ks) (first vs)]
                                          (extend* env (rest ks) (rest vs)))
                                    (wrong "Too few values"))
                                  (if (empty? ks)
                                    env
                                    (wrong "Too many values")))
               (symbol? vs) (cons [ks vs] env)))]
      (AtomAListEnvironment.
       (atom
        (extend* @a-list ks vs))))))

(defn make-env []
  (AtomAListEnvironment. (atom '())))

(declare evlis eprogn make-function evaluate-application)
(defmulti evaluate-sexp (fn [sexp env fenv denv] (first sexp)))

(defn evaluate
  [e env fenv denv]
  (if (not (seq? e))
    ;; atom
    (cond
     (symbol? e) (lookup env e)
     (or (number? e) (string? e) (char? e) (= true e) (= false e) (vector? e)) e
     :else (wrong "Cannot evaluate " e))
    ;; else
    (evaluate-sexp e env fenv denv)))

(defmethod evaluate-sexp 'quote [[q x] env fenv denv]
  x)

(defmethod evaluate-sexp 'if [[s c t f & more] env fenv denv]
  (if (evaluate c  env fenv denv)
    (evaluate t env fenv denv)
    (evaluate f env fenv denv)))

(defmethod evaluate-sexp 'begin [[b & more] env fenv denv]
  (eprogn more env fenv denv))

(defmethod evaluate-sexp 'set! [[s k v] env fenv denv]
  (update! env k (evaluate v env fenv denv)))

(defmethod evaluate-sexp 'lambda [[l args & exps] env fenv denv]
  (make-function args exps env fenv))

(defmethod evaluate-sexp 'function [[_ f] env fenv denv]
  (if (symbol? f)
    (lookup fenv f)
    (wrong "Incorrect function " f)))

(defmethod evaluate-sexp 'flet [[_ bindings & body] env fenv denv]
  (eprogn
   body
   env
   (extend fenv
     (map first bindings)
     (map (fn [[name args & fbody]] (make-function args fbody env fenv)) bindings))
   denv))

;; from Exercise 2.8... essentially flet but allowing recursion (as
;; per clojure's letfn) - mutates fenv
(defmethod evaluate-sexp 'labels [[_ bindings & body] env fenv denv]
  (let [fenv+ (extend fenv (map first bindings) (repeat :uninitialised))]
    (doall
     (map (fn [[name args & fbody]] (update! fenv+ name (make-function args fbody env fenv+))) bindings))
    (eprogn body env fenv+ denv)))

(defmethod evaluate-sexp 'dynamic [[_ n] env fenv denv]
  (lookup denv n))

(defmethod evaluate-sexp 'dynamic-set! [[_ n v] env fenv denv]
  (update! denv n (evaluate v env fenv denv)))

(defmethod evaluate-sexp 'dynamic-let [[_ bindings & body] env fenv denv]
  (eprogn body
          env
          fenv
          (extend denv
            (map first bindings)
            (map (fn [[k v]] (evaluate v env fenv denv)) bindings))))

(defmethod evaluate-sexp 'let [[_ bindings body] env fenv denv]
  (eprogn
   body
   (extend env
     (map (fn [binding]
            (if (symbol? binding) binding (first binding))) bindings)
     (map (fn [binding]
            (if (symbol? binding) :uninitialised (evaluate (second binding) env fenv denv))) bindings))
   fenv denv))

(defmethod evaluate-sexp :default [[f & args] env fenv denv]
  (evaluate-application f
                        (evlis args env fenv denv)
                        env
                        fenv
                        denv))


(defn evlis [exps env fenv denv]
  (map #(evaluate % env fenv denv) exps))

(defn eprogn [exps env fenv denv]
  (if (seq exps)
    (last (evlis exps env fenv denv))
    '()))

(defn make-function [args body env fenv]
  (fn [vals denv]
    (eprogn body (extend env args vals) fenv denv)))

(defn evaluate-application [fn args env fenv denv]
  (cond
   (symbol? fn) ((lookup fenv fn) args denv)
   (and (seq fn) (= (first fn) 'lambda)) (eprogn (rest (rest fn))
                                            (extend env (second fn) args)
                                            fenv
                                            denv)
   :else (wrong "Incorrect functional term " fn)))

(def env-global (make-env))
(def fenv-global (make-env))
(def denv-global (make-env))

(defmacro definitial
  ([name]
     `(initialise! env-global '~name :uninitialised))
  ([name value]
     `(initialise! env-global '~name ~value)))

(defmacro definitial-function
  ([n]
     `(initialise! fenv-global '~n :uninitialised))
  ([n value]
     `(initialise! fenv-global '~n ~value)))

(defmacro defprimitive [name value arity]
  `(definitial-function ~name
     (fn [values# denv#]
       (if (= ~arity (count values#))
         (~value values# denv#)
         (wrong "Incorrect arity" (list '~name values#))))))

(definitial-function funcall
  (fn [[f & args] denv]
    (if f
      (f args denv)
      f)))

(defprotocol MutableCons
  (mcar [self])
  (mcdr [self])
  (mset-car! [self val])
  (mset-cdr! [self val]))

(deftype ArrayCons [ar]
  MutableCons
  (mcar [_] (aget ar 0))
  (mcdr [_] (aget ar 1))
  (mset-car! [_ val] (aset ar 0 val))
  (mset-cdr! [_ val] (aset ar 1 val)))

(defn mcons [a b]
  (ArrayCons. (into-array Object [a b])))

(defn with-denv
  "Wrap a function with a version that also accepts a dynamic
  environment."
  [f]
  (fn [args denv]
    (apply f args)))

(defprimitive car (with-denv mcar) 1)
(defprimitive cdr (with-denv mcdr) 1)
(defprimitive cons (with-denv mcons) 2)
(defprimitive set-car! (with-denv mset-car!) 2)
(defprimitive set-cdr! (with-denv mset-cdr!) 2)
(defprimitive + (with-denv +) 2)
(defprimitive - (with-denv -) 2)
(defprimitive eq? (with-denv =) 2)
(defprimitive < (with-denv <) 2)

(definitial nul nil)
(definitial |t| true)
(definitial |f| false)
(definitial x)
(definitial y)
(definitial z)
(definitial foo)
(definitial bar)
(definitial fib)
(definitial fact)

(defn chapter2-lisp3 []
  (loop []
    (print "\n>")
    (flush)
    (pr (evaluate (read) env-global fenv-global denv-global))
    (flush)
    (recur)))

(defn -main []
  (chapter2-lisp3))

(comment
  (flet ((f (x) (+ x (dynamic y))))
        (dynamic-let ((y 2)) (f 3)))

  (set! x (quote a-sym))
  
  (dynamic-let ((x (quote dyn)))
               (car (cdr ((lambda (x) (cons x (cons (dynamic x) nul)))
                          (quote param)))))

  (labels ((odd? (x) (if (eq? 0 x) |f| (even? (- x 1))))
           (even? (x) (if (eq? 0 x) |t| (odd? (- x 1)))))
          (even? 4))

  (flet ((invoke (f x) (funcall f x))
         (g (x) 'hello))
        (invoke (function g) 'ignored)))