SICP 問題 5.10

新しく構文を追加する．
簡単にincrementとdecrementで．

(define (make-execution-procedure inst labels machine
                                  pc flag stack ops)
  (cond ((eq? (car inst) 'assign)
         (make-assign inst machine labels ops pc))
        ((eq? (car inst) 'test)
         (make-test inst machine labels ops flag pc))
        ((eq? (car inst) 'branch)
         (make-branch inst machine labels flag pc))
        ((eq? (car inst) 'goto)
         (make-goto inst machine labels pc))
        ((eq? (car inst) 'save)
         (make-save inst machine stack pc))
        ((eq? (car inst) 'restore)
         (make-restore inst machine stack pc))
        ((eq? (car inst) 'perform)
         (make-perform inst machine labels ops pc))
        ((eq? (car inst) 'increment)    ;increment
         (make-increment inst machine pc))
        ((eq? (car inst) 'decrement)    ;decrement
         (make-decrement inst machine pc))
        (else (error "Unknown instruction type -- ASSEMBLE" inst))))

;;; 選択子
(define (increment-reg-name name) (cadr name))
(define (decrement-reg-name name) (cadr name))

(define (make-increment inst machine pc)
  (let ((target (get-register machine (increment-reg-name inst))))
    (lambda ()
      (let ((value (get-contents target)))
        (cond ((number? value)
               (set-contents! target (+ value 1))
               (advance-pc pc))
              (error "INCREMENT require number, but" value))))))

(define (make-decrement inst machine pc)
  (let ((target (get-register machine (decrement-reg-name inst))))
    (lambda ()
      (let ((value (get-contents target)))
        (cond ((number? value)
               (set-contents! target (- value 1))
               (advance-pc pc))
              (error "DECREMENT require number, but" value))))))

test

(define add-two
  (make-machine
   '(a)
   (list )
   '(controller
     main
     (increment a)
     (increment a)
     (increment a)
     (decrement a)
     done)))

gosh> (set-register-contents! add-two 'a 200)
done
gosh> (start add-two)
done
gosh> (get-register-contents add-two 'a)
202