自己参照写的 SICP 4.1 元循环求值器

mylisp01.rkt
;---------------------------
(module mylisp01 racket
(displayln "mylisp01 module loaded!!")
(displayln "--------------------------")
(provide (all-defined-out))
(require compatibility/mlist)
;;;
;-------------------------
(define (my-eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((my-set-and-define? 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))
((application? exp) ;;复合表达式 e10
(my-apply (my-eval (operator exp) env)
(list-of-values (operands exp) env)
env))
(else
(error "Unknown expression type -- EVAL" exp))
))
;----------------------------
;;;----------environment start------------------
;;;用hash表实现，缺点过程是内部的，不知道怎么垃圾回收
;;;(frame1 frame2 ...)
;;;frame: hash-table
(define (init-environment) (box '()))
(define (env-box env) (box env))
(define (env-unbox env) (unbox env))
(define (env-set! old-env new-unbox-env)
(box-cas! old-env (unbox old-env) new-unbox-env))
(define (first-frame env) (car env))
(define (rest-environment env) (cdr env))
(define (extend-environment vars contents base-env)
(let ((base-unbox-env (env-unbox base-env))
(new-unbox-env (make-hash)))
(env-set! base-env (cons (make-frame vars contents new-unbox-env) base-unbox-env))
base-env))
(define (reduce-environment base-env)
(let ((base-unbox-env (env-unbox base-env)))
(env-set! base-env (cdr base-unbox-env))
base-env))
(define (make-frame vars contents new-unbox-env)
(cond ((not (pair? vars))
(hash-set! new-unbox-env vars contents)
new-unbox-env)
(else
(let ((vars-len (length vars))
(contents-len (length contents)))
(cond ((= vars-len contents-len)
(let loop ((vars vars) (contents contents))
(cond ((null? vars) new-unbox-env)
(else
(hash-set! new-unbox-env (car vars) (car contents))
(loop (cdr vars) (cdr contents))))))
(else
(error "vars-num != contents-num" vars contents)))))))
;;;((variable? exp) (lookup-variable-value exp env))
(define (lookup-variable-value exp env)
(let ((unbox-env (env-unbox env)))
(cond ((null? unbox-env) (error "env is null!" unbox-env))
(else
(let ((frame (first-frame unbox-env))
(rest-env (env-box (rest-environment unbox-env))))
(cond ((hash-ref frame exp #f) => (lambda (x) x))
(else
(lookup-variable-value exp rest-env))))))))
;;;------environment page end-------------------------
;;;tagged-list?
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))
;;;((self-evaluating? exp) exp)
(define (self-evaluating? exp)
(or (number? exp)
(string? exp)))
;;;((variable? exp) (lookup-variable-value exp env))
(define (variable? exp)
(symbol? exp))
;;;((quoted? exp) (text-of-quotation exp))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (make-quoted exp)
(cons 'quote exp))
;;;((my-set-and-define? exp) (eval-definition exp env))
(define (my-set-and-define? exp)
(or (tagged-list? exp 'set!) (tagged-list? exp 'define)))
;;;(define fun ...)
;;;(define fun (lambda arg ...))
;;;(define fun (lambda (args) ...))
;;;(define (fun args) ...)
(define (eval-definition exp env)
(let ((first-exp (cadr exp))
(rest-exp (cddr exp)))
(cond ((pair? first-exp)
(let ((fun-name (car first-exp))
(fun-args (cdr first-exp))
(body rest-exp))
(extend-environment fun-name
(make-procedure fun-args body env)
env)
(cons (list fun-name fun-args) "ok!-(fun args)")))
(else
(let ((fun-name first-exp))
(extend-environment fun-name
(my-eval (car rest-exp) env)
env)
(cons (list fun-name) "ok!-vars"))))))
;;;;接下页

;;;;接上页
;;;((if? exp) (eval-if exp env))
;;;(if (predicate) consequent alternative)
(define (if? exp)
(tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (null? (cdddr exp))
'false ;;;为空返回自定义结果
(cadddr exp)))
(define (eval-if exp env)
(if (my-eval (if-predicate exp) env)
(my-eval (if-consequent exp) env)
(my-eval (if-alternative exp) env)))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
#|
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
|#
;;;(lambda arg ...)
;;;(lambda (args) ...)
(define (lambda? exp)
(tagged-list? exp 'lambda))
(define (lambda-parameters exp)
(cadr exp))
(define (lambda-body exp)
(cddr exp))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
;;;((begin? exp) (eval-sequence (begin-actions exp) env))
;;;(begin ... ... ...)
(define (begin? exp)
(tagged-list? exp 'begin))
(define (begin-actions exp)
(cdr exp))
(define (eval-sequence contents env)
(cond ((null? contents) (error "begin null?" contents))
(else
(let loop ((contents contents))
(cond ((null? (cdr contents))
(my-eval (car contents) env))
(else
(my-eval (car contents) env)
(loop (cdr contents))))))))
(define (make-begin seq) (cons 'begin seq))
#|
((application? exp) ;;复合表达式 e10
(my-apply (my-eval (operator exp) env)
(list-of-values (operands exp) env)))
|#
;;;(fun others ...)
(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 (my-apply procedure arguments env)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
(let ((result (eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure)))))
(reduce-environment env)
result))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(define (primitive-procedure? procedure)
(procedure? procedure))
(define apply-primitive-procedure apply)
(define (compound-procedure? procedure)
(tagged-list? procedure 'procedure))
(define (procedure-parameters p)
(cadr p))
(define (procedure-body p)
(caddr p))
(define (procedure-environment p)
(cadddr p))
(define (list-of-values args env)
(map (lambda (x) (my-eval x env)) args))
;---------------------------------
(define my-base-environment (init-environment))
(define (make-environment env . args)
(let loop ((args args))
(cond ((<= (length args) 0) 'make-environment-ok!)
(else
(extend-environment (car args) (cadr args) env)
(loop (cddr args))))))
(make-environment my-base-environment
'#t #t
'#f #f
'cons cons
'car car
'cdr cdr
'+ +
'- -
'* *
'/ /
'null? null?
'eq? eq?
'equal? equal?)
; (begin
; (extend-environment '#t #t ns)
; (extend-environment '#f #f ns)
; (extend-environment 'cons cons ns)
; (extend-environment 'car car ns)
; (extend-environment 'cdr cdr ns)
; (extend-environment '+ + ns)
; (extend-environment '- - ns)
; (extend-environment '* * ns)
; (extend-environment '/ / ns)
; (extend-environment 'null? null? ns)
; 'init-environment-ok!)
;;;==============================
) ;;;module end
;;;;环境处理有比较严重的问题，待修改。

mylisp01test.rkt
;--------------------------------------
#lang racket
(require "mylisp01.rkt")
;---------------------
(define ns my-base-environment)
;--------
(my-eval "asb" ns)
(my-eval 'car ns)
(my-eval ''(123 asdfa32 a(f 0)()(\\##@#aasf)) ns)
(my-eval '(set! wo 121) ns)
(my-eval '(define ta 212) ns)
(my-eval 'wo ns)
(my-eval 'ta ns)
(my-eval '(if 1 'a 'b) ns)
;----
(my-eval '(define (square n) (* n n)) ns)
(my-eval '(lambda (n) (* n n)) ns)
(my-eval '(begin 'a 'b 123 "234" square) ns)
(my-eval '(square 10) ns)
(my-eval '(define (add n m) (+ n m)) ns)
(my-eval '(add 10 100) ns)
(my-eval '(add 20 30) ns)
(my-eval '(define (div n m) (/ n m)) ns)
(my-eval '(div 88 11) ns)
(my-eval '(define div2 (lambda (n m) (/ n m))) ns)
(my-eval '(div2 88 11) ns)
'----------------------
(my-eval '(define (append n m)
(if (null? n)
m
(cons (car n)
(append (cdr n) m))))
ns)
(my-eval '(append '(a b c) '(d e f)) ns)
ns
;;;作用域测试
(my-eval '((lambda (x y)
((lambda (x y)
(+ x y)) 100 1000)
(* x y)) 5 6) ns)
;;;！！！内部函数定义对环境操作有问题
(my-eval '(define (add2 n m)
(define (inc n)
(+ n 1))
(define (dec n)
(- n 1))
(if (equal? m 0)
n
(add2 (inc n) (dec m))))
ns)
(my-eval '(add2 15 19) ns)
ns

mylisp02.rkt
;------------------------
;;;解决词法作用域问题
;;;真正用到了hash表功能，去掉了不必要的box功能
;;;下一步mylisp03改进 数据导向方法改写 ，加入宏功能等
(module mylisp02 racket
(displayln "-----mylisp02 loaded.------")
(provide (all-defined-out))
(require compatibility/mlist)
;;;
;-------------------------
(define (my-eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((my-set-and-define? 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))
((application? exp) ;;复合表达式 e10
(my-apply (my-eval (operator exp) env)
(list-of-values (operands exp) env)
env))
(else
(error "Unknown expression type -- EVAL" exp))
))
;----------------------------
;;;----------environment start------------------
;;;(frame1 frame2 ...)
;;;frame: hash-table
(define (init-environment) (make-hash))
(define (first-frame env) (car env))
(define (rest-environment env) (cdr env))
(define (extend-environment vars contents base-env)
(cond ((pair? vars)
(for-each (lambda (x y) (hash-set! base-env x y)) vars contents)
base-env)
(else
(hash-set! base-env vars contents)
base-env)))
(define (make-fun-environment vars contents base-env)
(let ((new-env (init-environment)))
(cond ((pair? vars)
(hash-set! new-env vars contents))
(else
(for-each (lambda (x y) (hash-set! new-env x y)) vars contents)))
(hash-set! new-env '*base-env* base-env)
new-env))
;;;((variable? exp) (lookup-variable-value exp env))
(define (lookup-variable-value exp env)
(cond ((hash? env)
(cond ((hash-ref env exp #f)
=> (lambda (x) x))
(else
;(printf "*base-env* -- ~a\n" exp)
(lookup-variable-value exp (hash-ref env '*base-env*)))))
(else
(error "No this exp -- fun:lookup-variable-value" exp))))
;;;------environment page end-------------------------
;;;tagged-list?
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))
;;;((self-evaluating? exp) exp)
(define (self-evaluating? exp)
(or (number? exp)
(string? exp)))
;;;((variable? exp) (lookup-variable-value exp env))
(define (variable? exp)
(symbol? exp))
;;;((quoted? exp) (text-of-quotation exp))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (make-quoted exp)
(cons 'quote exp))
;;;((my-set-and-define? exp) (eval-definition exp env))
(define (my-set-and-define? exp)
(or (tagged-list? exp 'set!) (tagged-list? exp 'define)))
;;;(define fun ...)
;;;(define fun (lambda arg ...))
;;;(define fun (lambda (args) ...))
;;;(define (fun args) ...)
(define (eval-definition exp env)
(let ((first-exp (cadr exp))
(rest-exp (cddr exp)))
(cond ((pair? first-exp)
(let ((fun-name (car first-exp))
(fun-args (cdr first-exp))
(body rest-exp))
(extend-environment fun-name
(make-procedure fun-args body env)
env)
(cons (list fun-name fun-args) "ok!-(fun args)")))
(else
(let ((fun-name first-exp))
(extend-environment fun-name
(my-eval (car rest-exp) env)
env)
(cons (list fun-name) "ok!-vars"))))))
;;;((if? exp) (eval-if exp env))
;;;(if (predicate) consequent alternative)
(define (if? exp)
(tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (null? (cdddr exp))
'false ;;;为空返回自定义结果
(cadddr exp)))
(define (eval-if exp env)
(if (my-eval (if-predicate exp) env)
(my-eval (if-consequent exp) env)
(my-eval (if-alternative exp) env)))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))

#|
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
|#
;;;(lambda arg ...)
;;;(lambda (args) ...)
(define (lambda? exp)
(tagged-list? exp 'lambda))
(define (lambda-parameters exp)
(cadr exp))
(define (lambda-body exp)
(cddr exp))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
;;;((begin? exp) (eval-sequence (begin-actions exp) env))
;;;(begin ... ... ...)
(define (begin? exp)
(tagged-list? exp 'begin))
(define (begin-actions exp)
(cdr exp))
(define (eval-sequence contents env)
(cond ((null? contents) (error "begin null?" contents))
(else
(let loop ((contents contents))
(cond ((null? (cdr contents))
(my-eval (car contents) env))
(else
(my-eval (car contents) env)
(loop (cdr contents))))))))
(define (make-begin seq) (cons 'begin seq))
#|
((application? exp) ;;复合表达式 e10
(my-apply (my-eval (operator exp) env)
(list-of-values (operands exp) env)))
|#
;;;(fun others ...)
(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 (my-apply procedure arguments env)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
(let ((result (eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(make-fun-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure))))))
result))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(define (primitive-procedure? procedure)
(procedure? procedure))
(define apply-primitive-procedure apply)
(define (compound-procedure? procedure)
(tagged-list? procedure 'procedure))
(define (procedure-parameters p)
(cadr p))
(define (procedure-body p)
(caddr p))
(define (procedure-environment p)
(cadddr p))
(define (list-of-values args env)
(map (lambda (x) (my-eval x env)) args))
;---------------------------------
(define my-base-environment (init-environment))
(define (make-environment env . args)
(let loop ((args args))
(cond ((<= (length args) 0) 'make-environment-ok!)
(else
(extend-environment (car args) (cadr args) env)
(loop (cddr args))))))
(make-environment my-base-environment
'#t #t
'#f #f
'cons cons
'car car
'cdr cdr
'+ +
'- -
'* *
'/ /
'null? null?
'eq? eq?
'equal? equal?)
; (begin
; (extend-environment '#t #t ns)
; (extend-environment '#f #f ns)
; (extend-environment 'cons cons ns)
; (extend-environment 'car car ns)
; (extend-environment 'cdr cdr ns)
; (extend-environment '+ + ns)
; (extend-environment '- - ns)
; (extend-environment '* * ns)
; (extend-environment '/ / ns)
; (extend-environment 'null? null? ns)
; 'init-environment-ok!)
;;;==============================
) ;;;module end

;;;;mylisp03.rkt
;-----------------------------------
;;;解决词法作用域问题
(module mylisp03 racket
(displayln "-----mylisp03 loaded.------")
(provide (all-defined-out))
;(require compatibility/mlist)
;;;
;-------------------------
(define *my-eval-table* (make-hash))
(define (eval-put sym exp)
(hash-set! *my-eval-table* sym exp))
(define (eval-get sym)
(hash-ref *my-eval-table* sym))
;-------------------------
(define (my-eval exp env)
(define (tagged-list exp) (car exp))
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((pair? exp)
(let ((sym (tagged-list exp)))
(cond ((hash-ref *my-eval-table* sym #f)
((eval-get sym) exp env))
(else
((eval-get 'application) exp env)))))
(else
(error "Unknown expression type -- EVAL" exp))))
;----------------------------
;;;----------environment start------------------
(define (init-environment) (make-hash))
(define (extend-environment vars contents base-env)
(cond ((pair? vars)
(for-each (lambda (x y) (hash-set! base-env x y)) vars contents)
base-env)
(else
(hash-set! base-env vars contents)
base-env)))
(define (make-fun-environment vars contents base-env)
(let ((new-env (init-environment)))
(cond ((pair? vars)
(hash-set! new-env vars contents))
(else
(for-each (lambda (x y) (hash-set! new-env x y)) vars contents)))
(hash-set! new-env '*base-env* base-env)
new-env))
;;;((variable? exp) (lookup-variable-value exp env))
(define (lookup-variable-value exp env)
(cond ((hash? env)
(cond ((hash-ref env exp #f)
=> (lambda (x) x))
(else
;(printf "*base-env* -- ~a\n" exp)
(lookup-variable-value exp (hash-ref env '*base-env* '*scheme-environment*)))))
((eq? env '*scheme-environment*)
(eval exp (module->namespace 'racket)))
(else
(error "No this exp -- fun:lookup-variable-value" exp))))
;;;------environment page end-------------------------
;;;tagged-list?
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))
;;;((self-evaluating? exp) exp)
(define (self-evaluating? exp)
(or (number? exp)
(string? exp)
(boolean? exp)
(null? exp)))
;;;((variable? exp) (lookup-variable-value exp env))
(define (variable? exp)
(symbol? exp))
;;;((quoted? exp) (text-of-quotation exp))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (make-quoted exp)
(cons 'quote exp))
(eval-put 'quote (lambda (exp env) (text-of-quotation exp)))
;;;((my-set-and-define? exp) (eval-definition exp env))
(define (my-set-and-define? exp)
(or (tagged-list? exp 'set!) (tagged-list? exp 'define)))
;;;(define fun ...)
;;;(define fun (lambda arg ...))
;;;(define fun (lambda (args) ...))
;;;(define (fun args) ...)
(define (eval-definition exp env)
(let ((first-exp (cadr exp))
(rest-exp (cddr exp)))
(cond ((pair? first-exp)
(let ((fun-name (car first-exp))
(fun-args (cdr first-exp))
(body rest-exp))
(extend-environment fun-name
(make-procedure fun-args body env)
env)
(cons (list fun-name fun-args) "ok!-(fun args)")))
(else
(let ((fun-name first-exp))
(extend-environment fun-name
(my-eval (car rest-exp) env)
env)
(cons (list fun-name) "ok!-vars"))))))
(eval-put 'set! (lambda (exp env) (eval-definition exp env)))
(eval-put 'define (lambda (exp env) (eval-definition exp env)))
;;;((if? exp) (eval-if exp env))
;;;(if (predicate) consequent alternative)
(define (if? exp)
(tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (null? (cdddr exp))
'false ;;;为空返回自定义结果
(cadddr exp)))
(define (eval-if exp env)
(if (my-eval (if-predicate exp) env)
(my-eval (if-consequent exp) env)
(my-eval (if-alternative exp) env)))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(eval-put 'if (lambda (exp env) (eval-if exp env)))

#|
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
|#
;;;(lambda arg ...)
;;;(lambda (args) ...)
(define (lambda? exp)
(tagged-list? exp 'lambda))
(define (lambda-parameters exp)
(cadr exp))
(define (lambda-body exp)
(cddr exp))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(eval-put 'lambda (lambda (exp env)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env)))
;;;((begin? exp) (eval-sequence (begin-actions exp) env))
;;;(begin ... ... ...)
(define (begin? exp)
(tagged-list? exp 'begin))
(define (begin-actions exp)
(cdr exp))
(define (eval-sequence contents env)
(cond ((null? contents) (error "begin null?" contents))
(else
(let loop ((contents contents))
(cond ((null? (cdr contents))
(my-eval (car contents) env))
(else
(my-eval (car contents) env)
(loop (cdr contents))))))))
(define (make-begin seq) (cons 'begin seq))
(eval-put 'begin (lambda (exp env) (eval-sequence (begin-actions exp) env)))
#|
((application? exp) ;;复合表达式 e10
(my-apply (my-eval (operator exp) env)
(list-of-values (operands exp) env)))
|#
;;;(fun others ...)
(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 (my-apply procedure arguments env)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
(let ((result (eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(make-fun-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure))))))
result))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(define (primitive-procedure? procedure)
(procedure? procedure))
(define apply-primitive-procedure apply)
(define (compound-procedure? procedure)
(tagged-list? procedure 'procedure))
(define (procedure-parameters p)
(cadr p))
(define (procedure-body p)
(caddr p))
(define (procedure-environment p)
(cadddr p))
(define (list-of-values args env)
(map (lambda (x) (my-eval x env)) args))
(eval-put 'application
(lambda (exp env)
(my-apply (my-eval (operator exp) env)
(list-of-values (operands exp) env)
env)))
;;;((cond? exp) (my-eval (cond->if exp) env))
(define (cond? exp) (tagged-list? exp 'cond))
;;;(cond (else ...))
;;;(cond ((test) ...))
;;;(cond ((test) ...)) (else ...))
;;;(cond ((test) => ...) ...)
(define (make-cond exp)
(cons 'cond exp))
(define (cond-frame exp) (cadr exp))
(define (cond-test c-f) (car c-f))
(define (cond-body c-f) (cdr c-f))
(define (cond-rest exp) (cddr exp))
(define (cond->if exp)
(let ((frame (cond-frame exp)))
(cond ((null? frame) #f) ;;;无else语句，返回自定义
(else
(let ((test (cond-test frame))
(body (cond-body frame))
(rest (cond-rest exp)))
(cond ((eq? test 'else)
(make-begin body))
(else
(let ((true-result (cond ((eq? (car body) '=>)
(list (cadr body) test))
(else
(make-begin body)))))
(make-if test
true-result
(cond->if (make-cond rest)))))))))))
(eval-put 'cond
(lambda (exp env)
;(displayln (cond->if exp))
(my-eval (cond->if exp) env)))

;---------------------------------
(define my-base-environment (init-environment))
(define (make-environment env . args)
(let loop ((args args))
(cond ((<= (length args) 0) 'make-environment-ok!)
(else
(extend-environment (car args) (cadr args) env)
(loop (cddr args))))))
;;;基本过程直接转到'racket的命名空间了
; (make-environment my-base-environment
; 'cons cons
; 'car car
; 'cdr cdr
; '= =
; '+ +
; '- -
; '* *
; '/ /
; 'null? null?
; 'eq? eq?
; 'equal? equal?)
;;;==============================
) ;;;module end
;;;;增加的测试
(my-eval '(if #f
(begin 'a)
(if (eq? 1 2)
(begin 'b)
(begin 3)))
ns)
(my-eval '(cond (#f 'a)
((eq? 1 2) 'b)
(else
3))
ns)
(my-eval '(define (test n)
(cond ((equal? n 10)
=> (lambda (x) (if x
100
200)))
(else
'www)))
ns)
(my-eval '(test 10) ns)
(my-eval '(test 20) ns)
(my-eval '(sqrt 10) ns)
;;;;--------------------------------------------
下一步，惰性求值等。

用简陋的方法修正了一个bug。。。
;;;((variable? exp) (lookup-variable-value exp env))
(define (lookup-variable-value exp env)
;(printf "lookup: exp: ~a, env: ~a;---!!---\n" exp env)
(cond ((hash? env)
(let ((test-result (hash-ref env exp "*false*"))) ;;;当返回值是#f的bug。。。不过似乎用(gensym)就可以彻底避免命名冲突了。。。
(cond ((if (eq? test-result "*false*") #f #t)
test-result)
(else
;(printf "*base-env* -- ~a\n" exp)
(lookup-variable-value exp (hash-ref env '*base-env* '*scheme-environment*))))))
((eq? env '*scheme-environment*)
(let ((result (eval exp (module->namespace 'racket))))
;(printf "racket-var: ~a\n" exp)
result))
(else
(error "No this exp -- fun:lookup-variable-value" exp))))