jmc.lispでjmc.lispを実行してみた

【他言語版へのリンク記事】簡易LISP処理系の実装例【各言語版まとめ】

"jmc.lisp"とは，John McCarthy氏の原初のLISPインタプリタ記述を，Paul Graham氏がCommon Lispで実装したものです．概要は次の通り．

• 実装はquote atom eq cons car cdr cond defunを使用
• 機能はquote atom eq cons car cdr cond lambda labelを提供

jmc.lispをGNU Emacsで実行した例は次の通り．

*** Welcome to IELM ***  Type (describe-mode) for help.
ELISP> (load "~/tmp/jmc.lisp")
t
ELISP> (eval. '((lambda (assoc k v) (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)))                                                                                      
              '())
(Orange . 210)

ダイナミックスコープということもあり，実行例ではlambda式をletrec（Scheme）やlabels（Common Lisp）などの代わりに使用しています．

…ということは，defunの代わりにlambdaを使えば，jmc.lispでjmc.lispを記述できるなということで，書き直して同じ実行例を記述したのが次の通り．区別しやすくするため，元定義ではeval.等とピリオド付きとなっているものを，eval_とアンダーバー付きとしています．

(print
(eval. '((lambda (caar_ cadr_ cadar_ caddr_ caddar_
                  null_ and_ not_ append_ list_ pair_ assoc_
                  eval_ evcon_ evlis_)
           (eval_ '((lambda (assoc k v) (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)))
                   '()))
        ; caar_
        '(lambda (x) (car (car x)))
        ; cadr_
        '(lambda (x) (car (cdr x)))
        ; cadar_
        '(lambda (x) (car (cdr (car x))))
        ; caddr_
        '(lambda (x) (car (cdr (cdr x))))
        ; caddar_
        '(lambda (x) (car (cdr (cdr (car x)))))
        ; null_
        '(lambda (x) (eq x '()))
        ; and_
        '(lambda (x y) (cond (x (cond (y 't) ('t '()))) ('t '())))
        ; not_
        '(lambda (x) (cond (x '()) ('t 't)))
        ; append_
        '(lambda (x y) (cond ((null_ x) y) ('t (cons (car x) (append_ (cdr x) y)))))
        ; list_
        '(lambda (x y) (cons x (cons y '())))
        ; pair_
        '(lambda (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))))))
        ; assoc_
        '(lambda (x y) (cond ((eq (caar_ y) x) (cadar_ y)) ('t (assoc_ x (cdr y)))))
        ; eval_
        '(lambda (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))
                ('t (eval_ (cons (assoc_ (car e) a)
                                 (cdr e))
                           a))))
             ((eq (caar_ e) 'label)
              (eval_ (cons (caddar_ e) (cdr e))
                     (cons (list_ (cadar_ e) (car e)) a)))
             ((eq (caar_ e) 'lambda)
              (eval_ (caddar_ e)
                     (append_ (pair_ (cadar_ e) (evlis_ (cdr e) a))
                              a)))))
        ; evcon_
        '(lambda (c a)
           (cond ((eval_ (caar_ c) a)
                  (eval_ (cadar_ c) a))
                 ('t (evcon_ (cdr c) a))))
        ; evlis_ 
        '(lambda (m a)
           (cond ((null_ m) '())
                 ('t (cons (eval_  (car m) a)
                           (evlis_ (cdr m) a)))))

        )
    '())
)

これを，元のjmc.lispにくっつけてjmclisp.clというファイル名とし，GNU Emacs 26.1およびSBCL 1.4.16でスクリプトとして実行した結果は次の通り．

$ emacs --script jmclisp.cl
（"Loading..."メッセージは省略）

(Orange . 210)
$ sbcl --script jmclisp.cl

(ORANGE . 210) 

#備考

##記事に関する補足

• "jmc.lisp"のほぼコピペだし，もともと超循環評価器（meta-circular evaluator）として作られたものなので，だからなんなんだという話もありますが．え，jmc.lispで動くjmc.lispで更にjmc.lispを動かしてみろ？えーと，今度は_evalとかにしてみるとわかりやすいのかな？やらないけど．

##更新履歴

• 2020-09-14：初版公開