SICP再開しました

SICP再開しました。
"4.1.7 構文解析を実行から分離する"を読んで実装したプログラムを載せておきます。
問題4.22の解答はプログラム中のanalyze-letの実装のとおり。

問題4.23の解答はこんな感じ。
本文版は以下のようになっている。

(define (analyze-sequence exps)
  (define (sequentially proc1 proc2)
    (lambda (env) (proc1 env) (proc2 env)))
  (define (loop first-proc rest-procs)
    (if (null? rest-procs)
        first-proc
        (loop (sequentially first-proc (car rest-procs))
                            (cdr rest-procs))))
  (let ((procs (map analyze exps)))
    (if (null? procs)
      (error "Empty sequence -- ANALYZE"))
      (loop (car procs) (cdr procs))))

これに対して以下のような式を与える。

(begin
  proc0
  proc1
  proc2)

すると

(lambda (env)
  ((lambda (env)
     (proc0 env)
     ((lambda (env)
	(proc1 env)
	((lambda (env)
	   (proc2 env)) env)) env))))

のようにlambda の入れ子構造が出来る。
この時点でevalだけをやり続ける構造が出来上がっている。

基本的な構造はconsセルみたいに最初と残りの部分の評価をする関数で出来ている。
こんな感じ。

(lambda (env)
  (first env)
  (rest  env))

Alyssa版は(map analyze procs)でリストを作り、
リストの先頭から順番に実行するlambdaを一つだけ作る。
本文版のようにlambdaの入れ子ではない。
リストを順番に評価していくので、評価器の動作でリスト構造の解析とNULLチェックが入ってしまう。

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; for debug
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (println . exps)
  (let loop ((exps exps))
    (if (null? exps)
	(newline)
	(begin
	  (display (car exps))
	  (loop (cdr exps))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; boolean and comparison functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (false? val)
  (equal? val 'false))
(define (true? val)
  (not (false? val)))

(define (make-comparison compare)
  (lambda (base . comparison-values)
    (let loop ((vs comparison-values))
      (cond 
       ((null? vs) 'true)
       ((compare base (car vs)) (loop (cdr vs)))
       (else 'false)))))

(define >? (make-comparison >))
(define <? (make-comparison <))
(define =? (make-comparison =))

(define (primitive-equal? l r)
  (if (equal? l r) 'true 'false))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; environment 
;
; environment structure:
; '(((a . 1) (b . 1))          <= newest frame
;   ((a . 2) (b . 2) (c . 3))
;      .... )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (setup-environment)
  `(((true   . true) 
     (false  . false)
     (car    . (primitive . ,car))
     (cdr    . (primitive . ,cdr))
     (cons   . (primitive . ,cons))
     (+      . (primitive . ,+))
     (-      . (primitive . ,-))
     (*      . (primitive . ,*))
     (/      . (primitive . ,/))
     (>      . (primitive . ,>?))
     (<      . (primitive . ,<?))
     (equal? . (primitive . ,primitive-equal?))
     (=      . (primitive . ,=?)))))
     

(define (lookup-var-val var env)
  (let loop ((frames env))
    (cond
     ((null? frames) (error "not found " var))
     (else
      (let ((var-val (assoc var (car frames))))
	(if var-val 
	    (cdr var-val)
	    (loop (cdr frames))))))))

(define (set-var-val! var val env)
  (let loop ((frames env))
    (if (null? frames) 
	(error "unbounded variable" var)
	(let ((var-val (assoc var (car frames))))
	  (if var-val
	      (let ((ret (cdr var-val)))
		(set-cdr! var-val val)
		ret)
	      (loop (cdr frames)))))))

(define (define-var-val! var val env)
  (set-car! env (cons (cons var val) (car env))))

(define (extend-env vars vals env)
  (cons (map cons vars vals) env))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; analyze functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; self-evaluating
(define (self-evaluating? exp)
  (or (number? exp) (string? exp)))

(define (analyze-self-evaluating exp)
  (lambda (env) exp))

(define (analyze-quoted exp)
  (let ((qvs (cadr exp)))
    (lambda (env)
      qvs)))

;; symbol 
(define (analyze-symbol exp)
  (lambda (env)
    (lookup-var-val exp env)))

;; quote
(define (syntax-check symbol)
  (lambda (exp)
    (and (pair? exp) (equal? (car exp) symbol))))

(define quoted? (syntax-check 'quote))

;; if
(define (analyze-if exp)
  (let ((predicate (analyze (cadr exp)))
	(consequent (analyze (caddr exp)))
	(alternative 
	 (if (not (null? (cdddr exp)))
	     (analyze (cadddr exp))
	     (lambda (env) 'none))))
  (lambda (env)
    (if (true? (predicate env))
	(consequent env)
	(alternative env)))))

;; set
(define (analyze-set exp)
  (let ((var (cadr exp))
	(val (analyze (caddr exp))))
    (lambda (env)
      (set-var-val! var (val env) env))))

(define (syntax? exp)
  (and (pair? exp) (assoc (car exp) syntaxes)))

(define (analyze-syntax exp)
  (let ((syntax (cdr (assoc (car exp) syntaxes))))
    (syntax exp)))

;; lambda 
(define (make-lambda args procs)
  (cons 'lambda (cons args procs)))

(define (make-procedure vars procs env)
  (list 'procedure vars procs env))

(define (analyze-lambda exp)
  (let ((vars  (cadr exp))
	(procs (analyze-sequence (cddr exp))))
    (lambda (env)
      (make-procedure vars procs env))))

;; sequence
(define (analyze-sequence exps)
  (let loop ((procs (map analyze exps)))
    (cond
     ((null? procs) (error "analyze-sequence: fail"))
     ((null? (cdr procs))
      (lambda (env) ((car procs) env)))
     (else
      (lambda (env)
	((car procs) env)
	((loop (cdr procs)) env))))))

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

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

(define (analyze-define exp)
  (let ((var (definition-variable exp))
	(vproc (analyze (definition-value exp))))
    (lambda (env)
      (define-var-val! var (vproc env) env)
      'ok)))

;; let
(define (analyze-let exp)
  (if (symbol? (cadr exp))
      (let* ((name (cadr exp))
	     (vars 
	      (map (lambda (var-val) (car var-val))
		   (caddr exp)))
	     (vals
	      (map (lambda (var-val) 
		     (analyze (cadr var-val)))
		   (caddr exp)))
	     (procs (analyze 
		     (make-lambda
		      vars
		      (cdddr exp)))))
	(lambda (env)
	  (let ((args (map (lambda (arg)
			     (arg env)) vals)))
	    (define-var-val! name (procs env) env)
	    (execute (procs env) args))))
      (let ((vars
	     (map (lambda (var-val) (car var-val))
		  (cadr exp)))
	    (vals 
	     (map (lambda (var-val) 
		    (analyze (cadr var-val)))
		  (cadr exp)))
	    (procs (analyze-sequence (cddr exp))))
	(lambda (env)
	  (let ((procedure
		 (make-procedure vars procs env)))
	    (execute
	     procedure
	     (map (lambda (arg)
		    (arg env)) vals)))))))

;; application
(define (analyze-application exp)
  (let ((proc (analyze (car exp)))
	(args (map analyze (cdr exp))))
    (lambda (env)
      (execute (proc env)
	       (map (lambda (arg)
		      (arg env)) args)))))

(define (application? exp)
  (pair? exp))

(define (primitive? proc)
  (equal? (car proc) 'primitive))

(define (procedure? proc)
  (equal? (car proc) 'procedure))

;; apply
(define (execute proc args)
  (cond
   ((primitive? proc)
    (apply (cdr proc) args))
   ((procedure? proc)
    ((caddr proc)
     (extend-env 
      (cadr proc) args (cadddr proc))))
   (else
    (error "execute fail:"))))

;; analyze
(define syntaxes
  `((if     . ,analyze-if) 
    (set!   . ,analyze-set)
    (begin  . ,analyze-sequence)
    (lambda . ,analyze-lambda)
    (define . ,analyze-define)
    (let    . ,analyze-let)))

(define (analyze exp)
  (cond 
   ((self-evaluating? exp)(analyze-self-evaluating exp))
   ((quoted? exp)         (analyze-quoted exp))
   ((symbol? exp)         (analyze-symbol exp))
   ((syntax? exp)         (analyze-syntax exp))
   ((application? exp)    (analyze-application exp))
   (else
    (error "analyze fail: unknown type"))))

(define (analyze-loop)
  (let ((global-env (setup-environment))
	(read-sexp 
	 (lambda ()
	   (newline)
	   (display "> ")
	   (read))))
    (let loop ()
      (let ((result ((analyze (read-sexp)) global-env)))
	(cond
	 ((equal? 'quit result) 'quit)
	 (else
	  (display result)
	  (loop)))))))