SICP４章を読んでscheme処理系書いてみた

SICPの４章読んでscheme処理系書いてみました。
ほとんど教科書の丸写しですけどね。
でも処理系の基本的な動きは理解出来たと思います。
いやー楽しいですね。SICPおもしろい。

(driver-loop)を評価すると実行できます。
MIT-schemeで動作確認したのでgaucheで動くかはわかりません。

手続きオブジェクトを束縛してる変数を評価すると無限ループに入る不具合があります。
手続きオブジェクトは処理とフレームのリスト構造で出来ているのですが、手続きオブジェクトの持つフレームには自分自身が含まれる実装になってしまっています。
ですので手続きオブジェクトを評価するとフレームが評価され、
フレーム内の手続きオブジェクトが評価され、
さらに手続きオブジェクトの持つフレームが評価されてってというように無限ループに陥ります。

最初は３章で出てきたメッセージパッシング的な実装をしてたんですが、
evalとapplyの相互依存のあたりで無駄に複雑な構造になってしまって何がなんだかわからなくなってしまいました。

で、結局以下のように教科書どおりの実装に落ち着きました。

以下コード

;
; mylisp.scm
;

;; BEGIN frame functions
(define (first-frame env)
  (car env))

(define (enclosing-environment env)
  (cdr env))

(define the-empty-environment 
  '())

(define (empty-environment? env)
  (eq? env the-empty-environment))

(define (make-frame variables values)
  (map cons variables values))

(define (extend-environment vars vals env)
  (cons (make-frame vars vals) env))

(define (lookup-var-val-in-frame var frame)
  (assoc var frame))

(define (add-binding-to-frame var val frame)
  (cons (cons var val) frame))

(define (lookup-var-val var env)
  (if (empty-environment? env)
      (error "not found:" var)
      (let ((var-val 
	     (lookup-var-val-in-frame 
	      var (first-frame env))))
	(if var-val
	    var-val
	    (lookup-var-val 
	     var (enclosing-environment env))))))
	

(define (set-var-val! var val env)
  (let ((var-val (lookup-var-val-in-frame var 
				 (first-frame env))))
    (if var-val
	(set-cdr! var-val val)
	(error "not found:" var))))

(define (define-var-val! var val env)
  (let ((frame (first-frame env)))
    (let ((var-val (assoc var frame)))
      (if var-val
	  (set-cdr! var-val val)
	  (set-car! 
	   env
	   (add-binding-to-frame 
	    var val frame))))))

;; END frame functions

;; BEGIN eval functions
(define (self-evaluating? exp)
  (cond 
   ((number? exp) #t)
   ((string? exp) #t)
   (else #f)))

(define (variable? proc)
  (symbol? proc))

(define (syntax? var)
  (eq? (car var) 'syntax))

(define (syntax var)
  (cadr var))

(define (operator var)
  (car var))

(define (operands exp)
  (cdr exp))

(define (eval exp env)
  (cond
   ((self-evaluating? exp) exp)
   ((variable? exp) (cdr (lookup-var-val exp env)))
   ((list? (operator exp))
    (apply 
     (eval (operator exp) env)
     (list-of-values (operands exp) env)))
   (else
    (let ((var (cdr (lookup-var-val (car exp) env))))
      (cond
       ((syntax? var) ((syntax var) exp env))
       ((application? var)
	(apply 
	 (eval (operator exp) env)
	 (list-of-values (operands exp) env)))
       (else
	(error "Unknown exp -- EVAL" exp)))))))

(define (list-of-values exps env)
  (map (lambda (x)
	 (eval x env))
       exps))

(define (eval-sequence exps env)
  (cond
   ((last-exp? exps) (eval (first-exp exps) env))
   (else
    (eval (first-exp exps) env)
    (eval-sequence (rest-exps exps) env))))

(define (last-exp? exps)
  (null? (cdr exps)))

(define (first-exp exps)
  (car exps))

(define (rest-exps exps)
  (cdr exps))

;; END eval functions

;; BEGIN apply functions
(define apply-in-underlying-scheme apply)

(define (apply proc args)
  (cond
   ((primitive-proc? proc)
    (apply-primitive-proc proc args))
   ((compound-proc? proc)
    (eval-sequence
     (proc-body proc)
     (extend-environment
      (proc-params proc)
      args
      (proc-env proc))))
   (else
    (error "Unknown proc -- APPLY" proc))))


(define (syntax? var)
  (eq? (car var) 'syntax))

(define (application? var)
  (or (eq? (car var) 'procedure)
      (eq? (car var) 'primitive)))

(define (apply-primitive-proc proc args)
  (apply-in-underlying-scheme
   (primitive-implementation proc) args))

;; END apply functions


(define (primitive-proc? proc)
  (tagged-list? proc 'primitive))
   
(define (tagged-list? proc symbol)
  (if (pair? proc)
      (eq? (car proc) symbol)
      #f))

(define (primitive-implementation proc)
  (cadr proc))

(define (compound-proc? proc)
  (tagged-list? proc 'procedure))

(define (make-procedure parameters body env)
  (list 'procedure parameters body env))

(define (proc-body proc)
  (caddr proc))

(define (proc-params proc)
  (cadr proc))

(define (proc-env proc)
  (cadddr proc))

(define (primitive-procedure-names procs)
  (map car procs))
(define (primitive-procedure-values procs)
  (map cdr procs))


;; BEGIN eval-if
(define (eval-if exp env)
  (if (eval (if-predicate exp) env)
      (eval (if-consequent exp) env)
      (eval (if-alternative exp) env)))

(define (if-predicate exp)
  (cadr exp))
(define (if-consequent exp)
  (caddr exp))
(define (if-alternative exp)
  (if (not (null? (cdddr exp)))
      (cadddr exp)
      'false))
;; END eval-if

;; BEGIN eval-quote
(define (text-of-quotation exp)
  (cadr exp))
(define (eval-quote exp env)
  (text-of-quotation exp))
;; END eval-quote

;; BEGIN eval-set!

(define (eval-set! exp env)
  (set-var-val! 
   (assignment-variable exp)
   (eval (assignment-value exp) env)
   env)
  'ok)

(define (assignment-variable exp) (cadr exp))

(define (assignment-value exp) (caddr exp))

;; END  eval-set!

;; BEGIN eval-define

(define (eval-define exp env)
  (define-var-val! 
    (define-variable exp)
    (eval (define-value exp) env)
    env)
  'ok)

(define (define-variable exp)
  (if (symbol? (cadr exp))
      (cadr exp)
      (caadr exp)))

(define (define-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (cdadr exp)
		   (cddr exp))))

(define (make-lambda vars body)
  (cons 'lambda (cons vars body)))

;; END eval-define

;; BEGIN eval-lambda
(define (eval-lambda exp env)
  (make-procedure 
   (lambda-params exp)
   (lambda-body exp)
   env))

(define (lambda-params exp) (cadr exp))

(define (lambda-body exp) (cddr exp))

;; END eval-lambda




(define primitive-procs
  (list 
   (list 'car 'primitive car)
   (list 'cdr 'primitive cdr)
   (list 'cons 'primitive cons)
   (list 'null? 'primitive null?)
   (list 'if 'syntax eval-if)
   (list 'quote 'syntax eval-quote)
   (list 'set! 'syntax eval-set!)
   (list 'define 'syntax eval-define)
   (list 'lambda 'syntax eval-lambda)
   (list 'begin 'syntax eval-sequence)
   (list '> 'primitive >)
   (list '< 'primitive <)
   (list '= 'primitive =)
   (list 'eq? 'primitive eq?)
   (list '+ 'primitive +)
   (list '- 'primitive -)
   (list '* 'primitive *)
   (list '/ 'primitive /)
   ))


(define (setup-environment)
  (let ((init-env 
	 (extend-environment
	  (primitive-procedure-names primitive-procs)
	  (primitive-procedure-values primitive-procs)
	  '())))
  (extend-environment 
   (list 'true 'false) 
   (list #t #f) 
   init-env)))

(define the-global-environment (setup-environment))


(define (driver-loop)
  (newline)
  (display "> ")
  (let ((input (read)))
    (let ((output (eval input the-global-environment)))
      (newline)
      (display output)))
  (driver-loop))