やや苦戦したので、ちょっとだけ参照した．
参照元
instにlabelをくっつけるのいいのは参照でわかったけれど、データ構造はどうしようかと悩んだ．
今回変更するのは，
- make-new-machineに変数labelを追加
- make-new-machineのexecute
- make-new-machineのprint-trace(ex5.16からの変更)
- extract-labels
- make-execute-procedure
方針としては，
- extract-labelsでlabelに対応するinstructionsにlabel情報を追加
- make-execure-procedureでlabel情報を見つけたら，(advance-pc pc)だけをする手続きを作成
- executeで(car instructions)がlabelかどうかを判断
- labelならば，変数labelをそれにセット
- labelじゃないなら，ex5.15のinstruction-count-upを行い，print-instを実行(ex5.15と干渉しないようにするため)
以下が変更詳細
(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0) ;; exercise 5.15 (trace? #f) ;; exercise 5.16 (label #f)) ;; exercise 5.17 : : (define (execute) (let ((instructions (get-contents pc))) (if (null? instructions) 'done (begin (if (not (eq? (caaar instructions) 'label)) ;;check-label-tag (begin (instruction-count-up) (print-trace (caar instructions))) (set! label (cadr (caar instructions)))) ((instruction-execution-proc (car instructions))) (execute))))) (define (print-trace trace) ;; exercise 5.16 (if trace? (print "label: " label " instruction: " trace))) : : ) ;; instructionにどうやってlabel情報をつけるか悩んだ ;; labelタグを追加するとmake-executeでの場合分けが簡単 (define (extract-labels text receive) (if (null? text) (receive '() '()) (extract-labels (cdr text) (lambda (instructions labels) (let ((next-instruction (car text))) (if (symbol? next-instruction) ;; label (if (assoc next-instruction labels) (error "exist label -- EXTRACT-LABELS" next-instruction) (let ((instructions (cons (list (list 'label next-instruction)) instructions))) ;;5.17 (receive instructions (cons (make-label-entry next-instruction instructions) labels)))) (receive (cons (make-instruction next-instruction) instructions) labels))))) ;extract-labels ) ;if ) ;define (define (make-execution-procedure instruction labels machine pc flag stack operations) (cond [(eq? (car instruction) 'assign) (make-assign instruction machine labels operations pc)] [(eq? (car instruction) 'test) (make-test instruction machine labels operations flag pc)] [(eq? (car instruction) 'branch) (make-branch instruction machine labels flag pc)] [(eq? (car instruction) 'goto) (make-goto instruction machine labels pc)] [(eq? (car instruction) 'save) (make-save instruction machine stack pc)] [(eq? (car instruction) 'restore) (make-restore instruction machine stack pc)] [(eq? (car instruction) 'perform) (make-perform instruction machine labels operations pc)] [(eq? (car instruction) 'label) ;; labe tag (lambda () (advance-pc pc))] [else (error "Unknown instruction type -- ASSEMBLE" instruction)] ))
実行
(define expt-machine (make-machine '(b n val continue) (list (list '= =) (list '- -) (list '* *)) '((assign continue (label expt-done)) expt-loop (test (op =) (reg n) (const 0)) (branch (label return)) (save continue) (assign n (op -) (reg n) (const 1)) (assign continue (label after-expt)) (goto (label expt-loop)) after-expt (restore continue) (assign val (op *) (reg b) (reg val)) (goto (reg continue)) return (assign val (const 1)) (goto (reg continue)) expt-done))) (set-register-contents! expt-machine 'b 2) (set-register-contents! expt-machine 'n 2) (trace-on expt-machine) (start expt-machine) (print-stack expt-machine) (print-inst-count expt-machine) (get-register-contents expt-machine 'val)
結果
見にくさをなんとかしなきゃな...
gosh> label: #f instruction: (assign continue (label expt-done)) label: expt-loop instruction: (test (op =) (reg n) (const 0)) label: expt-loop instruction: (branch (label return)) label: expt-loop instruction: (save continue) label: expt-loop instruction: (assign n (op -) (reg n) (const 1)) label: expt-loop instruction: (assign continue (label after-expt)) label: expt-loop instruction: (goto (label expt-loop)) label: expt-loop instruction: (test (op =) (reg n) (const 0)) label: expt-loop instruction: (branch (label return)) label: expt-loop instruction: (save continue) label: expt-loop instruction: (assign n (op -) (reg n) (const 1)) label: expt-loop instruction: (assign continue (label after-expt)) label: expt-loop instruction: (goto (label expt-loop)) label: expt-loop instruction: (test (op =) (reg n) (const 0)) label: expt-loop instruction: (branch (label return)) label: return instruction: (assign val (const 1)) label: return instruction: (goto (reg continue)) label: after-expt instruction: (restore continue) label: after-expt instruction: (assign val (op *) (reg b) (reg val)) label: after-expt instruction: (goto (reg continue)) label: after-expt instruction: (restore continue) label: after-expt instruction: (assign val (op *) (reg b) (reg val)) label: after-expt instruction: (goto (reg continue)) done gosh> (total-pushes = 2 maximum-depth = 2) #<undef> gosh> instruction-count: 23 #<undef> gosh> 4
