Scheme 几乎复制了DrRacket中的SICP解释器代码，但出现错误

我学习解释器已经有相当长的一段时间了，在阅读了SICP第4.1~4.2章之后，我尝试在DrRacket中以

planet neil/SICP

模式复制这些代码。我已经仔细阅读了这些代码，但仍然无法使代码正确运行

在复制过程中，我做了一些更改：

• eval

  功能已重命名为

  ewal

  ；（因为我想避免底层方案评估代码）

• apply

  函数已重命名为

  epply

  （底层方案中的

  应用

  函数除外）
• 为了更好地理解，我重新安排了代码结构
• 对我的底层实现使用

  #f

  和

  #t

• 我还禁用了驱动程序循环，因为我发现

  驱动程序循环

  从未为输入输出值

代码未能正确评估复合过程，但可以处理自评估、定义和其他特殊形式。我仔细检查了求值过程，发现如果我更改了一个点（我在代码中标记了

（*）

），那么

    ((compound-procedure? procedure)  (eval-sequence (procedure-body procedure)

修改为

    ((compound-procedure? procedure)  (ewal (procedure-body procedure)

解释器最终可以再次评估复合过程。我不知道为什么，但我认为我的是正确的。但SICP不会错的。我的第二个问题是如何使

驱动循环

正确输出eval值

解释器也包含在a中，因为它太长了

#lang planet neil/sicp

;; plot:
;; 1. env operation
;; 2. eval function
;; 3. test and eval for each special form and combination eval
;; 4. REPL
;; 5: test

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; environment
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define the-empty-environment '())


(define (first-frame env) (car env))
(define (enclosing-environment env)(cdr env))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; env operation
;;;;;;;;;;;;;;;;;;;;;;;;;;

(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 args supplied" vars vals)
          (error "Too few args 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))))


;;;;;;;;;;;;;;;;;;;;;;;;;;
;; frame operation
;;;;;;;;;;;;;;;;;;;;;;;;;;
(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))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; eval
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ewal exp env)
  (cond ((self-evaluating? exp)      exp)
        ((variable? exp)             (lookup-variable-value exp env))
        ((quoted? exp)               (text-of-quotation exp))
        ((assignment? exp)           (eval-assignment exp env))
        ((definition? exp)           (eval-definition exp env))
        ((if? exp)                   (eval-if exp env))
        ((lambda? exp)               (make-procedure (lambda-parameters exp)
                                                     (lambda-body exp)
                                                     env))
        ((begin? exp)                (eval-sequence (begin-actions exp) env))
        ((cond? exp)                 (ewal (cond->if exp) env))
        ((application? exp)          (epply (ewal (operator exp) env)
                                            (list-of-values (operands exp) env)))
        (else                        (error "Unknown type -- EWAL" exp))))



;;;;;;;;;;;;;;;;;;;;;;;;;;
;; self-eval test and eval
;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (self-evaluating? exp)
  (cond ((number? exp) #t)
        ((string? exp) #t)
        (else #f)))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; variable test an eval
;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (variable? exp) (symbol? exp))
;; (lookup-variable-value exp env) see below

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; quote test and eval
;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (quoted? exp)
  (tagged-list? exp 'quote))

(define (text-of-quotation exp) (cadr exp))

(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      #f))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; assignment test and eval
;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (assignment? exp)
  (tagged-list? exp 'set!))

(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))

(define (eval-assignment exp env)
  (set-variable-value! (assignment-variable exp)
                       (ewal (assignment-value exp) env)
                       env)
  'ok) 

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; definition test and eval
;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)    ;;formal parameters
                   (cddr exp))))  ;;body

(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))

(define (eval-definition exp env)
  (define-variable! (definition-variable exp)
                    (ewal (definition-value exp) env)
                    env)
  'ok)

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; lambda test and eval
;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (lambda? exp) (tagged-list? exp 'lambda))

(define (lambda-parameters exp) (cadr exp))

(define (lambda-body exp) (caddr exp))

(define (make-procedure parameters body env)
  (list 'procedure parameters body env))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; if test and eval
;;;;;;;;;;;;;;;;;;;;;;;;;;

(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? (cadddr exp)))
      (cadddr exp)
      'false))

(define (eval-if exp env)
  (if (true? (ewal (if-predicate exp) env))
      (ewal (if-consequent exp) env)
      (ewal (if-alternative exp) env)))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; begin test and eval
;;;;;;;;;;;;;;;;;;;;;;;;;;

(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 (eval-sequence exps env)
  (cond ((last-exp? exps) (ewal (first-exp exps) env))
        (else (ewal (first-exp exps) env)
              (eval-sequence (rest-exps exps) env))))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; application test and eval
;;;;;;;;;;;;;;;;;;;;;;;;;;


(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 (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (cons (ewal (first-operand exps) env)
            (list-of-values (rest-operands exps) env))))

(define (epply procedure arguments)
  (cond ((primitive-procedure? procedure) (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)  (ewal (procedure-body procedure)        ;; (*)
                                                         (extend-environment (procedure-parameters procedure)
                                                                             arguments
                                                                             (procedure-environment procedure))))
        (else                             (error "Unkown procedure type -- EPPLY" procedure))))


(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))

(define (primitive-implementation proc) (cadr proc))


(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 (apply-primitive-procedure proc args)
  (apply-in-underlying-scheme (primitive-implementation proc) args))

(define apply-in-underlying-scheme apply)

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; cond test and eval
;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (cond? exp) (tagged-list? exp 'cond))

(define (cond-clauses exp) (cdr exp))

(define (cond-else-clause? clause)
  (eq? (cond-predicate clause) 'else))

(define (cond-predicate clause) (car clause))

(define (cond-actions clause) (cdr clause))

(define (cond->if exp)
  (expand-clauses (cond-clauses exp)))

(define (expand-clauses clauses)
  (if (null? clauses)
    'false
    (let ((first (car clauses))
          (rest (cdr clauses)))
      (if (cond-else-clause? first)
        (if (null? rest)
          (sequence->exp (cond-actions first))
          (error "ELSE clause isn't last -- COND->IF" clauses))
        (make-if (cond-predicate first)
                 (sequence->exp(cond-actions first))
                 (expand-clauses rest))))))

(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

(define (sequence->exp seq)
  (cond ((null? seq) seq)
        ((last-exp? seq) (first-exp seq))
        (else (make-begin seq))))

(define (make-begin seq) (cons 'begin seq))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; env setup
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (setup-environment)
  (let ((initial-env
         (extend-environment (primitive-procedure-names)
                             (primitive-procedure-objects)
                             the-empty-environment)))
    (define-variable! '#t #t initial-env)
    (define-variable! '#f #f initial-env)
    initial-env))

(define primitive-procedures
  (list(list 'car car)
       (list 'cdr cdr)
       (list 'null? null?)
       (list 'cons cons)
       (list '+ +)
       (list '- -)
       (list '* *)
       (list '/ /)
       (list '= =)))

(define (true? x)
  (not (eq? x false)))

(define (false? x)
  (eq? x false))

(define (primitive-procedure-names)
  (map car primitive-procedures))

(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))


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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; REPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define input-prompt "M-Eval input:")
(define output-prompt "M-Eval value:")

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (let ((output (ewal input the-global-environment)))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))

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

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

(define (user-print object)
  (if (compound-procedure? object)
    (display (list 'compound-procedure
                   (procedure-parameters object)
                   (procedure-body object)
                   '<procedure-env>))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; test
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define env0 the-global-environment)

(ewal '(define (p1 x) (+ x 1)) env0 )  
(ewal '(p1 4) env0)
(ewal '(define (append x y)
         (if (null? x)
             y
             (cons (car x)
                   (append (cdr x) y)))) env0)
(ewal '(define (factorial n)
         (if (= 1 n)
             1
             (* n (factorial (- n 1))))) env0)

(ewal '(factorial 5) env0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; init main loop
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;(driver-loop)
;; this is commented since I found it run incorrectly

这是一个应用程序，操作员可以通过eval进行评估

(ewal (operator '((lambda (n)
          (if (= 1 n)
              1
              0))
        5)) env0)

运算符的值是一个列表（闭包），如下所示：

(procedure (n) (if (= 1 n) 1 0) #new-env)

如果我的过程主体是闭包的

caddr

，则主体将是

（如果（=1N）10）

但是，如果我将

过程主体

更改为

（cddr p）

，

过程主体

将变为：

（（if（=1n）10）#new env）

这意味着

#新env

将成为我的过程主体的一部分。无论如何，这并不是不正确的，因为过程主体不应该包括闭包的环境

---

但实际上，这个解释器无法处理其主体由表达式列表组成的函数。在本例中，我不知道如何从闭包中提取主体（exp list）

关于

评估序列

，您的

程序体

函数不正确。它应该是

cddr

，而不是

caddr

，以符合

评估序列的期望

关于
驱动循环
，它使用
用户打印
显示输出，但
用户打印
不完整。它只显示复合过程的值，而不显示其他任何值
 关于
评估序列
，您的
程序体
函数不正确。它应该是
cddr
，而不是
caddr
，以符合
评估序列的期望

关于
驱动循环
，它使用
用户打印
显示输出，但
用户打印
不完整。它只显示复合过程的值，而不显示其他任何值
 在我的解释器中，案例
lambda
无法计算其主体由表达式列表组成的函数，因为
lambda主体
被定义为
（caddr exp）
。我应该修改它：

(define (lambda-body exp) (cddr exp))

在我的
epply
函数中，条件
复合过程应该求值过程体的序列，因为现在过程体是一个表达式列表，而不是一个表达式。
在我的解释器中，case
lambda
不能求值一个函数体由一个表达式列表组成，因为
lambda body
被定义为
（caddr exp）
。我应该修改它：

(define (lambda-body exp) (cddr exp))

在我的
epply
函数中，条件
composite procedure
应该计算过程体的序列，因为现在过程体是一个表达式列表，而不是一个表达式。
是否尝试计算一个函数体由一个表达式列表组成？例如：
”（定义（p1x）（+x1）（+x2））
？在这种情况下，结果正确吗？
eval sequence
是否正在处理
begin
表单？使用
评估序列时给出的错误是什么？（“代码未能正确评估复合过程”对我来说不是很清楚。）@renzo对我不准确的描述表示抱歉<代码>评估序列
在
开始
表单上运行良好。但是对于您的表达式，我的实现只将
（+x1）
作为过程体，
（+x2）
已被丢弃。如何解决这个问题？威尔·内斯的答案解决了你所有的问题吗？
cddr
至少应该解决
eval序列的问题
。也许
lambda body
是错误的，应该是
cddr
而不是
caddr
。然后对闭包执行
caddr
将计算为表达式列表。@Renzo现在我的问题解决了！当计算lambda
cddr
时，我应该使用
cddr
获取lambda表达式的主体！非常感谢。您是否尝试求值其主体由表达式列表组成的函数？例如：
”（定义（p1x）（+x1）（+x2））
？在这种情况下，结果正确吗？
eval sequence
是否正在处理
begin
表单？使用
评估序列时给出的错误是什么？（“代码未能正确评估复合过程”对我来说不是很清楚。）@renzo对我不准确的描述表示抱歉<代码>评估序列
在
开始
表单上运行良好。但是对于您的表达式，我的实现只将
（+x1）
作为过程体，
（+x2）
已被丢弃。如何解决这个问题？威尔·内斯的答案解决了你所有的问题吗？
cddr
至少应该解决
eval序列的问题
。也许
lambda body
是错误的，应该是
cdd