next up previous
Next: 6 クロージャの実現 Up: ソフトウェア特論 講義資料 Scheme言語とインタプリタ Previous: 4 任意個数の引数指定機構の実現


5 Schemeインタプリタ

マクロが使えて,可変個の引数をもつ関数の定義が可能な Schemeのインタプリタのプログラムをまとめておきます.

(defun scheme-interpreter ()
  (init-scheme-interpreter)
  (loop
    (format t "~&==> ")
    (print (interp (read) nil))))

(defun interp (x &optional env)
  (cond
   ((symbolp x) (get-var x env))
   ((atom x) x)
   ((member (car x) '(quote begin set! if lambda))
    (interp-specialform (car x) (cdr x) env))
   ((scheme-macro (car x))
    (interp (scheme-macro-expand x) env))
   (t (interp-call x env))))

(defun get-var (var env)
  (if (assoc var env)
      (second (assoc var env))
    (get-global-var var)))

(defun get-global-var (var)
  (get var 'scheme-global-value "unbound"))


(defun interp-specialform (name params env)
  (case
   name
   (quote (car params))
   (begin (if (null params) nil
            (car (last
                  (mapcar
                   #'(lambda (v) (interp v env))
                   params)))))
   (set! (set-var! (car params)
                   (interp (cadr params) env)
                   env))
   (if  (if (interp (car params) env)
            (interp (cadr params) env)
          (interp (caddr params) env)))
   (lambda
     (let* ((vars (car params))
            (code (cons 'begin (cdr params))))
       #'(lambda (&rest args)
           (interp
            code
            (extend-env vars args env)))))))

(defun set-var! (var value env)
  (if (assoc var env)
      (setf (second (assoc var env)) value)
    (set-global-var! var value))
  value)

(defun set-global-var! (var value)
  (setf (get var 'scheme-global-value) value))

(defun extend-env (vars vals env)
  (cond
   ((null vars)
    (assert (null vals) () "Too many args")
    env)
   ((atom vars)
    (cons (list vars vals) env))
   (t
    (cons (list (first vars) (first vals))
          (extend-env (rest vars) (rest vals) env)))))

(defun scheme-macro (symbol)
  (if (symbolp symbol) (get symbol 'scheme-macro)))

(defun scheme-macro-expand (x)
  (if
      (and (listp x) (scheme-macro (car x)))
      (scheme-macro-expand
       (apply (scheme-macro (car x)) (cdr x)))
    x))

(defun interp-call (call env)
  (apply (interp (car call) env)
         (mapcar #'(lambda (v) (interp v env))
                 (cdr call))))
組み込み関数群のリストを 大域変数*scheme-procs*に入れますが, ファイルのロードごとに代入がなされる defparameterを使います.

(defun init-scheme-interpreter nil
  (set-global-var! 't t)
  (set-global-var! 'nil nil)
  (set-global-var! 'pi pi)
  (set-global-var! 'get (symbol-function 'get))
  (set-global-var! 'put
                   #'(lambda (sym key value)
                       (setf (get sym key) value)))
  (mapc #'init-scheme-proc *scheme-procs*)
  (init-scheme-macros)
  )

(defparameter *scheme-procs*
    '(+ - * / abs sqrt sin cos atan = < > <= >=
      cons car cdr not append list member read random
      (null? null) (eq? eq) (equal? equal) (eqv? eql)
      (number? numberp) (even? evenp) (odd? oddp)
      (write prin1) (display princ) (newline terpri)))

(defun init-scheme-proc (x)
  (if
      (atom x)
      (init-scheme-proc (list x x))
    (set-global-var! (car x)
                     (symbol-function (cadr x)))))

(defun init-scheme-macros nil
  (def-scheme-macro and (&rest args)
    (cond ((null args) 'T)
          (t `(if ,(car args)
                  (and ,@(cdr args))))))
  
  (def-scheme-macro let (bindings &rest body)
    `((lambda ,(mapcar #'car bindings) ,@body)
      ,@(mapcar #'cadr bindings)))
  
  (def-scheme-macro define (name &rest body)
    (if (atom name)
        `(begin (set! ,name  ,@body) ',name)
      `(define ,(car name) 
           (lambda ,(cdr name) ,@body))))
  
  (def-scheme-macro let* (bindings &rest body)
    (if (null bindings)
        `(begin ,@body)
      `(let (,(car bindings))
         (let* ,(cdr bindings) ,@body))))
  
  (def-scheme-macro or (&rest args)
    (cond
     ((null args) 'nil)
     ((null (cdr args)) (car args))
     (t (let ((var (gensym)))
          `(let ((,var ,(car args)))
             (if ,var ,var (or ,@(cdr args))))))))
  
  (def-scheme-macro cond (&rest clauses)
    (cond
     ((null clauses) nil)
     ((null (cdr clauses))
      `(or ,(car clauses) (cond ,@(cdr clauses))))
     ((eq (car (car clauses)) 'else)
      `(begin ,@(cdr (car clauses))))
     (t `(if ,(car (car clauses))
             (begin ,@(cdr (car clauses)))
           (cond ,@(cdr clauses))))))
  
  (def-scheme-macro case (key &rest clauses)
    (let ((key-val (gensym "KEY")))
      `(let ((,key-val ,key))
         (cond
          ,@(mapcar
             #'(lambda (clause)
                 (if (eq (car clause) 'else)
                     clause
                   `((member ,key-val ',(car clause))
                     ,@(cdr clause))))
             clauses)))))
  
  (def-scheme-macro letrec (bindings &rest body)
    `(let
         ,(mapcar #'(lambda (v) (list (car v) nil))
           bindings)
       ,@(mapcar #'(lambda (v) `(set! ,@v)) bindings)
       ,@body))
  
  (def-scheme-macro delay (computation)
    `(lambda () ,computation))

  )

(defmacro def-scheme-macro (name parmlist &rest body)
  `(setf (get ',name 'scheme-macro)
         #'(lambda ,parmlist ,@body)))


generated through LaTeX2HTML. M.Inaba 平成18年5月6日