This work is licensed under a Creative Commons Attribution-NonCommercial-ShareAlike 2.5 China Mainland License.
下面是 the little schemer 中的 简单interpreter实现以及在DrRacket中的一步步的调试观察。
这里注意运行下面的代码需要设置一下
另外，使用DrRacket的调试来step by step 观察 Scheme 程序运行非常不错。
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;a simple scheme interpreter run on scheme (DrRacket 5.3)
;date:2012-9-3
;some trivil functions
(define (atom? x)
(and (not (null? x))
(not (pair? x))))
(define first
(lambda (p)
(car p)))
(define second
(lambda (p)
(car (cdr p))))
(define third
(lambda (p)
(car (cdr (cdr p)))))
(define build
(lambda (s1 s2)
(cons s1 (cons s2 (quote ())))))
(define new-entry build)
;entry and table
(define lookup-in-entry-help
(lambda (name names values entry-f)
(cond
((null? names) (entry-f name))
((eq? (car names) name) (car values))
(else (lookup-in-entry-help name (cdr names) (cdr values) entry-f)))))
(define lookup-in-entry
(lambda (name entry entry-f)
(lookup-in-entry-help name
(first entry)
(second entry)
entry-f)))
(define extend-table cons)
(define lookup-in-table
(lambda (name table table-f)
(cond
((null? table) (table-f name))
(else (lookup-in-entry name
(car table)
(lambda (name)
(lookup-in-table name (cdr table) table-f)))))))
;;;;;;;;;;;actions
(define atom-to-action
(lambda (e)
(cond
((number? e) *const)
((eq? e #t) *const)
((eq? e (quote cons)) *const)
((eq? e (quote car)) *const)
((eq? e (quote cdr)) *const)
((eq? e (quote null?)) *const)
((eq? e (quote eq?)) *const)
((eq? e (quote atom?)) *const)
((eq? e (quote zero?)) *const)
((eq? e (quote add1)) *const)
((eq? e (quote sub1)) *const)
((eq? e (quote number?)) *const)
(else *identifier))))
(define list-to-action
(lambda (e)
(cond
((atom? (car e))
(cond
((eq? (car e) (quote quote)) *quote)
((eq? (car e) (quote lambda)) *lambda)
((eq? (car e) (quote cond)) *cond)
(else *application)))
(else *application))))
(define expression-to-action
(lambda (e)
(cond
((atom? e) (atom-to-action e))
(else (list-to-action e)))))
;*const action
(define *const
(lambda (e table)
(cond
((number? e) e)
((eq? e #t) #t)
((eq? e #f) #f)
(else (build (quote primitive) e)))))
;*quote action
(define text-of second)
(define *quote
(lambda (e table)
(text-of e)))
;identifier action
(define initial-table
(lambda (name)
(car (quote ()))))
(define *identifier
(lambda (e table)
(lookup-in-table e table initial-table)))
;*lambda action
(define *lambda
(lambda (e table)
(build (quote non-primitive)
(cons table (cdr e)))))
;*cond action
(define table-of first)
(define formals-of second)
(define body-of third)
(define else?
(lambda (x)
(cond
((atom? x) (eq? x (quote else)))
(else #f))))
(define question-of first)
(define answer-of second)
(define evcon
(lambda (lines table)
(cond
((else? (question-of (car lines)))
(meaning (answer-of (car lines)) table))
((meaning (question-of (car lines)) table)
(meaning (answer-of (car lines)) table))
(else (evcon (cdr lines) table)))))
(define cond-lines-of cdr)
(define *cond
(lambda (e table)
(evcon (cond-lines-of e) table)))
;*application action
(define evlis
(lambda (args table)
(cond
((null? args) (quote ()))
(else
(cons (meaning (car args) table)
(evlis (cdr args) table))))))
(define function-of car)
(define arguments-of cdr)
(define primitive?
(lambda (l)
(eq? (first l) (quote primitive))))
(define non-primitive?
(lambda (l)
(eq? (first l) (quote non-primitive))))
(define :atom?
(lambda (x)
(cond
((atom? x) #t)
((null? x) #t)
((eq? (car x) (quote primitive)) #t)
(else #f))))
(define apply-primitive
(lambda (name vals)
(cond
((eq? name (quote cons))
(cons (first vals) (second vals)))
((eq? name (quote car))
(car (first vals)))
((eq? name (quote vals))
(cdr (first vals)))
((eq? name (quote null?))
(null? (first vals)))
((eq? name (quote eq?))
(eq? (first (second vals))))
((eq? name (quote atom?))
(:atom? (first vals)))
((eq? name (quote zero?))
(zero? (first vals)))
((eq? name (quote add1))
(add1 (first vals)))
((eq? name (quote sub1))
(sub1 (first vals)))
((eq? name (quote number?))
(number? (first vals))))))
(define apply-closure
(lambda (closure vals)
(meaning (body-of closure)
(extend-table
(new-entry (formals-of closure) vals) (table-of closure)))))
(define apply
(lambda (fun vals)
(cond
((primitive? fun)
(apply-primitive (second fun) vals))
((non-primitive? fun) (apply-closure (second fun) vals)))))
(define *application
(lambda (e table)
(apply
(meaning (function-of e) table)
(evlis (arguments-of e) table))))
;;;;;;;;;value--the interpreter entrance
(define meaning
(lambda (e table)
((expression-to-action e) e table)))
(define value
(lambda (e)
(meaning e (quote ()))))
;;;;test examples;;;
;;DrRacket中注释代码COMMENT in DrRacket: select codes and press ctrl + alt + ";"
;;DrRacket中取消注释UNCOMMENT in DrRacket: select codes and press ctrl + alt + "="
;example1.(meaning e table)是什么,其中e是(lambda (x) (cons x y)),table 是(((y z) ((8) 9)))。
;(define e '(lambda (x) (cons x y)))
;(define table '(((y z) ((8) 9))))
;(meaning e table)
;example2.(*cond e table), 其中e是(cond (coffee klastsch) (else party)), table 是 (((coffee) (#t)) ((klastsch party) (5 (6))))
;(define e '(cond (coffee klastsch) (else party)))
;(define table '(((coffee) (#t)) ((klastsch party) (5 (6)))))
;(*cond e table)
;example3.
(define e '((lambda (nothing)
(cond
(nothing (quote something))
(else (quote nothing))))
#t))
(value e)