On Lisp

Paul GrahamのOn Lispの訳ってネットで公開されてたんだね。
知らなかったよ。http://www.komaba.utmc.or.jp/~flatline/onlispjhtml/
最近買ったDoug HoyteのLET OVER LAMBDAによく引用が出てきていたから、ちょっと読んでみようかな。

複数call/ccに対応

GitHub - sodeyama/slisp: lisp interpreter

sLispの以下の点を改善しました。

• コメントを可能にしました
• call/ccで生成するラムダ式で使う変数名をgensymで作るようにしました（変数名の衝突を防ぐ目的)
• call/ccを複数書けるようにしました。(ただし、トップレベルの各S式中に1つのみ)
• slisp-mode(emacsメジャーモード)。ファイル開いてC-c nで評価

各々の対応するコードは以下

コメント

(defun slisp-get-src-string (filename)
  (let ((pre-buffer (current-buffer))
        (ret ""))
    (find-file filename)
    (setq str (buffer-substring-no-properties (point-min) (point-max)))
    (let ((lines (split-string str "\n")))
      (dolist (line lines)
        (if (not (string-match "^;" line))
            (setq ret (concat ret line)))))
    (switch-to-buffer pre-buffer)
    ret))

ファイルを開いたバッファからslisp-get-tokensに渡す文字列を生成する段階でコメント行を排除。

call/ccで生成するラムダ式で使う変数名をgensymで生成

(defmacro with-gensyms (syms &rest body)
  (declare (indent 1))
  `(let ,(mapcar
          (lambda (sym)
            `(,sym (gensym)))
          syms)
     ,@body))

Common Lispでよく使われるwith-gensymsをelispのmacroで再現してます。

(with-gensyms (a b c)
  body)

のようなコードは

(let ((a (gensym))
      (b (gensym))
      (c (gensym)))
  body)

に展開されます。gensymは一意なシンボルを生成するelispのmacro。

call/ccを複数書けるように

(defun slisp-callcc-parse (exp env)
  (dolist (seed (cdr exp))
    (with-gensyms (variable)
      (let* ((ret (slisp-callcc-getcc seed variable env))
             (find (slisp-get-findcallcc ret))
             (cc (slisp-get-callcc ret)))
        (if find
            (progn
              (let ((sexp (list "lambda" (list variable) (list "throw" cc))))
                (slisp-callcc-fifo-set sexp))))))))

slisp-callcc-fifoをcall/ccで生成された継続を保存するfifoデータとしslisp-callcc-fifo-set, slisp-callcc-fifo-getでセット、ゲットしただけ。

Software Design

そういえば、Software Design 2010年5月号で記事書きました。
Software Design 2010年5月号｜技術評論社

* Emacsのトラノマキ
【13】俺流Lispインタプリタ……アリエル

です。

どこがemacsの記事なんだ、という突っ込みがあるかもしれませんが

emacsって結局elispが全てでしょ
elispってまー一応Lispだよね。

という三段論法によりemacsの記事と言っても差し支えないでしょう。

■

ぱーふぇくとYコンビネータ

slisp/slisp-ycc.el at master · sodeyama/slisp · GitHub

sLispのベータ変換にバグがあり

(defun Y (f)
  ((lambda (x)
     (f (x x)))
   (lambda (x)
     (f (x x)))))

(print ((Y 
         (lambda (f)
           (lambda (n)
             (if (= n 0)
                 1
               (* n (f (- n 1))))))) 8))

みたいなコードをsLispで評価出来なかったんですが、修正しました。
ベータ変換時に、変換するkeyがlambdaとletで束縛されている変数と一致する場合はlambdaやletのS式内部を変換してはいけないんですが、ここを変換してしまっていて無限ループに陥ってました。

この修正で以下のように完全に関数名が消えた階乗の再帰が書けます

(print 
 (((lambda (f)
     ((lambda (x)
        (f (x x)))
      (lambda (x)
        (f (x x)))))
   (lambda (f)
     (lambda (n)
       (if (= n 0)
           1
         (* n (f (- n 1))))))) 8))

なかなか美しいですね。

Yコンビネータと同じ効力を持つZコンビネータも評価出来ます。

(defun Z (y)
  ((lambda (x)
     (lambda (m)
       ((y (x x)) m)))
   (lambda (x)
     (lambda (m)
       ((y (x x)) m)))))
(defun fact0 (f)
  (lambda (n)
    (if (= n 0)
        1
      (* n (f (- n 1))))))
(print ((Z fact0) 8))

elispのfuncallのウザさは異常だよねって人はsLispを改造して使ってみてはいかがか

sLispで継続

Lisp処理系で継続も(ry ってことでsLispで継続を実装しました。
S式パースするのとcatch throw使う方法で書いたらなんかあっさり書けた。

ま、厳密に仕様みながら実装したわけではないので色々動作はおかしいと思う
あとcall/ccは1個しか書けません
call/cc使われている所を洗い出すのに一回構文木全体をチェックしてます。

sLispに与えるS式 1

(print "hajimari dayo")
(let ((a 1))
  (let ((b 2))
    (print (+ (+ a b) (call/cc (lambda (cc) (cc 3)))))))
(print "owari dayo")

上のS式だと継続ccは

(lambda (x)
  (let ((a 1))
    (let ((b 2))
      (print (+ (+ a b) x)))))

で与えられます。そんでこれが呼び出されたらトップレベルまで脱出します。
上の計算だと
"hajimari dayo"と表示された後に (cc 3)の結果 "5"が表示されて"owari dayo"が表示されます。

sLispに与えるS式 2

(print "hajimari dayo")
(let ((a 1))
  (let ((b 2))
    (print (+ (+ a b) (call/cc (lambda (cc) (+ 3 4)))))))
(print "owari dayo")

こんなS式だと継続が呼ばれないので (+ (+ a b) (+ 3 4))が評価されて結果10となります。

sLispに与えるS式 3

(print "hajimari dayo")
(setq hoge nil)
(let ((a 1))
  (let ((b 2))
    (print (+ (+ a b)
              (call/cc (lambda (cc)
                         (progn
                           (setq hoge cc)
                           (cc 4))))))))
(print "owari dayo")
(print (hoge 5))
(print (hoge 6))

こんな感じで継続を変数"hoge"に保存して後で呼び出すことも出来ます。
結果は以下のようになります。

hajimari dayo
7
owari dayo
8
9

全ソースコード

(require 'cl)

(setq max-specpdl-size 16384)
(setq max-lisp-eval-depth 9192)

(setq slisp-filename "mylisp.l")

(setq type_list '("(" ")"))
(setq start_paren "(")
(setq end_paren ")")
(setq double_quote "\"")
(setq ignore_list '("\t" "\r" "\n" " "))

(setq primitive-list
      '("list" "setq" "let" "defun"
        "if" "cond" "lambda" "apply"
        "top-progn" "progn" "quote" "print"
        "+" "-" "*" "/" "=" ">" "<"
        "not" "or" "and"
        "call/cc" "throw"))
(setq sequence-top-symbol "top-progn")

(setq environment (make-hash-table :test #'equal))


(defun gethash-keys (hash)
  (loop for k being the hash-keys in hash collect k))

(defun slisp-copy-hash (srcenv destenv)
  (dolist (key (gethash-keys srcenv))
    (if (eq (gethash key destenv) nil)
        (puthash key (gethash key srcenv) destenv))))

(defun slisp-clear-messages ()
  (let ((buffer (get-buffer "*Messages*"))
        (cur (current-buffer)))
    (progn
      (set-buffer buffer)
      (erase-buffer)
      (switch-to-buffer cur))))

(defun slisp-contains (x list)
  (loop for y in list
        thereis (equal x y)))

(defun slisp-get-src-string (filename)
  (let ((pre-buffer (current-buffer)))
    (find-file filename)
    (setq str (buffer-substring-no-properties (point-min) (point-max)))
    (switch-to-buffer pre-buffer)
    str))

(defmacro slisp-set-tokenbuf-and-clear (buf tokens)
  `(if (not (equal ,buf ""))
       (progn
         (push ,buf ,tokens)
         (setq ,buf ""))))

(defun slisp-get-tokens (in_str)
  (let ((chars (split-string in_str ""))
        (token_buf "")
        (tokens nil)
        (in_double_quote nil))
    (dolist (c chars)
      (if (equal c double_quote)
          (if in_double_quote
              (setq in_double_quote nil)
            (setq in_double_quote t)))
      (cond ((slisp-contains c type_list)
             (progn
               (slisp-set-tokenbuf-and-clear token_buf tokens)
               (push c tokens)))
            ((and (not in_double_quote) (slisp-contains c ignore_list))
             (slisp-set-tokenbuf-and-clear token_buf tokens))
            (t
             (setq token_buf (concat token_buf c)))))
    (nreverse tokens)))

(defun slisp-check-primitive (token)
  (slisp-contains token primitive-list))

(defun slisp-check-type (token type)
  (cond ((equal type "string") (string-match "^\"\\(.+\\)\"$" token))
        ((equal type "number") (string-match "^\\([0-9]+\\)$" token))
        ((equal type "symbol") (string-match "\\\w+" token))
        ((equal type "quote") (string-match "\'.+" token))))

(defun slisp-parse (tokens)
  (let ((stack '()))
    (dolist (token tokens)
      (cond ((equal token start_paren)
             (push '() stack))
            ((equal token end_paren)
             (let* ((cur_stack (pop stack))
                    (up_stack (pop stack)))
               (push
                (cons (nreverse cur_stack) up_stack)
                stack)))
            ((slisp-check-primitive token)
             (push (cons token (pop stack)) stack))
            ((slisp-check-type token "string")
             (push (cons (match-string 1 token) (pop stack)) stack))
            ((slisp-check-type token "number")
             (push (cons (string-to-number (match-string 1 token)) (pop stack)) stack))
            ((slisp-check-type token "symbol")
             (push (cons (make-symbol token) (pop stack)) stack))
            (t
             (push (cons token (pop stack)) stack))))
    (let ((cur (pop stack)))
      (cons sequence-top-symbol (nreverse cur)))))

(defun slisp-callcc-parse (exp env)
  (catch 'exit
    (dolist (seed (cdr exp))
      (let* ((ret (slisp-callcc-getcc seed env))
             (find (slisp-get-findcallcc ret))
             (cc (slisp-get-callcc ret)))
        (if find
            (progn
              (let ((sexp (list "lambda" (list (make-symbol "variable-for-callcc")) (list "throw" cc))))
                (puthash "callcc" (slisp-eval sexp env) env))
              (throw 'exit t)))))))

(defun slisp-callcc-getcc (exp env)
  (catch 'exit
    (let ((cc '())
          (find_callcc nil))
      (dolist (i exp)
        (if (listp i)
            (let ((find (slisp-get-findcallcc (slisp-callcc-getcc i env)))
                  (ret (slisp-get-callcc (slisp-callcc-getcc i env))))
              (setq find_callcc find)
              (setq cc (slisp-callcc-setlist ret cc))
              (if (and (symbolp ret)
                       (equal (symbol-name ret) "variable-for-callcc"))
                  (setq find_callcc t)))
          (if (and (stringp i)
                   (equal i "call/cc"))
              (throw 'exit (list t (make-symbol "variable-for-callcc")))
            (setq cc (slisp-callcc-setlist i cc)))))
      (if (listp cc)
          (list find_callcc (nreverse cc))
        (list find_callcc cc)))))

(defun slisp-get-findcallcc (exp)
  (car exp))

(defun slisp-get-callcc (exp)
  (cadr exp))

(defun slisp-callcc-setlist (exp l)
  (if (eq l nil)
      (list exp)
    (cons exp l)))

(defmacro slisp-make-primitive? (exp operator)
  `(cond ((listp ,exp)
          (let ((op (car ,exp)))
            (and (string? op)
                 (equal op ,operator))))
         (t
          nil)))

(defun slisp-eval (exp env)
  (defun neq (exp obj)
    (not (eq exp obj)))
  (defun pair? (exp)
    (if (listp exp)
        (let ((first (car exp))
              (second (cadr exp)))
          (and (neq first nil)
               (neq second nil)))
      nil))

  (defun number? (exp)
    (numberp exp))
  (defun string? (exp)
    (stringp exp))
  (defun symbol? (exp)
    (symbolp exp))
  (defun self? (exp)
    (cond ((number? exp) t)
          ((string? exp) t)
          ((booleanp exp) t)))
  (defun variable? (exp)
    (symbolp exp))

  ;; special forms check
  (defun list? (exp)
    (slisp-make-primitive? exp "list"))
  (defun let? (exp)
    (slisp-make-primitive? exp "let"))
  (defun set? (exp)
    (slisp-make-primitive? exp "setq"))
  (defun defun? (exp)
    (slisp-make-primitive? exp "defun"))
  (defun if? (exp)
    (slisp-make-primitive? exp "if"))
  (defun cond? (exp)
    (slisp-make-primitive? exp "cond"))
  (defun lambda? (exp)
    (slisp-make-primitive? exp "lambda"))
  (defun apply? (exp)
    (slisp-make-primitive? exp "apply"))
  (defun call/cc? (exp)
    (slisp-make-primitive? exp "call/cc"))
  (defun throw? (exp)
    (slisp-make-primitive? exp "throw"))
  (defun top-progn? (exp)
    (slisp-make-primitive? exp "top-progn"))
  (defun progn? (exp)
    (slisp-make-primitive? exp "progn"))
  (defun print? (exp)
    (slisp-make-primitive? exp "print"))
  (defun arithmetic? (exp)
    (let ((op (car exp)))
      (cond ((equal op "+") t)
            ((equal op "-") t)
            ((equal op "*") t)
            ((equal op "/") t)
            ((equal op "=") t)
            ((equal op ">") t)
            ((equal op "<") t)
            ((equal op "not") t)
            ((equal op "or") t)
            ((equal op "and") t)
            (t nil))))

  (defun eval-lambda? (exp)
    (let ((first (car exp))
          (rest (cdr exp)))
      (and (listp first)
           (equal "lambda" (car first))
           (not (eq rest nil)))))

  (defun eval-define? (exp)
    (let ((var (car exp)))
      (variable? var)))

  (defun eval-callcc? (exp)
    (let ((var (car exp)))
      (and (stringp var)
           (equal var "call/cc"))))

  (defun throw? (exp)
    (let ((var (car exp)))
      (and (stringp var)
           (equal var "throw"))))

  (defun eval-self? (exp)
    (self? (car exp)))

  (defun eval-rec-lambda? (exp)
    (if (listp exp)
        (let ((first (car exp))
              (rest (cdr exp)))
          (and (equal first "lambda")
               (neq rest nil)))
      nil))

  (defun application? (exp)
    (pair? exp))

  (defun eval-define (exp env)
    (let* ((func-name (symbol-name (car exp)))
           (func-hash (gethash func-name env))
           (func-args-var (car func-hash))
           (func-body (cadr func-hash))
           (args-length (length func-args-var))
           (func-args-real (cdr exp))
           (new_env (copy-hash-table env)))
      (cond ((eq args-length 0)
             (let ((new_exp (list func-body (list (car func-args-real)))))
               new_exp))
            (t
             (dotimes (i args-length)
               (let ((variable (nth i func-args-var))
                     (value (nth i func-args-real)))
                 (setq exp (beta-reduction exp value (symbol-name variable) env))))
             (slisp-eval exp new_env)))))

 (defun eval-lambda (exp env)
    (let* ((first (car exp))
           (func-args-var (cadr first))
           (func-body (caddr first))
           (func-args-real (cdr exp))
           (args-length (length func-args-var))
           (ret func-body))
      (cond ((self? ret)
             ret)
            ((eq func-args-var nil)
             (slisp-eval func-body env))
            (t
             (progn
               (if (variable? ret)
                   (setq ret (lookup-variable-value ret env)))
               (dotimes (i args-length)
                 (let ((variable (nth i func-args-var))
                       (value (nth i func-args-real)))
                   (setq ret (beta-reduction ret value (symbol-name variable) env))))
               (slisp-eval ret env))))))
  
  (defun eval-self-lambda (exp env)
    (let ((func-args-var (cadr exp))
          (func-body (caddr exp))
          (do_eval nil))
      (dolist (item func-args-var)
        (let ((name (symbol-name item)))
        (if (neq (gethash name env) nil)
            (setq do_eval t))))
      (if do_eval
          (slisp-eval func-body env)
        exp)))

  (defun eval-callcc (exp env)
    (let* ((body (cadr exp))
           (lambda-arg (car (cadr body)))
           (lambda-body (caddr body)))
      (puthash (symbol-name lambda-arg) (gethash "callcc" env) env)
      (slisp-eval lambda-body env)))

  (defun eval-if (exp env)
    (let ((condition (nth 1 exp))
          (true-body (nth 2 exp))
          (else-body (nth 3 exp)))
      (if (slisp-eval condition (copy-hash-table env))
          (slisp-eval true-body (copy-hash-table env))
        (if (not (eq else-body nil))
            (slisp-eval else-body (copy-hash-table env))))))

  (defun eval-cond (exp env)
    (let ((condlist (cdr exp)))
      (loop for conditem in condlist
            when (slisp-eval (car conditem) (copy-hash-table env))
            return (slisp-eval (cadr conditem) (copy-hash-table env)))))

  (defun make-lambda (exp env)
    (let ((func-name "lambda")
          (func-args (nth 1 exp))
          (func-impl (nth 2 exp)))
      (puthash func-name (list func-args func-impl) env)))

  (defun convert-list (exp)
    (cdr exp))

  (defun set-let (exp env)
    (let ((var-list (cadr exp))
          (exp-list (caddr exp)))
      (dolist (var-item var-list)
        (let ((variable (car var-item))
              (value 
               (cond ((eq (cadr var-item) nil) nil)
                     (t (cadr var-item)))))
          (puthash (symbol-name variable) value env)))
      (slisp-eval exp-list env)))

  (defun set-definition (exp env)
    (let* ((func-name (nth 1 exp))
           (func-args (nth 2 exp))
           (func-impl (nth 3 exp))
           (new_exp (list "lambda" func-args func-impl)))
      (puthash (symbol-name func-name) new_exp env)))

  (defun progn-actions (exp)
    (cdr exp))

  (defun eval-top-sequence (actions env)
    (dolist (action actions)
      (catch 'callcc-exit
        (setq ret (slisp-eval action env)))))

  (defun eval-sequence (actions env)
    (dolist (action actions)
      (slisp-eval action env)))

  (defun calc (exp env)
    (let ((op (car exp))
          (first (slisp-eval (cadr exp) (copy-hash-table env)))
          (second (slisp-eval (caddr exp) (copy-hash-table env))))
      (cond ((equal op "+") (+ first second))
            ((equal op "-") (- first second))
            ((equal op "*") (* first second))
            ((equal op "/") (/ first second))
            ((equal op "=") (= first second))
            ((equal op "<") (< first second))
            ((equal op ">") (> first second))
            ((equal op "not") (not first))
            ((equal op "or") (or first second))
            ((equal op "and") (and first second)))))

  (defun print (exp env)
    (let ((mes (slisp-eval (cadr exp) (copy-hash-table env))))
      (cond ((number? mes)
             (message "%d" mes))
            ((booleanp mes)
             (if mes (message "t")
               (message "nil")))
            (t
             (message "%s" mes)))))

  (defun lookup-variable-value (exp env)
    (let* ((symbolname (symbol-name exp)))
      (gethash symbolname env)))

  (defun have-variable-value? (exp env)
    (and (not (listp exp))
         (symbolp exp)
         (let ((v (lookup-variable-value exp env)))
           (neq v nil))))

  (defun set-assignment (exp env)
    (let ((variable (cadr exp))  
          (value (slisp-eval (caddr exp) (copy-hash-table env))))
      (puthash (symbol-name variable) value environment)))

  (defun list-of-values (exp env)
    exp)

  (defun beta-reduction (exp trans_exp key env)
    (let ((ret '())
          (check_exp exp)
          (have_key nil))
      (cond ((lambda? check_exp)
             (progn
               (setq check_exp (cddr exp))
               (let ((func-args (cdr check_exp)))
                 (dolist (arg func-args)
                   (if (and (not (listp arg))
                            (equal (symbol-name arg) key))
                       (setq have_key t))))))
            ((let? check_exp)
             (progn
               (setq check_exp (cddr exp))
               (let ((func-args (cdr check_exp)))
                 (dolist (arg func-args)
                   (if (and (not (listp arg))
                            (equal (symbol-name arg) key))
                       (setq have_key t)))))))
      (if (eq have_key t)
          exp
        (if (listp check_exp)
            (let ((len (length check_exp)))
              (dolist (i check_exp)
                (if (listp i)
                    (let ((in_exp (beta-reduction i trans_exp key env)))
                      (if (= len 1)
                          (setq ret in_exp)
                        (setq ret (cons in_exp (if (eq ret nil) '() ret)))))
                  (let ((ii (if (symbolp i) (symbol-name i) i)))
                    (if (= len 1)
                        (setq ret (if (equal ii key) trans_exp i))
                      (setq ret (cons
                                 (if (equal ii key)
                                     trans_exp
                                   i)
                                 (if (eq ret nil) '() ret))))))))
          (setq ret (cons
                     (if (eq (symbol-name check_exp) key)
                         trans_exp
                       check_exp)
                     ret)))
        (if (> (length check_exp) 1)
            (setq ret (nreverse ret)))
        (cond ((lambda? exp)
               (progn
                 (setq ret (list "lambda" (cadr exp) ret))))
              ((let? exp)
               (progn
                 (setq ret (list "let" (cadr exp) ret)))))
        ret)))

  (defun eval-apply (exp env)
    (let* ((first (car exp))
           (second (cdr exp))
           (procedure (slisp-eval first env)))
      (let ((new_exp (cons procedure second)))
        (cond ((eval-lambda? new_exp)
               (eval-lambda new_exp env))
              ((eval-define? new_exp)
               (eval-define new_exp env))
              ((eval-callcc? new_exp)
               (eval-callcc new_exp env))
              ((eval-self? new_exp)
               (car new_exp))
              (t
               (error "eval-apply not match:%s" new_exp))))))

  (defun eval-throw (exp env)
    (let ((body (cadr exp)))
      (slisp-eval body env)
      (throw 'callcc-exit t)))

  (cond ((self? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((list? exp) (convert-list exp))
        ((let? exp) (set-let exp env))
        ((set? exp) (set-assignment exp env))
        ((defun? exp) (set-definition exp env))
        ((if? exp) (eval-if exp env))
        ((cond? exp) (eval-cond exp env))
        ((throw? exp) (eval-throw exp env))
        ((lambda? exp)
         (eval-self-lambda exp env))
        ((top-progn? exp) (eval-top-sequence (progn-actions exp) env))
        ((progn? exp) (eval-sequence (progn-actions exp) env))
        ((arithmetic? exp) (calc exp env))
        ((print? exp) (print exp env))
        ((application? exp)
         (eval-apply exp env))
        (t (error "Unknown expression type. " exp))))

(slisp-clear-messages)
(let ((tree (slisp-parse (slisp-get-tokens (slisp-get-src-string slisp-filename)))))
  (slisp-callcc-parse tree environment)
  (slisp-eval tree environment))

sLispでYコンビネータ

「Yコンビネータも出来ないLisp処理系って処理系として終わってるよね。キモッ!」
と女子大生に言われないように、sLispでYコンビネータを出来るようにしました。
前回アップした似非Lisp処理系からかなり書き換えてます。
とりあえずdefunって結局lambdaだよねってのとlambdaときたらラムダ計算のβ簡約(beta reduction)でしょ！
そんで簡約仕切るまで評価はしないよね、常識的に考えて
という戦略です。

次のemacsの記事はこれの解説にするかな。。
継続の実装はちょっと時間的に無理ぽ

sLispに与えるS式

Y関数がYコンビネータです。Yに再帰させたい関数fact0を与えて階乗の再帰的処理をしています

(defun fact0 (f)
  (lambda (n)
    (if (= n 0)
        1
      (* n (f (- n 1))))))

(defun Y (f)
  ((lambda (x)
     (f (x x)))
   (lambda (x)
     (f (x x)))))

(print ((Y fact0) 8))

計算途中

こんな感じでガリガリβ簡約してくれて最後にfact0の再帰的な結果が！感動しますよまじで。

ret:(= (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 0)
ret:(x x)
ret:(fact0 (x x))
ret:(lambda (x) (fact0 (x x)))
ret:(x x)
ret:(fact0 (x x))
ret:(lambda (x) (fact0 (x x)))
ret:*1
ret:(* (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1)))
ret:(if (= (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 0) 1 (* (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1))))
end of eval-lambda beta-reduction ret:(if (= (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 0) 1 (* (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1))))
ret:*2
ret:(* n (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- n 1)))
ret:(if (= n 0) 1 (* n (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- n 1))))
ret:(lambda (n) (if (= n 0) 1 (* n (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- n 1)))))
end of eval-lambda beta-reduction ret:(lambda (n) (if (= n 0) 1 (* n (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- n 1)))))
ret:(= (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 0)
ret:(x x)
ret:(fact0 (x x))
ret:(lambda (x) (fact0 (x x)))
ret:(x x)
ret:(fact0 (x x))
ret:(lambda (x) (fact0 (x x)))
ret:*3
ret:(* (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 1)))
ret:(if (= (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 0) 1 (* (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 1))))
end of eval-lambda beta-reduction ret:(if (= (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 0) 1 (* (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 1))))
40320

全ソースコード

(require 'cl)

(setq max-specpdl-size 16384)
(setq max-lisp-eval-depth 9192)

(setq slisp-filename "mylisp.l")

(setq type_list '("(" ")"))
(setq start_paren "(")
(setq end_paren ")")
(setq double_quote "\"")
(setq ignore_list '("\t" "\r" "\n" " "))

(setq primitive-list
      '("list" "setq" "let" "defun"
        "if" "cond" "lambda" "apply"
        "progn" "quote" "print"
        "+" "-" "*" "/" "=" ">" "<"
        "not" "or" "and"))
(setq sequence-symbol "progn")

(setq environment (make-hash-table :test #'equal))


(defun gethash-keys (hash)
  (loop for k being the hash-keys in hash collect k))

(defun slisp-copy-hash (srcenv destenv)
  (dolist (key (gethash-keys srcenv))
    (if (eq (gethash key destenv) nil)
        (puthash key (gethash key srcenv) destenv))))

(defun slisp-clear-messages ()
  (let ((buffer (get-buffer "*Messages*"))
        (cur (current-buffer)))
    (progn
      (set-buffer buffer)
      (erase-buffer)
      (switch-to-buffer cur))))

(defun slisp-contains (x list)
  (loop for y in list
        thereis (equal x y)))

(defun slisp-get-src-string (filename)
  (let ((pre-buffer (current-buffer)))
    (find-file filename)
    (setq str (buffer-substring-no-properties (point-min) (point-max)))
    (switch-to-buffer pre-buffer)
    str))

(defmacro slisp-set-tokenbuf-and-clear (buf tokens)
  `(if (not (equal ,buf ""))
       (progn
         (push ,buf ,tokens)
         (setq ,buf ""))))

(defun slisp-get-tokens (in_str)
  (let ((chars (split-string in_str ""))
        (token_buf "")
        (tokens nil)
        (in_double_quote nil))
    (dolist (c chars)
      (if (equal c double_quote)
          (if in_double_quote
              (setq in_double_quote nil)
            (setq in_double_quote t)))
      (cond ((slisp-contains c type_list)
             (progn
               (slisp-set-tokenbuf-and-clear token_buf tokens)
               (push c tokens)))
            ((and (not in_double_quote) (slisp-contains c ignore_list))
             (slisp-set-tokenbuf-and-clear token_buf tokens))
            (t
             (setq token_buf (concat token_buf c)))))
    (nreverse tokens)))

(defun slisp-check-primitive (token)
  (slisp-contains token primitive-list))

(defun slisp-check-type (token type)
  (cond ((equal type "string") (string-match "^\"\\(.+\\)\"$" token))
        ((equal type "number") (string-match "^\\([0-9]+\\)$" token))
        ((equal type "symbol") (string-match "\\\w+" token))
        ((equal type "quote") (string-match "\'.+" token))))

(defun slisp-parse (tokens)
  (let ((stack '()))
    (dolist (token tokens)
      (cond ((equal token start_paren)
             (push '() stack))
            ((equal token end_paren)
             (let* ((cur_stack (pop stack))
                    (up_stack (pop stack)))
               (push
                (cons (nreverse cur_stack) up_stack)
                stack)))
            ((slisp-check-primitive token)
             (push (cons token (pop stack)) stack))
            ((slisp-check-type token "string")
             (push (cons (match-string 1 token) (pop stack)) stack))
            ((slisp-check-type token "number")
             (push (cons (string-to-number (match-string 1 token)) (pop stack)) stack))
            ((slisp-check-type token "symbol")
             (push (cons (make-symbol token) (pop stack)) stack))
            (t
             (push (cons token (pop stack)) stack))))
    (let ((cur (pop stack)))
      (cons sequence-symbol (nreverse cur)))))

(defmacro slisp-make-primitive? (exp operator)
  `(cond ((listp ,exp)
          (let ((op (car ,exp)))
            (and (string? op)
                 (equal op ,operator))))
         (t
          nil)))

(defun slisp-eval (exp env)
  (defun neq (exp obj)
    (not (eq exp obj)))
  (defun pair? (exp)
    (if (listp exp)
        (let ((first (car exp))
              (second (cadr exp)))
          (and (neq first nil)
               (neq second nil)))
      nil))

  (defun number? (exp)
    (numberp exp))
  (defun string? (exp)
    (stringp exp))
  (defun symbol? (exp)
    (symbolp exp))
  (defun self? (exp)
    (cond ((number? exp) t)
          ((string? exp) t)
          ((booleanp exp) t)))
          ;((and (listp exp) ;; self lambda
          ;      (equal (car exp) "lambda"))
          ; t)))
  (defun variable? (exp)
    (symbolp exp))

  ;; special forms check
  (defun list? (exp)
    (slisp-make-primitive? exp "list"))
  (defun let? (exp)
    (slisp-make-primitive? exp "let"))
  (defun set? (exp)
    (slisp-make-primitive? exp "setq"))
  (defun defun? (exp)
    (slisp-make-primitive? exp "defun"))
  (defun if? (exp)
    (slisp-make-primitive? exp "if"))
  (defun cond? (exp)
    (slisp-make-primitive? exp "cond"))
  (defun lambda? (exp)
    (slisp-make-primitive? exp "lambda"))
  (defun apply? (exp)
    (slisp-make-primitive? exp "apply"))
  (defun progn? (exp)
    (slisp-make-primitive? exp "progn"))
  (defun print? (exp)
    (slisp-make-primitive? exp "print"))
  (defun arithmetic? (exp)
    (let ((op (car exp)))
      (cond ((equal op "+") t)
            ((equal op "-") t)
            ((equal op "*") t)
            ((equal op "/") t)
            ((equal op "=") t)
            ((equal op ">") t)
            ((equal op "<") t)
            ((equal op "not") t)
            ((equal op "or") t)
            ((equal op "and") t)
            (t nil))))

  (defun eval-lambda? (exp)
    (let ((first (car exp))
          (rest (cdr exp)))
      (and (listp first)
           (equal "lambda" (car first))
           (not (eq rest nil)))))

  (defun eval-define? (exp)
    (let ((var (car exp)))
      (variable? var)))

  (defun eval-rec-lambda? (exp)
    (if (listp exp)
        (let ((first (car exp))
              (rest (cdr exp)))
          (and (equal first "lambda")
               (neq rest nil)))
      nil))

  (defun application? (exp)
    (pair? exp))

  (defun eval-define (exp env)
    (let* ((func-name (symbol-name (car exp)))
           (func-hash (gethash func-name env))
           (func-args-var (car func-hash))
           (func-body (cadr func-hash))
           (args-length (length func-args-var))
           (func-args-real (cdr exp))
           (new_env (copy-hash-table env)))
      (cond ((eq args-length 0)
             (let ((new_exp (list func-body (list (car func-args-real)))))
               new_exp))
            (t
             (dotimes (i args-length)
               (let ((variable (nth i func-args-var))
                     (value (nth i func-args-real)))
                 (setq exp (beta-reduction exp value (symbol-name variable) env))))
             (slisp-eval exp new_env)))))

  (defun eval-lambda (exp env)
    (let* ((first (car exp))
           (func-args-var (cadr first))
           (func-body (caddr first))
           (func-args-real (cdr exp))
           (args-length (length func-args-var))
           (ret func-body))
      (dotimes (i args-length)
        (let ((variable (nth i func-args-var))
              (value (nth i func-args-real)))
          (setq ret (beta-reduction ret value (symbol-name variable) env))))
      (message "end of eval-lambda beta-reduction ret:%s" ret)
      (slisp-eval ret env)))
  
  (defun eval-self-lambda (exp env)
    (let ((func-args-var (cadr exp))
          (func-body (caddr exp))
          (do_eval nil))
      (dolist (item func-args-var)
        (let ((name (symbol-name item)))
        (if (neq (gethash name env) nil)
            (setq do_eval t))))
      (if do_eval
          (slisp-eval func-body env)
        exp)))

  (defun eval-if (exp env)
    (let ((condition (nth 1 exp))
          (true-body (nth 2 exp))
          (else-body (nth 3 exp)))
      (if (slisp-eval condition (copy-hash-table env))
          (slisp-eval true-body (copy-hash-table env))
        (if (not (eq else-body nil))
            (slisp-eval else-body (copy-hash-table env))))))

  (defun eval-cond (exp env)
    (let ((condlist (cdr exp)))
      (loop for conditem in condlist
            when (slisp-eval (car conditem) (copy-hash-table env))
            return (slisp-eval (cadr conditem) (copy-hash-table env)))))

  (defun make-lambda (exp env)
    (let ((func-name "lambda")
          (func-args (nth 1 exp))
          (func-impl (nth 2 exp)))
      (puthash func-name (list func-args func-impl) env)))

  (defun convert-list (exp)
    (cdr exp))

  (defun set-let (exp env)
    (let ((var-list (cadr exp))
          (exp-list (caddr exp)))
      (dolist (var-item var-list)
        (let ((variable (car var-item))
              (value 
               (cond ((eq (cadr var-item) nil) nil)
                     (t (cadr var-item)))))
          (puthash (symbol-name variable) value env)))
      (slisp-eval exp-list env)))

  (defun set-definition (exp env)
    (let* ((func-name (nth 1 exp))
           (func-args (nth 2 exp))
           (func-impl (nth 3 exp))
           (new_exp (list "lambda" func-args func-impl)))
      (puthash (symbol-name func-name) new_exp env)))

  (defun progn-actions (exp)
    (cdr exp))

  (defun eval-sequence (actions env)
    (dolist (action actions value)
      (setq value (slisp-eval action env))))

  (defun calc (exp env)
    (let ((op (car exp))
          (first (slisp-eval (cadr exp) (copy-hash-table env)))
          (second (slisp-eval (caddr exp) (copy-hash-table env))))
      (cond ((equal op "+") (+ first second))
            ((equal op "-") (- first second))
            ((equal op "*") (* first second))
            ((equal op "/") (/ first second))
            ((equal op "=") (= first second))
            ((equal op "<") (< first second))
            ((equal op ">") (> first second))
            ((equal op "not") (not first))
            ((equal op "or") (or first second))
            ((equal op "and") (and first second)))))

  (defun print (exp env)
    (let ((mes (slisp-eval (cadr exp) (copy-hash-table env))))
      (cond ((number? mes)
             (message "%d" mes))
            ((booleanp mes)
             (if mes (message "t")
               (message "nil")))
            (t
             (message "%s" mes)))))

  (defun lookup-variable-value (exp env)
    (let* ((symbolname (symbol-name exp)))
      (gethash symbolname env)))

  (defun set-assignment (exp env)
    (let ((variable (cadr exp))  
          (value (slisp-eval (caddr exp) (copy-hash-table env))))
      (puthash (symbol-name variable) value env)))

  (defun list-of-values (exp env)
    exp)

  (defun beta-reduction (exp trans_exp key env)
    (let ((ret '())
          (check_exp exp)
          (have_key nil))
      (cond ((lambda? check_exp)
             (progn
               (setq check_exp (cddr exp))
               (let ((func-args (cdr check_exp)))
                 (dolist (arg func-args)
                   (if (and (not (listp arg))
                            (equal (symbol-name arg) key))
                       (setq have_key t))))))
            ((let? check_exp)
             (progn
               (setq check_exp (cddr exp))
               (let ((func-args (cdr check_exp)))
                 (dolist (arg func-args)
                   (if (and (not (listp arg))
                            (equal (symbol-name arg) key))
                       (setq have_key t)))))))
      (if (eq have_key t)
          exp
        (if (listp check_exp)
            (let ((len (length check_exp)))
              (dolist (i check_exp)
                (if (listp i)
                    (let ((in_exp (beta-reduction i trans_exp key env)))
                      (if (= len 1)
                          (setq ret in_exp)
                        (setq ret (cons in_exp (if (eq ret nil) '() ret)))))
                  (let ((ii (if (symbolp i) (symbol-name i) i)))
                    (if (= len 1)
                        (setq ret (if (equal ii key) trans_exp i))
                      (setq ret (cons
                                 (if (equal ii key)
                                     trans_exp
                                   i)
                                 (if (eq ret nil) '() ret))))))))
          (setq ret (cons
                     (if (eq (symbol-name check_exp) key)
                         trans_exp
                       check_exp)
                     ret)))
        (if (> (length check_exp) 1)
            (setq ret (nreverse ret)))
        (cond ((lambda? exp)
               (setq ret (list "lambda" (cadr exp) ret)))
              ((let? exp)
               (setq ret (list "let" (cadr exp) ret))))
        (message "ret:%s" ret)
        ret)))

  (defun eval-apply (exp env)
    (let* ((first (car exp))
           (second (cdr exp))
           (procedure (slisp-eval first env)))
      (let ((new_exp (cons procedure second)))
        (cond ((eval-lambda? new_exp)
               (eval-lambda new_exp env))
              ((eval-define? new_exp)
               (eval-define new_exp env))
              (t
               (error "eval-apply not match:%s" new_exp))))))

  (cond ((self? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((list? exp) (convert-list exp))
        ((let? exp) (set-let exp env))
        ((set? exp) (set-assignment exp env))
        ((defun? exp) (set-definition exp env))
        ((if? exp) (eval-if exp env))
        ((cond? exp) (eval-cond exp env))
        ((lambda? exp)
         (eval-self-lambda exp env))
        ((progn? exp) (eval-sequence (progn-actions exp) env))
        ((arithmetic? exp) (calc exp env))
        ((print? exp) (print exp env))
        ((application? exp)
         (eval-apply exp env))
        ;(t exp)))
        (t (error "Unknown expression type. " exp))))

(slisp-clear-messages)
(slisp-eval (slisp-parse (slisp-get-tokens (slisp-get-src-string slisp-filename))) environment)

*1:lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) ret:(- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) ret:(((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1

*2:lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) ret:(fact0 ((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x))))) end of eval-lambda beta-reduction ret:(fact0 ((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x))))) ret:(= n 0) ret:(- n 1) ret:(((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- n 1

*3:lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) ret:(- (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 1) ret:(((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 1