簡易LISP処理系の実装例（Clojure版）

【他言語版へのリンク記事】[簡易LISP処理系の実装例【各言語版まとめ】](https://qiita.com/ytaki0801/items/dcb0fe48cbeab30ac40d)

この記事は，Clojureによる二種類の原初LISP評価器（["McCarthy's Original Lisp"](http://paulgraham.com/lispcode.html)）の実装をまとめたものです．

# コンスセル未対応版

ClojureはS式入出力を扱うプログラミング言語のため，LISP評価器の実装自体は容易ですが，他のLISP系言語と異なりリスト構造はコンスセルに基づくものではなく，ドット対表現も利用できません．この版では，リスト構造を基本データ構造としつつ，『原初LISP評価器の機能に相当するClojureの機能のみで原初LISP評価器を定義』しています．具体的には次の通りです．

* 実装は`'` `seq?` `=` `cons` `first` `rest` `cond` `defn`を使用
* 機能は`quote` `atom` `eq` `cons` `car` `cdr` `cond` `lambda`を提供

S式入力はClojureの`read`をそのまま使用しており，`'`についても`quote`に自動的に変換されることを想定しています．実行例（1.10.0）は次の通り**（最後の例で`(car (cdr (assoc k v)))`としていることに注意）**．

```lisp
$ clojure
Clojure 1.10.0
user=> (load-file "jmclisp.clojure")
#'user/eval_
user=> (eval_ (read) '())
(car (cdr '(10 20 30)))
20
user=> (eval_ (read) '())
((lambda (x) (car (cdr x))) '(abc def ghi))
def
user=> (eval_ (read) '())
((lambda (f x y) (f x (f y '()))) 'cons '10 '20)
(10 20)
user=> (eval_ (read) '())
((lambda (f x y) (f x (f y '())))
 '(lambda (x y) (cons x (cons y '())))
 '10 '20)
(10 (20 ()))
user=> (eval_ (read) '())
((lambda (assoc k v) (car (cdr (assoc k v))))
 '(lambda (k v)
    (cond ((eq v '()) nil)
          ((eq (car (car v)) k)
           (car v))
          ('t (assoc k (cdr v)))))
 'Orange
 '((Apple 120) (Orange 210) (Lemon 180)))
210
```

"McCarthy's Original Lisp"の詳細については[まとめ記事](https://qiita.com/ytaki0801/items/dcb0fe48cbeab30ac40d)を参照．ダイナミックスコープということもあり，実行例ではlambda式を`letrec`（Scheme）や`labels`（Common Lisp）などの代わりに使用しています．

ソースコード一式は次の通り．

```Clojure:jmclisp.clojure
; The Lisp defined in McCarthy's 1960 paper, implemented by Clojure
; derived from jmc.lisp in http://paulgraham.com/lispcode.html
; Assumes only quote, seq?, =, cons, first, rest, cond and defn

(defn car_ [x] (first x))
(defn cdr_ [x] (rest x))
(defn caar_ [x] (car_ (car_ x)))
(defn cadr_ [x] (car_ (cdr_ x)))
(defn cadar_ [x] (car_ (cdr_ (car_ x))))
(defn caddr_ [x] (car_ (cdr_ (cdr_ x))))
(defn caddar_ [x] (car_ (cdr_ (cdr_ (car_ x)))))

(defn null_ [x] (= x '()))

(defn and_ [x y] (cond x (cond y true :else false) :else false))

(defn not_ [x] (cond x false :else true))

(defn atom_ [x] (not_ (seq? x)))

(defn append_ [x y]
  (cond (null_ x) y
        :else (cons (car_ x) (append_ (cdr_ x) y))))

(defn list_ [x y] (cons x (cons y '())))

(defn pair_ [x y]
  (cond (and_ (null_ x) (null_ y))
        '()
        (and_ (not_ (atom_ x)) (not_ (atom_ y)))
        (cons (list_ (car_ x) (car_ y))
              (pair_ (cdr_ x) (cdr_ y)))))

(defn assoc_ [x y]
  (cond (null_ y) false
        (= (caar_ y) x) (cadar_ y)
        :else (assoc_ x (cdr_ y))))

(declare eval_)

(defn evcon_ [c a]
  (cond (eval_ (caar_ c) a) (eval_ (cadar_ c) a)
        :else (evcon_ (cdr_ c) a)))

(defn evlis_ [m a]
  (cond (null_ m) '()
        :else (cons (eval_  (car_ m) a)
                    (evlis_ (cdr_ m) a))))

(defn eval_ [e a]
  (cond (atom_ e) (assoc_ e a)
        (atom_ (car_ e))
          (cond (= (car_ e) 'quote) (cadr_ e)
                (= (car_ e) 'atom)  (atom_ (eval_ (cadr_  e) a))
                (= (car_ e) 'eq)    (=     (eval_ (cadr_  e) a)
                                           (eval_ (caddr_ e) a))
                (= (car_ e) 'car)   (car_  (eval_ (cadr_  e) a))
                (= (car_ e) 'cdr)   (cdr_  (eval_ (cadr_  e) a))
                (= (car_ e) 'cons)  (cons  (eval_ (cadr_  e) a)
                                           (eval_ (caddr_ e) a))
                (= (car_ e) 'cond)  (evcon_ (cdr_ e) a)
                :else (eval_ (cons (assoc_ (car_ e) a) (cdr_ e))
                             a))
        (= (caar_ e) 'lambda)
          (eval_ (caddar_ e)
                 (append_ (pair_ (cadar_ e) (evlis_ (cdr_ e) a))
                          a))))
```

# コンスセル対応版

[ふたつの要素をもつリスト構造をコンスセルとした基本操作関数の実装](https://qiita.com/ytaki0801/items/a11c8143c5c63a406c7f#clojure%E3%81%AE%E5%AE%9F%E8%A3%85%E4%BE%8B)と，その実装に併せたS式入出力を定義した版です．実行例（1.10.0）は次の通り**（最後の例で`(cdr (assoc k v))`としていることに注意）**．

```lisp
$ clojure
Clojure 1.10.0
user=> (load-file "jmclisp2.clojure")
#'user/s_rep
user=> (s_rep)
(car (cdr '(10 20 30)))
20
user=> (s_rep)
((lambda (x) (car (cdr x))) '(abc def ghi))
def
user=> (s_rep)
((lambda (f x y) (f x (f y '()))) 'cons '10 '20)
(10 20)
user=> (s_rep)
((lambda (f x y) (f x (f y '())))
 '(lambda (x y) (cons x (cons y '())))
 '10 '20)
(10 (20 ()))
user=> (s_rep)
((lambda (assoc k v) (cdr (assoc k v)))
 '(lambda (k v)
    (cond ((eq v '()) nil)
          ((eq (car (car v)) k)
           (car v))
          ('t (assoc k (cdr v)))))
 'Orange
 '((Apple . 120) (Orange . 210) (Lemmon . 180)))
210
```

ソースコード一式は次の通り．

```Clojure:jmclisp2.clojure
;
; JMC Lisp: defined in McCarthy's 1960 paper,
; with S-expression input/output and conscell processing
;


; basic conscell processing: cons_, car_, cdr_, eq_, atom_
(defn cons_ [x y] (list x y))
(defn car_ [x] (first x))
(defn cdr_ [x] (second x))
(defn eq_ [s1 s2] (= s1 s2))
(defn atom_ [x] (not (seq? x)))


; S-expression with dotted pairs output: s_output
(declare s_output)
(defn s_strcons [s]
  (let [sa_r (s_output (car_ s)) sd (cdr_ s)]
    (cond (eq_ sd nil) (cons sa_r nil)
          (atom_ sd) (cons sa_r (cons '. (cons sd nil)))
          :else (cons sa_r (s_strcons sd)))))
(defn s_output [s]
  (cond (eq_ s nil) '()
        (eq_ s true) 't
        (eq_ s false) 'nil
        (atom_ s) s
        :else (s_strcons s)))


; S-expression with conscell lists input: s_input
(defn s_syn [s]
  (cond (atom_ s) s
        (= s '()) nil
        (= (rest s) '()) (cons_ (s_syn (first s)) nil)
        (= (second s) '.) (cons_ (s_syn (first s))
                                 (s_syn (first (rest (rest s)))))
        :else (cons (s_syn (first s))
                    (cons_ (s_syn (rest s)) nil))))
(defn s_input [] (s_syn (read)))


; JMC Lisp evaluator: eval_

(defn caar_ [x] (car_ (car_ x)))
(defn cadr_ [x] (car_ (cdr_ x)))
(defn cadar_ [x] (car_ (cdr_ (car_ x))))
(defn caddr_ [x] (car_ (cdr_ (cdr_ x))))
(defn caddar_ [x] (car_ (cdr_ (cdr_ (car_ x)))))

(defn null_ [x] (eq_ x nil))

(defn and_ [x y] (cond x (cond y true :else false) :else false))

(defn not_ [x] (cond x false :else true))

(defn append_ [x y]
  (cond (null_ x) y
        :else (cons_ (car_ x) (append_ (cdr_ x) y))))

(defn list_ [x y] (cons_ x (cons_ y nil)))

(defn pair_ [x y]
  (cond (and_ (null_ x) (null_ y))
        nil
        (and_ (not_ (atom_ x)) (not_ (atom_ y)))
        (cons_ (list_ (car_ x) (car_ y))
              (pair_ (cdr_ x) (cdr_ y)))))

(defn assoc_ [x y]
  (cond (null_ y) false
        (eq_ (caar_ y) x) (cadar_ y)
        :else (assoc_ x (cdr_ y))))

(declare eval_)

(defn evcon_ [c a]
  (cond (eval_ (caar_ c) a) (eval_ (cadar_ c) a)
        :else (evcon_ (cdr_ c) a)))

(defn evlis_ [m a]
  (cond (null_ m) nil
        :else (cons_ (eval_  (car_ m) a)
                     (evlis_ (cdr_ m) a))))

(defn eval_ [e a]
  (cond (atom_ e) (assoc_ e a)
        (atom_ (car_ e))
          (cond (eq_ (car_ e) 'quote) (cadr_ e)
                (eq_ (car_ e) 'atom)  (atom_ (eval_ (cadr_  e) a))
                (eq_ (car_ e) 'eq)    (eq_   (eval_ (cadr_  e) a)
                                             (eval_ (caddr_ e) a))
                (eq_ (car_ e) 'car)   (car_  (eval_ (cadr_  e) a))
                (eq_ (car_ e) 'cdr)   (cdr_  (eval_ (cadr_  e) a))
                (eq_ (car_ e) 'cons)  (cons_ (eval_ (cadr_  e) a)
                                             (eval_ (caddr_ e) a))
                (eq_ (car_ e) 'cond)  (evcon_ (cdr_ e) a)
                :else (eval_ (cons_ (assoc_ (car_ e) a) (cdr_ e))
                             a))
        (eq_ (caar_ e) 'lambda)
          (eval_ (caddar_ e)
                 (append_ (pair_ (cadar_ e) (evlis_ (cdr_ e) a))
                          a))))

; REP (no Loop): s_rep
(defn s_rep [] (s_output (eval_ (s_input) nil)))
```

# 備考

## 更新履歴
* 2020-12-16：コンスセル対応版を追加
* 2020-12-10：初版公開（コンスセル未対応版）