sicp 元循环求值器 全部源码

拷贝到 DrRacket 里面， 语言选择：由源代码来确定语言（左下角选择） 直接点击运行即可。

---

#lang racket
(require sicp)


(define (eval 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)]                                          ; if表达式， 递规
        [(lambda? exp) (make-procedure (lambda-parameters exp)                 ; lambda，转换成一个可应用的过程
                                       (lambda-body exp)
                                       env)]
        [(begin? exp) (eval-sequence (begin-actions exp) env)]                 ; begin， 求值一系列表达式，按照出现的顺序
        [(cond? exp) (eval (cond->if exp) env)]                                ; cond 转换成 if 继续求值
        [(application? exp) (my_apply (eval (operator exp) env)                ; 组合式, 求值运算符部分、运算对象部分，再调用 my-apply将参数传递给过程
                                      (list-of-values (operands exp) env))]
        [else
         (error "Unknown expression type -- EVAL" exp)]))                      ; 符则返回错误

;; 定义新的 apply
(define (my_apply procedure arguments) ;; 两个参数：过程 过程参数
  (cond [(primitive-procedure? procedure)                                      ; 基本过程？直接调用
         (apply-primitive-procedure procedure arguments)]                      
        [(compound-procedure? procedure)                                       ; 复合过程
         (eval-sequence                                                        ; 按顺序求值
          (procedure-body procedure)                                           ;   过程体
          (extend-environment                                                  ;   扩展环境
           (procedure-parameters procedure)                                    ;     过程参数
           arguments                                                           ;     参数
           (procedure-environment procedure)))]
        [else
         (error "Unknown procedure type -- APPLY" procedure)]))


;; 生成实际参数列表 : 以组合式的运算对象数参数，求值各个运算对象，返回这些值的表
;; **** 这里可以使用 map 来求值，下面这样写，是为了表明，可以不用高阶过程来完成这件事儿 
(define (list-of-values exps env)
  (if (no-operands? exps)    ; 没有运算对象？返回空表
      '()
      (cons (eval (first-operand exps) env)   ; 求值第一个运算对象
            (list-of-values (rest-operands exps) env)))) ;; 递规则求值其它运算运对象


;; 条件  在给定环境中求值谓词部分，如果为真则求值推论部分，否则求值替代部分
(define (eval-if exp env)
  (if (true?
       (eval (if-predicate exp) env))   ;; 求值谓词部分
      (eval (if-consequent exp) env)    ;; 为真 求值推论部分
      (eval (if-alternative exp) env))) ;;     求值替代部分

;; 序列, 用于 my-apply 、begin 用于求值过程体里的表达式序列
(define (eval-sequence exps env)
  (cond [(last-exp? exps)
         (eval (first-exp exps) env)]
        [else (eval (first-exp exps) env)
              (eval-sequence (rest-exps exps) env)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 赋值和定义

;; 变量赋值
(define (eval-assignment exp env)
  (set-variable-value! (assignment-variable exp)               ; 找到变量
                       (eval (assignment-value exp) env)       ; 使用 eval找出需要赋的值，
                       env)
  'ok)

;; 变量定义
(define (eval-definition exp env)
  (define-variable! (definition-variable exp)                  ; 找到表达式中的 变量符号
    (eval (definition-value exp) env)                          ; 求值变量的值
    env)                                                       ; 
  'ok)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 4.1.2 表达式的表示


;; 自求值表达式式只有数字和字符串
(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))  ;; 如果第一个符号是 'quote

;; 引号表达式的 表达式部分   (text-of-quotation "(quote a)" ) => "a"
(define (text-of-quotation exp) (cadr exp))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 确定某个表的开始否是不是某个给定的符号
(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      false))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; 赋值 (set!  )
(define (assignment? exp)
  (tagged-list? exp 'set!))

;; 取得 变量
(define (assignment-variable exp) (cadr exp))

;; 取得 值
(define (assignment-value exp) (caddr exp))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|
定义的形式：
(define  )
或者
(define (  ... )
  )  =>
语法糖:
(define 
  (lambda ( ... )
    ))

|# 

;; 定义？
(define (definition? exp)
  (tagged-list? exp 'define))  ;; 以 define 开头

;; 取得 
(define (definition-variable exp)
  (if (symbol? (cadr exp))      ;; 取第二个符号
      (cadr exp)
      (caadr exp)))

;; 取得 
(define (definition-value exp)
  (if (symbol? (cadr exp)) ;; 如果列表的第二项是符号
      (caddr exp)          ;; 直接取第三项
      ;;; 否则是叻外一种形式的定义， (define  (  ... ) )
      ;;; 构造成 lambda 表达式 返回
      (make-lambda (cdadr exp)   ;; 参数 formal parameters  : ( ... )
                   (cddr exp)))) ;; body : () 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; lambda
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda paramenters body)
  (cons 'lambda (cons paramenters body)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 条件 if
(define (if? exp) (tagged-list? exp 'if))

;; 取得谓词部分
(define (if-predicate exp) (cadr exp))
;; 取得 then
(define (if-consequent exp) (caddr exp))
;; 取得 else
(define (if-alternative exp)
  (if (not (null? (cdddr exp)))
      (cadddr exp)
      'false))
;; 构造 if 表达式
(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; begin
(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))
;; 序列转换为 表达式，如果需要的话，就在在前面加上 begin
(define (sequence->exp seq)
  (cond [(null? seq) seq]       ;; 空的序列，直接返回
        [(last-exp? seq) (first-exp seq)] ;; 最后一个序列，则直接取第一个
        [else (make-begin seq)])) ;; 否则 构造 为 (begin  )
;; 构造 begin
(define (make-begin seq) (cons 'begin seq))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 过程： 不符合上述各种表达式类型的任意复合类型
;; car为 运算符, cdr为运算对象的表
;; 过程?
(define (application? exp) (pair? exp))
;; 取得运算符
(define (operator exp) (car exp)) ;; 之前这里之成 (cdr exp) 所以操作符号
;; 取得 运算对象 表
(define (operands exp) (cdr exp))
;; 没有运算对象？
(define (no-operands? ops) (null? ops))
;; 第一个运算对象
(define (first-operand ops) (car ops))
;; 第二...N个运算对象的表
(define (rest-operands ops) (cdr ops))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 派生表达式
;; cond 可以表示为 if的嵌套
#|
(cond [(> x 0) x]
      [(= x 0) (display 'zero) 0]
      [else (- x)])
=>
(if (> x 0)
    x
    (if (= x 0)
        (begin (display 'zero)
               0)
        (- x))
|#

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

;; 条件：动作 表
(define (cond-clauses exp) (cdr exp))

;; 取得 else 部分
(define (cond-else-clause? clause)
  (eq? (cond-predicate clause) 'else))

; 取得谓词部分
(define (cond-predicate clause) (car clause))

; 取得动作部分 表
(define (cond-actions clause) (cdr clause))

; cond->if 将 cond 归约为 if
(define (cond->if exp)
  (expand-clauses (cond-clauses exp)))

; 展开 条件：动作 表 为 if 的嵌套
(define (expand-clauses clauses)
  (if (null? clauses)
      'false                           ;; 空的，直接返回fasle
      (let ([first (car clauses)]      ;; 取得第一个
            (rest (cdr clauses)))      ;; 取得剩余的
        (if (cond-else-clause? first)  ;; 判是否是 else条件
            (if (null? rest)           ;; 如果 科余的为空
                (sequence->exp (cond-actions first)) ;; 转化为 表达式
                (error "ELSE clause isn't last -- COND->IF"
                       clauses))
            ;; 不是 else 子句部分 转化为 if 表达式
            (make-if (cond-predicate first)
                     (sequence->exp (cond-actions first))
                     (expand-clauses rest))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 4.1.3 求值器的数据结构

;; 谓词检测
(define (true? x)
  (not (eq? x false)))

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

;;;; 为了能处理基本过程，我们假定己经有了以下过程
;; (apply-primitive-procedure  ) : 将给定过程应用于 里的参数，并返回应用的结果
;; (primitive-procedure? ) : 检测 是否是一个过程

;;  复合过程由 形式参数， 过程体，环境 通过构造函数做出来
(define (make-procedure parameters body env)
  (list 'procedure parameters body env))

;; 是否以 procedure开头
(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))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 对环境的操作, 一个环境就是一个框架的序列, 每个框架都是一个约束的表格
;; 其中的约束关联起一些变量和与之对应的值
#|
1. 返回 在 里面的约束值，如果没有发出一个错误信号
(lookup-variable-value  ) : 
2. 返回一个新环境，这个环境里包含一个新现框架，其中的所有位于表里的符号约束到
   里对应的元素上, 其外围环境中 
(extend-environment   )
;; 定义变量
(define-variable!   )
;; 设置变量的值
(set-variable-value!   )

|#

;; 环境表示为 一个框架的表,一个环境的外围环境就是这个表的cdr
(define (enclosing-environment env) (cdr env))

;; 第一个环境
(define (first-frame env) (car env))

;; 空环境用 '() 表示
(define the-empty-environment '())


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 环境里的每个框架都是一对表形成的序对：一个是 这一框架中所有变量的表，还有就是约束值的表
#|
(car '(a b c)
     '(1 2 3))  => a=1, b=2, c=3
|#
;; 创建frame 由 表variables 和 表values cons
(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))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 基本过程
#|
基本过程对象的具体表示朝着不重要，只要 apply 能够识别它们，并通过过程primitive-procedure?
和 apply-primitive-procedure 去应用它们。
我们选择的方式是， 是将基本过程都表示为以符号primitive开头的表,在其中包含着Lisp系统里实现现这一基本过
程的那个过程
|#

;; 是否是基础过程？
(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))

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

;; setup-environment 将从一个表里取得基本过程的名字和相应的实现过程
(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
        ;;; 其他基本过程
        (list '+ +)
        (list '- -)
        (list '* *)
        (list '/ /)
        ))

;; 获取基本过程的名称表
(define (primitive-procedure-names)
  (map car
       primitive-procedures))

;; 获取基本过程的对象表
(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))

;; 为了应用一个基本过程， 只需要简单的利同基础Lisp系统，将相应的实现过程应用于实际参数
(define (apply-primitive-procedure proc args)
  ;(apply-in-underlying-scheme ;; 这里假设 (define apply-in-underlying-scheme apply)
  (apply
   (primitive-implementation proc) args))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 提供一个驱动循环, 模拟lisp 的repl

;; 输入提示符
(define input-prompt ";;; M-Eval input:")
;; 输出提示符
(define output-prompt ";;; M-Eval output:")

;; 驱动循环
(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ([input (read)])
    (let ([output (eval 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 'commpound-procedure
                     (procedure-parameters object)
                     (procedure-body object)
                     '))
      (display object)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 4.1.4 作为程序运行这个求值器
(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))

;; 全局的环境, 环境中包含 'true 'false
(define the-global-environment (setup-environment))


(driver-loop)