Permalink
Browse files

添加 SICP 主页上提供的求值器

  • Loading branch information...
huangz1990 committed May 29, 2012
1 parent a51b257 commit 98f3e22e4c65e746e0b70e8f5b2f594a4a0b70dc
Showing with 580 additions and 0 deletions.
  1. +111 −0 chp4/code/analyze.scm
  2. +213 −0 chp4/code/evdata.scm
  3. +83 −0 chp4/code/meval.scm
  4. +173 −0 chp4/code/syntax.scm
View
@@ -0,0 +1,111 @@
+;;; ANALYZE.SCM
+
+;;; Analyzing Interpreter from Section 4.2.2
+;;; with Lazy Parameter Declarations as in Exercise 4.14
+
+;;; Produces (lambda (env) ...)
+(define (analyze exp)
+ (cond ((self-evaluating? exp) (analyze-self-evaluating exp))
+ ((variable? exp) (analyze-variable exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((lambda? exp) (analyze-lambda exp))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (COND->IF exp)))
+ ((let? exp) (analyze (LET->combination exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+(define (analyze-self-evaluating exp)
+ (lambda (env) exp))
+
+
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env) qval)))
+
+
+(define (analyze-variable exp)
+ (lambda (env)
+ (lookup-variable-value exp env)))
+
+
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env)
+ (set-variable-value! var (vproc env) env))))
+
+
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env)
+ (define-variable! var (vproc env) env))))
+
+
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env)
+ (make-procedure vars bproc env))))
+
+
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env)
+ (if (force-it (pproc env))
+ (cproc env)
+ (aproc env)))))
+
+
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env) (force-it (a env)) (b env)))
+ (let ((procs (map analyze exps)))
+ (define (loop first rest)
+ (if (null? rest)
+ first
+ (loop (sequentially first (car rest))
+ (cdr rest))))
+ (if (null? procs)
+ (error
+ "BEGIN requires subexpressions -- ANALYZE" exps))
+ (loop (car procs) (cdr procs))))
+
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env)
+ (exapply (force-it (fproc env)) aprocs env))))
+
+
+(define (exapply proc aprocs env)
+ (cond ((primitive-procedure? proc)
+ (apply-primitive-procedure
+ proc
+ (force-all-args aprocs env)))
+ ((compound-procedure? proc)
+ (let ((params (procedure-parameters proc)))
+ ((procedure-body proc)
+ (extend-environment (parameter-names params)
+ (process-arg-procs params aprocs env)
+ (procedure-environment proc)))))
+ (else
+ (error "Unknown procedure type -- EXAPPLY"
+ proc))))
+
+
+(define (start-analyze)
+ (set! current-evaluator (lambda (exp env) ((analyze exp) env)))
+ (set! current-prompt "AEVAL=> ")
+ (set! current-value-label ";;A-value: ")
+ (init-env)
+ (eval-loop))
View
@@ -0,0 +1,213 @@
+;;;EVDATA.SCM
+;;; Chapter 4 Evaluator data structures and driver loop
+
+;;; The Read-Eval-Print Loop for the evaluators
+
+
+(define (eval-loop)
+ (newline)
+ (let ((result
+ (force-it
+ (current-evaluator
+ (prompt-for-command-expression current-prompt)
+ the-global-environment))))
+ (newline)
+ (display current-value-label)
+ (pp (make-printable result))
+ (eval-loop)))
+
+
+;;; Since the environment is generally a circular list which will print forever,
+;;; we use MAKE-PRINTABLE to turn circular list structures into lists
+
+(define (make-printable object)
+ (let ((visited '()))
+ (define (mk-pble object)
+ (if (and (pair? object) (not (eq? object *lazythunk*)))
+ (let ((previous (memq object visited)))
+ (if previous
+ (string->symbol
+ (string-append
+ "revisited["
+ (number->string (length previous))
+ "]"))
+ (begin
+ (set! visited (cons object visited))
+ (cons (mk-pble (car object))
+ (mk-pble (cdr object))))))
+ object))
+ (mk-pble object)))
+
+
+(define current-evaluator 'uninitialized)
+(define current-prompt 'uninitialized)
+(define current-value-label 'uninitialized)
+
+;;; Data Structures
+
+(define (true? x) (not (eq? x #f)))
+
+(define (false? x) (eq? x #f))
+
+(define the-unspecified-value (list 'the-unspecified-value))
+
+;;; Primitive procedures are inherited from Scheme.
+
+(define primitive-procedure? procedure?)
+(define apply-primitive-procedure apply)
+
+;;; Compound procedures
+
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+
+(define (compound-procedure? exp)
+ (tagged-list? exp 'procedure))
+
+(define (procedure-parameters p) (list-ref p 1))
+(define (procedure-body p) (list-ref p 2))
+(define (procedure-environment p) (list-ref p 3))
+
+
+;;; An ENVIRONMENT is a list of FRAMES.
+;;; Each frame is a cons-pair consisting of a
+;;; list of variables and a list of values.
+
+(define the-global-environment 'uninitialized)
+(define the-empty-environment '())
+
+(define (extend-environment variables values base-environment)
+ (if (= (length variables) (length values))
+ (cons (cons variables values) base-environment)
+ (if (< (length variables) (length values))
+ (error "Too many arguments supplied" variables values)
+ (error "Too few arguments supplied" variables values))))
+
+
+;;; Initialize the environment
+
+(define (init-env)
+ (set! the-global-environment
+ (extend-environment '() '() the-empty-environment))
+ (set! scheme-variable-cache '())) ;This cache is an optimization in the
+ ;implementation of LOOKUP-SCHEME-VALUE
+
+;;; The environment is set up here to hook into Scheme along the lines
+;;; of exercise 4.14.
+
+(define (lookup-variable-value var env)
+ (define (parent-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (parent-loop (cdr env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else
+ (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (lookup-scheme-value var)
+ (scan (caar env) (cdar env))))
+ (parent-loop env))
+
+
+(define (set-variable-value! var val env)
+ (define (parent-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (parent-loop (cdr env)))
+ ((eq? var (car vars))
+ (set-car! vals val)
+ the-unspecified-value)
+ (else
+ (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (scan (caar env) (cdar env))))
+ (parent-loop env))
+
+
+(define (define-variable! var val env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (set-car! (car env) (cons var (caar env)))
+ (set-cdr! (car env) (cons val (cdar env))))
+ ((eq? var (car vars))
+ (set-car! vals val)
+ the-unspecified-value)
+ (else
+ (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- DEFINE" var) ;should not happen.
+ (scan (caar env) (cdar env))))
+
+
+;;; Procedures handling lazy parameter declarations
+
+(define (force-all-args aprocs env)
+ (map (lambda (aproc) (force-it (aproc env)))
+ aprocs))
+
+(define (process-arg-procs params aprocs env)
+ (map (lambda (param aproc)
+ (cond ((variable? param) (aproc env))
+ ((lazy? param) (delay-it aproc env))
+ ((memo? param) (delay-it-memo aproc env))
+ (else (error "Unknown declaration" param))))
+ params
+ aprocs))
+
+
+;;; Delayed evaluation structures
+
+(define (delay-it proc env)
+ (cons *lazythunk*
+ (lambda () (proc env))))
+
+(define (delay-it-memo proc env)
+ (let ((value *unforced*))
+ (cons *lazythunk*
+ (lambda ()
+ (if (eq? value *unforced*)
+ (begin (set! value (proc env))
+ (set! proc '())
+ (set! env '())))
+ value))))
+
+(define (force-it obj)
+ (if (and (pair? obj) (eq? (car obj) *lazythunk*))
+ (force-it ((cdr obj)))
+ obj))
+
+(define *unforced* (list '*unforced*))
+(define *lazythunk* (list '*lazythunk*))
+
+;;;MISCELLANEOUS SYSTEM PROCEDURES---CAN BE IGNORED
+
+;;; We speed up Scheme variable lookup by keeping
+;;; a cache of the variables that we actually look up.
+
+(define lexical-unreferenceable?
+ (make-primitive-procedure 'lexical-unreferenceable?))
+
+(define lexical-reference
+ (make-primitive-procedure 'lexical-reference))
+
+(define scheme-variable-cache '())
+
+(define (lookup-scheme-value var)
+ (let ((vcell (assq var scheme-variable-cache)))
+ (cond (vcell (cdr vcell))
+ ((not (lexical-unreferenceable? user-initial-environment var))
+ (let ((val (lexical-reference user-initial-environment var)))
+ (set! scheme-variable-cache
+ (cons (cons var val) scheme-variable-cache))
+ val))
+ (else
+ (error "Unbound variable" var)))))
+
+;;; The following commands keep the Scheme printer from going into
+;;; an infinite loop when printing circular list structures such
+;;; as environments.
+
+(set! *unparser-list-depth-limit* 7)
+(set! *unparser-list-breadth-limit* 10)
Oops, something went wrong.

0 comments on commit 98f3e22

Please sign in to comment.