SICP5章2節計算機モデル

問題5.8を入れた計算機モデル

;; register machine simulator

(define (make-machine register-names ops controller-text)
  (let ((machine (make-new-machine)))
    (for-each (lambda (register-name)
                ((machine 'allocate-register) register-name))
              register-names)
    ((machine 'install-operations) ops)
    ((machine 'install-instruction-sequence)
     (assemble controller-text machine))
    machine))

;; Registers
(define (make-register name)
  (let ((contents '*unassigned*))
    (define (dispatch message)
      (cond [(eq? message 'get) contents]
            [(eq? message 'set)
             (lambda (value) (set! contents value))]
            [else
             (error "Unknown request -- REGISTER" message)]))
    dispatch))

(define (get-contents register)
  (register 'get))

(define (set-contents register value)
  ((register 'set) value))

;; The stack
(define (make-stack)
  (let ((s '()))
    (define (push x)
      (set! s (cons x s)))
    (define (pop)
      (if (null? s)
          (error "Empty stack -- POP")
          (let ((top (car s)))
            (set! s (cdr s))
            top)))
    (define (initialize)
      (set! s '())
      'done)
    (define (dispatch message)
      (cond [(eq? message 'push) push]
            [(eq? message 'pop) (pop)]
            [(eq? message 'initialize) (initialize)]
            [else
             (error "Unknown request -- STACK" message)]))
    dispatch))

(define (pop stack)
  (stack 'pop))

(define (push stack value)
  ((stack 'push) value))

;; The basic machine
(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '()))
    (let ((the-operations
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply define 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 (execute)
        (let ((instructions (get-contents pc)))
          (if (null? instructions)
              'done
              (begin
                ((instruction-execution-proc (car instructions)))
                (execute)))))
      (define (dispatch message)
        (cond [(eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute)]
              [(eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq))]
              [(eq? message 'allocate-register) allocate-register]
              [(eq? message 'get-register) lookup-register]
              [(eq? message 'install-operations)
               (lambda (operations) (set! the-operations
                                          (append the-operations operations)))]
              [(eq? message 'stack) stack]
              [(eq? message 'operations) the-operations]
              [else
               (error "Unknown request -- MACHINE" message)]))
      dispatch)))

(define (start machine)
  (machine 'start))

(define (get-register-contents machine register-name)
  (get-contents (get-register machine register-name)))

(define (set-register-contents! machine register-name value)
  (set-contents! (get-register machine register-name) value)
  'done)

(define (get-register machine reg-name)
  ((machine 'get-register) reg-name))

;; The assembler
(define (assemble controller-text machine)
  (extract-labels controller-text
     (lambda (instructions labels)
       (updata-instructions! instructions labels machine)
       instructions)))

(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)
                 (receive instructions
                          (cons (make-label-entry next-instruction
                                                  instructions)
                                 labels))
                 (receive (cons (make-instruction next-instruction)
                                instructions)
                          labels))))
         )
      ))

;; 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))))
         )
      ))
;; ============================================================
(define (updata-instructions! instructions labels machine)
  (let ((pc (get-register machine 'pc))
        (flag (get-register machine 'flag))
        (stack (machine 'stack))
        (operations (machine 'operations)))
    (for-each
     (lambda (instruction)
       (set-instruction-execution-proc!
        instruction
        (make-execution-procedure
         (instruction-text instruction) labels machine
         pc flag stack operations)))
     instructions)))

(define (make-instruction text)
  (cons text '()))

(define (instruction-text instruction)
  (car instruction))

(define (instruction-execution-proc instruction)
  (cdr instruction))

(define (set-instruction-execution-proc! instruction proc)
  (set-cdr! instruction proc))

(define (make-label-entry label-name instructions)
  (cons label-name instructions))

(define (lookup-label labels label-name)
  (let ((val (assoc label-name labels)))
    (if val
        (cdr val)
        (error "Undefined label -- ASSEMBLE" label-name))))

;; 5.2.3 Generate Execution Procedures for Instructions
(define (make-execution-procedure instruction labels machine
                                  pc flag stack operations)
  (cond [(eq? (car instruction) 'assign)
         (make-assign instruction machine labels operations pc)]
        [(eq? (car instruction) 'test)
         (make-test instruction machine labels operations flag pc)]
        [(eq? (car instruction) 'branch)
         (make-branch instruction machine labels flag pc)]
        [(eq? (car instruction) 'goto)
         (make-goto instruction machine labels pc)]
        [(eq? (car instruction) 'save)
         (make-save instruction machine stack pc)]
        [(eq? (car instruction) 'restore)
         (make-restore instruction machine stack pc)]
        [(eq? (car instruction) 'perform)
         (make-perform instruction machine lables operations pc)]
        [else
         (error "Unknown instruction type -- ASSEMBLE" instruction)]
        ))

;; Assign instructions
(define (make-assign instruction machine labels operations pc)
  (let ((target
         (get-register machine (assign-reg-name instruction)))
        (value-exp (assign-valuee-exp instruction)))
    (let ((value-proc
           (if (operation-exp? value-exp)
               (make-operation-exp
                value-exp machine labels operations)
               (make-primitive-exp
                (car value-exp) machine labels))))
      (lambda () ;; execution procedure for assign
        (set-contents! target (value-proc))
        (advance-pc pc))
      )))

(define (assign-reg-name assign-instrution)
  (cadr assign-instrution))

(define (assign-valuee-exp assign-instrution)
  (cddr assign-instrution))

(define (advance-pc pc)
  (set-contents! pc (cdr (get-contents pc))))

;; Test, Branch, and Goto instructions
;; Test
(define (make-test instruction machine labels operations flag pc)
  (let ((condition (test-condition instruction)))
    (if (operation-exp? condition)
        (let ((condition-proc
               (make-operation-exp
                condition machine labels operations)))
          (lambda ()
            (set-contents flag (condition-proc))
            (advance-pc pc)))
        (error "Bad TEST instruction -- ASSEMBLE" instruction))
    ))

(define (test-condition test-instruction)
  (cdr test-instruction))

;; Branch
(define (make-branch instruction machine labels flag pc)
  (let ((destination (branch-destination instruction)))
    (if (label-exp? destination)
        (let ((instructions
               (lookup-label labels (label-exp-label destination))))
          (lambda ()
            (if (get-contents flag)
                (set-contents! pc instructions)
                (advance-pc pc))))
        (error "Bad BRANCH instructions -- ASSEMBLE" instruction))
    ))

(define (branch-destination branch-instruction)
  (cadr branch-instruction))

;; Goto
(define (make-goto instruction machine labels pc)
  (let ((destination (goto-destination instruction)))
    (cond [(label-exp? destination)
           (let ((instructions
                  (lookup-label labels
                                (label-exp-label destination))))
             (lambda () (set-contents! pc instructions)))]
          [(register-exp? destination)
           (let ((reg
                  (get-register machine
                                (register-exp-reg destination))))
             (lambda ()
               (set-contents! pc (get-contents reg))))]
          [else (error "Bad GOTO instruction -- ASSEMBLE" instruction)])
    ))

(define (goto-destination goto-instruction)
  (cadr goto-instruction))

;; Other Instructions
;; Save
(define (make-save instruction machine stack pc)
  (let ((reg (get-register machine
                           (stack-instruction-reg-name instruction))))
    (lambda ()
      (push stack (get-contents reg))
      (advance-pc pc))
    ))

;; Restore
(define (make-restore instruction machine stack pc)
  (let ((reg (get-register machine
                           (stack-instruction-reg-name instruction))))
    (lambda ()
      (set-contents! reg (pop stack))
      (advance-pc pc))
    ))

(define (stack-instruction-reg-name stack-instruction)
  (cadr stack-instruction))

;; Perform
(define (make-perform instruction machine labels operations pc)
  (let ((action (perform-action instruction)))
    (if (operation-exp? action)
        (let ((action-proc
               (make-operation-exp
                action machine labels operations)))
          (lambda ()
            (action-proc)
            (advance-pc pc)))
        (error "Bad PERFORM instruction -- ASSEMBLE" instruction))
    ))

(define (perform-action instruction)
  (cdr instruction))

;; Execution procedures of subexpressions
(define (make-primitive-exp exp machine labels)
  (cond [(constant-exp? exp)
         (let ((constant-value (constant-exp-value exp)))
           (lambda () constant-value))]
         [(label-exp? exp)
          (let ((instructions
                 (lookup-label labels
                               (label-exp-label exp))))
            (lambda () instructions))]
         [(register-exp? exp)
          (let ((reg (get-register machine
                                   (register-exp-reg exp))))
            (lambda () (get-contents reg)))]
         [else
          (error "Unknown expression type -- ASSEMBLE" exp)])
  )

(define (register-exp? exp) (tagged-list? exp 'reg))

(define (register-exp-reg exp) (cadr exp))

(define (constant-exp? exp) (tagged-list? exp 'const))

(define (constant-exp-value exp) (cadr exp))

(define (label-exp? exp) (tagged-list? exp 'label))

(define (label-exp-label exp) (cadr exp))

(define (make-operation-exp exp machine labels operations)
  (let ((operation (lookup-primitive (operation-exp-op exp)
                                     operations))
        (aprocs
         (map (lambda (e)
                (make-primitive-exp e machine labels))
              (operation-exp-operands exp))))
    (lambda ()
      (apply operation (map (lambda (p) (p)) aprocs)))
    ))

(define (operation-exp? exp)
  (and (pair? exp) (tagged-list? (car exp) 'op)))

(define (operation-exp-op operation-exp)
  (cadr (car operation-exp)))

(define (operation-exp-operands operation-exp)
  (cdr operation-exp))

(define (lookup-primitive symbol operations)
  (let ((val (assoc symbol operations)))
    (if val
        (cadr val)
        (error "Unknown operation -- ASSEMBLE" symbol))
    ))

(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      #f))