Scheme的入口函数与求值规则[#51]
program. Scheme 解释器的 run 入口[mce-entry]
Defines: (run)
Assembled in Scheme 解释器的装配计划, Scheme解释器入口模块
Outputs: metacircular.scm, lp-example/mce/entry.scm
Requires: evaluate-sequence, initial-environment
(define (run expressions)
;; 每次用户程序运行都有自己的初始环境。
(evaluate-sequence expressions (initial-environment)))Scheme解释器的run调用initial-environment与evaluate-sequence。evaluate区分特殊形式与普通调用：特殊形式决定求值范围，普通调用求出操作符和从左到右的参数值，交给apply-value。入口依赖由Requires显示，阅读链接不会提供这些binding。
program. Scheme 求值器 evaluate 与特殊形式[mce-eval]
Defines: (syntax-check evaluate-sequence evaluate-arguments evaluate valid-bindings? expand-let expand-let-star evaluate-cond evaluate-and evaluate-or every-symbol? unique-symbols?)
Assembled in Scheme 解释器的装配计划, Scheme求值与闭包应用模块
Outputs: metacircular.scm, lp-example/mce/engine.scm
Requires: lookup, define-value!, apply-value
(define (syntax-check condition expression)
(unless condition (throw 'mce-syntax expression)))
(define (evaluate-sequence expressions environment)
(syntax-check (and (list? expressions) (pair? expressions)) expressions)
(let loop ((remaining expressions))
(let ((value (evaluate (car remaining) environment)))
(if (null? (cdr remaining)) value (loop (cdr remaining))))))
(define (evaluate-arguments expressions environment)
(if (null? expressions) '()
;; 不依赖宿主的参数求值顺序。
(let ((value (evaluate (car expressions) environment)))
(cons value (evaluate-arguments (cdr expressions) environment)))))
(define (evaluate expression environment)
(cond
((or (number? expression) (boolean? expression) (string? expression)) expression)
((symbol? expression) (lookup expression environment))
((not (and (list? expression) (pair? expression)))
(throw 'mce-syntax expression))
(else
(let ((head (car expression)) (arguments (cdr expression)))
(cond
((eq? head 'quote)
(syntax-check (= (length arguments) 1) expression)
(car arguments))
((eq? head 'if)
(syntax-check (= (length arguments) 3) expression)
(evaluate (if (eq? (evaluate (car arguments) environment) #f)
(caddr arguments) (cadr arguments)) environment))
((eq? head 'lambda)
(syntax-check (and (>= (length arguments) 2)
(list? (car arguments))
(every-symbol? (car arguments))
(unique-symbols? (car arguments))) expression)
(vector 'closure (car arguments) (cdr arguments) environment))
((eq? head 'begin) (evaluate-sequence arguments environment))
((eq? head 'let) (evaluate (expand-let arguments) environment))
((eq? head 'let*)
(syntax-check (and (>= (length arguments) 2)
(valid-bindings? (car arguments))) expression)
(evaluate (expand-let-star (car arguments) (cdr arguments)) environment))
((eq? head 'cond) (evaluate-cond arguments environment))
((eq? head 'and) (evaluate-and arguments environment))
((eq? head 'or) (evaluate-or arguments environment))
((or (eq? head 'unless) (eq? head 'when))
(syntax-check (>= (length arguments) 2) expression)
(let ((truth (not (eq? (evaluate (car arguments) environment) #f))))
(if (eq? truth (eq? head 'when))
(evaluate-sequence (cdr arguments) environment) #f)))
((eq? head 'define)
(syntax-check (>= (length arguments) 2) expression)
(let ((target (car arguments)))
(cond
((symbol? target)
(syntax-check (= (length arguments) 2) expression)
(define-value! target (evaluate (cadr arguments) environment) environment)
target)
((and (pair? target) (symbol? (car target)))
(define-value! (car target)
(evaluate (cons 'lambda (cons (cdr target) (cdr arguments))) environment)
environment)
(car target))
(else (throw 'mce-syntax expression)))))
(else
(let ((procedure (evaluate head environment)))
(apply-value procedure (evaluate-arguments arguments environment)))))))))
(define (valid-bindings? bindings)
(and (list? bindings)
(let loop ((remaining bindings))
(or (null? remaining)
(and (list? (car remaining)) (= (length (car remaining)) 2)
(symbol? (caar remaining)) (loop (cdr remaining)))))))
(define (expand-let arguments)
(syntax-check (>= (length arguments) 2) arguments)
(let* ((named? (symbol? (car arguments)))
(bindings (if named? (cadr arguments) (car arguments)))
(body (if named? (cddr arguments) (cdr arguments))))
(syntax-check (and (valid-bindings? bindings) (pair? body)
(unique-symbols? (map car bindings))) arguments)
(let ((names (map car bindings)) (values (map cadr bindings)))
(if named?
(cons (list 'lambda names
(list 'define (car arguments) (cons 'lambda (cons names body)))
(cons (car arguments) names)) values)
(cons (cons 'lambda (cons names body)) values)))))
(define (expand-let-star bindings body)
(if (null? bindings) (cons 'begin body)
(list 'let (list (car bindings)) (expand-let-star (cdr bindings) body))))
(define (evaluate-cond clauses environment)
(if (null? clauses) #f
(let ((clause (car clauses)))
(syntax-check (and (list? clause) (pair? clause)) clause)
(if (eq? (car clause) 'else)
(begin
(syntax-check (and (null? (cdr clauses)) (pair? (cdr clause))) clause)
(evaluate-sequence (cdr clause) environment))
(let ((value (evaluate (car clause) environment)))
(if (eq? value #f) (evaluate-cond (cdr clauses) environment)
(if (null? (cdr clause)) value
(evaluate-sequence (cdr clause) environment))))))))
(define (evaluate-and expressions environment)
(if (null? expressions) #t
(let ((value (evaluate (car expressions) environment)))
(if (or (eq? value #f) (null? (cdr expressions))) value
(evaluate-and (cdr expressions) environment)))))
(define (evaluate-or expressions environment)
(if (null? expressions) #f
(let ((value (evaluate (car expressions) environment)))
(if (eq? value #f) (evaluate-or (cdr expressions) environment) value))))
(define (every-symbol? xs)
(or (null? xs) (and (symbol? (car xs)) (every-symbol? (cdr xs)))))
(define (unique-symbols? xs)
(or (null? xs) (and (not (memq (car xs) (cdr xs))) (unique-symbols? (cdr xs)))))if只求值一个分支，只有 #f为假；quote保留数据。lambda创建闭包。这个子集的define是教学约定，不实现完整Scheme的内部定义标准。