計算機プログラムの構造と解釈[第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.2(レジスタ計算機シミュレータ)、5.2.4(計算機の性能監視)、問題 5.18.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
- Scheme手習い
問題 5.18.
コード(BBEdit, Emacs)
simulator18.scm
;; -*- coding: utf-8 -*-
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))
(define (make-machine ops controller-text)
(let ((machine (make-new-machine)))
((machine 'install-operations) ops)
((machine 'install-instruction-sequence)
(assemble controller-text machine))
machine))
(define (make-register name)
(let ((contents '*unassigned*)
(trace #f))
(define (dispatch message)
(cond ((eq? message 'get) contents)
((eq? message 'set)
(lambda (value) (set! contents value)))
((eq? message 'trace-on)
(set! trace #t))
((eq? message 'trace-off)
(set! trace #f))
((eq? message 'trace?) trace)
(else
(error "Unknown request -- REGISTER" message))))
dispatch))
(define (get-contents register)
(register 'get))
(define (set-contents! register value)
((register 'set) value))
(define (make-stack)
(let ((s '())
(number-pushes 0)
(max-depth 0)
(current-depth 0))
(define (push x)
(set! s (cons x s))
(set! number-pushes (+ 1 number-pushes))
(set! current-depth (+ 1 current-depth))
(set! max-depth (max current-depth max-depth)))
(define (pop)
(if (null? s)
(error "Empty stack -- POP")
(let ((top (car s)))
(set! s (cdr s))
(set! current-depth (- current-depth 1))
top)))
(define (initialize)
(set! s '())
(set! number-pushes 0)
(set! max-depth 0)
(set! current-depth 0))
(define (print-statistics)
(print (list 'total-pushes '= number-pushes
'maximum-depth '= max-depth)))
(define (dispatch message)
(cond ((eq? message 'push) push)
((eq? message 'pop) (pop))
((eq? message 'initialize) (initialize))
((eq? message 'print-statistics)
(print-statistics))
(else (error "Unknown request -- STACK"
message))))
dispatch))
(define (pop stack)
(stack 'pop))
(define (push stack value)
((stack 'push) value))
(define (print-statistics machine)
((machine 'stack) 'print-statistics))
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(instruction-counting 0)
(trace-flag #f)
(label #f))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statisstics
(lambda () (stack 'print-statistics)))))
(register-table
(list (list 'pc pc) (list 'flag flag))))
(define (allocate-register name)
(if (assoc name register-table)
(error "Multiply defined register: " name)
(set! register-table
(cons (list name (make-register name))
register-table)))
'register-allocated)
(define (lookup-register name)
(let ((val (assoc name register-table)))
(if val
(cadr val)
(begin (allocate-register name)
(lookup-register name)))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
(if (eq? (caaar insts) 'label)
(set! label (cadr (caar insts)))
(set! instruction-counting (+ instruction-counting 1)))
(if trace-flag
(print "label: " label ", trace: " (caar insts)))
((instruction-execution-proc (car insts)))
(execute)))))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
((eq? message 'install-instruction-sequence)
(lambda (seq) (set! the-instruction-sequence seq)))
((eq? message 'allocate-register) allocate-register)
((eq? message 'get-register) lookup-register)
((eq? message 'install-operations)
(lambda (ops) (set! the-ops (append the-ops ops))))
((eq? message 'stack) stack)
((eq? message 'operations) the-ops)
((eq? message 'print-instruction-counting)
(print "(instruction-counting = " instruction-counting ")"))
((eq? message 'initialize-instruction-counting)
(set! instruction-counting 0)
'done)
((eq? message 'trace-on) (set! trace-flag #t))
((eq? message 'trace-off) (set! trace-flag #f))
((eq? message 'trace-register-on)
(lambda (reg-name)
(let ((val (lookup-register reg-name)))
(if val
(val 'trace-on)
(error "Unknown register:" reg-name)))))
((eq? message 'trace-register-off)
(lambda (reg-name)
(let ((val (lookup-register reg-name)))
(if val
(val 'trace-off)
(error "Unknown register:" reg-name)))))
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(define (start machine)
(machine 'start))
(define (get-register-contents machine register-name)
(get-contents (get-register machine register-name)))
(define (set-register-contents! machine register-name value)
(set-contents! (get-register machine register-name) value)
'done)
(define (get-register machine reg-name)
((machine 'get-register) reg-name))
(define (print-instruction-counting machine)
(machine 'print-instruction-counting))
(define (initialize-instruction-counting machine)
(machine 'initialize-instruction-counting))
(define (trace-register-on machine register-name)
((machine 'trace-register-on) register-name))
(define (trace-register-off machine register-name)
((machine 'trace-register-off) register-name))
(define (assemble controller-text machine)
(extract-labels controller-text
(lambda (insts labels)
(update-insts! insts labels machine)
insts)))
(define (extract-labels text receive)
(if (null? text)
(receive '() '())
(extract-labels
(cdr text)
(lambda (insts labels)
(let ((next-inst (car text)))
(if (symbol? next-inst)
(if (assoc next-inst labels)
(error "Multiply defined label:" next-inst)
(begin (set! insts (cons (list (list 'label next-inst))
insts))
(receive insts
(cons (make-label-entry next-inst
insts)
labels))))
(receive (cons (make-instruction next-inst)
insts)
labels)))))))
(define (update-insts! insts labels machine)
(let ((pc (get-register machine 'pc))
(flag (get-register machine 'flag))
(stack (machine 'stack))
(ops (machine 'operations)))
(for-each
(lambda (inst)
(set-instruction-execution-proc!
inst
(make-execution-procedure
(instruction-text inst) labels machine
pc flag stack ops)))
insts)))
(define (make-instruction text)
(cons text '()))
(define (instruction-text inst)
(car inst))
(define (instruction-execution-proc inst)
(cdr inst))
(define (set-instruction-execution-proc! inst proc)
(set-cdr! inst proc))
(define (make-label-entry label-name insts)
(cons label-name insts))
(define (lookup-label labels label-name)
(let ((val (assoc label-name labels)))
(if val
(cdr val)
(error "Undefined label -- ASSEMBLE" label-name))))
(define (make-execution-procedure inst labels machine pc flag stack ops)
(cond ((eq? (car inst) 'assign)
(make-assign inst machine labels ops pc))
((eq? (car inst) 'test)
(make-test inst machine labels ops flag pc))
((eq? (car inst) 'branch)
(make-branch inst machine labels flag pc))
((eq? (car inst) 'goto)
(make-goto inst machine labels pc))
((eq? (car inst) 'save)
(make-save inst machine stack pc))
((eq? (car inst) 'restore)
(make-restore inst machine stack pc))
((eq? (car inst) 'perform)
(make-perform inst machine labels ops pc))
((eq? (car inst) 'del)
((make-del inst machine pc)))
((eq? (car inst) 'label)
(lambda () (advance-pc pc)))
(else (error "Unknown instruction type -- ASSEMBLE"
inst))))
(define (make-assign inst machine labels operations pc)
(let ((target
(get-register machine (assign-reg-name inst)))
(value-exp (assign-value-exp inst)))
(let ((value-proc
(if (operation-exp? value-exp)
(make-operation-exp
value-exp machine labels operations)
(make-primitive-exp
(car value-exp) machine labels))))
(lambda ()
(if (target 'trace?)
(print "register-name:" (assign-reg-name inst)
" old:" (get-contents target)
" new:" (value-proc)))
(set-contents! target (value-proc))
(advance-pc pc)))))
(define (assign-reg-name assign-instruction)
(cadr assign-instruction))
(define (assign-value-exp assign-instruction)
(cddr assign-instruction))
(define (advance-pc pc)
(set-contents! pc (cdr (get-contents pc))))
(define (make-test inst machine labels operations flag pc)
(let ((condition (test-condition inst)))
(if (operation-exp? condition)
(let ((condition-proc
(make-operation-exp
condition machine labels operations)))
(lambda ()
(set-contents! flag (condition-proc))
(advance-pc pc)))
(error "Bad TEST instruction -- ASSEMBLE" inst))))
(define (test-condition test-instruction)
(cdr test-instruction))
(define (make-branch inst machine labels flag pc)
(let ((dest (branch-dest inst)))
(if (label-exp? dest)
(let ((insts
(lookup-label labels (label-exp-label dest))))
(lambda ()
(if (get-contents flag)
(set-contents! pc insts)
(advance-pc pc))))
(error "Bad BRANCH instruction -- ASSEMBLE" inst))))
(define (branch-dest branch-instruction)
(cadr branch-instruction))
(define (make-goto inst machine labels pc)
(let ((dest (goto-dest inst)))
(cond ((label-exp? dest)
(let ((insts
(lookup-label labels
(label-exp-label dest))))
(lambda () (set-contents! pc insts))))
((register-exp? dest)
(let ((reg
(get-register machine
(register-exp-reg dest))))
(lambda ()
(set-contents! pc (get-contents reg)))))
(else (error "Bad GOTO instruction -- ASSEMBLE"
inst)))))
(define (goto-dest goto-instruction)
(cadr goto-instruction))
(define (make-save inst machine stack pc)
(let ((reg (get-register machine
(stack-inst-reg-name inst))))
(lambda ()
(push stack (get-contents reg))
(advance-pc pc))))
(define (make-restore inst machine stack pc)
(let ((reg (get-register machine
(stack-inst-reg-name inst))))
(lambda ()
(set-contents! reg (pop stack))
(advance-pc pc))))
(define (stack-inst-reg-name stack-instruction)
(cadr stack-instruction))
(define (make-perform inst machine labels operations pc)
(let ((action (perform-action inst)))
(if (operation-exp? action)
(let ((action-proc
(make-operation-exp
action machine labels operations)))
(lambda ()
(action-proc)
(advance-pc pc)))
(error "Bad PERFORM instruction -- ASSEMBLE" inst))))
(define (perform-action inst) (cdr inst))
(define (make-primitive-exp exp machine labels)
(cond ((constant-exp? exp)
(let ((c (constant-exp-value exp)))
(lambda () c)))
((label-exp? exp)
(let ((insts
(lookup-label labels
(label-exp-label exp))))
(lambda () insts)))
((register-exp? exp)
(let ((r (get-register machine
(register-exp-reg exp))))
(lambda () (get-contents r))))
(else
(error "Unknown expression type -- ASSEMBLE" exp))))
(define (register-exp? exp) (tagged-list? exp 'reg))
(define (register-exp-reg exp) (cadr exp))
(define (constant-exp? exp) (tagged-list? exp 'const))
(define (constant-exp-value exp) (cadr exp))
(define (label-exp? exp) (tagged-list? exp 'label))
(define (label-exp-label exp) (cadr exp))
(define (make-operation-exp exp machine labels operations)
(let ((op (lookup-prim (operation-exp-op exp) operations))
(aprocs
(map (lambda (e)
(if (label-exp? e)
(error "Bad OPERANDS instruction -- ASSEMBLE" e)
(make-primitive-exp e machine labels)))
(operation-exp-operands exp))))
(lambda ()
(apply op (map (lambda (p) (p)) aprocs)))))
(define (operation-exp? exp)
(and (pair? exp) (tagged-list? (car exp) 'op)))
(define (operation-exp-op operation-exp)
(cadr (car operation-exp)))
(define (operation-exp-operands operation-exp)
(cdr operation-exp))
(define (lookup-prim symbol operations)
(let ((val (assoc symbol operations)))
(if val
(cadr val)
(error "Unknown operation -- ASSEMBLE" symbol))))
(define (make-del inst machine pc)
(let ((target
(get-register machine (del-reg-name inst))))
(lambda ()
(set-contents! target '*unassigned*)
(advance-pc pc))))
(define (del-reg-name delete-instruction)
(cadr delete-instruction))
sample18.scm
#!/usr/bin/env gosh
;;-*- coding: utf-8 -*-
(load "./simulator18.scm")
(define factorial-machine
(make-machine
(list (list '= =) (list '- -) (list '* *))
'((assign continue (label fact-done))
fact-loop
(test (op =) (reg n) (const 1))
(branch (label base-case))
(save continue)
(save n)
(assign n (op -) (reg n) (const 1))
(assign continue (label after-fact))
(goto (label fact-loop))
after-fact
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
base-case
(assign val (const 1))
(goto (reg continue))
fact-done)))
(for-each
(lambda (i)
(print "start " i "!")
(if (= i 2)
(trace-register-on factorial-machine 'val))
(if (= i 3)
(trace-register-on factorial-machine 'n))
(if (= i 8)
(trace-register-off factorial-machine 'val))
(if (= i 9)
(trace-register-off factorial-machine 'n))
((factorial-machine 'stack) 'initialize)
(set-register-contents! factorial-machine 'n i)
(start factorial-machine)
(print i "! = " (get-register-contents factorial-machine 'val))
(print-statistics factorial-machine)
(print-instruction-counting factorial-machine)
(initialize-instruction-counting factorial-machine))
'(1 2 3 4 5 6 7 8 9 10))
入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))
$ ./sample18.scm start 1! 1! = 1 (total-pushes = 0 maximum-depth = 0) (instruction-counting = 5) start 2! register-name:val old:1 new:1 register-name:val old:1 new:2 2! = 2 (total-pushes = 2 maximum-depth = 2) (instruction-counting = 16) start 3! register-name:n old:3 new:2 register-name:n old:2 new:1 register-name:val old:2 new:1 register-name:val old:1 new:2 register-name:val old:2 new:6 3! = 6 (total-pushes = 4 maximum-depth = 4) (instruction-counting = 27) start 4! register-name:n old:4 new:3 register-name:n old:3 new:2 register-name:n old:2 new:1 register-name:val old:6 new:1 register-name:val old:1 new:2 register-name:val old:2 new:6 register-name:val old:6 new:24 4! = 24 (total-pushes = 6 maximum-depth = 6) (instruction-counting = 38) start 5! register-name:n old:5 new:4 register-name:n old:4 new:3 register-name:n old:3 new:2 register-name:n old:2 new:1 register-name:val old:24 new:1 register-name:val old:1 new:2 register-name:val old:2 new:6 register-name:val old:6 new:24 register-name:val old:24 new:120 5! = 120 (total-pushes = 8 maximum-depth = 8) (instruction-counting = 49) start 6! register-name:n old:6 new:5 register-name:n old:5 new:4 register-name:n old:4 new:3 register-name:n old:3 new:2 register-name:n old:2 new:1 register-name:val old:120 new:1 register-name:val old:1 new:2 register-name:val old:2 new:6 register-name:val old:6 new:24 register-name:val old:24 new:120 register-name:val old:120 new:720 6! = 720 (total-pushes = 10 maximum-depth = 10) (instruction-counting = 60) start 7! register-name:n old:7 new:6 register-name:n old:6 new:5 register-name:n old:5 new:4 register-name:n old:4 new:3 register-name:n old:3 new:2 register-name:n old:2 new:1 register-name:val old:720 new:1 register-name:val old:1 new:2 register-name:val old:2 new:6 register-name:val old:6 new:24 register-name:val old:24 new:120 register-name:val old:120 new:720 register-name:val old:720 new:5040 7! = 5040 (total-pushes = 12 maximum-depth = 12) (instruction-counting = 71) start 8! register-name:n old:8 new:7 register-name:n old:7 new:6 register-name:n old:6 new:5 register-name:n old:5 new:4 register-name:n old:4 new:3 register-name:n old:3 new:2 register-name:n old:2 new:1 8! = 40320 (total-pushes = 14 maximum-depth = 14) (instruction-counting = 82) start 9! 9! = 362880 (total-pushes = 16 maximum-depth = 16) (instruction-counting = 93) start 10! 10! = 3628800 (total-pushes = 18 maximum-depth = 18) (instruction-counting = 104) $
0 コメント:
コメントを投稿