λ4.2節
問題 4.25
問題 4.26
問題 4.27
問題 4.28
問題 4.29
問題 4.30
問題 4.31
問題 4.32
問題 4.33
問題 4.34
遅延評価器
メモ化した遅延評価器
遅延評価器
(define apply-in-underlying-scheme apply) ;;脚注17
;;駆動ループ 4.1.4
(define input-prompt ";;; L-Eval input:")
(define output-prompt ";;; L-Eval value:")
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
(let ((output
(actual-value input the-global-environment)))
(announce-output output-prompt)
(user-print output)))
(driver-loop))
(define (prompt-for-input string)
(newline) (newline) (display string) (newline))
(define (announce-output string)
(newline) (display string) (newline))
(define (user-print object)
(if (compound-procedure? object)
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'))
(display object)))
;;環境
(define primitive-procedures
(list (list '* *)
(list '+ +)
(list '- -)
(list '/ /)
(list '< <)
(list '= =)
(list '> >)
;; (list 'apply apply)
(list 'assoc assoc)
(list 'atan atan)
(list 'cadr cadr)
(list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'cos cos)
(list 'display display)
(list 'eq? eq?)
(list 'error error)
;; (list 'eval eval)
(list 'list list)
(list 'log log)
(list 'max max)
(list 'min min)
(list 'newline newline)
(list 'not not)
(list 'null? null?)
(list 'number? number?)
(list 'pair? pair?)
(list 'quotient quotient)
(list 'random random)
(list 'read read)
(list 'remainder remainder)
(list 'round round)
(list 'runtime runtime)
(list 'set-car! set-car!)
(list 'set-cdr! set-cdr!)
(list 'sin sin)
(list 'symbol? symbol?)
(list 'vector-ref vector-ref)
(list 'vector-set! vector-set!)
))
(define the-empty-environment '())
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
(define (primitive-procedure-names)
(map car
primitive-procedures))
(define (make-frame variables values)
(cons variables values))
(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(if (< (length vars) (length vals))
(error "Too many arguments supplied" vars vals)
(error "Too few arguments supplied" vars vals))))
(define (first-frame env) (car env))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (enclosing-environment env) (cdr env))
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
(cond ((null? vars)
(add-binding-to-frame! var val frame))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define-variable! 'true true initial-env)
(define-variable! 'false false initial-env)
initial-env))
(define the-global-environment (setup-environment))
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
;; 4.1.2 evalの下請け手続き
;; 4.1.2 自己評価式
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
(else false)))
;; 4.1.2 変数
(define (variable? exp) (symbol? exp))
;; 4.1.2 クォート式
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
;; 4.1.2 代入
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
;; 4.1.2 定義
(define (definition? exp)
(tagged-list? exp '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) ;formal parameter
(cddr exp)))) ;body
;; 4.1.2 lambda式
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
;; 4.1.2 条件式
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
'false))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
;; 4.1.2 begin
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
;; 4.1.2 手続き作用
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
;; 4.1.2 導出された式
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false ;no else clause
(let ((first (car clauses))
(rest (cdr clauses)))
(if (eq? (cadr first) '=>) ;ex4.05
(let ((temp `(let ((val ,(cond-predicate first))) ;ex4.05
(if val (,(caddr first) val) ;ex4.05
,(expand-clauses rest)))))
(display temp) (newline) temp)
(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)))))))
;(define (expand-clauses clauses)
; (if (null? clauses)
; 'false ;no else clause
; (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))))))
;; 4.1.1 手続きの引数
;(define (list-of-values exps env)
; (if (no-operands? exps)
; '()
; (cons (eval (first-operand exps) env)
; (list-of-values (rest-operands exps) env))))
;; 4.2.2 条件式
(define (eval-if exp env)
(if (true? (actual-value (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
;; 4.1.1 並び
(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))))
;; 4.1.1 代入と定義
(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)
;; 4.1.1 eval
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-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))
((and? exp) (eval (and->if exp) env)) ;ex4.04
((or? exp) (eval (or->if exp) env)) ;ex4.04
((let? exp) (eval (let->combination exp) env)) ;ex4.06
((let*? exp) (eval (let*->nested-lets exp) env)) ;ex4.07
((letrec? exp) (eval (letrec->let exp) env)) ;ex4.20
((application? exp)
(apply (actual-value (operator exp) env)
(operands exp)
env))
(else
(error "Unknown expression type -- EVAL" exp))))
(define (actual-value exp env)
(force-it (eval exp env)))
;; 4.2.2 apply
(define (apply procedure arguments env)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure
procedure
(list-of-arg-values arguments env))) ;;; 変更した
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
(list-of-delayed-args arguments env) ;;; 変更した
(procedure-environment procedure))))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc) args))
(define (list-of-arg-values exps env)
(if (no-operands? exps)
'()
(cons (actual-value (first-operand exps) env)
(list-of-arg-values (rest-operands exps)
env))))
(define (list-of-delayed-args exps env)
(if (no-operands? exps)
'()
(cons (delay-it (first-operand exps) env)
(list-of-delayed-args (rest-operands exps)
env))))
;;; representing procedures
;; 4.1.3 条件のテスト
(define (true? x)
(not (eq? x false)))
(define (false? x)
(eq? x false))
;; 4.1.3 手続きの表現
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
(tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
;; 4.1.3 環境に対する操作
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(car vals))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable -- SET!" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
;;thunk
(define (force-it obj)
(if (thunk? obj)
(actual-value (thunk-exp obj) (thunk-env obj))
obj))
(define (delay-it exp env)
(list 'thunk exp env))
(define (thunk? obj)
(tagged-list? obj 'thunk))
(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (caddr thunk))
;;(define (evaluated-thunk? obj)
;; (tagged-list? obj 'evaluated-thunk))
;;
;;(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
;;
;;(define (force-it obj)
;; (cond ((thunk? obj)
;; (let ((result (actual-value
;; (thunk-exp obj)
;; (thunk-env obj))))
;; (set-car! obj 'evaluated-thunk)
;; (set-car! (cdr obj) result) ;;;expをその値で置き換える
;; (set-cdr! (cdr obj) '()) ;;;不要なenvを忘れる
;; result))
;; ((evaluated-thunk? obj)
;; (thunk-value obj))
;; (else obj)))
;;ex4.04
(define (and? exp) (tagged-list? exp 'and))
(define (or? exp) (tagged-list? exp 'or))
(define (and->if exp)
(expand-conjuncts (conjuncts exp)))
(define (conjuncts exp) (cdr exp))
(define (expand-conjuncts conjuncts)
(cond ((null? conjuncts) 'false)
((null? (cdr conjuncts))
(make-if (car conjuncts) (car conjuncts) 'false))
(else (make-if (car conjuncts)
(expand-conjuncts (cdr conjuncts))
'false))))
(define (or->if exp)
(expand-disjuncts (disjuncts exp)))
(define (disjuncts exp) (cdr exp))
(define (expand-disjuncts disjuncts)
(cond ((null? disjuncts) 'true)
((null? (cdr disjuncts))
(make-if (car disjuncts) (car disjuncts) 'false))
(else (make-if (car disjuncts)
(car disjuncts)
(expand-disjuncts (cdr disjuncts))))))
;; ex4.06 ex4.08
(define (let? exp) (tagged-list? exp 'let))
(define (let->combination exp)
(if (symbol? (cadr exp))
(let ((tag (cadr exp)) (bindings (caddr exp)) (body (cdddr exp))) ;ex4.08
(list (list 'lambda '() ;ex4.08
(cons 'define (cons (cons tag (map car bindings)) body));ex4.08
(cons tag (map cadr bindings))))) ;ex4.08
(let ((bindings (cadr exp)) (body (cddr exp)))
(cons (make-lambda (map car bindings) body)
(map cadr bindings)))))
;; ex4.07
(define (let*? exp) (tagged-list? exp 'let*))
(define (let*->nested-lets exp)
(define (nested-lets bindings body)
(if (null? (cdr bindings))
(cons (make-lambda (list (caar bindings)) body) (cdar bindings))
(cons (make-lambda (list (caar bindings))
(list (nested-lets (cdr bindings) body))) (cdar bindings))))
(let ((bindings (cadr exp)) (body (cddr exp)))
(nested-lets bindings body)))
;; ex4.20
(define (letrec? exp) (tagged-list? exp 'letrec))
(define (letrec->let exp)
(let ((bindings (cadr exp)) (body (cddr exp)))
(cons 'let (cons
(map (lambda (x) (list (car x) ''())) bindings)
(append (map (lambda (x) (cons 'set! x)) bindings) body)))))
;; 4.1.4 対話開始
(define the-global-environment (setup-environment))
;(display (string #\bel))
(newline)(newline)
(display
"CAUTION: the original apply was removed; mceval cannot be loaded again.")
(newline)
(display
"USE (driver-loop) to return to metaciucular evaluator.")
(newline)
(driver-loop)
メモ化した遅延評価器
(define apply-in-underlying-scheme apply) ;;脚注17
;;駆動ループ 4.1.4
(define input-prompt ";;; L-Eval input:")
(define output-prompt ";;; L-Eval value:")
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
(let ((output
(actual-value input the-global-environment)))
(announce-output output-prompt)
(user-print output)))
(driver-loop))
(define (prompt-for-input string)
(newline) (newline) (display string) (newline))
(define (announce-output string)
(newline) (display string) (newline))
(define (user-print object)
(if (compound-procedure? object)
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'))
(display object)))
;;環境
(define primitive-procedures
(list (list '* *)
(list '+ +)
(list '- -)
(list '/ /)
(list '< <)
(list '= =)
(list '> >)
;; (list 'apply apply)
(list 'assoc assoc)
(list 'atan atan)
(list 'cadr cadr)
(list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'cos cos)
(list 'display display)
(list 'eq? eq?)
(list 'error error)
;; (list 'eval eval)
(list 'list list)
(list 'log log)
(list 'max max)
(list 'min min)
(list 'newline newline)
(list 'not not)
(list 'null? null?)
(list 'number? number?)
(list 'pair? pair?)
(list 'quotient quotient)
(list 'random random)
(list 'read read)
(list 'remainder remainder)
(list 'round round)
(list 'runtime runtime)
(list 'set-car! set-car!)
(list 'set-cdr! set-cdr!)
(list 'sin sin)
(list 'symbol? symbol?)
(list 'vector-ref vector-ref)
(list 'vector-set! vector-set!)
))
(define the-empty-environment '())
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
(define (primitive-procedure-names)
(map car
primitive-procedures))
(define (make-frame variables values)
(cons variables values))
(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(if (< (length vars) (length vals))
(error "Too many arguments supplied" vars vals)
(error "Too few arguments supplied" vars vals))))
(define (first-frame env) (car env))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (enclosing-environment env) (cdr env))
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
(cond ((null? vars)
(add-binding-to-frame! var val frame))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define-variable! 'true true initial-env)
(define-variable! 'false false initial-env)
initial-env))
(define the-global-environment (setup-environment))
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
;; 4.1.2 evalの下請け手続き
;; 4.1.2 自己評価式
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
(else false)))
;; 4.1.2 変数
(define (variable? exp) (symbol? exp))
;; 4.1.2 クォート式
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
;; 4.1.2 代入
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
;; 4.1.2 定義
(define (definition? exp)
(tagged-list? exp '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) ;formal parameter
(cddr exp)))) ;body
;; 4.1.2 lambda式
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
;; 4.1.2 条件式
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
'false))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
;; 4.1.2 begin
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
;; 4.1.2 手続き作用
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
;; 4.1.2 導出された式
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false ;no else clause
(let ((first (car clauses))
(rest (cdr clauses)))
(if (eq? (cadr first) '=>) ;ex4.05
(let ((temp `(let ((val ,(cond-predicate first))) ;ex4.05
(if val (,(caddr first) val) ;ex4.05
,(expand-clauses rest)))))
(display temp) (newline) temp)
(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)))))))
;(define (expand-clauses clauses)
; (if (null? clauses)
; 'false ;no else clause
; (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))))))
;; 4.1.1 手続きの引数
;(define (list-of-values exps env)
; (if (no-operands? exps)
; '()
; (cons (eval (first-operand exps) env)
; (list-of-values (rest-operands exps) env))))
;; 4.2.2 条件式
(define (eval-if exp env)
(if (true? (actual-value (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
;; 4.1.1 並び
(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))))
;; 4.1.1 代入と定義
(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)
;; 4.1.1 eval
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-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))
((and? exp) (eval (and->if exp) env)) ;ex4.04
((or? exp) (eval (or->if exp) env)) ;ex4.04
((let? exp) (eval (let->combination exp) env)) ;ex4.06
((let*? exp) (eval (let*->nested-lets exp) env)) ;ex4.07
((letrec? exp) (eval (letrec->let exp) env)) ;ex4.20
((application? exp)
(apply (actual-value (operator exp) env)
(operands exp)
env))
(else
(error "Unknown expression type -- EVAL" exp))))
(define (actual-value exp env)
(force-it (eval exp env)))
;; 4.2.2 apply
(define (apply procedure arguments env)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure
procedure
(list-of-arg-values arguments env))) ;;; 変更した
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
(list-of-delayed-args arguments env) ;;; 変更した
(procedure-environment procedure))))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc) args))
(define (list-of-arg-values exps env)
(if (no-operands? exps)
'()
(cons (actual-value (first-operand exps) env)
(list-of-arg-values (rest-operands exps)
env))))
(define (list-of-delayed-args exps env)
(if (no-operands? exps)
'()
(cons (delay-it (first-operand exps) env)
(list-of-delayed-args (rest-operands exps)
env))))
;;; representing procedures
;; 4.1.3 条件のテスト
(define (true? x)
(not (eq? x false)))
(define (false? x)
(eq? x false))
;; 4.1.3 手続きの表現
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
(tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
;; 4.1.3 環境に対する操作
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(car vals))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable -- SET!" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
;;thunk
;;(define (force-it obj)
;; (if (thunk? obj)
;; (actual-value (thunk-exp obj) (thunk-env obj))
;; obj))
(define (delay-it exp env)
(list 'thunk exp env))
(define (thunk? obj)
(tagged-list? obj 'thunk))
(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (caddr thunk))
(define (evaluated-thunk? obj)
(tagged-list? obj 'evaluated-thunk))
(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
(define (force-it obj)
(cond ((thunk? obj)
(let ((result (actual-value
(thunk-exp obj)
(thunk-env obj))))
(set-car! obj 'evaluated-thunk)
(set-car! (cdr obj) result) ;;;expをその値で置き換える
(set-cdr! (cdr obj) '()) ;;;不要なenvを忘れる
result))
((evaluated-thunk? obj)
(thunk-value obj))
(else obj)))
;;ex4.04
(define (and? exp) (tagged-list? exp 'and))
(define (or? exp) (tagged-list? exp 'or))
(define (and->if exp)
(expand-conjuncts (conjuncts exp)))
(define (conjuncts exp) (cdr exp))
(define (expand-conjuncts conjuncts)
(cond ((null? conjuncts) 'false)
((null? (cdr conjuncts))
(make-if (car conjuncts) (car conjuncts) 'false))
(else (make-if (car conjuncts)
(expand-conjuncts (cdr conjuncts))
'false))))
(define (or->if exp)
(expand-disjuncts (disjuncts exp)))
(define (disjuncts exp) (cdr exp))
(define (expand-disjuncts disjuncts)
(cond ((null? disjuncts) 'true)
((null? (cdr disjuncts))
(make-if (car disjuncts) (car disjuncts) 'false))
(else (make-if (car disjuncts)
(car disjuncts)
(expand-disjuncts (cdr disjuncts))))))
;; ex4.06 ex4.08
(define (let? exp) (tagged-list? exp 'let))
(define (let->combination exp)
(if (symbol? (cadr exp))
(let ((tag (cadr exp)) (bindings (caddr exp)) (body (cdddr exp))) ;ex4.08
(list (list 'lambda '() ;ex4.08
(cons 'define (cons (cons tag (map car bindings)) body));ex4.08
(cons tag (map cadr bindings))))) ;ex4.08
(let ((bindings (cadr exp)) (body (cddr exp)))
(cons (make-lambda (map car bindings) body)
(map cadr bindings)))))
;; ex4.07
(define (let*? exp) (tagged-list? exp 'let*))
(define (let*->nested-lets exp)
(define (nested-lets bindings body)
(if (null? (cdr bindings))
(cons (make-lambda (list (caar bindings)) body) (cdar bindings))
(cons (make-lambda (list (caar bindings))
(list (nested-lets (cdr bindings) body))) (cdar bindings))))
(let ((bindings (cadr exp)) (body (cddr exp)))
(nested-lets bindings body)))
;; ex4.20
(define (letrec? exp) (tagged-list? exp 'letrec))
(define (letrec->let exp)
(let ((bindings (cadr exp)) (body (cddr exp)))
(cons 'let (cons
(map (lambda (x) (list (car x) ''())) bindings)
(append (map (lambda (x) (cons 'set! x)) bindings) body)))))
;; 4.1.4 対話開始
(define the-global-environment (setup-environment))
;(display (string #\bel))
(newline)(newline)
(display
"CAUTION: the original apply was removed; mceval cannot be loaded again.")
(newline)
(display
"USE (driver-loop) to return to metaciucular evaluator.")
(newline)
(driver-loop)
問題 4.25
通常のSchemeでは, unlessは特殊形式でないため, 三つの引数の評価を始める. 第二引
数はfactorialだから, またunlessの引数評価を始め, かくして停止せず, スタックを使
い切る. 実際やってみると:
1 ]=> (define (unless condition usual-value exceptional-value)
(if conditon exceptional-value usual-value))
;Value: unless
1 ]=> (define (factorial n)
(unless (= n 1)
(* n (factorial (- n 1)))
1)
)
;Value: factorial
1 ]=> (factorial 5)
;Aborting!: maximum recursion depth exceeded
一方, 4.2.2節の遅延評価を使うと, unlessの引数はそのままifへ引き継ぎ, そこで述語
を評価, 次に帰結部へいき, これは乗算だから, 次のfactorialの計算へ進む. やってみ
ると
;;; L-Eval input:
(define (unless condition usual-value exceptional-value)
(if condition exceptional-value usual-value))
;;; L-Eval value:
ok
;;; L-Eval input:
(define (factorial n)
(unless (= n 1)
(* n (factorial (- n 1)))
1))
;;; L-Eval value:
ok
;;; L-Eval input:
(factorial 5)
;;; L-Eval value:
120
問題 4.27
;;; L-Eval input:
(define count 0)
;;; L-Eval value:
ok
;;; L-Eval input:
(define (id x)
(set! count (+ count 1))
x)
;;; L-Eval value:
ok
;;; L-Eval input:
(define w (id (id 10)))
;;; L-Eval value:
ok
;;; L-Eval input:
count
;;; L-Eval value:
1
;;; L-Eval input:
w
;;; L-Eval value:
10
;;; L-Eval input:
count
;;; L-Eval value:
2
(define w (id (id 10)))のときにidが1回評価され, countは1になる.
しかしwの値は確定していない. wを印字しようとするとidがもう1回
評価され, countは2になる.
問題 4.29
(define count 0)
(define (id x)
(set! count (+ count 1))
x)
(define (square x) (* x x))
(square (id 10))
count
メモ化しない評価器
;;; L-Eval input:
(square (id 10))
;;; L-Eval value:
100
;;; L-Eval input:
count
;;; L-Eval value:
2
メモ化した評価器
;;; L-Eval input:
(square (id 10))
;;; L-Eval value:
100
;;; L-Eval input:
count
;;; L-Eval value:
1
問題 4.33
このままやると
;;; L-Eval input:
(car '(a b c))
;Unknown procedure type -- APPLY (a b c)
;To continue, call RESTART with an option number:
; (RESTART 1) => Return to read-eval-print level 1.
となってしまう.
もともとのcar, cdrを退避しておき,
(define car-in-underlying-scheme car)
(define cdr-in-underlying-scheme cdr)
(define (cons x y)
(lambda (m) (m x y)))
(define (car z)
(z (lambda (p q) p)))
(define (cdr z)
(z (lambda (p q) q)))
(define (convert x)
(if (pair? x) (cons (convert (car-in-underlying-scheme x))
(convert (cdr-in-underlying-scheme x)))
x))
で古いシステムから新しいシステムへ変換する.
実行してみる.
;;; L-Eval input:
(car (convert '(a b c)))
;;; L-Eval value:
a
;;; L-Eval input:
(define foo (convert '(a b c)))
;;; L-Eval value:
ok
;;; L-Eval input:
(car (cdr foo))
;;; L-Eval value:
b
;;; L-Eval input:
(car (cdr (cdr foo)))
;;; L-Eval value:
c