하나의 apply 경계가 서로 다른 두 프로시저 표현을 연결한다.

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

  (define (make-frame variables values)
    (cons 'frame (map cons variables values)))
  (define (frame-bindings frame) (cdr frame))
  (define (first-frame environment) (car environment))
  (define (enclosing-environment environment) (cdr environment))
  (define (find-binding variable bindings)
    (cond ((null? bindings) #f)
          ((eq? variable (caar bindings)) (car bindings))
          (else (find-binding variable (cdr bindings)))))
  (define (lookup-variable-value variable environment)
    (if (null? environment)
        (error "unbound shared variable" variable)
        (let ((binding
                (find-binding
                  variable
                  (frame-bindings (first-frame environment)))))
          (if binding
              (cdr binding)
              (lookup-variable-value
                variable
                (enclosing-environment environment))))))
  (define (define-variable! variable value environment)
    (let ((frame (first-frame environment)))
      (let ((binding (find-binding variable (frame-bindings frame))))
        (if binding
            (set-cdr! binding value)
            (set-cdr! frame
                      (cons (cons variable value)
                            (frame-bindings frame)))))))
  (define (extend-environment variables values base-environment)
    (if (= (length variables) (length values))
        (cons (make-frame variables values) base-environment)
        (error "shared argument count mismatch" variables values)))

  (define (make-primitive implementation)
    (list 'primitive implementation))
  (define (primitive-procedure? procedure)
    (tagged-list? procedure 'primitive))
  (define (primitive-implementation procedure) (cadr procedure))

  (define (make-interpreted-procedure parameters body environment)
    (list 'interpreted parameters body environment))
  (define (interpreted-procedure? procedure)
    (tagged-list? procedure 'interpreted))
  (define (interpreted-parameters procedure) (cadr procedure))
  (define (interpreted-body procedure) (caddr procedure))
  (define (interpreted-environment procedure) (cadddr procedure))

  (define (make-compiled-procedure parameters code environment)
    (list 'compiled parameters code environment))
  (define (compiled-procedure? procedure)
    (tagged-list? procedure 'compiled))
  (define (compiled-parameters procedure) (cadr procedure))
  (define (compiled-code procedure) (caddr procedure))
  (define (compiled-environment procedure) (cadddr procedure))

  (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 (application? expression) (pair? expression))

  (define (eval-sequence expressions environment)
    (cond ((null? expressions)
           (error "empty interpreted sequence"))
          ((null? (cdr expressions))
           (evaluate (car expressions) environment))
          (else
           (evaluate (car expressions) environment)
           (eval-sequence (cdr expressions) environment))))
  (define (list-of-values expressions environment)
    (if (null? expressions)
        '()
        (cons (evaluate (car expressions) environment)
              (list-of-values (cdr expressions) environment))))
  (define (evaluate expression environment)
    (cond ((self-evaluating? expression) expression)
          ((symbol? expression)
           (lookup-variable-value expression environment))
          ((quoted? expression) (cadr expression))
          ((if? expression)
           (if (evaluate (cadr expression) environment)
               (evaluate (caddr expression) environment)
               (evaluate (cadddr expression) environment)))
          ((lambda? expression)
           (make-interpreted-procedure
             (cadr expression)
             (cddr expression)
             environment))
          ((begin? expression)
           (eval-sequence (cdr expression) environment))
          ((application? expression)
           (apply-any
             (evaluate (car expression) environment)
             (list-of-values (cdr expression) environment)))
          (else (error "unknown interpreted expression" expression))))

  (define (compile-expression expression)
    (cond ((self-evaluating? expression)
           (list (list 'constant expression)))
          ((symbol? expression)
           (list (list 'lookup expression)))
          ((quoted? expression)
           (list (list 'constant (cadr expression))))
          ((if? expression)
           (append
             (compile-expression (cadr expression))
             (list
               (list 'branch
                     (compile-expression (caddr expression))
                     (compile-expression (cadddr expression))))))
          ((lambda? expression)
           (list
             (list 'closure
                   (cadr expression)
                   (compile-sequence (cddr expression)))))
          ((begin? expression)
           (compile-sequence (cdr expression)))
          ((application? expression)
           (append
             (compile-expression (car expression))
             (compile-operands (cdr expression))
             (list (list 'call (length (cdr expression))))))
          (else (error "unknown compiled expression" expression))))
  (define (compile-operands expressions)
    (if (null? expressions)
        '()
        (append (compile-expression (car expressions))
                (compile-operands (cdr expressions)))))
  (define (compile-sequence expressions)
    (cond ((null? expressions)
           (error "empty compiled sequence"))
          ((null? (cdr expressions))
           (compile-expression (car expressions)))
          (else
           (append (compile-expression (car expressions))
                   (list (list 'pop))
                   (compile-sequence (cdr expressions))))))

  (define (make-stack) (cons 'stack '()))
  (define (push-stack! stack value)
    (set-cdr! stack (cons value (cdr stack))))
  (define (pop-stack! stack)
    (if (null? (cdr stack))
        (error "empty shared stack")
        (let ((value (cadr stack)))
          (set-cdr! stack (cddr stack))
          value)))
  (define (top-stack stack)
    (if (null? (cdr stack))
        (error "missing shared result")
        (cadr stack)))
  (define (stack-empty? stack) (null? (cdr stack)))
  (define (pop-arguments! count stack)
    (if (= count 0)
        '()
        (let ((argument (pop-stack! stack)))
          (append (pop-arguments! (- count 1) stack)
                  (list argument)))))

  (define (execute-code code environment stack)
    (if (null? code)
        (top-stack stack)
        (let ((instruction (car code))
              (remaining (cdr code)))
          (cond
            ((tagged-list? instruction 'constant)
             (push-stack! stack (cadr instruction))
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'lookup)
             (push-stack!
               stack
               (lookup-variable-value (cadr instruction) environment))
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'closure)
             (push-stack!
               stack
               (make-compiled-procedure
                 (cadr instruction)
                 (caddr instruction)
                 environment))
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'pop)
             (pop-stack! stack)
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'branch)
             (let ((predicate (pop-stack! stack)))
               (execute-code
                 (if predicate (cadr instruction) (caddr instruction))
                 environment
                 stack)
               (execute-code remaining environment stack)))
            ((tagged-list? instruction 'call)
             (let ((arguments
                     (pop-arguments! (cadr instruction) stack)))
               (let ((procedure (pop-stack! stack)))
                 (push-stack! stack (apply-any procedure arguments))
                 (execute-code remaining environment stack))))
            (else (error "unknown shared instruction" instruction))))))

  (define dispatch-log '())
  (define (procedure-kind procedure)
    (cond ((primitive-procedure? procedure) 'primitive)
          ((interpreted-procedure? procedure) 'interpreted)
          ((compiled-procedure? procedure) 'compiled)
          (else (error "unknown shared procedure" procedure))))
  (define (record-dispatch! procedure)
    (set! dispatch-log
          (cons (procedure-kind procedure) dispatch-log)))
  (define (apply-any procedure arguments)
    (record-dispatch! procedure)
    (cond
      ((primitive-procedure? procedure)
       (apply (primitive-implementation procedure) arguments))
      ((interpreted-procedure? procedure)
       (eval-sequence
         (interpreted-body procedure)
         (extend-environment
           (interpreted-parameters procedure)
           arguments
           (interpreted-environment procedure))))
      ((compiled-procedure? procedure)
       (let ((stack (make-stack)))
         (let ((value
                 (execute-code
                   (compiled-code procedure)
                   (extend-environment
                     (compiled-parameters procedure)
                     arguments
                     (compiled-environment procedure))
                   stack)))
           (pop-stack! stack)
           value)))
      (else (error "cannot apply shared procedure" procedure))))

  (define primitive-bindings
    (list (cons '+ +) (cons '- -) (cons '* *)
          (cons '= =) (cons '< <) (cons 'list list)))
  (define global-environment
    (list
      (make-frame
        (map car primitive-bindings)
        (map (lambda (binding)
               (make-primitive (cdr binding)))
             primitive-bindings))))

  (define double
    (make-interpreted-procedure
      '(x)
      '((* x 2))
      global-environment))
  (define-variable! 'double double global-environment)

  (define closure-stack (make-stack))
  (define add-three
    (execute-code
      (compile-expression '(lambda (x) (+ x 3)))
      global-environment
      closure-stack))
  (pop-stack! closure-stack)
  (define-variable! 'add-three add-three global-environment)

  (set! dispatch-log '())
  (define evaluator-value
    (evaluate '(add-three 5) global-environment))
  (define evaluator-dispatches (reverse dispatch-log))

  (set! dispatch-log '())
  (define compiled-call-stack (make-stack))
  (define compiled-value
    (execute-code
      (compile-expression '(double 7))
      global-environment
      compiled-call-stack))
  (pop-stack! compiled-call-stack)
  (define compiled-dispatches (reverse dispatch-log))

  (list
    (list 'evaluator-to-compiled
          evaluator-value
          evaluator-dispatches)
    (list 'compiled-to-evaluator
          compiled-value
          compiled-dispatches
          (stack-empty? compiled-call-stack))
    (list 'representations
          (compiled-procedure? add-three)
          (interpreted-procedure? double))))