문법으로 디스패치하고 target과 linkage를 지키며 명령열 계약을 합성한다.

(begin
  (define (tagged-list? expression tag)
    (and (pair? expression) (eq? (car expression) tag)))
  (define (self-evaluating? expression)
    (or (number? expression)
        (string? expression)
        (boolean? expression)))
  (define (quoted? expression) (tagged-list? expression 'quote))
  (define (if? expression) (tagged-list? expression 'if))
  (define (lambda? expression) (tagged-list? expression 'lambda))
  (define (begin? expression) (tagged-list? expression 'begin))

  (define (expression-class expression)
    (cond ((self-evaluating? expression) 'self)
          ((symbol? expression) 'variable)
          ((quoted? expression) 'quote)
          ((if? expression) 'if)
          ((lambda? expression) 'lambda)
          ((begin? expression) 'begin)
          ((pair? expression) 'application)
          (else 'unknown)))

  (define (contains? item items)
    (cond ((null? items) #f)
          ((eq? item (car items)) #t)
          (else (contains? item (cdr items)))))
  (define (adjoin item items)
    (if (contains? item items)
        items
        (append items (list item))))
  (define (union left right)
    (if (null? right)
        left
        (union (adjoin (car right) left)
               (cdr right))))
  (define (difference left right)
    (cond ((null? left) '())
          ((contains? (car left) right)
           (difference (cdr left) right))
          (else
           (cons (car left)
                 (difference (cdr left) right)))))

  (define (make-sequence needs modifies statements)
    (list needs modifies statements))
  (define (sequence-needs sequence) (car sequence))
  (define (sequence-modifies sequence) (cadr sequence))
  (define (sequence-statements sequence) (caddr sequence))
  (define empty-sequence (make-sequence '() '() '()))
  (define (append-sequences first second)
    (make-sequence
      (union (sequence-needs first)
             (difference (sequence-needs second)
                         (sequence-modifies first)))
      (union (sequence-modifies first)
             (sequence-modifies second))
      (append (sequence-statements first)
              (sequence-statements second))))

  (define label-counter 0)
  (define (new-label prefix)
    (set! label-counter (+ label-counter 1))
    (list prefix label-counter))
  (define (linkage-sequence linkage)
    (cond ((eq? linkage 'next) empty-sequence)
          ((eq? linkage 'return)
           (make-sequence
             '(continue)
             '()
             '((goto (reg continue)))))
          (else
           (make-sequence
             '()
             '()
             (list (list 'goto
                         (list 'label linkage)))))))
  (define (end-with-linkage sequence linkage)
    (append-sequences sequence
                      (linkage-sequence linkage)))

  (define (compile-self expression target linkage)
    (end-with-linkage
      (make-sequence
        '()
        (list target)
        (list (list 'assign target
                    (list 'const expression))))
      linkage))
  (define (compile-variable expression target linkage)
    (end-with-linkage
      (make-sequence
        '(env)
        (list target)
        (list
          (list 'assign target
                (list 'op
                      'lookup-variable-value
                      (list 'const expression)
                      '(reg env)))))
      linkage))
  (define (compile-quote expression target linkage)
    (compile-self (cadr expression) target linkage))

  (define (compile-operands operands)
    (define (loop remaining result)
      (if (null? remaining)
          result
          (loop
            (cdr remaining)
            (append-sequences
              result
              (append-sequences
                (compile (car remaining) 'val 'next)
                (make-sequence
                  '(argl val)
                  '(argl)
                  '((assign argl
                      (op append-argument
                          (reg argl)
                          (reg val))))))))))
    (loop operands
          (make-sequence
            '()
            '(argl)
            '((assign argl (const ()))))))

  (define (compile-application expression target linkage)
    (end-with-linkage
      (append-sequences
        (compile (car expression) 'proc 'next)
        (append-sequences
          (compile-operands (cdr expression))
          (make-sequence
            '(proc argl)
            (list target)
            (list
              (list 'assign target
                    '(op apply-procedure
                         (reg proc)
                         (reg argl)))))))
      linkage))

  (define (compile-if expression target linkage)
    (let ((alternative-label (new-label 'false-branch))
          (after-label (new-label 'after-if)))
      (end-with-linkage
        (make-sequence
          '(env continue)
          (union (list target) '(val proc argl continue))
          (append
            (sequence-statements
              (compile (cadr expression) 'val 'next))
            (append
              '((test (op false? (reg val))))
              (append
                (list (list 'branch
                            (list 'label alternative-label)))
                (append
                  (sequence-statements
                    (compile (caddr expression)
                             target
                             'next))
                  (append
                    (list
                      (list 'goto (list 'label after-label))
                      (list 'label alternative-label))
                    (append
                      (sequence-statements
                        (compile (cadddr expression)
                                 target
                                 'next))
                      (list (list 'label after-label)))))))))
        linkage)))

  (define (compile-sequence expressions target linkage)
    (cond ((null? expressions) empty-sequence)
          ((null? (cdr expressions))
           (compile (car expressions) target linkage))
          (else
           (append-sequences
             (compile (car expressions) 'val 'next)
             (compile-sequence
               (cdr expressions)
               target
               linkage)))))

  (define (compile-lambda expression target linkage)
    (let ((parameters (cadr expression))
          (body-code
            (compile-sequence (cddr expression)
                              'val
                              'return)))
      (end-with-linkage
        (make-sequence
          '(env)
          (list target)
          (list
            (list 'assign target
                  (list 'op
                        'make-compiled-procedure
                        (list 'const parameters)
                        (list 'const
                              (sequence-statements body-code))
                        '(reg env)))))
        linkage)))

  (define (compile expression target linkage)
    (cond ((self-evaluating? expression)
           (compile-self expression target linkage))
          ((symbol? expression)
           (compile-variable expression target linkage))
          ((quoted? expression)
           (compile-quote expression target linkage))
          ((if? expression)
           (compile-if expression target linkage))
          ((lambda? expression)
           (compile-lambda expression target linkage))
          ((begin? expression)
           (compile-sequence (cdr expression)
                             target
                             linkage))
          ((pair? expression)
           (compile-application expression target linkage))
          (else
           (error "unknown compiler expression" expression))))
  (map expression-class
       '(42
         x
         (quote ok)
         (if x 1 2)
         (lambda (x) (+ x 1))
         (begin 1 2)
         (+ 1 2)))
)