2015/12/18
SICP 問題 4.03
;; evalをデータ主導スタイルに書き換える.
;; 本文で定義されたeval
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-valiable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp) (make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type: EVAL" exp))))
;; opを持つexpと持たないexpで分ける.
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-valiable-value exp env))
(let ((op (get 'eval (operator exp)))) ;;opが見付からなければfalseが束縛
(cond (op
(op (operands exp) env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type: EVAL" exp))))))
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define (install-eval-package)
;; クオート式
(define (text-of-quotation exp) (cadr exp))
;; 代入
(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(eval (assignment-value exp) env)
env)
'ok)
;; 定義
(define (eval-definition exp env)
(define-variable! (definition-variable exp)
(eval (definition-value exp) env)
env)
'ok)
;; 条件式
(define (eval-if exp env)
(if (true? (eval (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
;; lambda
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
;; 列
(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 (begin-actions exp) (cdr exp))
(define (cond->if exp) (expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false ;; else 説は無い
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last: COND->IF"
clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
(put 'eval 'quote text-of-quotation)
(put 'eval 'set! eval-assignment)
(put 'eval 'define eval-definition)v
(put 'eval 'if eval-if)
(put 'eval 'lambda (lambda (exp env) (make-procedure (lambda-parameters exp)
(lambda-body exp)
env)))
(put 'eval 'begin (lambda (exp env) (eval-sequence (begin-actions exp) env)))
(put 'eval 'cond (lambda (exp env) (eval (cond->if exp) env)))
'done)