[scheme][Lisp]SchemeでLispインタプリタ書いた

とっても簡易なインタプリタです。初めて書いたインタプリタです。やったー！まだバグってますが、取り合えずコードをさらしてみる。
とはいっても「schemeによる記号処理入門」P.125 ～ のほぼ写経だけど。
(slisp)を実行すればREPLが起動します。終了は(end*)、(exit*)、(bye*)、(quiet*)のいずれかを実行すれば終了します。

;; Small-Lisp ver 1.4
;; defined by valvallow
;; 2009/05/18
;; referenced 「Schemeによる記号処理入門」P.125 ～

(define *prompt* ">> ")
(define *version* "Small-Lisp Ver.1.4")

(define *environment*
  '())

(define init-environment
  (lambda ()
    (set! *environment*
          '((t . t)(nil . nil)))))

(define error-message
  (lambda (x)
    (display " **** Unknown expression : ")
    (display x)
    (newline)))
(define assoc*
  (lambda (x y)
    (cond
     ((null? y)
      (error-message x) '())
     ((equal? x (caar y))
      (cdar y))
     (else (assoc* x (cdr y))))))

(define atom?
  (lambda (x)
    (not (pair? x))))

(define eval-args
  (lambda (exp env)
    (cond
     ((null? exp) '())
     (else (cons (myeval (car exp) env)
                 (eval-args (cdr exp) env))))))

(define myatom?
  (lambda (foo)
    (cond
     ((not (pair? foo)) 't)
     (else 'nil))))

(define myeq?
  (lambda (foo baz)
    (cond
     ((eqv? foo baz) 't)
     (else 'nil))))

(define pairlis
  (lambda (x y z)
    (cond
     ((or (null? x)(null? y)) z)
     (else (append (pairlis-aux x y) z)))))

(define pairlis-aux
  (lambda (x y)
    (cond
     ((or (null? x)(null? y)) '())
     (else (cons (cons (car x)(car y))
                 (pairlis-aux (cdr x)(cdr y)))))))

(define myapply
  (lambda (func args env)
    (cond
     ((and (atom? func) (not (null? func)))
      (cond
       ((eq? func 'car*)(caar args))
       ((eq? func 'cdr*)(cdar args))
       ((eq? func 'cons*)(cons (car args)(cadr args)))
       ((eq? func 'atom*)(myatom? (car args)))
       ((eq? func 'eq*)(myeq? (car args)(cadr args)))
       ((eq? func 'caar*)(caar args))
       ((eq? func 'cadr*)(cadr args))
       ((eq? func 'cdar*)(cdar args))
       ((eq? func 'cddr*)(cddr args))
       ((eq? func 'caaar*)(caaar args))
       ((eq? func 'caadr*)(caadr args))
       ((eq? func 'cadar*)(cadar args))
       ((eq? func 'caddr*)(caddr args))
       ((eq? func 'cdaar*)(cdaar args))
       ((eq? func 'cdadr*)(cdadr args))
       ((eq? func 'cddar*)(cddar args))
       ((eq? func 'cdddr*)(cdddr args))
       ((eq? func 'null*)
        (if (null? (car args)) 't 'nil))
       ((eq? func 'zero*)
        (if (zero? (car args)) 't 'nil))
       ((eq? func 'plus*)(+ (car args)(cadr args)))
       ((eq? func 'minus*)(- (car args)(cadr args)))
       ((eq? func 'multiple*)(* (car args)(cadr args)))
       ((eq? func 'divide*)(/ (car args)(cadr args)))
       ((eq? func 'greater*)
        (if (> (car args)(cadr args)) 't 'nil))
       (else (myapply (myeval func env) args env))))
     ((eq? (car func) 'lambda*)
      (myeval (caddr func)
              (pairlis (cadr func) args env)))
     (else (error-message args)))))

(define eval-cond
  (lambda (con env)
    (cond
     ((null? con) 'nil)
     ((eq? 'nil (myeval (caar con) env))
      (eval-cond (cdr con) env))
     (else (myeval (cadar con) env)))))

(define eval-defun
  (lambda (exp env)
    (let ((name (car exp))
          (args (cadr exp))
          (body (caddr exp)))
      (set! *environment*
            (cons `(,name . (lambda* ,args ,body))
                  env)) name)))

(define eval-setq
  (lambda (exp env)
    (let ((var (car exp))
          (val (myeval (cadr exp) env)))
      (set! *environment*
            (cons (cons var val) env)) val)))

(define myeval
  (lambda (exp env)
    (cond
     ((atom? exp)
      (cond
       ((number? exp) exp)
       (else (assoc* exp env))))
     ((eq? (car exp) 'cond*)(eval-cond (cdr exp) env))
     ((eq? (car exp) 'setq*)(eval-setq (cdr exp) env))
     ((eq? (car exp) 'defun*)(eval-defun (cdr exp) env))
     ((eq? (car exp) 'quote*)(cadr exp))
     ((eq? (car exp) 'if*)
      (cond
       ((eq? (myeval (cadr exp) env) 'nil))
       (else (myeval (caddr exp) env))))
     (else (myapply (car exp)
                    (eval-args (cdr exp) env) env)))))

(define slisp
  (lambda ()
    (print *version*)
    (init-environment)
    (display *prompt*)
    (do ((exp (read)(read)))
        ((and (list? exp)
              (member (car exp)
                      '(bye* quite* end* exit*)))
         'good-bye)
      (print (myeval exp *environment*))
      (display *prompt*))))

(use slib)
(require 'trace)
(trace myeval)