SICP演習問題5.7,5.8

計算機モデルが動いたので，問題5.7をやる．

5.7

;; exercise 5.7 (section5.1)
;; a
(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 3)
(set-register-contents! expt-machine 'n 4)
(start expt-machine)
(get-register-contents expt-machine 'val)
;=> 81

;; b
(define expt-machine
  (make-machine
   '(counter product n b)
   (list (list '= =) (list '* *) (list '- -))
   '((assign counter (reg n))
     (assign product (const 1))
    expt-iter
     (test (op =) (reg counter) (const 0))
     (branch (label expt-done))
     (assign product (op *) (reg b) (reg product))
     (assign counter (op -) (reg counter) (const 1))
     (goto (label expt-iter))
    expt-done)))
(set-register-contents! expt-machine 'b 3)
(set-register-contents! expt-machine 'n 4)
(start expt-machine)
(get-register-contents expt-machine 'product)
;=> 81

5.8

;; exercise 5.8
(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)
                     (receive instructions
                              (cons (make-label-entry next-instruction
                                                      instructions)
                                    labels)))
                 (receive (cons (make-instruction next-instruction)
                                instructions)
                          labels))))) ;extract-labels
         ) ;if
      )    ;define