Ядро метациклического вычислителя eval и apply

(begin
  (define (tagged-list? expression tag)
    (if (pair? expression)
        (eq? (car expression) tag)
        #f))
  (define (self-evaluating? expression)
    (cond ((number? expression) #t)
          ((string? expression) #t)
          ((boolean? expression) #t)
          (else #f)))
  (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 (text-of-quotation expression) (cadr expression))
  (define (assignment-variable expression) (cadr expression))
  (define (assignment-value expression) (caddr expression))
  (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 (if-predicate expression) (cadr expression))
  (define (if-consequent expression) (caddr expression))
  (define (if-alternative expression) (cadddr expression))
  (define (lambda-parameters expression) (cadr expression))
  (define (lambda-body expression) (cddr expression))
  (define (begin-actions expression) (cdr expression))
  (define (operator expression) (car expression))
  (define (operands expression) (cdr 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 (first-frame environment) (car environment))
  (define (frame-bindings frame) (cdr frame))
  (define (extend-environment variables values base)
    (cons (make-frame variables values) base))
  (define (lookup-variable-value variable environment)
    (if (null? environment)
        (error "unbound variable" variable)
        (let ((binding
               (assoc variable
                      (frame-bindings (first-frame environment)))))
          (if binding
              (cdr binding)
              (lookup-variable-value variable (cdr environment))))))
  (define (define-variable! variable value environment)
    (let* ((frame (first-frame 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 assignment" variable)
        (let ((binding
               (assoc variable
                      (frame-bindings (first-frame environment)))))
          (if binding
              (begin
                (set-cdr! binding value)
                (list 'assigned variable))
              (set-variable-value! variable value (cdr environment))))))

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

  (define (list-of-values expressions environment)
    (if (null? expressions)
        '()
        (cons (evaluate (car expressions) environment)
              (list-of-values (cdr expressions) environment))))
  (define (eval-sequence expressions environment)
    (if (null? (cdr expressions))
        (evaluate (car expressions) environment)
        (begin
          (evaluate (car expressions) environment)
          (eval-sequence (cdr expressions) environment))))
  (define (eval-if expression environment)
    (if (evaluate (if-predicate expression) environment)
        (evaluate (if-consequent expression) environment)
        (evaluate (if-alternative expression) environment)))
  (define (eval-assignment expression environment)
    (set-variable-value!
      (assignment-variable expression)
      (evaluate (assignment-value expression) environment)
      environment))
  (define (eval-definition expression environment)
    (define-variable!
      (definition-variable expression)
      (evaluate (definition-value expression) environment)
      environment))
  (define (apply-procedure procedure arguments)
    (cond ((procedure? procedure)
           (apply procedure arguments))
          ((compound-procedure? procedure)
           (eval-sequence
             (procedure-body procedure)
             (extend-environment
               (procedure-parameters procedure)
               arguments
               (procedure-environment procedure))))
          (else
           (error "not a guest procedure" procedure))))
  (define (evaluate expression environment)
    (cond ((self-evaluating? expression) expression)
          ((symbol? expression)
           (lookup-variable-value expression environment))
          ((quoted? expression)
           (text-of-quotation expression))
          ((assignment? expression)
           (eval-assignment expression environment))
          ((definition? expression)
           (eval-definition expression environment))
          ((if? expression)
           (eval-if expression environment))
          ((lambda? expression)
           (make-procedure
             (lambda-parameters expression)
             (lambda-body expression)
             environment))
          ((begin? expression)
           (eval-sequence (begin-actions expression) environment))
          ((pair? expression)
           (apply-procedure
             (evaluate (operator expression) environment)
             (list-of-values (operands expression) environment)))
          (else
           (error "unknown guest expression" expression))))

  (define primitive-bindings
    (list (cons '+ +) (cons '- -) (cons '* *) (cons '/ /)
          (cons '= =) (cons '< <) (cons '> >)
          (cons 'cons cons) (cons 'car car) (cons 'cdr cdr)
          (cons 'list list) (cons 'null? null?)
          (cons 'pair? pair?) (cons 'not not)))
  (define (make-global-environment)
    (list (cons '*frame* primitive-bindings)))
  (define (run-program forms environment form-budget)
    (define (loop remaining budget transcript)
      (cond ((null? remaining)
             (list 'complete (reverse transcript) 0))
            ((= budget 0)
             (list 'truncated
                   (reverse transcript)
                   (length remaining)))
            (else
             (loop (cdr remaining)
                   (- budget 1)
                   (cons (evaluate (car remaining) environment)
                         transcript)))))
    (loop forms form-budget '()))

  (define guest-program
    '((define (square x) (* x x))
      (define (make-adder x) (lambda (y) (+ x y)))
      (define add-five (make-adder 5))
      (define base 5)
      (square (+ base 2))
      (add-five 7)
      (set! base 9)
      (if (> base 8) (square base) 0)
      (add-five 1)))
  (list
    (run-program guest-program (make-global-environment) 20)
    (run-program guest-program (make-global-environment) 5)))