SICP
Exercise 5.23
;;; eval-dispatch に追加
(test (op cond?) (reg exp))
(branch (label ev-cond))
(test (op let?) (reg exp))
(branch (label ev-let))
(test (op let*?) (reg exp))
(branch (label ev-let*))
;;; eval に追加
ev-cond
(assign exp (op cond->if) (reg exp))
(goto (label eval-dispatch))
ev-let
(assign exp (op let->combination) (reg exp))
(goto (label eval-dispatch))
ev-let*
(assign exp (op let*->nested-lets) (reg exp))
(goto (label eval-dispatch))
;; test programs
(define (cond.test)
(format "cond.test[greater] : ~s~%cond.test[equal] : ~s~%cond.test[2] : ~s"
(cond ((> 3 2) 'greater)
((< 3 2) 'less))
(cond ((> 3 3) 'greater)
((< 3 3) 'less)
(else 'equal))
(cond ((assoc 'b '((a 1) (b 2))) => cadr)
(else #f))
))
(define (let.test)
(format "let.test[6] : ~d~%let.test[35] : ~d"
(let ((x 2) (y 3))
(* x y))
(let ((x 2) (y 3))
(let ((x 7)
(z (+ x y)))
(* z x)))
))
(define (nlet.test)
(format "nlet.test[(6 1 3) (-5 -2)] : ~s"
(let loop ((numbers '(3 -2 1 6 -5))
(nonneg '())
(neg '()))
(cond ((null? numbers) (list nonneg neg))
((>= (car numbers) 0)
(loop (cdr numbers) (cons (car numbers) nonneg) neg))
((< (car numbers) 0)
(loop (cdr numbers) nonneg (cons (car numbers) neg)))))
))
(define (let*.test)
(format "let*test[70] : ~d"
(let ((x 2) (y 3))
(let* ((x 7)
(z (+ x y)))
(* z x)))
))
;;;;; EC-Eval input:
;;(cond.test)
;;;;; EC-Eval value:
;;cond.test[greater] : greater
;;cond.test[equal] : equal
;;cond.test[2] : 2
;;;;; EC-Eval input:
;;(let.test)
;;;;; EC-Eval value:
;;let.test[6] : 6
;;let.test[35] : 35
;;;;; EC-Eval input:
;;(nlet.test)
;;;;; EC-Eval value:
;;nlet.test[(6 1 3) (-5 -2)] : ((6 1 3) (-5 -2))
;;;;; EC-Eval input:
;;(let*.test)
;;;;; EC-Eval value:
;;let*test[70] : 70
Exercise 5.24
;;; argl を clauses のポインタに使用
ev-cond
(save continue)
(assign argl (op cond-clauses) (reg exp))
ev-cond-clauses
(test (op null?) (reg argl))
(branch (label ev-cond-no-action))
(assign unev (op car) (reg argl))
(test (op cond-else-clause?) (reg unev))
(branch (label ev-cond-sequence))
(save argl)
(save unev)
(assign exp (op cond-predicate) (reg unev))
(assign continue (label ev-cond-ev-pred-done))
(goto (label eval-dispatch))
ev-cond-ev-pred-done
(restore unev)
(restore argl)
(test (op true?) (reg val))
(branch (label ev-cond-sequence))
(assign argl (op cdr) (reg argl))
(goto (label ev-cond-clauses))
ev-cond-sequence
(assign unev (op cond-actions) (reg unev))
(goto (label ev-sequence))
ev-cond-no-action
(assign val (const #f))
(restore continue)
(goto (reg continue))
;;; test program
(define (cond.test)
(format "cond.test[greater] : ~s~%cond.test[equal] : ~s~%cond.test[2] : ~s"
(cond ((> 3 2) 'greater)
((< 3 2) 'less))
(cond ((> 3 3) 'greater)
((< 3 3) 'less)
(else 'equal))
;(cond ((assoc 'b '((a 1) (b 2))) => cadr)
; (else #f))
'skip
))
;;;;; EC-Eval input:
;;(cond.test)
;;;;; EC-Eval value:
;;cond.test[greater] : greater
;;cond.test[equal] : equal
;;cond.test[2] : skip
Exercise 5.25
;;; register Lazy を eceval に追加しその値が #t であれば遅延評価を行う。
;;; eceval-operations に以下の手続きを追加
(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))
;;; primitive / の変更 (test用:gaucheの/は0除算を許可しているので)
(define (/ n d)
(if (= d 0)
(Error "division by 0")
(with-module scheme (/ n d))))
;;; ev-application の変更
ev-application
(test (op eq?) (reg Lazy) (const #t)) ;ex5.25
(branch (label L-ev-application)) ;ex5.25
(save continue)
(save env)
:
;;; 遅延評価用の ev-application
;; ex5.25->
L-ev-application
(save continue)
(save env)
(assign argl (op operands) (reg exp))
(save argl)
(assign exp (op operator) (reg exp))
(assign continue (label ev-application-1))
(goto (label actual-value))
ev-application-1
(restore argl)
(restore env)
(assign proc (reg val))
(assign continue (label ev-appl-ret))
(goto (label apply))
ev-appl-ret
(restore continue)
(goto (reg continue))
;; (apply proc argl env)
apply
;; Procedure application
L-apply-dispatch
(test (op primitive-procedure?) (reg proc))
(branch (label L-primitive-apply))
(test (op compound-procedure?) (reg proc))
(branch (label L-compound-apply))
(goto (label unknown-procedure-type))
L-primitive-apply
(save continue)
(save proc)
(assign continue (label primitive-apply-1))
(goto (label list-of-arg-values))
primitive-apply-1
(restore proc)
(assign val (op apply-primitive-procedure) (reg proc) (reg val))
(test (op eq?) (reg exit) (reg val))
(branch (label done))
(restore continue)
(goto (reg continue))
L-compound-apply
(save proc)
(assign continue (label compound-apply-1))
(goto (label list-of-delayed-args))
compound-apply-1
(restore proc)
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment) (reg unev) (reg val) (reg env))
(assign unev (op procedure-body) (reg proc))
(goto (label ev-sequence))
;; (actual-value exp env)
actual-value
(save continue)
(assign continue (label actual-value-1))
(goto (label eval-dispatch))
actual-value-1
(assign continue (label actual-value-2))
(goto (label force-it))
actual-value-2
(restore continue)
(goto (reg continue))
;; (force-it val)
force-it
(save continue)
(test (op thunk?) (reg val))
(branch (label force-it-1))
(goto (label force-it-ret))
force-it-1
(assign exp (op thunk-exp) (reg val))
(assign env (op thunk-env) (reg val))
(assign continue (label force-it-ret))
(goto (label actual-value))
force-it-ret
(restore continue)
(goto (reg continue))
;; (list-of-arg-values argl env)
list-of-arg-values
(test (op no-operands?) (reg argl))
(branch (label list-of-arg-values-nooperands-ret))
(save continue)
(assign exp (op first-operand) (reg argl))
(assign argl (op rest-operands) (reg argl))
(save argl)
(save env)
(assign continue (label list-of-arg-values-1))
(goto (label actual-value))
list-of-arg-values-1
(restore env)
(restore argl)
(save val)
(assign continue (label list-of-arg-values-2))
(goto (label list-of-arg-values))
list-of-arg-values-2
(restore unev) ; saved val !!!
(assign val (op cons) (reg unev) (reg val))
(restore continue)
(goto (reg continue))
list-of-arg-values-nooperands-ret
(assign val (const ()))
(goto (reg continue))
;; (list-of-delayed-args argl env)
list-of-delayed-args
(test (op no-operands?) (reg argl))
(branch (label list-of-delayed-args-nooperands-ret))
(save continue)
(assign exp (op first-operand) (reg argl))
(assign argl (op rest-operands) (reg argl))
(assign val (op delay-it) (reg exp) (reg env))
(save val)
(assign continue (label list-of-delayed-args-1))
(goto (label list-of-delayed-args))
list-of-delayed-args-1
(restore unev) ; saved val !!!
(assign val (op cons) (reg unev) (reg val))
(restore continue)
(goto (reg continue))
list-of-delayed-args-nooperands-ret
(assign val (const ()))
(goto (reg continue))
;; <-ex5.25
;;; ev-if の変更
ev-if
(save exp)
(save env)
(save continue)
(assign continue (label ev-if-decide))
(assign exp (op if-predicate) (reg exp))
(test (op eq?) (reg Lazy) (const #t)) ; ex5.25
(branch (label actual-value)) ; ex5.25
(goto (label eval-dispatch))
;;gosh> (start eceval)
;;;;; EC-Eval input:
;;(define (try a b)
;; (if (= a 0) 1 b))
;;;;; EC-Eval value:
;;ok
;;;;; EC-Eval input:
;;(try 0 (/ 1 0))
;;
;;#!# Error: division by 0
;;done
;;gosh> (reg! 'Lazy #t) <- set-register-contents! の短縮形
;;done
;;gosh> (start eceval)
;;;;; EC-Eval input:
;;(define (try a b)
;; (if (= a 0) 1 b))
;;;;; EC-Eval value:
;;ok
;;;;; EC-Eval input:
;;(try 0 (/ 1 0))
;;;;; EC-Eval value:
;;1
Exercise 5.26
;;;;; EC-Eval input:
;;(fact-i 1)
;;(total-pushes = 64 maximum-depth = 10 current-depth = 0)
;;;;; EC-Eval value:
;;1
;;;;; EC-Eval input:
;;(fact-i 2)
;;(total-pushes = 99 maximum-depth = 10 current-depth = 0)
;;;;; EC-Eval value:
;;2
;;;;; EC-Eval input:
;;(fact-i 3)
;;(total-pushes = 134 maximum-depth = 10 current-depth = 0)
;;;;; EC-Eval value:
;;6
;;;;; EC-Eval input:
;;(fact-i 4)
;;(total-pushes = 169 maximum-depth = 10 current-depth = 0)
;;;;; EC-Eval value:
;;24
;;;;; EC-Eval input:
;;(fact-i 5)
;;(total-pushes = 204 maximum-depth = 10 current-depth = 0)
;;;;; EC-Eval value:
;;120
;;; a
;;; iter が呼ばれてから次の iter が呼ばれるまでに使用される stack
;;; の最大 depth
;;; b
;;; 29+35n
Exercise 5.27
;;; 1: 2: 3: 4: 5: 10:
;;; Max Tot: Max Tot: Max Tot: Max Tot: Max Tot: Max Tot:
;;;Recursive 8 16: 13 48: 18 80: 23 112: 28 144: 53 304:
;;;Iterrative 10 64: 10 99: 10 134: 10 169: 10 204: 10 379:
;;;Recursive
;;; Maximum depth : 8 + 5 * (n - 1)
;;; Number of pushes : 16 + 32 * (n - 1)
;;;Iterative
;;; Maximum depth : 10
;;; Number of pushes : 64 + 35 * (n - 1)
Exercise 5.28
;;; 1: 2: 3: 4: 5: 10:
;;; Max Tot: Max Tot: Max Tot: Max Tot: Max Tot: Max Tot:
;;;Recursive 11 18: 19 52: 27 86: 35 120: 43 154: 83 324:
;;;Iterrative 17 70: 20 107: 23 144: 26 181: 29 218: 44 403:
;;;Recursive
;;; Maximum depth : 11 + 8 * (n - 1)
;;; Number of pushes : 18 + 34 * (n - 1)
;;;Iterative
;;; Maximum depth : 17 + 3 * (n - 1)
;;; Number of pushes : 70 + 37 * (n - 1)
Exercise 5.29
;;; 2: 3: 4: 5: 6: 7: 8:
;;; Max Tot: Max Tot: Max Tot: Max Tot: Max Tot: Max Tot: Max Tot:
;;; 13 72: 18 128: 23 240: 28 408: 33 688: 38 1136: 43 1864:
;;; a. 13 + 5 * (n - 2)
;;; b. S(n) = S(n - 1) + S(n - 2) + 40
;;; S(n) = 56 * Fib(n + 1) - 40
Exercise 5.30
;;; a.
;;; eceval-operation に登録されている手続き extend-environment, lookup-variable-value
;;; set-variable-value, expand-clause で呼出される error を Errorsignal に置換える。
(define (Errorsignal . objs)
(cons Errorsignal objs))
;;; 次の3つの手続きをeceval-operations に登録
(define (Error? obj)
(and (pair? obj) (eq? (car obj) Errorsignal)))
(define (ErrorM errsig) (cdr errsig))
(define (ErrorL objs)
(define (iter objs)
(if (null? (cdr objs))
(user-print (car objs))
(begin (user-print (car objs))
(display " ")
(iter (cdr objs)))))
(newline) (display "#!# Error: ")
(iter objs))
;;; eceval signal-errorを修正
signal-error
(perform (op ErrorL) (reg val))
(goto (label read-eval-print-loop))
signal-errorp
(assign val (op ErrorM) (reg val))
(goto (label signal-error))
;;; eceval extend-environment, lookup-variable-value, set-variavle-value,cond->if
;;; を使用している所を以下の要領で修正。
ev-variable
(assign val (op lookup-variable-value) (reg exp) (reg env))
(test (op Error?) (reg val))
(branch (label signal-errorp))
(goto (reg continue))
;;;;; EC-Eval input:
;;#(a b c)
;;
;;#!# Error: Unknown-expression-type-error : #(a b c)
;;;;; EC-Eval input:
;;x
;;
;;#!# Error: Unbound variable : x
;;;;; EC-Eval input:
;;; b
;;; primitive-procedures に登録する primitive の三番目の項目にエラーチェックリストを
;;; を追加する。car であれば、引数の数のチェックと引数が pair であることのチェックを
(list 'car car `((,Eargc (,= (,length (,argv)) 1)) (,Epair)))
;;; のように 一つのチェックを (チェック手続き [必要であればそのパラメータ]) の形式で
;;; 要素として持つリストとして追加する。/ であれば、
(list '/ / `((,Enums) (,Ediv0)))
;;; となる。apply の前にこのチェックリストを使ってパラメータのチェックを行う。
;;; primitive-p-parameter-check を eceval-operations に登録
(define PROC '())
(define ARGV '())
(define (argv) ARGV)
(define (primitive-p-parameter-check proc argl)
(if (> (length proc) 2)
(begin
(set! ARGV argl)
(set! PROC (primitive-implementation proc))
(let check-loop ((checks (primitive-checks proc)))
(if (null? checks)
'done
(let ((r (eval (car checks) (interaction-environment))))
(if (Error? r)
r
(check-loop (cdr checks)))))))))
(define (primitive-checks proc) (caddr proc))
(define (proc-name)
(let loop ((plist primitive-procedures))
(cond ((null? plist) 'proc-name-fatal-error)
((eq? (cadar plist) PROC) (caar plist))
(else (loop (cdr plist))))))
(define (Eargc pred)
(if (not pred)
(Errorsignal "Number of arguments for" (proc-name)
", got" (length ARGV) "args.")))
(define (Epair)
(if (not (pair? (car ARGV)))
(Errorsignal "Pair reqired for" (proc-name) ", but got" (car ARGV))))
(define (Enums)
(let loop ((args ARGV))
(cond ((null? args) 'ok)
((not (number? (car args)))
(Errorsignal "Number required for" (proc-name) ", but got" ARGV))
(else (loop (cdr args))))))
(define (Ediv0)
(let loop ((args (cdr ARGV)))
(cond ((null? args) 'ok)
((zero? (car args))
(Errorsignal "Division by 0, got" ARGV))
(else (loop (cdr args))))))
;;; eceval primitive-apply 変更
primitive-apply
(assign val (op primitive-p-parameter-check) (reg proc) (reg argl))
(test (op Error?) (reg val))
(branch (label signal-errorp))
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
;;;;; EC-Eval input:
;;(car 1 2)
;;#!# Error: Number of arguments for car , got 2 args.
;;;;; EC-Eval input:
;;(car 1)
;;#!# Error: Pair reqired for car , got 1
;;;;; EC-Eval input:
;;(car (cons 'a 'b))
;;(total-pushes = 9 maximum-depth = 8 current-depth = 0)
;;;;; EC-Eval value:
;;a
;;;;; EC-Eval input:
;;(/ 128 'a)
;;#!# Error: Number required for / , but got (128 a)
;;;;; EC-Eval input:
;;(/ 128 0)
;;#!# Error: Division by 0, got (128 0)
;;;;; EC-Eval input:
最終更新：2009年07月22日 20:42
