sicp-ex-5.18

  
  
 (define (trace-on-register machine register-name) 
   ((get-register machine register-name) 'trace-on) 
   'trace-on) 
 (define (trace-off-register machine register-name) 
   ((get-register machine register-name) 'trace-off) 
   'trace-off) 
  
 (define (make-register name) 
  (let ((contents '*unassigned*) 
            (trace? false)) 
   (define (dispatch message) 
    (cond ((eq? message 'get) contents) 
              ((eq? message 'set) 
                   (lambda (value)  
                    (if trace? 
                            (begin 
                                 (display name) 
                                 (display " ") 
                                 (display contents) 
                                 (display " ") 
                                 (display value) 
                                 (newline) 
                             (set! contents value)) 
                            (set! contents value)))) 
                  ((eq? message 'trace-on) 
                   (set! trace? true)) 
                  ((eq? message 'trace-off) 
                   (set! trace? false)) 
                  (else 
                   (error "Unkown request -- REGISTER" message)))) 
   dispatch)) 

Instead of having calls to display in the register procedure (as the exercise asks) here's a variation that passes a message handler in as a parameter to trace-on!.

  (define (write-null . message-parts) '())

  (define (make-register name)
    (let ((contents '*unassigned*))
      (define write-trace write-null)
      (define (trace-on sink)
        (set! write-trace sink))
      (define (trace-off)
        (set! write-trace write-null)) 
      (define (dispatch message)
        (cond ((eq? message 'get) contents)
              ((eq? message 'set)
               (lambda (value)
                 (write-trace name contents value)
                 (set! contents value)))
              ((eq? message 'trace-on) trace-on)
              ((eq? message 'trace-off) trace-off)
              (else
               (error "Unknown request -- REGISTER" message))))
      dispatch))

Usage:

  (reg-trace-on! machine 'val
                 (lambda (reg before after)
                   (newline)
                   (display reg)
                   (display ": ")
                   (display before)
                   (display " -> ")
                   (display after)))

  
 (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 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 (lookup-insts labels insts) 
   (let ((val (assoc insts labels))) 
     (if val 
         (cdr val) 
         #f))) 
  
 (define (assemble controller-text machine) 
   (extract-labels controller-text 
                   (lambda (insts labels) 
                     (update-insts! insts labels machine) 
                     ((machine 'install-instruction-labels) labels) 
                     insts))) 
  
  
 (define (make-register name labels) 
   (let ((contents '*unassigned*) 
         (trace-switch #f)) 
      
     (define (print-information value) 
       (display "\n\n***********************\n") 
  
       (display ">>> ") 
       (display "name:") 
       (display name) 
       (newline) 
  
       (display ">>> ") 
       (display "old: ") 
       (if (pair? contents) 
           (if (lookup-insts labels contents) 
               (display (lookup-insts labels contents)) 
               (pretty-print (list (instruction-text (car contents)) '...))) 
           (display contents)) 
       (newline) 
  
       (display ">>> ") 
       (display "new: ") 
       (if (pair? value) 
           (if (lookup-insts labels value) 
               (display (lookup-insts labels value)) 
               (pretty-print (list (instruction-text (car value)) '...))) 
           (display value)) 
        
       (newline) 
  
       (display "***********************\n\n") 
       ) 
      
     (define (dispatch message) 
       (cond ((eq? message 'get) contents) 
             ((eq? message 'set) 
              (lambda (value) 
                (if trace-switch (print-information value)) 
                (set! contents value))) 
             ((eq? message 'trace-on) (set! trace-switch #t)) 
             ((eq? message 'trace-off) (set! trace-switch #f)) 
             (else 
              (error "Unknown request -- REGISTER" message)))) 
     dispatch)) 
  
  
 (define (make-new-machine) 
   (let* ((stack (make-stack)) 
          (the-instruction-sequence '()) 
          (the-instruction-labels '((*DUMMY* . *HEAD*))) 
          (flag (make-register 'flag the-instruction-labels)) 
          (pc (make-register 'pc the-instruction-labels)) 
          (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 the-instruction-labels)) ;** 
                         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 
                       (let ((label (lookup-insts the-instruction-labels insts))) 
                         (if label 
                             (begin 
                               (display "\t") 
                               (display label) 
                               (newline)))) 
                        
                       (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 'install-instruction-labels) ;** 
                (lambda (labels) (set-cdr! the-instruction-labels (map 
                                                               (lambda (x) (cons (cdr x) (car x))) labels)))) 
               ((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)) 
               ((eq? message 'register-trace-off) 
                (lambda (r) ((lookup-register r) 'trace-off))) 
               ((eq? message 'register-trace-on) 
                (lambda (r) ((lookup-register r) 'trace-on))) 
               (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)) 
      ))) 
  
  
 (define (register-trace-off machine) 
   (display "which register?\n") 
   (let ((r (read))) 
     ((machine 'register-trace-off) r) 
     (display "disable trace of ") 
     (display r) 
     (newline) 
     (driver-loop))) 
  
 (define (register-trace-on machine) 
   (display "which register?\n") 
   (let ((r (read))) 
     ((machine 'register-trace-on) r) 
     (display "enable trace of ") 
     (display r) 
     (newline) 
     (driver-loop))) 
  
 (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)] 
           [(eq? n 'r-trace-off) (register-trace-off factorial-machine)] 
           [(eq? n 'r-trace-on) (register-trace-on factorial-machine)] 
           [(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 
  
  
 > (driver-loop) 
  
  
 ;;; Factorial-Machine input: 
 1 
  
 ;;; Factorial-Machine output: 
  
 total-pushes: 0 
 maximum-depth: 0 
 value: 1 
  
  
 ;;; Factorial-Machine input: 
 r-trace-on 
  
 ;;; Factorial-Machine output: 
 which register? 
 continue 
 enable trace of continue 
  
  
 ;;; Factorial-Machine input: 
 1 
  
 ;;; Factorial-Machine output: 
  
  
 *********************** 
 >>> name:continue 
 >>> old: factorial-done 
 >>> new: factorial-done 
 *********************** 
  
  
 total-pushes: 0 
 maximum-depth: 0 
 value: 1 
  
  
 ;;; Factorial-Machine input: 
 2 
  
 ;;; Factorial-Machine output: 
  
  
 *********************** 
 >>> name:continue 
 >>> old: factorial-done 
 >>> new: factorial-done 
 *********************** 
  
  
  
 *********************** 
 >>> name:continue 
 >>> old: factorial-done 
 >>> new: after-factorial 
 *********************** 
  
  
  
 *********************** 
 >>> name:continue 
 >>> old: after-factorial 
 >>> new: factorial-done 
 *********************** 
  
  
 total-pushes: 2 
 maximum-depth: 2 
 value: 2 
  
  
 ;;; Factorial-Machine input: 
 trace-on 
  
 ;;; Factorial-Machine output: 
 enable trace 
  
  
 ;;; Factorial-Machine input: 
 2 
  
 ;;; Factorial-Machine output: 
 1:      (perform (op initialize-stack)) 
 2:      (assign continue (label factorial-done)) 
  
  
 *********************** 
 >>> name:continue 
 >>> old: factorial-done 
 >>> new: factorial-done 
 *********************** 
  
         factorial-loop 
 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:      (save continue) 
 8:      (save n) 
 9:      (assign continue (label after-factorial)) 
  
  
 *********************** 
 >>> name:continue 
 >>> old: factorial-done 
 >>> new: after-factorial 
 *********************** 
  
 10:     (assign n (op -) (reg n) (const 1)) 
 11:     (goto (label factorial-loop)) 
         factorial-loop 
 12:     (test (op =) (reg n) (const 0)) 
 13:     (branch (label base-case)) 
 14:     (test (op =) (reg n) (const 1)) 
 15:     (branch (label base-case)) 
         base-case 
 16:     (assign val (const 1)) 
 17:     (goto (reg continue)) 
         after-factorial 
 18:     (restore n) 
 19:     (restore continue) 
  
  
 *********************** 
 >>> name:continue 
 >>> old: after-factorial 
 >>> new: factorial-done 
 *********************** 
  
 20:     (assign val (op *) (reg val) (reg n)) 
 21:     (goto (reg continue)) 
         factorial-done 
 22:     (perform (op print-stack-statistics)) 
  
 total-pushes: 2 
 maximum-depth: 2 
 value: 2 
  
  
 ;;; Factorial-Machine input: 
 r-trace-off 
  
 ;;; Factorial-Machine output: 
 which register? 
 continue 
 disable trace of continue 
  
  
 ;;; Factorial-Machine input: 
 2 
  
 ;;; Factorial-Machine output: 
 1:      (perform (op initialize-stack)) 
 2:      (assign continue (label factorial-done)) 
         factorial-loop 
 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:      (save continue) 
 8:      (save n) 
 9:      (assign continue (label after-factorial)) 
 10:     (assign n (op -) (reg n) (const 1)) 
 11:     (goto (label factorial-loop)) 
         factorial-loop 
 12:     (test (op =) (reg n) (const 0)) 
 13:     (branch (label base-case)) 
 14:     (test (op =) (reg n) (const 1)) 
 15:     (branch (label base-case)) 
         base-case 
 16:     (assign val (const 1)) 
 17:     (goto (reg continue)) 
         after-factorial 
 18:     (restore n) 
 19:     (restore continue) 
 20:     (assign val (op *) (reg val) (reg n)) 
 21:     (goto (reg continue)) 
         factorial-done 
 22:     (perform (op print-stack-statistics)) 
  
 total-pushes: 2 
 maximum-depth: 2 
 value: 2 
  
  
 ;;; Factorial-Machine input: 
 quit 
  
 ;;; Factorial-Machine output: 
 goodbye