(define (self-evaluating? exp)
  (cond ((number? exp) true)
        ((string? exp) true)
        (else false)))
(define (variable? exp) (symbol? exp))
(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      false))
(define (quoted? exp)
  (tagged-list? exp 'quote))
(define (assignment? exp)
  (tagged-list? exp 'set!))
(define (definition? exp)
  (tagged-list? exp 'define))
(define (definition-variable exp)
  (if (symbol? (cadr exp))
      (cadr exp)
      (caadr exp)))
(define (definition-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (cdadr exp)
                   (cddr exp))))
(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
  (if (not (null? (cdddr exp)))
      (cadddr exp)
      'false))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))


(define (cond? exp) (tagged-list? exp 'cond))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))

(define (compile exp target linkage)
  (cond ((self-evaluating? exp)
         (compile-self-evaluating exp target linkage))
        ((quoted? exp) (compile-quoted exp target linkage))
        ((variable? exp)
         (compile-variable exp target linkage))
        ((assignment? exp)
         (compile-assignment exp target linkage))
        ((definition? exp)
         (compile-definition exp target linkage))
        ((if? exp) (compile-if exp target linkage))
        ((lambda? exp) (compile-lambda exp target linkage))
        ((begin? exp)
         (compile-sequence (begin-actions exp)
                           target
                           linkage))
        ((cond? exp) (compile (cond->if exp) target linkage))
        ((application? exp)
         (compile-application exp target linkage))
        (else
         (error "Unknown expression type -- COMPILE" exp))))

(define (make-instruction-sequence needs modifies statements)
  (list needs modifies statements))

(define (empty-instruction-sequence)
  (make-instruction-sequence '() '() '()))

(define (compile-linkage linkage)
  (cond ((eq? linkage 'return)
         (make-instruction-sequence '(continue) '()
          '((goto (reg continue)))))
        ((eq? linkage 'next)
         (empty-instruction-sequence))
        (else
         (make-instruction-sequence '() '()
          `((goto (label ,linkage)))))))

(define (end-with-linkage linkage instruction-sequence)
  (preserving '(continue)
   instruction-sequence
   (compile-linkage linkage)))

(define (compile-self-evaluating exp target linkage)
  (end-with-linkage linkage
   (make-instruction-sequence '() (list target)
    `((assign ,target (const ,exp))))))

(define (compile-quoted exp target linkage)
  (end-with-linkage linkage
   (make-instruction-sequence '() (list target)
    `((assign ,target (const ,(text-of-quotation exp)))))))

(define (compile-variable exp target linkage)
  (end-with-linkage linkage
   (make-instruction-sequence '(env) (list target)
    `((assign ,target
              (op lookup-variable-value)
              (const ,exp)
              (reg env))))))

(define (compile-assignment exp target linkage)
  (let ((var (assignment-variable exp))
        (get-value-code
         (compile (assignment-value exp) 'val 'next)))
    (end-with-linkage linkage
     (preserving '(env)
      get-value-code
      (make-instruction-sequence '(env val) (list target)
       `((perform (op set-variable-value!)
                  (const ,var)
                  (reg val)
                  (reg env))
         (assign ,target (const ok))))))))

(define (compile-definition exp target linkage)
  (let ((var (definition-variable exp))
        (get-value-code
         (compile (definition-value exp) 'val 'next)))
    (end-with-linkage linkage
     (preserving '(env)
      get-value-code
      (make-instruction-sequence '(env val) (list target)
       `((perform (op define-variable!)
                  (const ,var)
                  (reg val)
                  (reg env))
         (assign ,target (const ok))))))))

(define label-counter 0)

(define (new-label-number)
  (set! label-counter (+ 1 label-counter))
  label-counter)

(define (make-label name)
  (string->symbol
    (string-append (symbol->string name)
                    (number->string (new-label-number)))))

(define (compile-if exp target linkage)
  (let ((t-branch (make-label 'true-branch))
        (f-branch (make-label 'false-branch))                    
        (after-if (make-label 'after-if)))
    (let ((consequent-linkage
           (if (eq? linkage 'next) after-if linkage)))
      (let ((p-code (compile (if-predicate exp) 'val 'next))
            (c-code
             (compile
              (if-consequent exp) target consequent-linkage))
            (a-code
             (compile (if-alternative exp) target linkage)))
        (preserving '(env continue)
         p-code
         (append-instruction-sequences
          (make-instruction-sequence '(val) '()
           `((test (op false?) (reg val))
             (branch (label ,f-branch))))
          (parallel-instruction-sequences
           (append-instruction-sequences t-branch c-code)
           (append-instruction-sequences f-branch a-code))
          after-if))))))

(define (compile-sequence seq target linkage)
  (if (last-exp? seq)
      (compile (first-exp seq) target linkage)
      (preserving '(env continue)
       (compile (first-exp seq) target 'next)
       (compile-sequence (rest-exps seq) target linkage))))

(define (compile-lambda exp target linkage)
  (let ((proc-entry (make-label 'entry))
        (after-lambda (make-label 'after-lambda)))
    (let ((lambda-linkage
           (if (eq? linkage 'next) after-lambda linkage)))
      (append-instruction-sequences
       (tack-on-instruction-sequence
        (end-with-linkage lambda-linkage
         (make-instruction-sequence '(env) (list target)
          `((assign ,target
                    (op make-compiled-procedure)
                    (label ,proc-entry)
                    (reg env)))))
        (compile-lambda-body exp proc-entry))
       after-lambda))))

(define (compile-lambda-body exp proc-entry)
  (let ((formals (lambda-parameters exp)))
    (append-instruction-sequences
     (make-instruction-sequence '(env proc argl) '(env)
      `(,proc-entry
        (assign env (op compiled-procedure-env) (reg proc))
        (assign env
                (op extend-environment)
                (const ,formals)
                (reg argl)
                (reg env))))
     (compile-sequence (lambda-body exp) 'val 'return))))

(define (compile-application exp target linkage)
  (let ((proc-code (compile (operator exp) 'proc 'next))
        (operand-codes
         (map (lambda (operand) (compile operand 'val 'next))
              (operands exp))))
    (preserving '(env continue)
     proc-code
     (preserving '(proc continue)
      (construct-arglist operand-codes)
      (compile-procedure-call target linkage)))))

(define (construct-arglist operand-codes)
  (let ((operand-codes (reverse operand-codes)))
    (if (null? operand-codes)
        (make-instruction-sequence '() '(argl)
         '((assign argl (const ()))))
        (let ((code-to-get-last-arg
               (append-instruction-sequences
                (car operand-codes)
                (make-instruction-sequence '(val) '(argl)
                 '((assign argl (op list) (reg val)))))))
          (if (null? (cdr operand-codes))
              code-to-get-last-arg
              (preserving '(env)
               code-to-get-last-arg
               (code-to-get-rest-args
                (cdr operand-codes))))))))

(define (code-to-get-rest-args operand-codes)
  (let ((code-for-next-arg
         (preserving '(argl)
          (car operand-codes)
          (make-instruction-sequence '(val argl) '(argl)
           '((assign argl
              (op cons) (reg val) (reg argl)))))))
    (if (null? (cdr operand-codes))
        code-for-next-arg
        (preserving '(env)
         code-for-next-arg
         (code-to-get-rest-args (cdr operand-codes))))))

(define (compile-procedure-call target linkage)
  (let ((primitive-branch (make-label 'primitive-branch))
        (compiled-branch (make-label 'compiled-branch))
        (after-call (make-label 'after-call)))
    (let ((compiled-linkage
           (if (eq? linkage 'next) after-call linkage)))
      (append-instruction-sequences
       (make-instruction-sequence '(proc) '()
        `((test (op primitive-procedure?) (reg proc))
          (branch (label ,primitive-branch))))
       (parallel-instruction-sequences
        (append-instruction-sequences
         compiled-branch
         (compile-proc-appl target compiled-linkage))
        (append-instruction-sequences
         primitive-branch
         (end-with-linkage linkage
          (make-instruction-sequence '(proc argl)
                                     (list target)
           `((assign ,target
                     (op apply-primitive-procedure)
                     (reg proc)
                     (reg argl)))))))
       after-call))))
(define all-regs '(env proc val argl continue))
(define (compile-proc-appl target linkage)
  (cond ((and (eq? target 'val) (not (eq? linkage 'return)))
         (make-instruction-sequence '(proc) all-regs
           `((assign continue (label ,linkage))
             (assign val (op compiled-procedure-entry)
                         (reg proc))
             (goto (reg val)))))
        ((and (not (eq? target 'val))
              (not (eq? linkage 'return)))
         (let ((proc-return (make-label 'proc-return)))
           (make-instruction-sequence '(proc) all-regs
            `((assign continue (label ,proc-return))
              (assign val (op compiled-procedure-entry)
                          (reg proc))
              (goto (reg val))
              ,proc-return
              (assign ,target (reg val))
              (goto (label ,linkage))))))
        ((and (eq? target 'val) (eq? linkage 'return))
         (make-instruction-sequence '(proc continue) all-regs
          '((assign val (op compiled-procedure-entry)
                        (reg proc))
            (goto (reg val)))))
        ((and (not (eq? target 'val)) (eq? linkage 'return))
         (error "return linkage, target not val -- COMPILE"
                target))))

;;命令列の組合せ

(define (registers-needed s)
  (if (symbol? s) '() (car s)))

(define (registers-modified s)
  (if (symbol? s) '() (cadr s)))

(define (statements s)
  (if (symbol? s) (list s) (caddr s)))

(define (needs-register? seq reg)
  (memq reg (registers-needed seq)))

(define (modifies-register? seq reg)
  (memq reg (registers-modified seq)))

(define (append-instruction-sequences . seqs)
  (define (append-2-sequences seq1 seq2)
    (make-instruction-sequence
     (list-union (registers-needed seq1)
                 (list-difference (registers-needed seq2)
                                  (registers-modified seq1)))
     (list-union (registers-modified seq1)
                 (registers-modified seq2))
     (append (statements seq1) (statements seq2))))
  (define (append-seq-list seqs)
    (if (null? seqs)
        (empty-instruction-sequence)
        (append-2-sequences (car seqs)
                            (append-seq-list (cdr seqs)))))
  (append-seq-list seqs))

(define (list-union s1 s2)
  (cond ((null? s1) s2)
        ((memq (car s1) s2) (list-union (cdr s1) s2))
        (else (cons (car s1) (list-union (cdr s1) s2)))))

(define (list-difference s1 s2)
  (cond ((null? s1) '())
        ((memq (car s1) s2) (list-difference (cdr s1) s2))
        (else (cons (car s1)
                    (list-difference (cdr s1) s2)))))

(define (preserving regs seq1 seq2)
  (if (null? regs)
      (append-instruction-sequences seq1 seq2)
      (let ((first-reg (car regs)))
        (if (and (needs-register? seq2 first-reg)
                 (modifies-register? seq1 first-reg))
            (preserving (cdr regs)
             (make-instruction-sequence
              (list-union (list first-reg)
                          (registers-needed seq1))
              (list-difference (registers-modified seq1)
                               (list first-reg))
              (append `((save ,first-reg))
                      (statements seq1)
                      `((restore ,first-reg))))
             seq2)
            (preserving (cdr regs) seq1 seq2)))))

(define (tack-on-instruction-sequence seq body-seq)
  (make-instruction-sequence
   (registers-needed seq)
   (registers-modified seq)
   (append (statements seq) (statements body-seq))))

(define (parallel-instruction-sequences seq1 seq2)
  (make-instruction-sequence
   (list-union (registers-needed seq1)
               (registers-needed seq2))
   (list-union (registers-modified seq1)
               (registers-modified seq2))
   (append (statements seq1) (statements seq2))))

;; eceval compile-and-run

(define (compile-and-run expression) ;; ch5.5.7
  (let ((instructions
         (assemble (statements
                    (compile expression 'val 'return))
                   eceval)))
    (set! the-global-environment (setup-environment))
    (set-register-contents! eceval 'val instructions)
    (set-register-contents! eceval 'flag true)
    (start eceval)))

(load "compile2.sch")

(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      false))
(define (self-evaluating? exp)
  (cond ((number? exp) true)
        ((string? exp) true)
        (else false)))
(define (variable? exp) (symbol? exp))
(define (quoted? exp)
  (tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (assignment? exp)
  (tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (definition? exp)
  (tagged-list? exp 'define))
(define (definition-variable exp)
  (if (symbol? (cadr exp))
      (cadr exp)
      (caadr exp)))
(define (definition-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (cdadr exp)
                   (cddr exp))))
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
  (if (not (null? (cdddr exp)))
      (cadddr exp)
      'false))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))


(define (true? x)
  (not (eq? x false)))
(define (false? x)
  (eq? x false))
(define (make-procedure parameters body env)
  (list 'procedure parameters body env))
(define (compound-procedure? p)
  (tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())
(define (make-frame variables values)
  (cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
  (set-car! frame (cons var (car frame)))
  (set-cdr! frame (cons val (cdr frame))))
(define (extend-environment vars vals base-env)
  (if (= (length vars) (length vals))
      (cons (make-frame vars vals) base-env)
      (if (< (length vars) (length vals))
          (error "Too many arguments supplied" vars vals)
          (error "Too few arguments supplied" vars vals))))
(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (car vals))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))
(define (set-variable-value! var val env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))
(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars)
             (add-binding-to-frame! var val frame))
            ((eq? var (car vars))
             (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame)
          (frame-values frame))))
(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define apply-in-underlying-scheme apply)

(define (empty-arglist) '())
(define (adjoin-arg arg arglist)
  (append arglist (list arg)))
(define (last-operand? ops)
  (null? (cdr ops)))
;;(define (user-print object)
;;  (if (compound-procedure? object)
;;      (display (list 'compound-procedure
;;                     (procedure-parameters object)
;;                     (procedure-body object)
;;                     '))
;;      (display object)))
;;脚注50
(define (user-print object) 
  (cond ((compound-procedure? object)
         (display (list 'compound-procedure
                         (procedure-parameters object)
                         (procedure-body object)
                         ')))
        ((compiled-procedure? object)
         (display '))
        (else (display object))))

(define primitive-procedures
  (list (list '* *)
        (list '+ +)
        (list '- -)
        (list '/ /)
        (list '< <)
        (list '= =)
        (list '> >)
;;      (list 'apply apply)
        (list 'assoc assoc)
        (list 'atan atan)
        (list 'cadr cadr)
        (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'cos cos)
        (list 'display display)
        (list 'eq? eq?)
        (list 'error error)
;;      (list 'eval eval)
        (list 'list list)
        (list 'log log)
        (list 'max max)
        (list 'min min)
        (list 'newline newline)
        (list 'not not)
        (list 'null? null?)
        (list 'number? number?)
        (list 'pair? pair?)
        (list 'quotient quotient)
        (list 'random random)
        (list 'read read)
        (list 'remainder remainder)
        (list 'round round)
        (list 'runtime runtime)
        (list 'set-car! set-car!)
        (list 'set-cdr! set-cdr!)
        (list 'sin sin)
        (list 'symbol? symbol?)
        (list 'vector-ref vector-ref)
        (list 'vector-set! vector-set!)
        (list 'compile-and-run compile-and-run)
   ))

(define (primitive-procedure-names)
  (map car
       primitive-procedures))
(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))
(define (setup-environment)
  (let ((initial-env
         (extend-environment (primitive-procedure-names)
                             (primitive-procedure-objects)
                             the-empty-environment)))
    (define-variable! 'true true initial-env)
    (define-variable! 'false false initial-env)
    initial-env))
(define the-global-environment (setup-environment))
(define (get-global-environment)
  the-global-environment)

(define (apply-primitive-procedure proc args)
  (apply-in-underlying-scheme
   (primitive-implementation proc) args))

(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))

(define (announce-output string)
  (newline) (display string) (newline))

(define (no-more-exps? seq) (null? seq))

;;脚注38
(define (make-compiled-procedure entry env)
  (list 'compiled-procedure entry env))
(define (compiled-procedure? proc)
  (tagged-list? proc 'compiled-procedure))
(define (compiled-procedure-entry c-proc) (cadr c-proc))
(define (compiled-procedure-env c-proc) (caddr c-proc))

(define eceval-operations
  (list 
(list 'adjoin-arg adjoin-arg)
(list 'announce-output announce-output)
(list 'application? application?)
(list 'apply-primitive-procedure apply-primitive-procedure)
(list 'assignment-value assignment-value)
(list 'assignment-variable assignment-variable)
(list 'assignment? assignment?)
(list 'begin-actions begin-actions)
(list 'begin? begin?)
(list 'compile-and-run compile-and-run)
(list 'compiled-procedure-entry compiled-procedure-entry)
(list 'compiled-procedure? compiled-procedure?)
(list 'compound-procedure? compound-procedure?)
(list 'define-variable! define-variable!)
(list 'definition-value definition-value)
(list 'definition-variable definition-variable)
(list 'definition? definition?)
(list 'empty-arglist empty-arglist)
(list 'extend-environment extend-environment)
(list 'first-exp first-exp)
(list 'first-operand first-operand)
(list 'get-global-environment get-global-environment)
(list 'if-alternative if-alternative)
(list 'if-consequent if-consequent)
(list 'if-predicate if-predicate)
(list 'if? if?)
;(list 'initialize-stack initialize-stack)
(list 'lambda-body lambda-body)
(list 'lambda-parameters lambda-parameters)
(list 'lambda? lambda?)
(list 'last-exp? last-exp?)
(list 'last-operand? last-operand?)
(list 'lookup-variable-value lookup-variable-value)
(list 'make-procedure make-procedure)
(list 'no-more-exps? no-more-exps?)
(list 'no-operands? no-operands?)
(list 'operands operands)
(list 'operator operator)
(list 'primitive-procedure? primitive-procedure?)
;(list 'print-stack-statistics print-stack-statistics)
(list 'procedure-body procedure-body)
(list 'procedure-environment procedure-environment)
(list 'procedure-parameters procedure-parameters)
(list 'prompt-for-input prompt-for-input)
(list 'quoted? quoted?)
(list 'read read)
(list 'rest-exps rest-exps)
(list 'rest-operands rest-operands)
(list 'self-evaluating? self-evaluating?)
(list 'set-variable-value! set-variable-value!)
(list 'text-of-quotation text-of-quotation)
(list 'true? true?)
(list 'user-print user-print)
(list 'variable? variable?)

(list 'compiled-procedure-env compiled-procedure-env)
(list 'cons cons)
(list 'false? false?)
(list 'list list)
(list 'make-compiled-procedure make-compiled-procedure)
))

(define eceval
  (make-machine
   '(exp env val proc argl continue unev compapp)
   eceval-operations
  '(
  (assign compapp (label compound-apply))
  (branch (label external-entry))
read-eval-print-loop
  (perform (op initialize-stack))
  (perform
   (op prompt-for-input) (const ";;; EC-Eval input:"))
  (assign exp (op read))
  (assign env (op get-global-environment))
  (assign continue (label print-result))
  (goto (label eval-dispatch))

external-entry
  (perform (op initialize-stack))
  (assign env (op get-global-environment))
  (assign continue (label print-result))
  (goto (reg val))
;   (goto (label eval-dispatch))

print-result
  (perform (op print-stack-statistics));;スタック統計量出力
  (perform
;;脚注38
   (op announce-output) (const ";;; EC-Eval value:"))
  (perform (op user-print) (reg val))
  (goto (label read-eval-print-loop))

eval-dispatch
  (test (op self-evaluating?) (reg exp))
  (branch (label ev-self-eval))
  (test (op variable?) (reg exp))
  (branch (label ev-variable))
  (test (op quoted?) (reg exp))
  (branch (label ev-quoted))
  (test (op assignment?) (reg exp))
  (branch (label ev-assignment))
  (test (op definition?) (reg exp))
  (branch (label ev-definition))
  (test (op if?) (reg exp))
  (branch (label ev-if))
  (test (op lambda?) (reg exp))
  (branch (label ev-lambda))
  (test (op begin?) (reg exp))
  (branch (label ev-begin))
  (test (op application?) (reg exp))
  (branch (label ev-application))
  (goto (label unknown-expression-type))

ev-compile-and-run
  (perform (op compile-and-run) (reg exp))
  (goto (reg continue))

ev-self-eval
  (assign val (reg exp))
  (goto (reg continue))

ev-variable
  (assign val (op lookup-variable-value) (reg exp) (reg env))
  (goto (reg continue))

ev-quoted
  (assign val (op text-of-quotation) (reg exp))
  (goto (reg continue))

ev-lambda
  (assign unev (op lambda-parameters) (reg exp))
  (assign exp (op lambda-body) (reg exp))
  (assign val (op make-procedure)
              (reg unev) (reg exp) (reg env))
  (goto (reg continue))

ev-application
  (save continue)
  (save env)
  (assign unev (op operands) (reg exp))
  (save unev)
  (assign exp (op operator) (reg exp))
  (assign continue (label ev-appl-did-operator))
  (goto (label eval-dispatch))

ev-appl-did-operator
  (restore unev)
  (restore env)
  (assign argl (op empty-arglist))
  (assign proc (reg val))
  (test (op no-operands?) (reg unev))
  (branch (label apply-dispatch))
  (save proc)

ev-appl-operand-loop
  (save argl)
  (assign exp (op first-operand) (reg unev))
  (test (op last-operand?) (reg unev))
  (branch (label ev-appl-last-arg))
  (save env)
  (save unev)
  (assign continue (label ev-appl-accumulate-arg))
  (goto (label eval-dispatch))

ev-appl-accumulate-arg
  (restore unev)
  (restore env)
  (restore argl)
  (assign argl (op adjoin-arg) (reg val) (reg argl))
  (assign unev (op rest-operands) (reg unev))
  (goto (label ev-appl-operand-loop))

ev-appl-last-arg
  (assign continue (label ev-appl-accum-last-arg))
  (goto (label eval-dispatch))
ev-appl-accum-last-arg
  (restore argl)
  (assign argl (op adjoin-arg) (reg val) (reg argl))
  (restore proc)
  (goto (label apply-dispatch))

apply-dispatch
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-apply))
  (test (op compound-procedure?) (reg proc))  
  (branch (label compound-apply))
  (test (op compiled-procedure?) (reg proc))  
  (branch (label compiled-apply))
  (goto (label unknown-procedure-type))

compiled-apply
  (restore continue)
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))

;apply-dispatch
;  (test (op primitive-procedure?) (reg proc))
;  (branch (label primitive-apply))
;  (test (op compound-procedure?) (reg proc))  
;  (branch (label compound-apply))
;  (goto (label unknown-procedure-type))

primitive-apply
  (assign val (op apply-primitive-procedure)
              (reg proc)
              (reg argl))
  (restore continue)
  (goto (reg continue))

compound-apply
  (assign unev (op procedure-parameters) (reg proc))
  (assign env (op procedure-environment) (reg proc))
  (assign env (op extend-environment)
              (reg unev) (reg argl) (reg env))
  (assign unev (op procedure-body) (reg proc))
  (goto (label ev-sequence))

ev-begin
  (assign unev (op begin-actions) (reg exp))
  (save continue)
  (goto (label ev-sequence))

;; 末尾再帰 ev-sequence
ev-sequence
  (assign exp (op first-exp) (reg unev))
  (test (op last-exp?) (reg unev))
  (branch (label ev-sequence-last-exp))
  (save unev)
  (save env)
  (assign continue (label ev-sequence-continue))
  (goto (label eval-dispatch))
ev-sequence-continue
  (restore env)
  (restore unev)
  (assign unev (op rest-exps) (reg unev))
  (goto (label ev-sequence))
ev-sequence-last-exp
  (restore continue)
  (goto (label eval-dispatch))

;;末尾再帰なし ev-sequence
;;ev-sequence
;;  (test (op no-more-exps?) (reg unev))
;;  (branch (label ev-sequence-end))
;;  (assign exp (op first-exp) (reg unev))
;;  (save unev)
;;  (save env)
;;  (assign continue (label ev-sequence-continue))
;;  (goto (label eval-dispatch))
;;ev-sequence-continue
;;  (restore env)
;;  (restore unev)
;;  (assign unev (op rest-exps) (reg unev))
;;  (goto (label ev-sequence))
;;ev-sequence-end
;;  (restore continue)
;;  (goto (reg continue))

ev-if
  (save exp)
  (save env)
  (save continue)
  (assign continue (label ev-if-decide))
  (assign exp (op if-predicate) (reg exp))
  (goto (label eval-dispatch))

ev-if-decide
  (restore continue)
  (restore env)
  (restore exp)
  (test (op true?) (reg val))
  (branch (label ev-if-consequent))
ev-if-alternative
  (assign exp (op if-alternative) (reg exp))
  (goto (label eval-dispatch))
ev-if-consequent
  (assign exp (op if-consequent) (reg exp))
  (goto (label eval-dispatch))

ev-assignment
  (assign unev (op assignment-variable) (reg exp))
  (save unev)
  (assign exp (op assignment-value) (reg exp))
  (save env)
  (save continue)
  (assign continue (label ev-assignment-1))
  (goto (label eval-dispatch))
ev-assignment-1
  (restore continue)
  (restore env)
  (restore unev)
  (perform
   (op set-variable-value!) (reg unev) (reg val) (reg env))
  (assign val (const ok))
  (goto (reg continue))

ev-definition
  (assign unev (op definition-variable) (reg exp))
  (save unev)
  (assign exp (op definition-value) (reg exp))
  (save env)
  (save continue)
  (assign continue (label ev-definition-1))
  (goto (label eval-dispatch))
ev-definition-1
  (restore continue)
  (restore env)
  (restore unev)
  (perform
   (op define-variable!) (reg unev) (reg val) (reg env))
  (assign val (const ok))
  (goto (reg continue))

unknown-expression-type
  (assign val (const unknown-expression-type-error))
  (goto (label signal-error))

unknown-procedure-type
  (restore continue)
  (assign val (const unknown-procedure-type-error))
  (goto (label signal-error))

signal-error
  (perform (op user-print) (reg val))
  (goto (label read-eval-print-loop))
   )))

(define the-global-environment (setup-environment))

(define (start-eceval)  ;;脚注49
  (set! the-global-environment (setup-environment))
  (set-register-contents! eceval 'flag false)
  (start eceval))

(start-eceval)

329ページのev-applicationをみて, 問題のレジスタ, env, proc, arglの退避回復
に注目すると

ev-application
  (save env)
  <演算子の評価>
ev-appl-did-operator
  (restore env)
  
  
  <被演算子がなければapply-dispatchへ>
  (save proc)
ev-appl-operand-loop
  (save argl)
  
  <最後の被演算子ならev-appl-last-argへ>
  (save env)
  <被演算子の評価>
ev-appl-accumulate-arg
  (restore env)
  (restore argl)
  (arglに評価済みの被演算子を追加>
  
ev-appl-last-arg
  <最後の被演算子の評価>
ev-appl-accum-last-arg
  (restore argl)
  
  (restore proc)
  

で問題文に書いてあるようになっている. 

これらのレジスタはどこでassignされるかをみると
env はapplyで定義された手続きを呼ぶとき, 手続きのenvに仮引数, 実引数の
ペアを追加してenvにおく. 

proc は組み合わせの評価で演算子を評価してprocにおく. 

argl は組み合わせの評価で被演算子をおく. 

(f 'x 'y) 演算子, 被演算子の評価に組み合わせがないので, save, restoreは不要. 

((f)) 'x 'y) 演算子の評価に組み合わせがあるが, procもarglもこれから使うので
save, restore不要

(f (g 'x) y) procの評価のあとyをarglにおき, そこで組み合わせ(g 'x)を評価する
ので(g 'x)の評価の前後でproc, arglのsave, restoreが必要

(f (g 'x) 'y) うえと同じ. 

↑  (assign val (op make-compiled-procedure) (label entry2) (reg env))
│  (goto (label after-lambda1))
│entry2
│  (assign env (op compiled-procedure-env) (reg proc))
│  (assign env (op extend-environment) (const (n)) (reg argl) (reg env))
│  (save continue)
│  (save env)
│  (assign proc (op lookup-variable-value) (const =) (reg env))
│  (assign val (const 1))
│  (assign argl (op list) (reg val))
│  (assign val (op lookup-variable-value) (const n) (reg env))
│  (assign argl (op cons) (reg val) (reg argl))
│  (test (op primitive-procedure?) (reg proc))
│  (branch (label primitive-branch17))
│compiled-branch16
A   (assign continue (label after-call15))
│  (assign val (op compiled-procedure-entry) (reg proc))
│  (goto (reg val))
│primitive-branch17
│  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
│after-call15
│  (restore env)
│  (restore continue)
│  (test (op false?) (reg val))
│  (branch (label false-branch4))
│true-branch5
│  (assign val (const 1))
│  (goto (reg continue))
│false-branch4
│  (assign proc (op lookup-variable-value) (const *) (reg env))
│  (save continue)
↓  (save proc)
    (save env)
↑ (assign proc (op lookup-variable-value) (const factorial-alt) (reg env))
│  (save proc)
│  (assign proc (op lookup-variable-value) (const /-) (reg env))
│  (assign val (const 1))
│  (assign argl (op list) (reg val))
│  (assign val (op lookup-variable-value) (const n) (reg env))
│  (assign argl (op cons) (reg val) (reg argl))
│  (test (op primitive-procedure?) (reg proc))
│  (branch (label primitive-branch8))
│compiled-branch7
│  (assign continue (label after-call6))
│  (assign val (op compiled-procedure-entry) (reg proc))
│  (goto (reg val))
B primitive-branch8
│  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
│after-call6
│  (assign argl (op list) (reg val))
│  (restore proc)
│  (test (op primitive-procedure?) (reg proc))
│  (branch (label primitive-branch11))
│compiled-branch10
│  (assign continue (label after-call9))
│  (assign val (op compiled-procedure-entry) (reg proc))
│  (goto (reg val))
│primitive-branch11
│  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
↓after-call9
    (assign argl (op list) (reg val))
    (restore env)
    (assign val (op lookup-variable-value) (const n) (reg env))
↑  (assign argl (op cons) (reg val) (reg argl))
│  (restore proc)
│  (restore continue)
│  (test (op primitive-procedure?) (reg proc))
│  (branch (label primitive-branch14))
│compiled-branch13
│  (assign val (op compiled-procedure-entry) (reg proc))
C   (goto (reg val))
│primitive-branch14
│  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
│  (goto (reg continue))
│after-call12
│after-if3
│after-lambda1
│  (perform (op define-variable!) (const factorial-alt) (reg val) (reg env))
↓  (assign val (const ok))

  (assign val (op make-compiled-procedure) (label entry2) (reg env))
  (goto (label after-lambda1))
entry2
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (n)) (reg argl) (reg env))
  (assign val (op make-compiled-procedure) (label entry7) (reg env))
  (goto (label after-lambda6))
entry7
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (product counter)) (reg argl) (reg env))
  (save continue)
  (save env)
  (assign proc (op lookup-variable-value) (const >) (reg env))
  (assign val (op lookup-variable-value) (const n) (reg env))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const counter) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch22))
compiled-branch21
  (assign continue (label after-call20))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch22
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call20
  (restore env)
  (restore continue)
  (test (op false?) (reg val))
  (branch (label false-branch9))
true-branch10
  (assign val (op lookup-variable-value) (const product) (reg env))
  (goto (reg continue))
false-branch9
  (assign proc (op lookup-variable-value) (const iter) (reg env))
  (save continue)
  (save proc)
  (save env)
  (assign proc (op lookup-variable-value) (const /+) (reg env))
  (assign val (const 1))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const counter) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch13))
compiled-branch12
  (assign continue (label after-call11))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch13
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call11
  (assign argl (op list) (reg val))
  (restore env)
  (save argl)
  (assign proc (op lookup-variable-value) (const *) (reg env))
  (assign val (op lookup-variable-value) (const product) (reg env))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const counter) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch16))
compiled-branch15
  (assign continue (label after-call14))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch16
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call14
  (restore argl)
  (assign argl (op cons) (reg val) (reg argl))
  (restore proc)
  (restore continue)
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch19))
compiled-branch18
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch19
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
after-call17
after-if8
after-lambda6
  (perform (op define-variable!) (const iter) (reg val) (reg env))
  (assign val (const ok))
  (assign proc (op lookup-variable-value) (const iter) (reg env))
  (assign val (const 1))
  (assign argl (op list) (reg val))
  (assign val (const 1))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch5))
compiled-branch4
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch5
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
after-call3
after-lambda1
  (perform (op define-variable!) (const factorial) (reg val) (reg env))
  (assign val (const ok))

  ┌─    (save continue)
  │┌  (save env)
  ││  (> counter n)の計算
  ││after-call20
  │└  (restore env)
  └─  (restore continue)
      false-branch9
┌──  (save continue)
│┌─  (save proc)
││┌  (save env)
│││(+ counter 1)の計算
│││after-call11
││└  (restore env)
││┌  (save argl)
│││(* counter product)の計算
││└  (restore argl)
│└─  (restore proc)
└──  (restore continue)
      (iter counter product)の計算

    ┌─  (save continue)
    │┌  (save env)
    ││(= n 1)の計算
    ││after-call15
    │└  (restore env)
    └─  (restore continue)
        false-branch4
┌───  (save continue)
│┌──  (save proc)
││┌─  (save argl)
│││┌  (save proc)
││││(- n 1)の計算
││││after-call6
│││└  (restore proc)
│││  (factorial (- n 1))の計算
│││  after-call9
││└─  (restore argl)
│└──  (restore proc)
└───  (restore continue)
       (* (factorial (- n 1)) n)の計算
       after-call12

ex5.35
(define (f x)
  (+ x (g (+ x 2))))
を翻訳する

label-numberが図5.18とは違っているが, 同じプログラムである. label-numberを
図5.18と同様にするにはcompilerのlabel-counterの初期値を
(define label-counter 14) (345ページ脚注37)
と設定する. 

;;;; 翻訳された手続き(compiled-procedure 入り口 環境)をvalに作り, 最後へ飛ぶ
;;  (assign val (op make-compiled-procedure) (label entry2) (reg env))
;;  (goto (label after-lambda1))
;;;; 手続き f の入り口
;;entry2
;;;; 翻訳された手続きから環境部分を取り出し, 
;;  (assign env (op compiled-procedure-env) (reg proc))
;;;; パラメタと引数で環境を拡張し, 
;;  (assign env (op extend-environment) (const (x)) (reg argl) (reg env))
;;;; 環境から + の手続きをprocへ取り出し, 
;;  (assign proc (op lookup-variable-value) (const /+) (reg env))
;;  (save continue)
;;  (save proc)
;;  (save env)
;;;; レジスタを退避した後, 環境から g の手続きをprocへ取り出し, 
;;  (assign proc (op lookup-variable-value) (const g) (reg env))
;;  (save proc)
;;;; レジスタを退避した後, 環境から + の手続きをprocへ取り出し,
;;  (assign proc (op lookup-variable-value) (const /+) (reg env))
;;;; 2をvalへ置き, 
;;  (assign val (const 2))
;;;; listにしてarglへ置き, 
;;  (assign argl (op list) (reg val))
;;;; 環境から x の値をvalへ取り出し, 
;;  (assign val (op lookup-variable-value) (const x) (reg env))
;;; arglへconsし, (argl には (x 2)が出来る.)
;;  (assign argl (op cons) (reg val) (reg argl))
;;  (test (op primitive-procedure?) (reg proc))
;;;; procにある手続きが基本手続きであれば, primitive-branch5へ
;;  (branch (label primitive-branch5))
;;compiled-branch4
;;;; 翻訳手続きの場合, 帰り番地を設定し, 手続きの入り口をvalへ置いて飛ぶ, 
;;  (assign continue (label after-call3))
;;  (assign val (op compiled-procedure-entry) (reg proc))
;;  (goto (reg val))
;;primitive-branch5
;;  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
;;after-call3
;;;; 手続きの値はvalにある. 
;;;; x + 2の値がvalにある. リストにしてarglへ置く. 
;;  (assign argl (op list) (reg val))
;;;; gをprodへ回復し, 
;;  (restore proc)
;;;; 基本手続きであれば, primitive-branch8へ
;;  (test (op primitive-procedure?) (reg proc))
;;  (branch (label primitive-branch8))
;;compiled-branch7
;;  (assign continue (label after-call6))
;;  (assign val (op compiled-procedure-entry) (reg proc))
;;  (goto (reg val))
;;primitive-branch8
;;  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
;;after-call6
;;  (assign argl (op list) (reg val))
;;  (restore env)
;;  (assign val (op lookup-variable-value) (const x) (reg env))
;;  (assign argl (op cons) (reg val) (reg argl))
;;  (restore proc)
;;  (restore continue)
;;  (test (op primitive-procedure?) (reg proc))
;;  (branch (label primitive-branch11))
;;compiled-branch10
;;  (assign val (op compiled-procedure-entry) (reg proc))
;;  (goto (reg val))
;;primitive-branch11
;;  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
;;  (goto (reg continue))
;;after-call9
;;after-lambda1
;;  (perform (op define-variable!) (const f) (reg val) (reg env))
;;  (assign val (const ok))

1 ]=> (compile-and-go
'(define (fib n)
  (if (< n 2) 
      n
      (+ (fib (- n 1)) (fib (- n 2))))))

(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(fib 2)

(total-pushes = 17 maximum-depth = 5)
;;; EC-Eval value:
1

;;; EC-Eval input:
(fib 3)

(total-pushes = 27 maximum-depth = 8)
;;; EC-Eval value:
2

;;; EC-Eval input:
(fib 4)

(total-pushes = 47 maximum-depth = 11)
;;; EC-Eval value:
3

;;; EC-Eval input:
(fib 5)

(total-pushes = 77 maximum-depth = 14)
;;; EC-Eval value:
5

;;; EC-Eval input:
(fib 6)

(total-pushes = 127 maximum-depth = 17)
;;; EC-Eval value:
8

;;; EC-Eval input:
(fib 7)


(total-pushes = 207 maximum-depth = 20)
;;; EC-Eval value:
13

;;; EC-Eval input:
(fib 8)

(total-pushes = 337 maximum-depth = 23)
;;; EC-Eval value:
21

;;; EC-Eval input:
(fib 9)

(total-pushes = 547 maximum-depth = 26)
;;; EC-Eval value:
34

;;; EC-Eval input:
(fib 10)

(total-pushes = 887 maximum-depth = 29)
;;; EC-Eval value:
55

;;; EC-Eval input:

これより
 n fib(n) total  max
 2     1    17    5
 3     2    27    8
 4     3    47   11
 5     5    77   14
 6     8   127   17
 7    13   207   20
 8    21   337   23
 9    34   547   26
10    55   887   29

ex5.47にあるread-eval-print-loopの直前の追加, 積極制御評価機械の記述(336ページ)
のレジスタのリストにcompappを追加する他, compile-proc-applを以下のように修正

<標的>, <接続>の各組に, 5行を挿入, compound手続きへ飛ぶ準備をする. 

(define (compile-proc-appl target linkage)
 (let ((compound-branch (make-label 'compound-branch)))    ;;新labelを用意
  (cond ((and (eq? target 'val) (not (eq? linkage 'return)))
         (make-instruction-sequence '(proc) all-regs
           `((assign continue (label ,linkage))
             (test (op compound-procedure?) (reg proc))    ;;以下5行を挿入 
             (branch (label ,compound-branch))             ;;
             (assign val (op compiled-procedure-entry)
                         (reg proc))
             (goto (reg val))
             ,compound-branch                              ;;
             (save continue)                               ;;
             (goto (reg compapp)))))                       ;;
        ((and (not (eq? target 'val))
              (not (eq? linkage 'return)))
         (let ((proc-return (make-label 'proc-return)))
           (make-instruction-sequence '(proc) all-regs
            `((assign continue (label ,proc-return))
              (test (op compound-procedure?) (reg proc))   ;;以下5行を挿入
              (branch (label ,compound-branch))            ;;
              (assign val (op compiled-procedure-entry)
                          (reg proc))
              (goto (reg val))
              ,compound-branch                             ;;
              (save continue)                              ;;
              (goto (reg compapp))                         ;;
              ,proc-return
              (assign ,target (reg val))
              (goto (label ,linkage))))))
        ((and (eq? target 'val) (eq? linkage 'return))
         (make-instruction-sequence '(proc continue) all-regs
          `((test (op compound-procedure?) (reg proc))     ;;以下5行を挿入
            (branch (label ,compound-branch))              ;;
            (assign val (op compiled-procedure-entry)
                        (reg proc))
            (goto (reg val))
            ,compound-branch                               ;;
            (save continue)                                ;;
            (goto (reg compapp)))))                        ;;
        ((and (not (eq? target 'val)) (eq? linkage 'return))
         (error "return linkage, target not val -- COMPILE"
                target)))))


実行例

1 ]=> (compile-and-go
  '(define (f x) (+ x (g (+ x 2)))))        ;;手続きfを翻訳する. 

(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(define (g x) (* x x))                      ;;手続きgを定義する. 

(total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(f 4)                                        ;;手続きfを呼び出す. 

(total-pushes = 18 maximum-depth = 8)
;;; EC-Eval value:
40

ecevalに以下のcompile-and-run手続きを追加, 
primitive-proceduresに
        (list 'compile-and-run compile-and-run)
の行を追加する. 

(define (compile-and-run expression) ;; ch5.5.7
  (let ((instructions
         (assemble (statements
                    (compile expression 'val 'return))
                   eceval)))
    (set! the-global-environment (setup-environment))
    (set-register-contents! eceval 'val instructions)
    (set-register-contents! eceval 'flag true)
    (start eceval)))
実行例

;;; EC-Eval input:
(compile-and-run
 '(define (factorial n)
    (if (= n 1)
        1
        (* (factorial (- n 1)) n))))

(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(factorial 5)

(total-pushes = 31 maximum-depth = 14)
;;; EC-Eval value:
120

;;; EC-Eval input:
(compile-and-run
 '(define (append x y)
    (if (null? x)
        y
        (cons (car x)
              (append (cdr x) y)))))

(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(append '(a b c) '(d e f))

(total-pushes = 34 maximum-depth = 11)
;;; EC-Eval value:
(a b c d e f)

;;; EC-Eval input:
(compile-and-run
 '(define (gcd a b)
    (if (= b 0)
        a
        (gcd b (remainder a b)))))

(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(gcd 206 40)

(total-pushes = 30 maximum-depth = 5)
;;; EC-Eval value:
2