SICP/ex-5_07-xx.scm

(load "util.scm")
(load "misc/sicp-regsim.scm")

(display "\nex-5.7 - test-machines\n")

; We have already tested the machines in the previous exercises.

(display "[answered]\n")

; continue at 5.2.2 - the assembler

(display "\nex-5.8 - double-here\n")

(define (extract-labels text receive)
  (define (warn-if-label-exists label labels)
    (if (assoc label labels)
      (begin
        (display "Duplicated labels -- EXTRACT-LABELS ")
        (display label)
        (newline))))
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
       (lambda (insts labels)
         (let ((next-inst (car text)))
           (if (symbol? next-inst)
             (warn-if-label-exists next-inst labels))
           (if (symbol? next-inst)
               (receive insts
                        (cons (make-label-entry next-inst
                                                insts)
                              labels))
               (receive (cons (make-instruction next-inst)
                              insts)
                        labels)))))))

(define double-here-machine
  (make-machine
    '(a)
    '()
    '(start
        (goto (label here))
      here
        (assign a (const 3))
        (goto (label there))
      here
        (assign a (const 4))
        (goto (label there))
      there)))

(start double-here-machine)
(assert (get-register-contents double-here-machine 'a) 3)

; The register contains 3 because the assembler jumps to the first label in the
; list.

(display "\nex-5.9 - strict-op\n")

(display "[done]\n")

(define (make-operation-exp exp machine labels operations)
  (let ((op (lookup-prim (operation-exp-op exp) operations))
        (aprocs
         (map (lambda (e)
                (if (or (register-exp? e) (constant-exp? e))
                  (make-primitive-exp e machine labels)
                  (error "Invalid operation argument -- MAKE-OPERATION-EXP" e)))
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (map (lambda (p) (p)) aprocs)))))

; The following instruction creates an error when analyzing the arguments for
; op. Previously it created the error during runtime.

; (define invalid-op-arg-machine
;   (make-machine
;     '(a)
;     (list (list '+ +))
;     '((assign a (op +) (label here) (const 1))
;       here)))

(display "\nex-5.10 - inc\n")

(define inc-reg-name cadr)

(define (make-inc inst machine labels operations pc)
  (let ((target (get-register machine (inc-reg-name inst))))
    (lambda ()
      (set-contents!
        target
        (+ (get-contents target) 1))
      (advance-pc pc))))

(define triple-inc-machine
  (make-machine
    '(a)
    ()
    '((inc a)
      (inc a)
      (inc a))))

(set-register-contents! triple-inc-machine 'a 8)
(start triple-inc-machine)
(assert (get-register-contents triple-inc-machine 'a) 11)

(display "\nex-5.11 - stack-behavior\n")

; a
(define fib-machine
  (make-machine
    '(n val continue)
    (list (list '< <) (list '- -) (list '= +) (list '+ +))
    '(controller
        (assign continue (label fib-done))
      fib-loop
        (test (op <) (reg n) (const 2))
        (branch (label immediate-answer))
        ;; set up to compute Fib(n - 1)
        (save continue)
        (assign continue (label afterfib-n-1))
        (save n)                           ; save old value of n
        (assign n (op -) (reg n) (const 1)); clobber n to n - 1
        (goto (label fib-loop))            ; perform recursive call
      afterfib-n-1                         ; upon return, val contains Fib(n - 1)
        (restore n)
        ;; set up to compute Fib(n - 2)
        (assign n (op -) (reg n) (const 2))
        (assign continue (label afterfib-n-2))
        (save val)                         ; save Fib(n - 1)
        (goto (label fib-loop))
      afterfib-n-2                         ; upon return, val contains Fib(n - 2)
        ; (assign n (reg val))             ; n now contains Fib(n - 2)
        ; (restore val)                    ; val now contains Fib(n - 1)
        (restore n)                        ; ex-5.11 - save one instruction
        (assign val                        ;  Fib(n - 1) +  Fib(n - 2)
                (op +) (reg val) (reg n))
        (restore continue)
        (goto (reg continue))              ; return to caller, answer is in val
      immediate-answer
        (assign val (reg n))               ; base case:  Fib(n) = n
        (goto (reg continue))
      fib-done)))

; We can replace ((assign n (reg val)) (restore val)) with (restore n) because
; we add up n and val anyway. It does not matter which is in which register.

(set-register-contents! fib-machine 'n 8)
(start fib-machine)
(display "a. ")
(assert (get-register-contents fib-machine 'val) 21)

; b.
(define stack-content car)
(define stack-register cadr)

(define (make-save inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (push stack (list (get-contents reg) reg))
      (advance-pc pc))))

(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (let ((stack-element (pop stack)))
        (if (not (eq? reg (stack-register stack-element)))
          (error "restore from different reg -- MAKE-RESTORE"
                 (reg 'name?)
                 ((stack-register stack-element) 'name?)))
      (set-contents! reg (stack-content stack-element))
      (advance-pc pc)))))

(display "b. [implemented]\n")

(display "c. ACTIVE!!!\n")
;c.  (restore y) puts into y the last value saved from y regardless of what
;other registers were saved after y and not restored. Modify the simulator to
;behave this way. You will have to associate a separate stack with each
;register. You should make the initialize-stack operation initialize all the
;register stacks.

(display "\nex-5.12\n")

; (display "\nex-5.13\n")