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))