gistfile1.clj

(defmulti -exec (comp peek :control))

(defmethod -exec 'NIL
  [{:keys [stack env control dump] :as registers}]
  (-> registers
      (update-in [:stack] conj nil)
      (update-in [:control] pop)))

(defmethod -exec 'LDC
  [{:keys [stack env control dump] :as registers}]
  (-> registers
      (update-in [:stack] conj (peek (pop control)))
      (update-in [:control] (comp pop pop))))

(defmethod -exec 'LD
  [{:keys [stack env control dump] :as registers}]
  (-> registers
      (update-in [:stack] conj (get-in env (peek (pop control))))
      (update-in [:control] (comp pop pop))))

(defmethod -exec 'SEL
  [{:keys [stack env control dump] :as registers}]
  (let [[ct cf] [(take 2 (rseq (pop control)))]]
    (-> registers
        (update-in [:stack] pop)
        (update-in [:dump] conj (pop (pop (pop control))))
        (update-in [:control] (constantly (case (peek stack)
                                            true ct
                                            false cf))))))

(defmethod -exec 'JOIN
  [{:keys [stack env control dump] :as registers}]
  (-> registers
      (update-in [:control] (constantly (peek dump)))
      (update-in [:dump] pop)))

(defmethod -exec 'LDF
  [{:keys [stack env control dump] :as registers}]
  (-> registers
      (update-in [:control] (comp pop pop))
      (update-in [:stack] conj [(peek (pop control)) env])))

(defmethod -exec 'AP
  [{:keys [stack env control dump] :as registers}]
  (let [[[f env'] v stack] [(peek stack) (peek (pop stack)) (pop (pop stack))]]
    (-> registers
        (assoc-in [:stack] [])
        (assoc-in [:env] (conj env' v))
        (assoc-in [:control] f)
        (update-in [:dump] conj (pop control) env stack))))

(defmethod -exec 'RTN
  [{:keys [stack env control dump] :as registers}]
  (let [[S E C D] (rseq dump)]
    (-> registers
        (assoc-in [:stack] (conj S (pop stack)))
        (assoc-in [:env] E)
        (assoc-in [:control] C)
        (assoc-in [:dump] D))))

(defmethod -exec 'DUM
  [{:keys [stack env control dump] :as registers}]
  (-> registers
      (update-in [:env] conj nil)
      (update-in [:control] pop)))

(defmethod -exec 'RAP
  [{:keys [stack env control dump] :as registers}]
  (let [[[f [_ env]] v stack]
        [(peek stack) (peek (pop stack)) (pop (pop stack))]]
    (-> registers
        (assoc-in [:stack] nil)
        (update-in [:env] conj (conj (pop v) (conj env nil)))
        (assoc-in [:control] f)
        (update-in [:dump] conj (pop control) env stack))))

(defmethod -exec 'STOP
  [{:keys [stack env control dump debug?] :as registers}]
  (if debug?
    (update-in registers [:control] pop)
    (System/exit 0)))

(defmethod -exec 'READC
  [{:keys [stack env control dump] :as registers}]
  (-> registers
      (update-in [:stack] conj (char (clojure.lang.LispReader/read1 *in*)))
      (update-in [:control] pop)))

(defmethod -exec 'WRITEC
  [{:keys [stack env control dump] :as registers}]
  (print (peek stack))
  (-> registers
      (update-in [:stack] pop)
      (update-in [:control] pop)))

(defn exec-builtin
  [builtin arity {:keys [stack env control dump] :as registers}]
  (let [[ret stack]
        (case (int arity)
          1 [(builtin (peek stack)) (pop stack)]
          2 [(builtin (peek stack) (peek (pop stack))) (pop (pop stack))])]
    (-> registers
        (assoc-in [:stack] (conj stack ret))
        (update-in [:control] pop))))

(defmethod -exec 'PEEK
  [{:keys [stack env control dump] :as registers}]
  (exec-builtin peek 1 registers))

(defmethod -exec 'POP
  [{:keys [stack env control dump] :as registers}]
  (exec-builtin pop 1 registers))

(defmethod -exec 'ATOM
  [{:keys [stack env control dump] :as registers}]
  (exec-builtin (complement seq?) 1 registers))

(defmethod -exec 'PUSH
  [{:keys [stack env control dump] :as registers}]
  (exec-builtin conj 2 registers))

(defmethod -exec 'EQ
  [{:keys [stack env control dump] :as registers}]
  (exec-builtin identical? 2 registers))

(defmethod -exec 'ADD
  [{:keys [stack env control dump] :as registers}]
  (exec-builtin + 2 registers))

(defmethod -exec 'SUB
  [{:keys [stack env control dump] :as registers}]
  (exec-builtin - 2 registers))

(defmethod -exec 'MUL
  [{:keys [stack env control dump] :as registers}]
  (exec-builtin * 2 registers))

(defmethod -exec 'DIV
  [{:keys [stack env control dump] :as registers}]
  (exec-builtin / 2 registers))

(defmethod -exec 'REM
  [{:keys [stack env control dump] :as registers}]
  (exec-builtin rem 2 registers))

(defmethod -exec 'LEQ
  [{:keys [stack env control dump] :as registers}]
  (exec-builtin <= 2 registers))

(defn builtin?
  [x]
  (contains? '#{PEEK POP ATOM PUSH EQ ADD SUB MUL DIV REM LEQ} x))

(defmethod -exec :default
  [{:keys [stack env control dump] :as registers}]
  (update-in registers [:control] pop))

(defn exec
  [input]
  (loop [in {:stack [] :env [] :control input :dump [] :debug? true :ns 'user}]
    (let [{:keys [stack env control dump debug?] :as out} (-exec in)]
      (if (seq control)
        (recur out)
        (peek stack)))))