社内SICP勉強会で最後の5章を進行中です。
この勉強会、入社した年からやっているのでもう2年半以上やっていると思われる。 5章で出てくるレジスタ計算機を動かすためには、P307〜P317を写経してやる必要があるんだが、割とスムーズに写経できて動いた記念でのせておく。
ちなみに僕の実行環境は DrRacket 言語:R5RS です。
[bash] (define (tagged-list? exp tag) (if (pair? exp) (eq? (car exp) tag) false))
; make-machine ; @params register-names レジスタに入れる変数のリスト ; @params ops オペランドの対応表 ; @params controller-text 本体 (define (make-machine register-names ops controller-text) (let *1 register-names) *2 machine))
;;; register ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; make-register ; @params name レジスタ名 (define (make-register name) (let *3 (define (dispatch message) (cond *4
(define (get-contents register) (register 'get))
(define (set-contents! register value) *5
;;; stack ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; make-stack (define (make-stack) (let *6 top))) (define (initialize) (set! s '()) 'done) (define (dispatch message) (cond *7 *8 (else (error "Unknown request -- STACK")))) dispatch))
(define (pop stack) (stack 'pop))
;;; machine ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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) *10
(define (make-new-machine) (let *11 (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '())) (let *12 register-table))) 'register-allocated) (define (lookup-register name) (let *13 *14 (extract-labels (cdr text) (lambda (insts labels) (let *15 (receive (cons (make-instruction next-inst) insts) labels)))))))
(define (update-insts! insts labels machine) (let *16 (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 *17 *18 *19 *20 *21 *22 *23 (else (error "Unknown request -- ASSEMBLE"))))
(define (make-assign inst machine labels operations pc) (let *24 (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 *25 (advance-pc pc))) (error "Bad Test"))))
(define (test-condition text-instruction) (cdr text-instruction))
(define (make-branch inst machine labels flag pc) (let *26
(define (make-goto inst machine labels pc) (let *27
(define (make-save inst machine stack pc) (let *28 (advance-pc pc))))
(define (make-restore inst machine stack pc) (let *29 (advance-pc pc))))
(define (stack-inst-reg-name stack-instruction) (cadr stack-instruction))
(define (make-perform inst machine labels operations pc) (let *30
(define (make-primitive-exp exp machine labels) (cond *31
(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 *32 (aprocs (map (lambda (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 *33 '(test-b (test (op =) (reg b) (const 0)) (branch (label gcd-done)) (assign t (op rem) (reg a) (reg b)) (assign a (reg b)) (assign b (reg t)) (goto (label test-b)) gcd-done)))
(set-register-contents! gcd-machine 'a 206)
(set-register-contents! gcd-machine 'b 40)
(start gcd-machine)
(get-register-contents gcd-machine 'a) [/bash]
4章とかも写経しないと本に載っていることを動かせない状態で、写経するとだいたいタイポがあって動かすまでにめっちゃ時間かかってしまう。 どうしても動かない原因わからなかったらネットで公開してる人がわりといるのでコピって来ても良いと思っている。 なお、ネットで公開してる人の実行環境は Gauche が多い気がする。
*1:machine (make-new-machine))) (for-each (lambda (register-name) ((machine 'allocate-register) register-name
*2:machine 'install-operations) ops) ((machine 'install-instruction-sequence) (assemble controller-text machine
*3:contents 'unassigned
*4:eq? message 'get) contents) ((eq? message 'set) (lambda (value) (set! contents value))) (else (error "Unknown request -- REGISTER")))) dispatch
*6:s '())) (define (push x) (set! s (cons x s))) (define (pop) (if (null? s) (error "Empty stack") (let ((top (car s))) (set! s (cdr s
*7:eq? message 'push) push) ((eq? message 'pop) (pop
*8:eq? message 'initialize) (initialize
*10:machine 'get-register) reg-name
*11:pc (make-register 'pc
*12:the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined: register") (set! register-table (cons (list name (make-register name
*13:val (assoc name register-table))) (if val (cadr val) (error "Unknown register")))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin ((instruction-execution-proc (car insts))) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute
*14: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) (else (error "Unkcnown request --MACHINE")))) dispatch)))
(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 '() '(
*15:next-inst (car text))) (if (symbol? next-inst) (receive insts (cons (make-label-entry next-inst insts) labels
*16:pc (get-register machine 'pc
*17:val (assoc label-name labels))) (if val (cdr val) (error "Undefined label"))))
(define (make-execution-procedure inst labels machine pc flag stack ops) (cond ((eq? (car inst) 'assign) (make-assign inst machine labels ops pc
*18:eq? (car inst) 'test) (make-test inst machine labels ops flag pc
*19:eq? (car inst) 'branch) (make-branch inst machine labels flag pc
*20:eq? (car inst) 'goto) (make-goto inst machine labels pc
*21:eq? (car inst) 'save) (make-save inst machine stack pc
*22:eq? (car inst) 'restore) (make-restore inst machine stack pc
*23:eq? (car inst) 'perform) (make-perform inst machine labels ops pc
*24: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() (set-contents! target (value-proc
*25:condition (test-condition inst))) (if (operation-exp? condition) (let ((condition-proc (make-operation-exp condition machine labels operations))) (lambda() (set-contents! flag (condition-proc
*26: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"))))
(define (branch-dest branch-instruction) (cadr branch-instruction
*27: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")))))
(define (goto-dest goto-instruction) (cadr goto-instruction
*28:reg (get-register machine (stack-inst-reg-name inst)))) (lambda() (push stack (get-contents reg
*29:reg (get-register machine (stack-inst-reg-name inst)))) (lambda() (set-contents! reg (pop stack
*30:action (perform-action inst))) (if (operation-exp? action) (let ((action-proc (make-operation-exp action machine labels perations))) (lambda() (action-proc) (advance-pc pc))) (error "Bad PERFORM"))))
(define (perform-action inst) (cdr inst
*31: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 "Unknow expression type -- ASSEMBLE"))))
(define (register-exp? exp) (tagged-list? exp 'reg
*32:op (lookup-prim (operation-exp-op exp) operations
*33:val (assoc symbol operations))) (if val (cadr val) (error "Unknown operation"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gcd-machine (make-machine '(a b t) (list (list 'rem remainder) (list '= =
