조립 단계는 명령 디스패치를 실행 루프 밖으로 옮길 수 있다.

(begin
  (define (tagged-list? value tag)
    (and (pair? value) (eq? (car value) tag)))

  (define (extract-labels controller position)
    (cond ((null? controller) '())
          ((symbol? (car controller))
           (cons (cons (car controller) position)
                 (extract-labels (cdr controller) position)))
          (else
           (extract-labels (cdr controller) (+ position 1)))))
  (define (extract-instructions controller)
    (cond ((null? controller) '())
          ((symbol? (car controller))
           (extract-instructions (cdr controller)))
          (else
           (cons (car controller)
                 (extract-instructions (cdr controller))))))

  (define (make-registers names)
    (map (lambda (name) (cons name '*unassigned*)) names))
  (define (make-machine register-names operations controller)
    (list '*machine*
          (make-registers register-names)
          (cons '*stack* '())
          operations
          (extract-instructions controller)
          (extract-labels controller 0)
          (cons 'pc 0)
          (cons 'flag #f)
          (cons 'halted #f)
          (cons 'steps 0)))

  (define (machine-registers machine) (list-ref machine 1))
  (define (machine-stack machine) (list-ref machine 2))
  (define (machine-operations machine) (list-ref machine 3))
  (define (machine-instructions machine) (list-ref machine 4))
  (define (machine-labels machine) (list-ref machine 5))
  (define (machine-pc-cell machine) (list-ref machine 6))
  (define (machine-flag-cell machine) (list-ref machine 7))
  (define (machine-halted-cell machine) (list-ref machine 8))
  (define (machine-steps-cell machine) (list-ref machine 9))

  (define (machine-pc machine) (cdr (machine-pc-cell machine)))
  (define (set-machine-pc! machine value)
    (set-cdr! (machine-pc-cell machine) value))
  (define (machine-flag machine) (cdr (machine-flag-cell machine)))
  (define (set-machine-flag! machine value)
    (set-cdr! (machine-flag-cell machine) value))
  (define (machine-halted? machine) (cdr (machine-halted-cell machine)))
  (define (halt-machine! machine)
    (set-cdr! (machine-halted-cell machine) #t))
  (define (machine-steps machine) (cdr (machine-steps-cell machine)))
  (define (increment-machine-steps! machine)
    (set-cdr! (machine-steps-cell machine)
              (+ (machine-steps machine) 1)))

  (define (register-cell machine name)
    (let ((cell (assoc name (machine-registers machine))))
      (if cell cell (error "unknown register" name))))
  (define (get-register machine name)
    (cdr (register-cell machine name)))
  (define (set-register! machine name value)
    (set-cdr! (register-cell machine name) value))

  (define (push! machine value)
    (set-cdr! (machine-stack machine)
              (cons value (cdr (machine-stack machine)))))
  (define (pop! machine)
    (let ((values (cdr (machine-stack machine))))
      (if (null? values)
          (error "empty machine stack")
          (let ((value (car values)))
            (set-cdr! (machine-stack machine) (cdr values))
            value))))
  (define (stack-empty? machine)
    (null? (cdr (machine-stack machine))))

  (define (operation machine name)
    (let ((binding (assoc name (machine-operations machine))))
      (if binding (cdr binding) (error "unknown operation" name))))
  (define (label-position machine name)
    (let ((binding (assoc name (machine-labels machine))))
      (if binding (cdr binding) (error "unknown label" name))))

  (define (evaluate-source machine source)
    (cond ((tagged-list? source 'const) (cadr source))
          ((tagged-list? source 'reg)
           (get-register machine (cadr source)))
          ((tagged-list? source 'label)
           (label-position machine (cadr source)))
          ((tagged-list? source 'op)
           (apply (operation machine (cadr source))
                  (map (lambda (operand)
                         (evaluate-source machine operand))
                       (cddr source))))
          (else
           (error "unknown machine source" source))))

  (define (advance! machine)
    (set-machine-pc! machine (+ (machine-pc machine) 1)))
  (define (execute-one! machine)
    (let* ((instruction
             (list-ref (machine-instructions machine)
                       (machine-pc machine)))
           (tag (car instruction)))
      (increment-machine-steps! machine)
      (cond
        ((eq? tag 'assign)
         (set-register! machine
                        (cadr instruction)
                        (evaluate-source machine (caddr instruction)))
         (advance! machine))
        ((eq? tag 'test)
         (set-machine-flag! machine
                            (evaluate-source machine (cadr instruction)))
         (advance! machine))
        ((eq? tag 'branch)
         (if (machine-flag machine)
             (set-machine-pc!
               machine
               (label-position machine (cadr instruction)))
             (advance! machine)))
        ((eq? tag 'goto)
         (set-machine-pc! machine
                          (evaluate-source machine (cadr instruction))))
        ((eq? tag 'save)
         (push! machine (get-register machine (cadr instruction)))
         (advance! machine))
        ((eq? tag 'restore)
         (set-register! machine (cadr instruction) (pop! machine))
         (advance! machine))
        ((eq? tag 'perform)
         (evaluate-source machine (cadr instruction))
         (advance! machine))
        ((eq? tag 'halt)
         (halt-machine! machine))
        (else
         (error "unknown machine instruction" instruction)))))

  (define (run-machine! machine step-limit)
    (cond ((machine-halted? machine) 'complete)
          ((= step-limit 0) 'step-limit)
          (else
           (execute-one! machine)
           (run-machine! machine (- step-limit 1)))))
  (define (make-execution-procedure instruction)
    (let ((tag (car instruction)))
      (cond
        ((eq? tag 'assign)
         (let ((target (cadr instruction))
               (source (caddr instruction)))
           (lambda (machine)
             (set-register! machine
                            target
                            (evaluate-source machine source))
             (advance! machine))))
        ((eq? tag 'test)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (set-machine-flag! machine
                                (evaluate-source machine source))
             (advance! machine))))
        ((eq? tag 'branch)
         (let ((label (cadr instruction)))
           (lambda (machine)
             (if (machine-flag machine)
                 (set-machine-pc! machine
                                  (label-position machine label))
                 (advance! machine)))))
        ((eq? tag 'goto)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (set-machine-pc! machine
                              (evaluate-source machine source)))))
        ((eq? tag 'save)
         (let ((register (cadr instruction)))
           (lambda (machine)
             (push! machine (get-register machine register))
             (advance! machine))))
        ((eq? tag 'restore)
         (let ((register (cadr instruction)))
           (lambda (machine)
             (set-register! machine register (pop! machine))
             (advance! machine))))
        ((eq? tag 'perform)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (evaluate-source machine source)
             (advance! machine))))
        ((eq? tag 'halt)
         (lambda (machine) (halt-machine! machine)))
        (else
         (error "unknown instruction at assembly" instruction)))))
  (define (run-procedures! machine procedures remaining)
    (cond ((machine-halted? machine) 'complete)
          ((= remaining 0) 'step-limit)
          (else
           (increment-machine-steps! machine)
           ((list-ref procedures (machine-pc machine)) machine)
           (run-procedures! machine
                            procedures
                            (- remaining 1)))))
  (define observations '())
  (define operations
    (list
      (cons '= =)
      (cons 'record
            (lambda (value)
              (set! observations
                    (append observations (list value)))
              'ok))))
  (define controller
    '(start
       (assign val (const 10))
       (test (op = (reg val) (const 10)))
       (branch after-skip)
       (assign val (const -1))
      after-skip
       (assign continue (label after-goto))
       (goto (reg continue))
      after-goto
       (save val)
       (assign val (const 0))
       (restore val)
       (perform (op record (reg val)))
       (halt)))
  (define machine
    (make-machine '(val continue) operations controller))
  (define generation-log '())
  (define procedures
    (map
      (lambda (instruction)
        (set! generation-log
              (append generation-log (list (car instruction))))
        (make-execution-procedure instruction))
      (machine-instructions machine)))
  (define (all-procedures? values)
    (if (null? values)
        #t
        (and (procedure? (car values))
             (all-procedures? (cdr values)))))
  (define status (run-procedures! machine procedures 30))
  (list generation-log
        (length procedures)
        (all-procedures? procedures)
        status
        (get-register machine 'val)
        observations
        (machine-steps machine))
)