Язык регистровой машины и его команды

(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 observations '())
  (define operations
    (list
      (cons '= =)
      (cons 'remainder remainder)
      (cons 'record
            (lambda (a b)
              (set! observations
                    (append observations (list (list a b))))
              'ok))))
  (define controller
    '(start
       (assign a (const 206))
       (assign b (const 40))
      loop
       (test (op = (reg b) (const 0)))
       (branch done)
       (assign t (op remainder (reg a) (reg b)))
       (assign a (reg b))
       (assign b (reg t))
       (perform (op record (reg a) (reg b)))
       (goto (label loop))
      done
       (halt)))
  (define machine
    (make-machine '(a b t) operations controller))
  (define status (run-machine! machine 100))
  (list status
        (get-register machine 'a)
        (get-register machine 'b)
        (machine-steps machine)
        observations)
)