sicp-ex-5.17

  
  
 ;; add a field to instruction to include label. and change the code in extract-labels 
 (define (make-instruction text) 
  (list text '() '())) 
 (define (make-instruction-with-label text label) 
  (list text label '())) 
 (define (instruction-text inst) 
  (car inst)) 
 (define (instruction-label inst) 
  (cadr inst)) 
 (define (instruction-execution-proc inst) 
  (caddr inst)) 
 (define (set-instruction-execution-proc! inst proc) 
  (set-car! (cddr inst) proc)) 
  
 (define (extract-labels text) 
  (if (null? text) 
      (cons '() '()) 
          (let ((result (extract-labels (cdr text)))) 
           (let ((insts (car result)) (labels (cdr result))) 
            (let ((next-inst (car text))) 
                 (if (symbol? next-inst) 
                     (if (label-exist? labels next-inst) 
                             (error "the label has existed EXTRACT-LABELS" next-inst) 
                         (let ((insts                                                    
                                            (if (null? insts) 
                                                '() 
                                                    (cons (make-instruction-with-label  
                                                                   (instruction-text (car insts)) 
                                                       next-inst) 
                                                      (cdr insts))))) 
                                  (cons insts 
                                    (cons (make-label-entry next-inst insts) labels)))) 
                         (cons (cons (make-instruction next-inst) insts) 
                               labels))))))) 
  
 ;; change the code in execute in make-new-machine 
  (define (execute) 
         (let ((insts (get-contents pc))) 
          (if (null? insts) 
              'done 
                  (begin 
                   (if trace-on 
                       (begin 
                        (if (not (null? (instruction-label (car insts))))                      
                                (begin  
                                     (display (instruction-label (car insts))) 
                                     (newline))) 
                            (display (instruction-text (car insts))) 
                        (newline))) 
                    ((instruction-execution-proc (car insts))) 
                    (set! instruction-number (+ instruction-number 1)) 
                    (execute))))) 

  
 ; This works but is is less efficient than meteorgans answer becuase it 
 ; searches for the label each time an instruction is executed. 
 ; added a `labels variable to `make-new-machine with a message `install-labels 
 ; and a message `print-labels. 
 ; The assemble will pass the `install-labels message in the recieve procedure 
 ; it passes to `extract-labels. 
 ; created a procedure `inst-label which takes and instruction as argument and 
 ; returns the label under which the instruction is. 
 ; This is know printed by the execute procedure also. 
 ; Each label has all the instruction starting from the one that follows it 
 ; till the last one. 
  
 ; this procedure is internal to make-new-machine 
 (define (inst-label inst) 
   (define (inst-label-iter inst lst) 
     (if (member inst (car lst)) 
         (caar lst) 
         (inst-label-iter inst (cdr lst)))) 
   (inst-label-iter inst (reverse labels)))  
  
 ; new messages in make-new-machine 
 ((eq? message 'install-labels) 
                (lambda (lbls) (set! labels lbls) 'done)) 
 ((eq? message 'print-labels) 
                (lambda () labels)) 
  
 ; modified assemble procedure. 
 (define (assemble controller-text machine) 
   (extract-labels controller-text 
                   (lambda (insts labels) 
                     ((machine 'install-labels) labels)  ; install the labels. 
                     (update-insts! insts labels machine) 
                     insts))) 

  
 ;;my solution trace the "goto" inst and "branch" inst to update the current-label. need a little more work to store the first-label 
  
 ;;add this at the begin of "make-new-machine" proc,  
 (current-label 'first-label) 
  
 ;;update execute 
 (define (execute) 
   (let ((insts (get-contents pc))) 
     (if (null? insts) 
         'done 
         (let ((inst (car insts))) 
           (begin (cond ((trace-on) 
                         (display current-label);*** 
                         (newline) 
                         (display (instruction-text inst)) 
                         (newline))) 
                  ((instruction-execution-proc inst)) 
                  (set! instruction-number (+ instruction-number 1)) 
                  ;*** 
                  (if (or (tagged-list? (instruction-text inst) 'goto) 
                          (and (tagged-list? (instruction-text inst) 'branch) 
                               (get-contents flag))) 
                      (set! current-label 
                            (label-exp-label (cadr (instruction-text))))) 
                  ;*** 
                  (execute)))))) 
  

I did this by adding the labels to the list of instructions. It works but it is a BAD solution as it effectively breaks the instruction list interface as each consumer of the instruction list now needs to check each instruction to see if it is a real instruction or just a label.

  
 (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 (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)]))) 
  
  
  
 (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-new-machine) 
   (let ((pc (make-register 'pc)) 
         (flag (make-register 'flag)) 
         (stack (make-stack)) 
         (the-instruction-sequence '()) 
         (the-instruction-labels '()) 
         (trace-switch #t)) 
     (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 (lookup-insts labels insts) 
         (let ((val (assoc insts labels))) 
           (if val 
               (cdr val) 
               #f))) 
        
       (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! 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)) 
               (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)) 
      ))) 
  
  
 ;;;;;;;;;;;;;;;;;test 
  
 ;;; Factorial-Machine input: 
 1 
  
 ;;; 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)) 
         base-case 
 7:      (assign val (const 1)) 
 8:      (goto (reg continue)) 
         factorial-done 
 9:      (perform (op print-stack-statistics)) 
  
 total-pushes: 0 
 maximum-depth: 0 
 value: 1 
  
  
 ;;; 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