lispインタプリタ

core.clj

;; mini-lisp interpretor
;; org.clojure/clojure 1.3.0
;; org.clojure/clojure-contrib 1.2.0
;; Leiningen 1.6.1 on Java 1.6.0_23 OpenJDK Client VM

(ns mini-lisp.core
  (:use [clojure.inspector :include [atom?]])
  (:gen-class))

(def prompt "=> ")
(def banner-message "mini-lisp interpretor")

(declare my-eval)

(defn eval-quote [exp _]
  (second exp))

(defn eval-if [exp env]
  (if (my-eval (second exp))
    (my-eval (nth exp 3) env)
    (my-eval (nth exp 4) env)))

(defn eval-progn [exp env]
  (doseq [e exp]
    (my-eval e env)))

(defn eval-defun [exp env]
  "(defun name [arg] (body))"
  (let [name (nth exp 1)
        args (nth exp 2)
        body (nth exp 3)]
    (do
      (dosync
       (ref-set env (assoc @env name (eval `(fn ~name ~args ~body)))))
      name)))

(defn eval-lambda [exp env]
  (let [args (nth exp 1)
        body (nth exp 2)]
    (fn [& r]
      (my-eval body (ref (reduce #(assoc %1 (first %2) (second %2))
                                 @env (map list args r)))))))

(defn my-eval [exp env]
  ;; (println "eval :" exp)
  (cond
   (symbol? exp) (get @env exp)
   (atom?   exp)  exp
   :else (case (first exp)
               quote  (eval-quote  exp env)
               defun  (eval-defun  exp env)
               if     (eval-if     exp env)
               progn  (eval-progn  exp env)
               lambda (eval-lambda exp env)
               ;; default
               (apply (my-eval (first exp) env)
                      (map #(my-eval % env) (rest exp))))))

(defn make-env []
  (ref (-> {}
           (assoc '+ (fn [& args] (apply + args)))
           (assoc '- (fn [& args] (apply - args)))
           (assoc '* (fn [& args] (apply * args)))
           (assoc '/ (fn [& args] (apply / args)))

           (assoc '= (fn [& args] (apply = args)))
           (assoc '< (fn [& args] (apply < args)))
           (assoc '> (fn [& args] (apply > args)))

           (assoc '<= (fn [& args] (apply <= args)))
           (assoc '>= (fn [& args] (apply >= args)))
           (assoc '== (fn [& args] (apply == args)))

           (assoc 'atom? (fn [arg] (atom? arg)))
           (assoc 'car (fn [arg] (first arg)))
           (assoc 'cdr (fn [arg] (rest arg)))
           (assoc 'cons (fn [a b] (list a b)))
           (assoc 'list (fn [& args] (apply list args)))

           (assoc 'print (fn [& args] (apply println args))))))

(defn -main [& args]
  (do
    (println banner-message)
    (let [env (make-env)]
      (loop []
        (do
          (print prompt)
          (flush)
          (println (my-eval (read) env))
          (recur))))))