실행이 시작되기 전에 소스 형식은 명령 태그가 된다.

(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 (assignment? expression) (tagged-list? expression 'set!))
  (define (definition? expression) (tagged-list? expression 'define))
  (define (if? expression) (tagged-list? expression 'if))
  (define (lambda? expression) (tagged-list? expression 'lambda))
  (define (begin? expression) (tagged-list? expression 'begin))

  (define (definition-variable expression)
    (if (symbol? (cadr expression))
        (cadr expression)
        (car (cadr expression))))
  (define (definition-value expression)
    (if (symbol? (cadr expression))
        (caddr expression)
        (cons 'lambda
              (cons (cdr (cadr expression))
                    (cddr expression)))))

  (define (compile-sequence expressions)
    (cond ((null? expressions)
           '((literal ok)))
          ((null? (cdr expressions))
           (compile-expression (car expressions)))
          (else
           (append
             (compile-expression (car expressions))
             (cons '(discard)
                   (compile-sequence (cdr expressions)))))))
  (define (compile-operands operands)
    (if (null? operands)
        '()
        (append
          (compile-expression (car operands))
          (compile-operands (cdr operands)))))
  (define (compile-expression expression)
    (cond
      ((self-evaluating? expression)
       (list (list 'literal expression)))
      ((symbol? expression)
       (list (list 'load expression)))
      ((quoted? expression)
       (list (list 'literal (cadr expression))))
      ((assignment? expression)
       (append
         (compile-expression (caddr expression))
         (list (list 'set (cadr expression)))))
      ((definition? expression)
       (append
         (compile-expression (definition-value expression))
         (list (list 'define
                     (definition-variable 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)))
      ((pair? expression)
       (append
         (compile-expression (car expression))
         (append
           (compile-operands (cdr expression))
           (list (list 'call (length (cdr expression)))))))
      (else
       (error "unknown expression for compiler" expression))))

  (define (pair-bindings variables values)
    (cond ((and (null? variables) (null? values)) '())
          ((null? variables) (error "too many arguments"))
          ((null? values) (error "too few arguments"))
          (else
           (cons (cons (car variables) (car values))
                 (pair-bindings (cdr variables)
                                (cdr values))))))
  (define (make-frame variables values)
    (cons '*frame* (pair-bindings variables values)))
  (define (frame-bindings frame) (cdr frame))
  (define (extend-environment variables values environment)
    (cons (make-frame variables values) environment))
  (define (lookup-variable-value variable environment)
    (if (null? environment)
        (error "unbound compiled variable" variable)
        (let ((binding
               (assoc variable
                      (frame-bindings (car environment)))))
          (if binding
              (cdr binding)
              (lookup-variable-value variable
                                     (cdr environment))))))
  (define (define-variable! variable value environment)
    (let* ((frame (car environment))
           (binding (assoc variable (frame-bindings frame))))
      (if binding
          (set-cdr! binding value)
          (set-cdr! frame
                    (cons (cons variable value)
                          (frame-bindings frame)))))
    (list 'defined variable))
  (define (set-variable-value! variable value environment)
    (if (null? environment)
        (error "unbound compiled assignment" variable)
        (let ((binding
               (assoc variable
                      (frame-bindings (car environment)))))
          (if binding
              (begin
                (set-cdr! binding value)
                (list 'assigned variable))
              (set-variable-value! variable
                                   value
                                   (cdr environment))))))

  (define (make-primitive implementation)
    (list 'primitive implementation))
  (define (primitive? procedure)
    (tagged-list? procedure 'primitive))
  (define (primitive-implementation procedure) (cadr 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 (split-call stack count)
    (define (loop remaining-stack remaining-count arguments)
      (if (= remaining-count 0)
          (list (car remaining-stack)
                arguments
                (cdr remaining-stack))
          (loop (cdr remaining-stack)
                (- remaining-count 1)
                (cons (car remaining-stack) arguments))))
    (loop stack count '()))

  (define (run-code code stack environment)
    (if (null? code)
        (list stack environment)
        (let* ((instruction (car code))
               (tag (car instruction)))
          (cond
            ((eq? tag 'literal)
             (run-code (cdr code)
                       (cons (cadr instruction) stack)
                       environment))
            ((eq? tag 'load)
             (run-code
               (cdr code)
               (cons
                 (lookup-variable-value
                   (cadr instruction)
                   environment)
                 stack)
               environment))
            ((eq? tag 'closure)
             (run-code
               (cdr code)
               (cons
                 (make-compiled-procedure
                   (cadr instruction)
                   (caddr instruction)
                   environment)
                 stack)
               environment))
            ((eq? tag 'define)
             (let ((result
                    (define-variable!
                      (cadr instruction)
                      (car stack)
                      environment)))
               (run-code (cdr code)
                         (cons result (cdr stack))
                         environment)))
            ((eq? tag 'set)
             (let ((result
                    (set-variable-value!
                      (cadr instruction)
                      (car stack)
                      environment)))
               (run-code (cdr code)
                         (cons result (cdr stack))
                         environment)))
            ((eq? tag 'discard)
             (run-code (cdr code)
                       (cdr stack)
                       environment))
            ((eq? tag 'branch)
             (let* ((selected
                      (if (car stack)
                          (cadr instruction)
                          (caddr instruction)))
                    (branch-state
                      (run-code selected
                                (cdr stack)
                                environment)))
               (run-code (cdr code)
                         (car branch-state)
                         (cadr branch-state))))
            ((eq? tag 'call)
             (let* ((parts
                      (split-call stack (cadr instruction)))
                    (procedure (car parts))
                    (arguments (cadr parts))
                    (caller-stack (caddr parts)))
               (if (primitive? procedure)
                   (run-code
                     (cdr code)
                     (cons
                       (apply
                         (primitive-implementation procedure)
                         arguments)
                       caller-stack)
                     environment)
                   (if (compiled-procedure? procedure)
                       (let* ((call-environment
                                (extend-environment
                                  (compiled-parameters procedure)
                                  arguments
                                  (compiled-environment procedure)))
                              (call-state
                                (run-code
                                  (compiled-code procedure)
                                  '()
                                  call-environment))
                              (value (car (car call-state))))
                         (run-code (cdr code)
                                   (cons value caller-stack)
                                   environment))
                       (error "not a compiled procedure"
                              procedure)))))
            (else
             (error "unknown compiled instruction"
                    instruction))))))

  (define (make-global-environment)
    (list
      (cons '*frame*
        (list
          (cons '+ (make-primitive +))
          (cons '- (make-primitive -))
          (cons '* (make-primitive *))
          (cons '/ (make-primitive /))
          (cons '= (make-primitive =))
          (cons '< (make-primitive <))
          (cons '> (make-primitive >))
          (cons 'list (make-primitive list))
          (cons 'cons (make-primitive cons))
          (cons 'car (make-primitive car))
          (cons 'cdr (make-primitive cdr))
          (cons 'null? (make-primitive null?))))))
  (define (compile-and-run expression)
    (let* ((code (compile-expression expression))
           (environment (make-global-environment))
           (state (run-code code '() environment)))
      (list (car (car state))
            code
            environment)))
  (define program
    '(begin
       (define base 10)
       (define (make-adder x)
         (lambda (y) (+ x y)))
       (define add-three (make-adder 3))
       (set! base (+ base 5))
       (if (> base 12)
           (list (add-three base) (quote large) base)
           (list 0 (quote small) base))))
  (define result (compile-and-run program))
  (list (car result)
        (map car (cadr result))
        (length (cadr result)))
)