計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著)ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著)Julie Sussman (原著)
Gerald Jay Sussman (原著)和田 英一 (翻訳)
開発環境
- OS X Yosemite - Apple (OS)
- Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
- Scheme (プログラミング言語)
- Gauche (処理系)
計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の5(レジスタ計算機での計算)、5.5(翻訳系)、5.5.7(翻訳したコードと評価機のインターフェース)、解釈と翻訳、問題 5.48.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
- Scheme手習い
問題 5.48.
コード(BBEdit, Emacs)
sample48.scm
#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-
(load "./eceval48.scm")
(compile-and-go
'(define (fib n)
(if (< n 2)
n
(+ (fib (- n 1)) (fib (- n 2))))))
eceval48.scm
#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-
(load "./simulator.scm")
(load "./compiler48.scm")
(define (initialize-stack)
(eceval 'initialize-stack))
(define eceval-operations
(list (list 'self-evaluating? self-evaluating?)
(list 'initialize-stack initialize-stack)
(list 'prompt-for-input prompt-for-input)
(list 'read read)
(list 'list list)
(list 'cons cons)
(list 'false? false?)
(list 'get-global-environment get-global-environment)
(list 'announce-output announce-output)
(list 'user-print user-print)
(list 'variable? variable?)
(list 'quoted? quoted?)
(list 'assignment? assignment?)
(list 'definition? definition?)
(list 'if? if?)
(list 'lambda? lambda?)
(list 'begin? begin?)
(list 'cond? cond?)
(list 'let? let?)
(list 'application? application?)
(list 'lookup-variable-value lookup-variable-value)
(list 'text-of-quotation text-of-quotation)
(list 'lambda-parameters lambda-parameters)
(list 'lambda-body lambda-body)
(list 'make-procedure make-procedure)
(list 'operands operands)
(list 'operator operator)
(list 'empty-arglist empty-arglist)
(list 'no-operands? no-operands?)
(list 'first-operand first-operand)
(list 'last-operand? last-operand?)
(list 'adjoin-arg adjoin-arg)
(list 'rest-operands rest-operands)
(list 'primitive-procedure? primitive-procedure?)
(list 'compound-procedure? compound-procedure?)
(list 'apply-primitive-procedure apply-primitive-procedure)
(list 'procedure-parameters procedure-parameters)
(list 'procedure-environment procedure-environment)
(list 'extend-environment extend-environment)
(list 'procedure-body procedure-body)
(list 'begin-actions begin-actions)
(list 'first-exp first-exp)
(list 'last-exp? last-exp?)
(list 'rest-exps rest-exps)
(list 'if-predicate if-predicate)
(list 'true? true?)
(list 'if-alternative if-alternative)
(list 'if-consequent if-consequent)
(list 'assignment-variable assignment-variable)
(list 'assignment-value assignment-value)
(list 'set-variable-value! set-variable-value!)
(list 'definition-variable definition-variable)
(list 'definition-value definition-value)
(list 'define-variable! define-variable!)
(list 'cond->if cond->if)
(list 'let->combination let->combination)
(list 'make-compiled-procedure make-compiled-procedure)
(list 'compiled-procedure? compiled-procedure?)
(list 'compiled-procedure-entry compiled-procedure-entry)
(list 'compiled-procedure-env compiled-procedure-env)
))
(define eceval
(make-machine
eceval-operations
'((assign compapp (label compound-apply))
(branch (label external-entry))
read-eval-print-loop
(perform (op initialize-stack))
(perform
(op prompt-for-input) (const ";;; EC-Eval input:"))
(assign exp (op read))
(assign env (op get-global-environment))
(assign continue (label print-result))
(goto (label eval-dispatch))
external-entry
(perform (op initialize-stack))
(assign env (op get-global-environment))
(assign continue (label print-result))
(goto (reg val))
print-result
(perform (op print-stack-statisstics)) ; 性能監視
(perform
(op announce-output) (const ";;; EC-Eval value:"))
(perform (op user-print) (reg val))
(goto (label read-eval-print-loop))
unknown-expression-type
(assign val (const unknown-expression-type-error))
(goto (label signal-error))
unknown-procedure-type
(restore continue)
(assign val (const unknown-procedure-type-error))
(goto (label signal-error))
signal-error
(perform (op user-print) (reg val))
(goto (label read-eval-print-loop))
eval-dispatch
(test (op self-evaluating?) (reg exp))
(branch (label ev-self-eval))
(test (op variable?) (reg exp))
(branch (label ev-variable))
(test (op quoted?) (reg exp))
(branch (label ev-quoted))
(test (op assignment?) (reg exp))
(branch (label ev-assignment))
(test (op definition?) (reg exp))
(branch (label ev-definition))
(test (op if?) (reg exp))
(branch (label ev-if))
(test (op lambda?) (reg exp))
(branch (label ev-lambda))
(test (op begin?) (reg exp))
(branch (label ev-begin))
(test (op cond?) (reg exp))
(branch (label ev-cond))
(test (op let?) (reg exp))
(branch (label ev-let))
(test (op application?) (reg exp))
(branch (label ev-application))
(goto (label unknown-expression-type))
ev-self-eval
(assign val (reg exp))
(goto (reg continue))
ev-variable
(assign val (op lookup-variable-value) (reg exp) (reg env))
(goto (reg continue))
ev-quoted
(assign val (op text-of-quotation) (reg exp))
(goto (reg continue))
ev-lambda
(assign unev (op lambda-parameters) (reg exp))
(assign exp (op lambda-body) (reg exp))
(assign val (op make-procedure)
(reg unev) (reg exp) (reg env))
(goto (reg continue))
ev-application
(save continue)
(save env)
(assign unev (op operands) (reg exp))
(save unev)
(assign exp (op operator) (reg exp))
(assign continue (label ev-appl-did-operator))
(goto (label eval-dispatch))
ev-appl-did-operator
(restore unev)
(restore env)
(assign argl (op empty-arglist))
(assign proc (reg val))
(test (op no-operands?) (reg unev))
(branch (label apply-dispatch))
(save proc)
ev-appl-operand-loop
(save argl)
(assign exp (op first-operand) (reg unev))
(test (op last-operand?) (reg unev))
(branch (label ev-appl-last-arg))
(save env)
(save unev)
(assign continue (label ev-appl-accumulate-arg))
(goto (label eval-dispatch))
ev-appl-accumulate-arg
(restore unev)
(restore env)
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(assign unev (op rest-operands) (reg unev))
(goto (label ev-appl-operand-loop))
ev-appl-last-arg
(assign continue (label ev-appl-accum-last-arg))
(goto (label eval-dispatch))
ev-appl-accum-last-arg
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(restore proc)
(goto (label apply-dispatch))
apply-dispatch
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-apply))
(test (op compound-procedure?) (reg proc))
(branch (label compound-apply))
(test (op compiled-procedure?) (reg proc))
(branch (label compiled-apply))
(goto (label unknown-procedure-type))
compiled-apply
(restore continue)
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-apply
(assign val (op apply-primitive-procedure)
(reg proc)
(reg argl))
(restore continue)
(goto (reg continue))
compound-apply
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment)
(reg unev) (reg argl) (reg env))
(assign unev (op procedure-body) (reg proc))
(goto (label ev-sequence))
ev-begin
(assign unev (op begin-actions) (reg exp))
(save continue)
(goto (label ev-sequence))
ev-sequence
(assign exp (op first-exp) (reg unev))
(test (op last-exp?) (reg unev))
(branch (label ev-sequence-last-exp))
(save unev)
(save env)
(assign continue (label ev-sequence-continue))
(goto (label eval-dispatch))
ev-sequence-continue
(restore env)
(restore unev)
(assign unev (op rest-exps) (reg unev))
(goto (label ev-sequence))
ev-sequence-last-exp
(restore continue)
(goto (label eval-dispatch))
ev-if
(save exp)
(save env)
(save continue)
(assign continue (label ev-if-decide))
(assign exp (op if-predicate) (reg exp))
(goto (label eval-dispatch))
ev-if-decide
(restore continue)
(restore env)
(restore exp)
(test (op true?) (reg val))
(branch (label ev-if-consequent))
ev-if-alternative
(assign exp (op if-alternative) (reg exp))
(goto (label eval-dispatch))
ev-if-consequent
(assign exp (op if-consequent) (reg exp))
(goto (label eval-dispatch))
ev-assignment
(assign unev (op assignment-variable) (reg exp))
(save unev)
(assign exp (op assignment-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-assignment-1))
(goto (label eval-dispatch))
ev-assignment-1
(restore continue)
(restore env)
(restore unev)
(perform
(op set-variable-value!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
ev-definition
(assign unev (op definition-variable) (reg exp))
(save unev)
(assign exp (op definition-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-definition-1))
(goto (label eval-dispatch))
ev-definition-1
(restore continue)
(restore env)
(restore unev)
(perform
(op define-variable!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
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))
)))
(define (compile-and-run expression)
(let ((instructions
(assemble (statements
(compile expression 'val 'return))
eceval)))
(set-register-contents! eceval 'val instructions)
(set-register-contents! eceval 'flag #t)
(start eceval)))
(define (setup-environment-1)
(extend-environment (list 'compile-and-run)
(list (list 'primitive compile-and-run))
(setup-environment)))
(define the-global-environment (setup-environment-1))
(define (start-eceval)
(set! the-global-environment (setup-environment-1))
(set-register-contents! eceval 'flag #f)
(start eceval))
(define (compile-and-go expression)
(let ((instructions
(assemble (statements
(compile expression 'val 'return))
eceval)))
(set! the-global-environment (setup-environment-1))
(set-register-contents! eceval 'val instructions)
(set-register-contents! eceval 'flag #t)
(start eceval)))
入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))
$ ./sample48.scm
(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok
;;; EC-Eval input:
fib
(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
<compiled-procedure>
;;; EC-Eval input:
(fib 0)
(total-pushes = 7 maximum-depth = 3)
;;; EC-Eval value:
0
;;; EC-Eval input:
(fib 1)
(total-pushes = 7 maximum-depth = 3)
;;; EC-Eval value:
1
;;; EC-Eval input:
(fib 2)
(total-pushes = 17 maximum-depth = 5)
;;; EC-Eval value:
1
;;; EC-Eval input:
(fib 3)
(total-pushes = 27 maximum-depth = 8)
;;; EC-Eval value:
2
;;; EC-Eval input:
(fib 4)
(total-pushes = 47 maximum-depth = 11)
;;; EC-Eval value:
3
;;; EC-Eval input:
(fib 5)
(total-pushes = 77 maximum-depth = 14)
;;; EC-Eval value:
5
;;; EC-Eval input:
(compile-and-run
'(define (factorial n)
(if (= n 1)
1
(* (factorial (- n 1)) n))))
(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok
;;; EC-Eval input:
factorial
(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
<compiled-procedure>
;;; EC-Eval input:
(factorial 5)
(total-pushes = 31 maximum-depth = 14)
;;; EC-Eval value:
120
;;; EC-Eval input:
fib
(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
<compiled-procedure>
;;; EC-Eval input:
(fib 0)
(total-pushes = 7 maximum-depth = 3)
;;; EC-Eval value:
0
;;; EC-Eval input:
(fib 10)
(total-pushes = 887 maximum-depth = 29)
;;; EC-Eval value:
55
;;; EC-Eval input:
(exit)
$
0 コメント:
コメントを投稿