<< Previous exercise (5.15) | Index | Next exercise (5.17) >>
Instead of having calls to display in the machine procedure (as the exercise asks) here's a variation that passes a message sink in as a parameter to trace-on!.
(define (make-new-machine)
...
(let (( ... ))
...
(define write-trace
(lambda (message) '()))
(define (trace-on sink)
(set! write-trace sink))
(define (trace-off)
(set! write-trace (lambda (message) '())))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
(write-trace (caar insts)) ;; ***
((instruction-execution-proc (car insts)))
(set! inst-count (+ inst-count 1))
(execute)))))
(define (dispatch message)
...
((eq? message 'trace-on) trace-on)
((eq? message 'trace-off) trace-off)
(else (error "Unknown request -- MACHINE" message)))
dispatch)))
(define (trace-on! machine sink)
((machine 'trace-on) sink))
(define (trace-off! machine)
((machine 'trace-off)))
Usage:
(trace-on! machine
(lambda (message)
(newline)
(display "--trace--: ")
(display message)))
(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" '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)
'done)
(define (print-statistics)
(newline)
(for-each display (list "total-pushes: " number-pushes
"\n"
"maximum-depth: " max-depth
"\n"
)))
(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 (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(trace-switch #f))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;;**next for monitored stack (as in section 5.2.4)
;; -- comment out if not wanted
(list 'print-stack-statistics
(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)
(error "Unknown register:" name))))
(define (execute cnt)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
(if trace-switch
(begin (display cnt)
(display ":\t")
(display (instruction-text (car insts)))
(newline)))
((instruction-execution-proc (car insts)))
(execute (+ 1 cnt))))))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute 1))
((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 'trace-on) (set! trace-switch #t))
((eq? message 'trace-off) (set! trace-switch #f))
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(define factorial-machine
(make-machine
'(continue n val)
(list (list '= =) (list '* *) (list '- -))
'(
(perform (op initialize-stack))
(assign continue (label factorial-done))
factorial-loop
(test (op =) (reg n) (const 0))
(branch (label base-case))
(test (op =) (reg n) (const 1))
(branch (label base-case))
(save continue)
(save n)
(assign continue (label after-factorial))
(assign n (op -) (reg n) (const 1))
(goto (label factorial-loop))
after-factorial
(restore n)
(restore continue)
(assign val (op *) (reg val) (reg n))
(goto (reg continue))
base-case
(assign val (const 1))
(goto (reg continue))
factorial-done
(perform (op print-stack-statistics))
)))
(factorial-machine 'trace-on)
(define input-prompt ";;; Factorial-Machine input:")
(define output-prompt ";;; Factorial-Machine output:")
(define (prompt-for-input string)
(newline) (newline) (display string) (newline))
(define (announce-output string)
(newline) (display string) (newline))
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((n (read)))
(announce-output output-prompt)
(cond [(eq? n 'quit) (display "goodbye\n")]
[(eq? n 'trace-on) (factorial-machine 'trace-on) (display "enable trace\n") (driver-loop)]
[(eq? n 'trace-off) (factorial-machine 'trace-off) (display "disable trace\n") (driver-loop)]
[(integer? n) (set-register-contents! factorial-machine 'n n)
(start factorial-machine)
(display "value: ")
(display (get-register-contents factorial-machine 'val))
(newline)
(driver-loop)]
[else (display "Unknown input, try again!\n") (driver-loop)])))
;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;test;;;;;;;;;;;;;
;;; Factorial-Machine input:
1
;;; Factorial-Machine output:
1: (perform (op initialize-stack))
2: (assign continue (label factorial-done))
3: (test (op =) (reg n) (const 0))
4: (branch (label base-case))
5: (test (op =) (reg n) (const 1))
6: (branch (label base-case))
7: (assign val (const 1))
8: (goto (reg continue))
9: (perform (op print-stack-statistics))
total-pushes: 0
maximum-depth: 0
value: 1
;;; Factorial-Machine input:
trace-off
;;; Factorial-Machine output:
disable trace
;;; Factorial-Machine input:
1
;;; Factorial-Machine output:
total-pushes: 0
maximum-depth: 0
value: 1
meteorgan