├── eval ├── keywords.scm ├── quote-eval.scm ├── variable-eval.scm ├── begin-eval.scm ├── and-eval.scm ├── types.scm ├── or-eval.scm ├── definition-eval.scm ├── if-eval.scm ├── assignment-eval.scm ├── let*-eval.scm ├── lambda-eval.scm ├── let-eval.scm ├── analyze.scm ├── core.scm ├── delay-force-eval.scm ├── proc-transform.scm ├── procedure.scm ├── letrec-eval.scm ├── cond-eval.scm ├── environment.scm └── application-eval.scm ├── .gitignore ├── syntax ├── begin.scm ├── assignment.scm ├── application.scm ├── lambda.scm ├── thunk.scm ├── definition.scm ├── if.scm ├── letrec.scm └── let.scm ├── LICENSE ├── test.scm ├── README.md ├── lib └── table.scm └── interp.scm /eval/keywords.scm: -------------------------------------------------------------------------------- 1 | (define undefined-keyword '**undefined**) 2 | 3 | (define variable-keyword '**variable**) 4 | 5 | (define application-keyword '**application**) 6 | 7 | (define eval-proc-key 'eval) 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.class 2 | 3 | # Mobile Tools for Java (J2ME) 4 | .mtj.tmp/ 5 | 6 | # Package Files # 7 | *.jar 8 | *.war 9 | *.ear 10 | 11 | # virtual machine crash logs, see http://www.java.com/en/download/help/error_hotspot.xml 12 | hs_err_pid* 13 | 14 | *~ 15 | -------------------------------------------------------------------------------- /syntax/begin.scm: -------------------------------------------------------------------------------- 1 | (define (make-begin) 2 | 3 | ;构造begin 4 | ;seq是一个列表 5 | (define (construct seq) 6 | (cons 'begin seq)) 7 | 8 | ;操作序列 9 | (define (actions exp) 10 | (cdr exp)) 11 | 12 | (define (dispatch m) 13 | (cond ((eq? 'construct m) construct) 14 | ((eq? 'actions m) actions) 15 | (else (error "Unknown operator" m)))) 16 | dispatch) 17 | 18 | -------------------------------------------------------------------------------- /eval/quote-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | 4 | ;对引号的处理 5 | (define (install-quote-eval) 6 | ;符号内容 7 | (define (text-of-quotation exp) 8 | (cadr exp)) 9 | 10 | (define (eval exp env) 11 | (text-of-quotation exp)) 12 | 13 | (define (observe exp) 14 | (let ((val (text-of-quotation exp))) 15 | (lambda (env) val))) 16 | 17 | (put eval eval-proc-key 'quote) 18 | (put observe observe-proc-key 'quote) 19 | '(quote eval installed)) 20 | -------------------------------------------------------------------------------- /syntax/assignment.scm: -------------------------------------------------------------------------------- 1 | (define (make-assignment) 2 | ;取出变量名 3 | (define (variable exp) 4 | (cadr exp)) 5 | 6 | ;值的表达式 7 | (define (value exp) 8 | (caddr exp)) 9 | 10 | ;新的赋值语句 11 | (define (construct var value) 12 | (list 'set! var value)) 13 | 14 | (define (dispatch m) 15 | (cond ((eq? m 'variable) variable) 16 | ((eq? m 'value) value) 17 | ((eq? m 'construct) construct) 18 | (else (error "Unknown operator" m)))) 19 | 20 | dispatch) -------------------------------------------------------------------------------- /syntax/application.scm: -------------------------------------------------------------------------------- 1 | ;需要注意，operator与operands需要用cons连接，而不是list 2 | (define (make-application) 3 | 4 | ;表达式操作部分 5 | (define (operator exp) 6 | (car exp)) 7 | 8 | ;操作数 9 | (define (operands exp) 10 | (cdr exp)) 11 | 12 | ;构建函数调用 13 | ;params是一个列表 14 | (define (construct proc params) 15 | (cons proc params)) 16 | 17 | (define (dispatch m) 18 | (cond ((eq? 'operator m) operator) 19 | ((eq? 'operands m) operands) 20 | ((eq? 'construct m) construct) 21 | (else (error "Unknown operator" m)))) 22 | dispatch) 23 | 24 | -------------------------------------------------------------------------------- /syntax/lambda.scm: -------------------------------------------------------------------------------- 1 | (define (make-lambda) 2 | 3 | ;构造lambda 4 | ;parameters是一个列表 5 | ;body是一个列表 6 | (define (construct parameters body) 7 | (cons 'lambda (cons parameters body))) 8 | 9 | ;lambda 参数列表 10 | (define (parameters exp) 11 | (cadr exp)) 12 | 13 | ;lambda过程体 14 | (define (body exp) 15 | (cddr exp)) 16 | 17 | (define (dispatch m) 18 | (cond ((eq? m 'parameters) parameters) 19 | ((eq? m 'body) body) 20 | ((eq? m 'construct) construct) 21 | (else (error "Unknown operator" m)))) 22 | 23 | dispatch) 24 | -------------------------------------------------------------------------------- /eval/variable-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "eval/environment.scm") 4 | 5 | (define (install-variable-eval) 6 | 7 | (define lookup-variable-value ((make-environment) 8 | 'lookup)) 9 | 10 | (define (eval exp env) 11 | (lookup-variable-value exp env)) 12 | 13 | (define (observe exp) 14 | (lambda (env) 15 | (lookup-variable-value exp env))) 16 | 17 | (put eval eval-proc-key variable-keyword) 18 | (put observe observe-proc-key variable-keyword) 19 | '(variable eval installed)) 20 | -------------------------------------------------------------------------------- /syntax/thunk.scm: -------------------------------------------------------------------------------- 1 | (define (make-thunk) 2 | 3 | (define (construct body env) 4 | (list 'thunk body env)) 5 | 6 | (define (body thunk) 7 | (cadr thunk)) 8 | 9 | (define (env thunk) 10 | (caddr thunk)) 11 | 12 | (define (thunk? arg) 13 | (and (list? arg) 14 | (eq? 'thunk (car arg)))) 15 | 16 | (define (dispatch m) 17 | (cond ((eq? m 'env) env) 18 | ((eq? m 'body) body) 19 | ((eq? m 'construct) construct) 20 | ((eq? m 'thunk?) thunk?) 21 | (else (error "Unknown operator" m)))) 22 | 23 | dispatch) 24 | -------------------------------------------------------------------------------- /eval/begin-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "syntax/begin.scm") 4 | 5 | ;对begind的处理 6 | (define (install-begin-eval) 7 | 8 | (let ((begin-dispatch (make-begin))) 9 | 10 | (define actions (begin-dispatch 'actions)) 11 | 12 | (define (eval exp env) 13 | (interp-sequence (actions exp) 14 | env)) 15 | 16 | (define (observe exp) 17 | (analyze-sequence (actions exp))) 18 | 19 | (put eval eval-proc-key 'begin) 20 | (put observe observe-proc-key 'begin) 21 | '(begin eval installed))) 22 | 23 | 24 | -------------------------------------------------------------------------------- /syntax/definition.scm: -------------------------------------------------------------------------------- 1 | (load "syntax/lambda.scm") 2 | 3 | (define (make-define) 4 | 5 | (define new-lambda ((make-lambda) 'construct)) 6 | 7 | ;变量名 8 | (define (variable exp) 9 | (if (symbol? (cadr exp)) 10 | (cadr exp) 11 | (caadr exp))) 12 | ;值 13 | (define (value exp) 14 | (if (symbol? (cadr exp)) 15 | (caddr exp) 16 | (new-lambda (cdadr exp) 17 | (cddr exp)))) 18 | ;构造器 19 | (define (construct var param) 20 | (list 'define var param)) 21 | 22 | ;是否为定义语句 23 | (define (define? exp) 24 | (and (pair? exp) 25 | (eq? 'define (car exp)))) 26 | 27 | (define (dispatch m) 28 | (cond ((eq? m 'variable) variable) 29 | ((eq? m 'value) value) 30 | ((eq? m 'construct) construct) 31 | ((eq? m 'define?) define?) 32 | (else (error "Unknown operator" m)))) 33 | 34 | dispatch) 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /eval/and-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "syntax/if.scm") 4 | 5 | ;对and的处理 6 | (define (install-and-eval) 7 | 8 | (define new-if ((make-if) 'construct)) 9 | 10 | ;and语句序列 11 | (define (and-clauses exp) 12 | (cdr exp)) 13 | 14 | ;and转成if 15 | (define (and->if exp) 16 | (expand-clauses (and-clauses exp))) 17 | 18 | ;展开and语句序列 19 | (define (expand-clauses clauses) 20 | (if (null? clauses) 21 | 'true 22 | (let ((first (car clauses)) 23 | (rest (cdr clauses))) 24 | (new-if first 25 | (expand-clauses rest) 26 | 'false)))) 27 | 28 | (define (eval exp env) 29 | (interp (and->if exp) env)) 30 | 31 | (define (observe exp) 32 | (analyze (and->if exp))) 33 | 34 | (put eval eval-proc-key 'and) 35 | (put eval eval-proc-key '&&) 36 | (put observe observe-proc-key 'and) 37 | (put observe observe-proc-key '&&) 38 | '(and eval installed)) 39 | 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /syntax/if.scm: -------------------------------------------------------------------------------- 1 | (define (make-if) 2 | 3 | ;if 谓词 4 | (define (predicate exp) 5 | (cadr exp)) 6 | 7 | ;if 推论 8 | (define (consequent exp) 9 | (caddr exp)) 10 | 11 | ;if 替代(可或缺) 12 | (define (alternative exp) 13 | (if (not (null? (cdddr exp))) 14 | (cadddr exp) 15 | 'false)) ;若缺少，则返回'false，注意'false带引号，此处只是在操作文本。 16 | 17 | (define (true? x) 18 | (not (false? x))) 19 | 20 | (define (false? x) 21 | ;除非是字面量类型，否则解释器得到的结果应该是解释器语言中的值。 22 | ;这需要解释器提供一些基本变量或过程。 23 | (eq? x false)) 24 | 25 | ;构造if 26 | ;三个参数都必须是单独一条语句 27 | (define (construct predicate consequent alternative) 28 | (list 'if predicate consequent alternative)) 29 | 30 | (define (dispatch m) 31 | (cond ((eq? m 'predicate) predicate) 32 | ((eq? m 'consequent) consequent) 33 | ((eq? m 'alternative) alternative) 34 | ((eq? m 'true?) true?) 35 | ((eq? m 'construct) construct) 36 | (else (error "Unknown operator" m)))) 37 | 38 | dispatch) 39 | -------------------------------------------------------------------------------- /eval/types.scm: -------------------------------------------------------------------------------- 1 | (load "lib/table.scm") 2 | 3 | (define operation-table 4 | (make-table)) 5 | 6 | (define get (operation-table 'lookup-proc)) 7 | 8 | (define put (operation-table 'insert-proc!)) 9 | 10 | 11 | ;;;为数据实体增加类型标签 12 | ;type-tag 类型符号 13 | ;contents 数据实体 14 | (define (attach-tag type-tag contents) 15 | (cons type-tag contents)) 16 | 17 | ;;;取出类型标签 18 | (define (type-tag z) 19 | (if (pair? z) 20 | (car z) 21 | (error "Bad tagged datum -- TYPE-TAG" z))) 22 | 23 | ;;;取出数据实体 24 | (define (contents z) 25 | (if (pair? z) 26 | (cdr z) 27 | (error "Bad tagged datum -- CONTENTS" z))) 28 | 29 | 30 | ;;;对函数进行应用，应用规则是根据参数类型自动分派 31 | ; op 函数名 32 | ; args 参数列表 33 | (define (apply-generic op . args) 34 | (let ((type-tags (map type-tag args))) ;;;参数类型的列表 35 | (let ((proc (get op type-tags))) ;;;通过函数名与类型列表取到函数体 36 | (if proc 37 | (apply proc (map contents args)) 38 | (error "No method for these types -- APPLY-GENERIC" 39 | (list op type-tags)))))) 40 | 41 | 42 | -------------------------------------------------------------------------------- /eval/or-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "syntax/if.scm") 4 | 5 | 6 | ;对or的处理 7 | (define (install-or-eval) 8 | 9 | (define new-if ((make-if) 'construct)) 10 | 11 | ;and语句序列 12 | (define (or-clauses exp) 13 | (cdr exp)) 14 | 15 | ;or转成if 16 | (define (or->if exp) 17 | (let ((value (expand-clauses (or-clauses exp)))) 18 | (display value) 19 | value)) 20 | 21 | ;展开or语句序列 22 | (define (expand-clauses clauses) 23 | (if (null? clauses) 24 | 'false 25 | (let ((first (car clauses)) 26 | (rest (cdr clauses))) 27 | (new-if first 28 | 'true 29 | (expand-clauses rest))))) 30 | 31 | (define (eval exp env) 32 | (interp (or->if exp) env)) 33 | 34 | (define (observe exp) 35 | (analyze (or->if exp))) 36 | 37 | (put eval eval-proc-key 'or) 38 | (put eval eval-proc-key '||) 39 | (put observe observe-proc-key 'or) 40 | (put observe observe-proc-key '||) 41 | '(or eval installed)) 42 | -------------------------------------------------------------------------------- /eval/definition-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "eval/environment.scm") 4 | (load "syntax/definition.scm") 5 | 6 | 7 | ;对定义的处理 8 | (define (install-definition-eval) 9 | 10 | (let ((define-dispatch (make-define)) 11 | (env-dispatch (make-environment))) 12 | 13 | (define variable 14 | (define-dispatch 'variable)) 15 | 16 | (define value 17 | (define-dispatch 'value)) 18 | 19 | (define define-variable! (env-dispatch 'def)) 20 | 21 | (define (eval exp env) 22 | (define-variable! (variable exp) 23 | (interp (value exp) env) 24 | env) 25 | 'ok) 26 | 27 | (define (observe exp) 28 | (let ((var (variable exp)) 29 | (proc (analyze (value exp)))) 30 | (lambda (env) 31 | (define-variable! var (proc env) env) 32 | 'ok))) 33 | 34 | (put eval eval-proc-key 'define) 35 | (put observe observe-proc-key 'define) 36 | '(define eval installed))) 37 | 38 | 39 | -------------------------------------------------------------------------------- /eval/if-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "syntax/if.scm") 4 | 5 | ;对判断语句的处理 6 | (define (install-if-eval) 7 | 8 | (let ((if-dispatch (make-if))) 9 | 10 | (define true? (if-dispatch 'true?)) 11 | 12 | (define predicate (if-dispatch 'predicate)) 13 | 14 | (define consequent (if-dispatch 'consequent)) 15 | 16 | (define alternative (if-dispatch 'alternative)) 17 | 18 | (define (eval exp env) 19 | (if (true? (interp (predicate exp) env)) 20 | (interp (consequent exp) env) 21 | (interp (alternative exp) env))) 22 | 23 | (define (observe exp) 24 | (let ((pproc (analyze (predicate exp))) 25 | (cproc (analyze (consequent exp))) 26 | (aproc (analyze (alternative exp)))) 27 | (lambda (env) 28 | (if (true? (pproc env)) 29 | (cproc env) 30 | (aproc env))))) 31 | 32 | (put eval eval-proc-key 'if) 33 | (put observe observe-proc-key 'if) 34 | '(if eval installed))) 35 | -------------------------------------------------------------------------------- /eval/assignment-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "eval/environment.scm") 4 | (load "syntax/assignment.scm") 5 | 6 | 7 | ;对赋值的处理办法 8 | (define (install-assignment-eval) 9 | 10 | (let ((assign-dispatch (make-assignment))) 11 | 12 | (define set-variable-value! ((make-environment) 'set)) 13 | 14 | (define variable (assign-dispatch 'variable)) 15 | 16 | (define value (assign-dispatch 'value)) 17 | 18 | (define (eval exp env) 19 | (set-variable-value! (variable exp) 20 | (interp (value exp) env) 21 | env) 22 | 'ok) 23 | 24 | (define (observe exp) 25 | (let ((var (variable exp)) 26 | (proc (analyze (value exp)))) 27 | (lambda (env) 28 | (set-variable-value! var 29 | (proc env) 30 | env) 31 | 'ok))) 32 | 33 | (put eval eval-proc-key 'set!) 34 | (put observe observe-proc-key 'set!) 35 | '(assignment eval installed))) 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /eval/let*-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "syntax/let.scm") 4 | 5 | ;对let*处理 6 | (define (install-let*-eval) 7 | 8 | 9 | (define (binds exp) 10 | (cadr exp)) 11 | 12 | (define (body exp) 13 | (cddr exp)) 14 | 15 | (define (new-binds k-v) 16 | (list k-v)) 17 | 18 | (define (new-body seq) 19 | (list seq)) 20 | 21 | (define new-let ((make-let) 'construct)) 22 | 23 | ;转成嵌套的let 24 | (define (let*->lets binds body) 25 | (define (iter binds) 26 | (if (null? binds) 27 | body 28 | (new-body (new-let (new-binds (car binds)) 29 | (iter (cdr binds)))))) 30 | (car (iter binds))) 31 | 32 | (define (eval exp env) 33 | (let ((new-exp (let*->lets (binds exp) 34 | (body exp)))) 35 | (interp new-exp env))) 36 | 37 | (define (observe exp) 38 | (let ((new-exp (let*->lets (binds exp) 39 | (body exp)))) 40 | (analyze new-exp))) 41 | 42 | (put eval eval-proc-key 'let*) 43 | (put observe observe-proc-key 'let*) 44 | '(let* eval installed)) 45 | -------------------------------------------------------------------------------- /eval/lambda-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "eval/procedure.scm") 4 | (load "eval/proc-transform.scm") 5 | (load "syntax/lambda.scm") 6 | 7 | (define (install-lambda-eval) 8 | 9 | (let ((lambda-dispatch (make-lambda)) 10 | (procedure-dispatch (make-procedure)) 11 | (trans-dispatch (make-proc-transform))) 12 | 13 | 14 | (define parameters (lambda-dispatch 'parameters)) 15 | 16 | (define (body exp) 17 | ((trans-dispatch 'trans-body) ((lambda-dispatch 'body) exp))) 18 | 19 | (define new-procedure (procedure-dispatch 'construct)) 20 | 21 | (define (eval exp env) 22 | (new-procedure (parameters exp) 23 | (body exp) 24 | env)) 25 | 26 | (define (observe exp) 27 | (let ((vars (parameters exp)) 28 | (proc (analyze-sequence (body exp)))) 29 | (lambda (env) 30 | (new-procedure vars proc env)))) 31 | 32 | (put eval eval-proc-key 'lambda) 33 | ;(put eval eval-proc-key 'λ) 34 | (put observe observe-proc-key 'lambda) 35 | ;(put observe observe-proc-key 'λ) 36 | '(lambda eval installed))) 37 | -------------------------------------------------------------------------------- /syntax/letrec.scm: -------------------------------------------------------------------------------- 1 | (define (make-letrec) 2 | 3 | ;let构造器 4 | ;body是一个列表 5 | ;binds是一个列表 6 | (define (construct binds body) 7 | (cons 'letrec (cons binds body))) 8 | 9 | ;letrec 绑定表 10 | (define (binds exp) 11 | (cadr exp)) 12 | 13 | ;letrec 体 14 | (define (body exp) 15 | (cddr exp)) 16 | 17 | ;创建一条绑定 18 | (define (bind key value) 19 | (list key value)) 20 | 21 | ;绑定的key 22 | (define (variable kv) 23 | (car kv)) 24 | 25 | ;绑定的value 26 | (define (value kv) 27 | (cadr kv)) 28 | 29 | (define (parameters binds) 30 | (if (null? binds) 31 | binds 32 | (cons (caar binds) 33 | (parameters (cdr binds))))) 34 | 35 | (define (values binds) 36 | (if (null? binds) 37 | binds 38 | (cons (cadar binds) 39 | (values (cdr binds))))) 40 | 41 | (define (dispatch m) 42 | (cond ((eq? m 'construct) construct) 43 | ((eq? m 'binds) binds) 44 | ((eq? m 'body) body) 45 | ((eq? m 'parameters) parameters) 46 | ((eq? m 'values) values) 47 | ((eq? m 'bind) bind) 48 | ((eq? m 'variable) variable) 49 | ((eq? m 'value) value) 50 | (else (error "Unknown operator" m)))) 51 | 52 | dispatch) 53 | -------------------------------------------------------------------------------- /eval/let-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "syntax/lambda.scm") 4 | (load "syntax/application.scm") 5 | (load "syntax/let.scm") 6 | 7 | ;对let处理 8 | (define (install-let-eval) 9 | 10 | (define new-lambda ((make-lambda) 'construct)) 11 | 12 | (define new-application ((make-application) 'construct)) 13 | 14 | (let ((let-dispatch (make-let))) 15 | 16 | (define body (let-dispatch 'body)) 17 | 18 | (define binds (let-dispatch 'binds)) 19 | 20 | (define parameters (let-dispatch 'parameters)) 21 | 22 | (define values (let-dispatch 'values)) 23 | 24 | 25 | (define (eval exp env) 26 | (let ((binding (binds exp))) 27 | (let ((new-exp (new-application (new-lambda (parameters binding) 28 | (body exp)) 29 | (values binding)) 30 | )) 31 | (interp new-exp env)))) 32 | 33 | (define (observe exp) 34 | (let ((binding (binds exp))) 35 | (let ((new-exp (new-application (new-lambda (parameters binding) 36 | (body exp)) 37 | (values binding)) 38 | )) 39 | (analyze new-exp)))) 40 | 41 | (put eval eval-proc-key 'let) 42 | (put observe observe-proc-key 'let) 43 | '(let eval installed))) 44 | 45 | -------------------------------------------------------------------------------- /eval/analyze.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | 3 | (define observe-proc-key "analyze") 4 | 5 | (define (analyze exp) 6 | (cond ((self-evaluating? exp) (lambda (env) exp)) ; 字面量 7 | (else (analyze-generic (wrap exp))))) 8 | 9 | ;动态转发解释过程 10 | (define (analyze-generic tagged-exp) 11 | (let ((type (type-tag tagged-exp)) 12 | (exp (contents tagged-exp))) 13 | (let ((proc (get observe-proc-key type))) 14 | (if proc 15 | (proc exp) 16 | (if (or (eq? type variable-keyword) 17 | (eq? type application-keyword)) 18 | (error "Unknown expression type -- INTERP" exp) 19 | (cond ((variable? exp) 20 | (analyze-generic (attach-tag variable-keyword exp))) 21 | ((application? exp) 22 | (analyze-generic (attach-tag application-keyword exp))) 23 | (else (error "Unknown expression type -- INTERP" exp)))))))) 24 | 25 | ;处理表达式序列 26 | (define (analyze-sequence exps) 27 | ;连通两个函数的调用 28 | (define (sequentially proc1 proc2) 29 | (lambda (env) (proc1 env) (proc2 env))) 30 | (define (loop first-proc rest-procs) 31 | (if (null? rest-procs) 32 | first-proc 33 | (loop (sequentially first-proc (car rest-procs)) 34 | (cdr rest-procs)))) 35 | (let ((procs (map analyze exps))) 36 | (if (null? procs) 37 | (error "Empty sequence -- ANALYZE") 38 | 'false) 39 | (loop (car procs) (cdr procs)))) 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | -------------------------------------------------------------------------------- /eval/core.scm: -------------------------------------------------------------------------------- 1 | (load "eval/types.scm") 2 | (load "eval/keywords.scm") 3 | 4 | (define (interp exp env) 5 | (cond ((self-evaluating? exp) exp) ; 字面量 6 | (else (interp-generic (wrap exp) env)))) 7 | 8 | ;封装语法类型 9 | (define (wrap exp) 10 | (if (pair? exp) 11 | (attach-tag (car exp) exp) 12 | (attach-tag exp exp))) 13 | 14 | ;动态转发解释过程 15 | (define (interp-generic tagged-exp env) 16 | (let ((type (type-tag tagged-exp)) 17 | (exp (contents tagged-exp))) 18 | (let ((proc (get eval-proc-key type))) 19 | (if proc 20 | (proc exp env) 21 | (if (or (eq? type variable-keyword) 22 | (eq? type application-keyword)) 23 | (error "Unknown expression type -- INTERP" exp) 24 | (cond ((variable? exp) 25 | (interp-generic (attach-tag variable-keyword exp) env)) 26 | ((application? exp) 27 | (interp-generic (attach-tag application-keyword exp) env)) 28 | (else (error "Unknown expression type -- INTERP" exp)))))))) 29 | 30 | ;处理表达式序列 31 | (define (interp-sequence exps env) 32 | (cond ((last-exp? exps) (interp (first-exp exps) env)) 33 | (else (interp (first-exp exps) env) 34 | (interp-sequence (rest-exps exps) env)))) 35 | 36 | ;是否字面量？ 37 | (define (self-evaluating? exp) 38 | (cond ((number? exp) true) 39 | ((string? exp) true) 40 | (else false))) 41 | 42 | ;是否变量？ 43 | (define (variable? exp) 44 | (symbol? exp)) 45 | 46 | ;是否过程应用？ 47 | (define (application? exp) 48 | (pair? exp)) 49 | 50 | ;是否最后一个？ 51 | (define (last-exp? seq) 52 | (null? (cdr seq))) 53 | 54 | ;取序列第一个 55 | (define (first-exp seq) 56 | (car seq)) 57 | 58 | ;剩余的序列 59 | (define (rest-exps seq) 60 | (cdr seq)) 61 | -------------------------------------------------------------------------------- /test.scm: -------------------------------------------------------------------------------- 1 | #lang scheme 2 | 3 | (define a 1) 4 | 5 | (define (test) 6 | 7 | (define b a) 8 | 9 | (define a 3) 10 | 11 | a) 12 | 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | (define (new-builder) 16 | (let* ([ls '()]) 17 | 18 | (define assembly (λ (x y) 19 | (cond [(null? x) y] 20 | [else (if true 21 | (cons (car x) 22 | (assembly (cdr x) 23 | y)) 24 | false)]))) 25 | 26 | (define (append x) 27 | (set! ls (assembly ls x))) 28 | 29 | (define (to-list) 30 | ls) 31 | 32 | (define (dispatch m) 33 | (cond [(eq? m 'to-list) (to-list)] 34 | [(eq? m 'append) append])) 35 | dispatch)) 36 | 37 | (define builder (new-builder)) 38 | 39 | ((builder 'append) '(a b c)) 40 | 41 | ((builder 'append) '(d e f)) 42 | 43 | (builder 'to-list) 44 | 45 | 46 | 47 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | 49 | 50 | ;letrec模拟 51 | (define (simulate-letrec) 52 | (let ([a '*] 53 | [b '*]) 54 | (set! a b) 55 | (set! b 1) 56 | a)) 57 | 58 | ;隔离定义作用域模拟 59 | (define (simulate-scope) 60 | (let ([a '*] 61 | [b '*]) 62 | (let ([x 1] 63 | [y a]) 64 | (set! a x) 65 | (set! b y) 66 | b))) 67 | 68 | 69 | (define (test-letrec) 70 | (define b 2) 71 | (letrec ([a b] 72 | [b 1]) 73 | a)) 74 | 75 | 76 | (letrec ((b 2)) 77 | (letrec ((a b) (b 1)) 78 | a)) 79 | 80 | 81 | (let ((b '**undefined**)) 82 | (set! b 2) 83 | (letrec ((a b) (b 1)) a)) 84 | 85 | 86 | (let ((a '**undefined**) (b '**undefined**)) 87 | (set! a b) 88 | (set! b 1) 89 | a) -------------------------------------------------------------------------------- /eval/delay-force-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "syntax/thunk.scm") 4 | 5 | (define (install-delay&force-eval) 6 | 7 | (let ((thunk-dispatch (make-thunk))) 8 | 9 | (define new-thunk (thunk-dispatch 'construct)) 10 | (define thunk? (thunk-dispatch 'thunk?)) 11 | (define thunk-body (thunk-dispatch 'body)) 12 | (define thunk-env (thunk-dispatch 'env)) 13 | 14 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | 16 | (define (delay-body exp) 17 | (cadr exp)) 18 | 19 | (define (delay-eval exp env) 20 | (new-thunk (delay-body exp) env)) 21 | 22 | (define (delay-observe exp) 23 | (let ((proc (analyze (delay-body exp)))) 24 | (lambda (env) 25 | (new-thunk proc env)))) ;闭包一个经过静态分析的过程，而非表达式 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | (define (force-body exp) 30 | (cadr exp)) 31 | 32 | (define (force-eval exp env) 33 | (let ((thunk (interp (force-body exp) env))) 34 | (if (thunk? thunk) 35 | (interp (thunk-body thunk) (thunk-env thunk)) 36 | (error "Only can force delayed thunk -- FORCE-EVAL" 37 | thunk)))) 38 | 39 | (define (force-observe exp) 40 | (let ((proc (analyze (force-body exp)))) 41 | (lambda (env) 42 | (let ((thunk (proc env))) 43 | (if (thunk? thunk) 44 | ((thunk-body thunk) env) 45 | (error "Only can force delayed thunk -- FORCE-OBSERVE" 46 | thunk)))))) 47 | 48 | 49 | (put delay-eval eval-proc-key 'delay) 50 | (put delay-observe observe-proc-key 'delay) 51 | (put force-eval eval-proc-key 'force) 52 | (put force-observe observe-proc-key 'force) 53 | '(delay&force eval installed))) 54 | 55 | -------------------------------------------------------------------------------- /syntax/let.scm: -------------------------------------------------------------------------------- 1 | (load "syntax/definition.scm") 2 | (load "syntax/application.scm") 3 | (load "syntax/lambda.scm") 4 | 5 | (define (make-let) 6 | 7 | (define new-define ((make-define) 'construct)) 8 | 9 | (define new-application ((make-application) 'construct)) 10 | 11 | (define new-lambda ((make-lambda) 'construct)) 12 | 13 | ;let构造器 14 | ;body是一个列表 15 | ;binds是一个列表 16 | (define (construct binds body) 17 | (cons 'let (cons binds body))) 18 | 19 | (define (binds exp) 20 | (if (named-let? exp) 21 | (caddr exp) 22 | (cadr exp))) 23 | 24 | (define (bind var value) 25 | (list var value)) 26 | 27 | (define (body exp) 28 | (if (named-let? exp) 29 | (new-body exp) 30 | (cddr exp))) 31 | 32 | ;命名let 33 | (define (named-let? exp) 34 | (not (pair? (cadr exp)))) 35 | 36 | (define (parameters binds) 37 | (if (null? binds) 38 | binds 39 | (cons (caar binds) 40 | (parameters (cdr binds))))) 41 | 42 | (define (values binds) 43 | (if (null? binds) 44 | binds 45 | (cons (cadar binds) 46 | (values (cdr binds))))) 47 | 48 | ;对body进行改变，转成内部定义，以及一次初始化调用 49 | (define (new-body exp) 50 | (let ((name (cadr exp)) 51 | (params (parameters (binds exp)))) 52 | (list (new-define name 53 | (new-lambda params 54 | (cdddr exp))) 55 | (new-application name params)))) 56 | 57 | 58 | (define (dispatch m) 59 | (cond ((eq? m 'construct) construct) 60 | ((eq? m 'binds) binds) 61 | ((eq? m 'body) body) 62 | ((eq? m 'parameters) parameters) 63 | ((eq? m 'values) values) 64 | ((eq? m 'bind) bind) 65 | (else (error "Unknown operator" m)))) 66 | 67 | dispatch) 68 | 69 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # scheme-bootstrap 2 | 3 | 这是一个自举的scheme解释器 4 | 5 | 启动文件为： `interp.scm` 6 | 7 | 建议使用 [scheme](http://www.gnu.org/software/mit-scheme/) 或 [racket](http://racket-lang.org/) 运行此程序 8 | 9 | 10 | # 程序入口 11 | 12 | 首先，打开`interpl.scm`文件的**REPL** 13 | 14 | 15 | 有两个程序入口可供使用，两个入口功能完全相同，但是其实现机理却完全不同。 16 | 17 | 18 | **第一个** 19 | 20 | 21 | 输入 `(repl)`，此时控制台将进入等待输入状态。 22 | 23 | 该入口提供“边解释边执行”的运算过程，对每个子表达式都会重复使用完全相同的流程。 24 | 25 | **第二个** 26 | 27 | 输入 `(repl-analyze)`，此时控制台将进入等待输入状态。 28 | 29 | 该入口提供“先解释后执行”的运算过程，对每次输入的表达式，都会先进行完全的静态分析，将表达式“编译”为解释器可以直接运行的过程，然后再执行编译后的过程。 30 | 31 | 理论上，第二个入口消除了大量的重复解释以及过程检索，效率应该更高。 32 | 33 | # 示例 34 | 35 | 在控制台输入scheme代码，例如： 36 | 37 | ```scheme 38 | (define (new-builder) 39 | (let ((ls '())) 40 | 41 | (define assembly (lambda (x y) 42 | (cond ((null? x) y) 43 | (else (if true 44 | (cons (car x) 45 | (assembly (cdr x) 46 | y)) 47 | false))))) 48 | 49 | (define (append x) 50 | (set! ls (assembly ls x))) 51 | 52 | (define (to-list) 53 | ls) 54 | 55 | (define (dispatch m) 56 | (cond ((eq? m 'to-list) (to-list)) 57 | ((eq? m 'append) append))) 58 | dispatch)) 59 | ``` 60 | 61 | 此时该函数将注册到环境中，然后再试用此函数。 62 | 63 | ```scheme 64 | (define builder (new-builder)) 65 | 66 | ((builder 'append) '(a b c)) 67 | 68 | ((builder 'append) '(d e f)) 69 | 70 | (builder 'to-list) 71 | ``` 72 | 73 | # 惰性求值 74 | 75 | `delay` 用于使表达式延迟求值 76 | 77 | ```scheme 78 | (define (f x) 79 | (delay (set! x (cons x '(2)))) 80 | x) 81 | ``` 82 | 83 | `(f 1)` 返回值为 `1` 84 | 85 | `force` 用于对延迟的表达式强制求值 86 | 87 | ```scheme 88 | (define (f x) 89 | (force (delay (set! x (cons x '(2))))) 90 | x) 91 | ``` 92 | `(f 1)` 返回值为 `'(1 2)` 93 | 94 | 95 | #Enjoy It! 96 | -------------------------------------------------------------------------------- /eval/proc-transform.scm: -------------------------------------------------------------------------------- 1 | (load "syntax/definition.scm") 2 | (load "syntax/letrec.scm") 3 | 4 | (define (make-proc-transform) 5 | 6 | (let ((define-dispatch (make-define)) 7 | (letrec-dispatch (make-letrec))) 8 | 9 | (define new-letrec (letrec-dispatch 'construct)) 10 | 11 | (define define? (define-dispatch 'define?)) 12 | 13 | (define variable (define-dispatch 'variable)) 14 | 15 | (define value (define-dispatch 'value)) 16 | 17 | (define bind (letrec-dispatch 'bind)) 18 | 19 | ;扫描出所有的内部定义语句 20 | (define (scan-out-defines seqs) 21 | (if (null? seqs) 22 | seqs 23 | (let ((seq (car seqs))) 24 | (if (define? seq) 25 | (cons seq 26 | (scan-out-defines (cdr seqs))) 27 | (scan-out-defines (cdr seqs)))))) 28 | 29 | ;扫描出所有不是内部定义的语句 30 | (define (scan-except-defines seqs) 31 | (if (null? seqs) 32 | seqs 33 | (let ((seq (car seqs))) 34 | (if (define? seq) 35 | (scan-except-defines (cdr seqs)) 36 | (cons seq 37 | (scan-except-defines (cdr seqs))))))) 38 | 39 | ;创建新的键值绑定表 40 | (define (new-binds seqs) 41 | (if (null? seqs) 42 | seqs 43 | (cons (bind (variable (car seqs)) 44 | (value (car seqs))) 45 | (new-binds (cdr seqs))))) 46 | 47 | (define (trans-body body-origin) 48 | (let* ((defs (scan-out-defines body-origin)) ;所有定义语句 49 | (undefs (scan-except-defines body-origin))) ;所有非定义语句 50 | (if (null? defs) 51 | undefs 52 | (let ((letrec-exp (new-letrec (new-binds defs) ;转换成letrec语句 53 | undefs))) 54 | (list letrec-exp))))) 55 | 56 | (define (dispatch m) 57 | (cond ((eq? m 'trans-body) trans-body) 58 | (else (error "Unknown operator" m)))) 59 | 60 | dispatch)) 61 | -------------------------------------------------------------------------------- /eval/procedure.scm: -------------------------------------------------------------------------------- 1 | (define (make-procedure) 2 | ;判断exp是否以tag开头 3 | (define (tagged-list? exp tag) 4 | (if (pair? exp) 5 | (eq? (car exp) tag) 6 | false)) 7 | 8 | ;创建过程 9 | ;parameters是一个列表 10 | ;body是一个列表 11 | ;env是一个环境 12 | (define (construct parameters body env) 13 | (list 'procedure parameters body env)) 14 | 15 | ;是否为普通过程 16 | (define (compound? p) 17 | (tagged-list? p 'procedure)) 18 | 19 | ;过程参数列表 20 | (define (parameters p) 21 | (cadr p)) 22 | 23 | ;过程体 24 | (define (body p) 25 | (caddr p)) 26 | 27 | 28 | ;过程环境 29 | (define (environment p) 30 | (cadddr p)) 31 | 32 | ;是否为基本过程 33 | (define (primitive? proc) 34 | (tagged-list? proc 'primitive)) 35 | 36 | ;基本过程的实现 37 | (define (primitive-implementation proc) 38 | (cadr proc)) 39 | 40 | ;基本过程列表 41 | (define primitive-procedures 42 | (list (list 'car car) 43 | (list 'cdr cdr) 44 | (list 'cons cons) 45 | (list 'null? null?) 46 | (list 'eq? eq?) 47 | (list '+ +) 48 | (list '- -) 49 | (list '* *) 50 | (list '/ /) 51 | (list '= =))) 52 | 53 | ;基本过程名列表 54 | (define (primitive-names) 55 | (map car 56 | primitive-procedures)) 57 | 58 | ;基本过程对象列表 59 | (define (primitive-objects) 60 | (map (lambda (proc) 61 | (list 'primitive (cadr proc))) 62 | primitive-procedures)) 63 | 64 | ;这些基本过程需要由解释器执行 65 | (define (apply-primitive proc args) 66 | (let ((p (primitive-implementation proc))) 67 | (apply p args))) 68 | 69 | (define (dispatch m) 70 | (cond ((eq? m 'construct) construct) 71 | ((eq? m 'compound?) compound?) 72 | ((eq? m 'parameters) parameters) 73 | ((eq? m 'body) body) 74 | ((eq? m 'environment) environment) 75 | ((eq? m 'primitive?) primitive?) 76 | ((eq? m 'apply-primitive) apply-primitive) 77 | ((eq? m 'primitive-names) (primitive-names)) 78 | ((eq? m 'primitive-objects) (primitive-objects)) 79 | (else (error "Unknown operator" m)))) 80 | dispatch) 81 | 82 | -------------------------------------------------------------------------------- /eval/letrec-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "eval/keywords.scm") 4 | (load "syntax/let.scm") 5 | (load "syntax/assignment.scm") 6 | (load "syntax/letrec.scm") 7 | 8 | 9 | ;提供同时定义语义的关键字 10 | (define (install-letrec-eval) 11 | 12 | (let ((let-dispatch (make-let)) 13 | (assign-dispatch (make-assignment)) 14 | (letrec-dispatch (make-letrec))) 15 | 16 | (define new-let (let-dispatch 'construct)) 17 | 18 | (define new-assignment (assign-dispatch 'construct)) 19 | 20 | (define binds (letrec-dispatch 'binds)) 21 | 22 | (define body (letrec-dispatch 'body)) 23 | 24 | (define bind (letrec-dispatch 'bind)) 25 | 26 | (define variable (letrec-dispatch 'variable)) 27 | 28 | (define value (letrec-dispatch 'value)) 29 | 30 | ;创建新的键值绑定表 31 | ;seq 旧的键值绑定表 32 | (define (new-binds seqs) 33 | (if (null? seqs) 34 | seqs 35 | (cons (bind (variable (car seqs)) 36 | (list 'quote undefined-keyword)) ;此处用符号，而不用字面量 37 | (new-binds (cdr seqs))))) ;若使用字面量，解释器将认为这是一个变量 38 | ;实现错误提示时将无法获知其真正绑定的变量名 39 | 40 | ;创建新的键值设置表 41 | ;seqs 旧的键值绑定表 42 | (define (new-sets seqs) 43 | (if (null? seqs) 44 | seqs 45 | (cons (new-assignment (variable (car seqs)) 46 | (value (car seqs))) 47 | (new-sets (cdr seqs))))) 48 | 49 | ;过程体解释 50 | (define (eval exp env) 51 | (let ((bd (binds exp))) 52 | (let ((let-exp (new-let (new-binds bd) 53 | (append (new-sets bd) 54 | (body exp))))) 55 | (interp let-exp env)))) 56 | 57 | 58 | (define (observe exp) 59 | (let ((bd (binds exp))) 60 | (let ((let-exp (new-let (new-binds bd) 61 | (append (new-sets bd) 62 | (body exp))))) 63 | (analyze let-exp)))) 64 | 65 | 66 | (put eval eval-proc-key 'letrec) 67 | (put observe observe-proc-key 'letrec) 68 | '(letrec eval installed))) 69 | -------------------------------------------------------------------------------- /eval/cond-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "syntax/if.scm") 4 | (load "syntax/begin.scm") 5 | (load "syntax/application.scm") 6 | 7 | ;对cond的处理 8 | (define (install-cond-eval) 9 | 10 | ;cond语句序列 11 | (define (cond-clauses exp) 12 | (cdr exp)) 13 | 14 | ;是否为else子句？ 15 | (define (cond-else-clause? clause) 16 | (eq? (cond-predicate clause) 'else)) 17 | 18 | ;是否为指向型cond? 19 | (define (cond-point-clause? clause) 20 | (eq? (cadr clause) '=>)) 21 | 22 | ;子句的谓词 23 | (define (cond-predicate clause) 24 | (car clause)) 25 | 26 | ;子句的推论 27 | (define (cond-actions clause) 28 | (if (cond-point-clause? clause) 29 | (cddr clause) 30 | (cdr clause))) 31 | 32 | ;cond转成if 33 | (define (cond->if exp) 34 | (expand-clauses (cond-clauses exp))) 35 | 36 | (define new-if ((make-if) 'construct)) 37 | (define new-begin ((make-begin) 'construct)) 38 | (define new-application ((make-application) 'construct)) 39 | 40 | ;展开cond语句序列 41 | (define (expand-clauses clauses) 42 | (if (null? clauses) 43 | 'false 44 | (let ((first (car clauses)) 45 | (rest (cdr clauses))) 46 | (if (cond-else-clause? first) 47 | (if (null? rest) 48 | (sequence->exp (cond-actions first)) 49 | (error "ELSE clause is not last -- COND->IF" 50 | clauses)) 51 | (new-if (cond-predicate first) 52 | (resolve-clause first) 53 | (expand-clauses rest)))))) 54 | 55 | (define (resolve-clause clause) 56 | (if (cond-point-clause? clause) 57 | ;如果是一个指向型的cond子句，则将action的结果应用到predicate。 58 | (new-application (sequence->exp (cond-actions clause)) (cond-predicate clause)) 59 | (sequence->exp (cond-actions clause)))) 60 | 61 | ;序列转表达式 62 | (define (sequence->exp seq) 63 | (cond ((null? seq) seq) 64 | ((last-exp? seq) (first-exp seq)) 65 | (else (new-begin seq)))) ;if的每个分支都是一个语句，而不是语句序列 66 | 67 | (define (eval exp env) 68 | (interp (cond->if exp) env)) 69 | 70 | (define (observe exp) 71 | (analyze (cond->if exp))) 72 | 73 | (put eval eval-proc-key 'cond) 74 | (put observe observe-proc-key 'cond) 75 | '(cond eval installed)) 76 | -------------------------------------------------------------------------------- /lib/table.scm: -------------------------------------------------------------------------------- 1 | (define (make-table) 2 | ;创建一个初始表，注意这是一个list 3 | ;初始列表的car无关，这个序对作为table的入口， 4 | ;如果没有这个序对，那么每次添加的新序对都会成为list头， 5 | ;那么已绑定的指针将指向list后面的序对 6 | (let ((local-table (list '*table*))) 7 | 8 | ;查找 9 | (define (lookup table cur . rem) 10 | (let ((record (assoc cur (cdr table)))) 11 | (if record 12 | (if (null? rem) 13 | (cdr record) 14 | (if (null? (cdr record)) 15 | #f 16 | ;如果记录体中的car不是序对，表示record不是一个子表也不是一条记录,而是单纯的数据。 17 | (if (pair? (cadr record)) 18 | (apply lookup record rem) 19 | #f))) 20 | #f))) 21 | 22 | ;插入 23 | (define (insert! table value cur . rem) 24 | (let ((record (assoc cur (cdr table)))) 25 | (cond (record 26 | (cond ((null? rem) 27 | (set-cdr! record value) 28 | table) 29 | (else 30 | ;;;如果有记录，且不是列表，表示值需要覆盖为列表 31 | (if (not (list? record)) 32 | (set-cdr! record '()) 33 | #f) 34 | (apply insert! record value rem) 35 | table))) 36 | (else 37 | (cond ((null? rem) 38 | (join table (cons cur value)) 39 | table) 40 | (else 41 | (join table (apply insert! 42 | (make-subtable cur) 43 | value 44 | rem)) 45 | table)))))) 46 | 47 | ;合并记录 48 | (define (join table record) 49 | (set-cdr! table 50 | (cons record 51 | (cdr table)))) 52 | 53 | ;创建子表 54 | (define (make-subtable name) 55 | (list name)) 56 | 57 | ;查找 58 | (define (lookup-proc cur . rem) 59 | (apply lookup local-table cur rem)) 60 | 61 | ;插入 62 | (define (insert-proc! value cur . rem) 63 | (apply insert! local-table value cur rem)) 64 | 65 | 66 | (define (dispatch m) 67 | (cond ((eq? m 'lookup-proc) lookup-proc) 68 | ((eq? m 'insert-proc!) insert-proc!) 69 | (else (error "Unknown opertion -- TABLE" 70 | m)))) 71 | 72 | dispatch)) -------------------------------------------------------------------------------- /interp.scm: -------------------------------------------------------------------------------- 1 | ;#lang scheme/load 2 | ;(require (planet neil/sicp)) 3 | 4 | (load "eval/core.scm") 5 | (load "eval/analyze.scm") 6 | (load "eval/variable-eval.scm") 7 | (load "eval/quote-eval.scm") 8 | (load "eval/assignment-eval.scm") 9 | (load "eval/definition-eval.scm") 10 | (load "eval/lambda-eval.scm") 11 | (load "eval/if-eval.scm") 12 | (load "eval/begin-eval.scm") 13 | (load "eval/cond-eval.scm") 14 | (load "eval/let-eval.scm") 15 | (load "eval/let*-eval.scm") 16 | (load "eval/and-eval.scm") 17 | (load "eval/or-eval.scm") 18 | (load "eval/letrec-eval.scm") 19 | (load "eval/application-eval.scm") 20 | (load "eval/environment.scm") 21 | (load "eval/procedure.scm") 22 | (load "eval/delay-force-eval.scm") 23 | 24 | (install-delay&force-eval) 25 | (install-letrec-eval) 26 | (install-let*-eval) 27 | (install-and-eval) 28 | (install-or-eval) 29 | (install-assignment-eval) 30 | (install-quote-eval) 31 | (install-begin-eval) 32 | (install-let-eval) 33 | (install-cond-eval) 34 | (install-lambda-eval) 35 | (install-definition-eval) 36 | (install-if-eval) 37 | (install-application-eval) 38 | (install-variable-eval) 39 | 40 | 41 | 42 | (define env-dispatch (make-environment)) 43 | (define proc-dispatch (make-procedure)) 44 | 45 | (define (setup-environment) 46 | 47 | (define def-var (env-dispatch 'def)) 48 | 49 | (let ((initial-env ((env-dispatch 'extend) (proc-dispatch 'primitive-names) 50 | (proc-dispatch 'primitive-objects) 51 | the-empty-environment))) 52 | 53 | ;为一些基本值赋予含义 54 | (def-var 'true true initial-env) 55 | (def-var 'false false initial-env) 56 | initial-env)) 57 | 58 | ;全局环境 59 | (define the-global-environment (setup-environment)) 60 | 61 | (define (prompt-for-input) 62 | (newline) 63 | (newline) 64 | (display ";;; M-Eval input: ") 65 | (newline)) 66 | 67 | (define (announce-output) 68 | (newline) 69 | (display ";;; M-Eval value: ") 70 | (newline)) 71 | 72 | (define (result-print object) 73 | (if ((proc-dispatch 'compound?) object) 74 | (display (list 'compound-procedure 75 | ((proc-dispatch 'parameters) object) 76 | ((proc-dispatch 'body) object) 77 | ')) 78 | (display object))) 79 | 80 | 81 | 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 | 84 | ;;;主程序,边解释边执行 85 | (define (repl) 86 | (prompt-for-input) 87 | (let ((input (read))) 88 | (let ((output (interp input the-global-environment))) 89 | (announce-output) 90 | (result-print output))) 91 | (repl)) 92 | 93 | ;;;主程序，先解释后执行 94 | (define (repl-analyze) 95 | (prompt-for-input) 96 | (let ((input (read))) 97 | (let ((output ((analyze input) the-global-environment))) 98 | (announce-output) 99 | (result-print output))) 100 | (repl-analyze)) 101 | -------------------------------------------------------------------------------- /eval/environment.scm: -------------------------------------------------------------------------------- 1 | (load "eval/keywords.scm") 2 | 3 | (define (make-environment) 4 | 5 | ;已装入的框架 6 | (define (enclosing-environment env) 7 | (cdr env)) 8 | 9 | ;第一个框架 10 | (define (first-frame env) 11 | (car env)) 12 | 13 | ;创建一个框架 14 | (define (make-env-frame variables values) 15 | (cons variables values)) 16 | 17 | ;框架中的变量列表 18 | (define (frame-variables frame) 19 | (car frame)) 20 | 21 | ;框架中的值列表 22 | (define (frame-values frame) 23 | (cdr frame)) 24 | 25 | ;添加一个键值对到框架中 26 | (define (add-binding-to-frame! var val frame) 27 | (set-car! frame (cons var (car frame))) 28 | (set-cdr! frame (cons val (cdr frame)))) 29 | 30 | ;扩展环境 31 | ;即在已有的环境顶部增加一个frame 32 | ;frame中包含最新的参数值对 33 | (define (extend-environment vars vals base-env) 34 | (if (= (length vars) (length vals)) 35 | (cons (make-env-frame vars vals) base-env) 36 | (if (< (length vars) (length vals)) 37 | (error "Too many arguments supplied" 38 | vars vals) 39 | (error "Too few arguments suuuplied" 40 | vars vals)))) 41 | 42 | ;查找变量的值 43 | (define (lookup-variable-value var env) 44 | (define (env-loop env) 45 | (define (scan vars vals) 46 | (cond ((null? vars) 47 | (env-loop (enclosing-environment env))) 48 | ((eq? var (car vars)) 49 | (car vals)) 50 | (else (scan (cdr vars) (cdr vals))))) 51 | (if (eq? env the-empty-environment) 52 | (error "Unbound variable" var) 53 | (let ((frame (first-frame env))) 54 | (scan (frame-variables frame) 55 | (frame-values frame))))) 56 | (let ((value (env-loop env))) 57 | (if (eq? value undefined-keyword) 58 | (error var "undefined; cannot use before initialization!") 59 | value))) 60 | 61 | ;改变赋值，全环境搜索 62 | (define (set-variable-value! var val env) 63 | (define (env-loop env) 64 | (define (scan vars vals) 65 | (cond ((null? vars) 66 | (env-loop (enclosing-environment env))) 67 | ((eq? var (car vars)) 68 | (set-car! vals val)) 69 | (else (scan (cdr vars) (cdr vals))))) 70 | (if (eq? env the-empty-environment) 71 | (error "Unbound variable" var) 72 | (let ((frame (first-frame env))) 73 | (scan (frame-variables frame) 74 | (frame-values frame))))) 75 | (env-loop env)) 76 | 77 | ;定义变量，只在当前frame搜索 78 | (define (define-variable! var val env) 79 | (let ((frame (first-frame env))) 80 | (define (scan vars vals) 81 | (cond ((null? vars) 82 | (add-binding-to-frame! var val frame)) 83 | ((eq? var (car vars)) 84 | (set-car! vals val)) 85 | (else (scan (cdr vars) (cdr vals))))) 86 | (scan (frame-variables frame) 87 | (frame-values frame)))) 88 | 89 | (define (dispatch m) 90 | (cond ((eq? m 'def) define-variable!) 91 | ((eq? m 'set) set-variable-value!) 92 | ((eq? m 'lookup) lookup-variable-value) 93 | ((eq? m 'extend) extend-environment) 94 | (else (error "Unknown operator" m)))) 95 | dispatch) 96 | 97 | ;空环境 98 | (define the-empty-environment 99 | '()) 100 | -------------------------------------------------------------------------------- /eval/application-eval.scm: -------------------------------------------------------------------------------- 1 | (load "eval/core.scm") 2 | (load "eval/analyze.scm") 3 | (load "eval/procedure.scm") 4 | (load "eval/environment.scm") 5 | (load "syntax/application.scm") 6 | 7 | 8 | (define (install-application-eval) 9 | 10 | (let ((application-dispatch (make-application)) 11 | (procedure-dispatch (make-procedure)) 12 | (environment-dispatch (make-environment))) 13 | 14 | ;表达式操作部分 15 | (define operator (application-dispatch 'operator)) 16 | 17 | ;操作数 18 | (define operands (application-dispatch 'operands)) 19 | 20 | ;没有操作数? 21 | (define (no-operands? ops) 22 | (null? ops)) 23 | 24 | ;第一个操作数 25 | (define (first-operand ops) 26 | (car ops)) 27 | 28 | ;剩余的操作数 29 | (define (rest-operands ops) 30 | (cdr ops)) 31 | 32 | (define primitive-procedure? 33 | (procedure-dispatch 'primitive?)) 34 | 35 | (define apply-primitive-procedure 36 | (procedure-dispatch 'apply-primitive)) 37 | 38 | (define compound-procedure? 39 | (procedure-dispatch 'compound?)) 40 | 41 | (define procedure-parameters 42 | (procedure-dispatch 'parameters)) 43 | 44 | (define procedure-body 45 | (procedure-dispatch 'body)) 46 | 47 | (define procedure-environment 48 | (procedure-dispatch 'environment)) 49 | 50 | (define extend-environment 51 | (environment-dispatch 'extend)) 52 | 53 | ;求参数列表的值 54 | ;若参数列表总某个参数的值为null,则解释器会判断参数列表结束， 55 | ;因此，此处需要特殊处理，每个参数都用一个cons存放。 56 | (define (list-of-values exps env) 57 | (if (no-operands? exps) 58 | exps 59 | (cons (let ((value (interp (first-operand exps) env))) 60 | value) 61 | (list-of-values (rest-operands exps) env)))) 62 | 63 | 64 | (define (adhibition procedure arguments) 65 | (cond ((primitive-procedure? procedure) 66 | (apply-primitive-procedure procedure arguments)) 67 | ((compound-procedure? procedure) 68 | (interp-sequence (procedure-body procedure) 69 | (extend-environment (procedure-parameters procedure) 70 | arguments 71 | (procedure-environment procedure)))) 72 | (else (error "Unknown procedure -- ADHIBITION" 73 | procedure 74 | arguments)))) 75 | 76 | 77 | (define (eval exp env) 78 | (adhibition (interp (operator exp) env) 79 | (list-of-values (operands exp) env))) 80 | 81 | (define (execute procedure arguments) 82 | (cond ((primitive-procedure? procedure) 83 | (apply-primitive-procedure procedure arguments)) 84 | ((compound-procedure? procedure) 85 | ((procedure-body procedure) 86 | (extend-environment (procedure-parameters procedure) 87 | arguments 88 | (procedure-environment procedure)))) 89 | (else (error "Unknown procedure -- EXECUTE" 90 | procedure 91 | arguments)))) 92 | 93 | 94 | (define (observe exp) 95 | (let ((fproc (analyze (operator exp))) 96 | (aprocs (map analyze (operands exp)))) 97 | (lambda (env) 98 | (execute (fproc env) 99 | (map (lambda (aproc) 100 | (aproc env)) 101 | aprocs))))) 102 | 103 | 104 | (put eval eval-proc-key application-keyword) 105 | (put observe observe-proc-key application-keyword) 106 | '(application eval installed))) 107 | --------------------------------------------------------------------------------