[sicp] Section 4.1.7: Do anal(ysis) before ejaculating for better performance
This commit is contained in:
parent
c9ff5c1f9a
commit
e213c77f67
|
@ -53,83 +53,19 @@
|
|||
((eq? m 'insert-proc!) insert!)
|
||||
(else (error "Unknown operation: TABLE" m))))
|
||||
dispatch))
|
||||
(define evaluation-table (make-table))
|
||||
(define (get-evaluator exp)
|
||||
(if (pair? exp)
|
||||
((evaluation-table 'lookup-proc) (car exp))
|
||||
(define anal-table (make-table))
|
||||
(define (get-analyzer exp)
|
||||
(if (list? exp)
|
||||
((anal-table 'lookup-proc) (car exp))
|
||||
#f))
|
||||
(define (evaluate exp env)
|
||||
(cond ((get-evaluator exp) => (lambda (evaluator) (evaluator exp env)))
|
||||
((or (number? exp) (string? exp)) exp)
|
||||
((symbol? exp) (lookup-variable-value exp env))
|
||||
((pair? exp) (eval-application (cons 'call exp) env))
|
||||
(else (error "Unknown expression type: EVAL" exp))))
|
||||
|
||||
(define (begin-actions exp) (cdr exp))
|
||||
(define (last-exp? seq) (null? (cdr seq)))
|
||||
(define (first-exp seq) (car seq))
|
||||
(define (rest-exps seq) (cdr seq))
|
||||
(define (eval-sequence exps env)
|
||||
(let ((first-value (evaluate (first-exp exps) env)))
|
||||
(if (last-exp? exps)
|
||||
first-value
|
||||
(eval-sequence (rest-exps exps) env))))
|
||||
(define (eval-begin exp env) (eval-sequence (begin-actions exp) env))
|
||||
|
||||
(define (primitive-procedure? p) (and (pair? p) (eq? (car p) 'primitive)))
|
||||
(define (primitive-implementation p) (cadr p))
|
||||
|
||||
(define (make-procedure parameters body env)
|
||||
(list 'procedure parameters body env))
|
||||
(define (compound-procedure? p) (and (pair? p) (eq? (car p) 'procedure)))
|
||||
(define (procedure-parameters p) (cadr p))
|
||||
; Exercise 4.16.c
|
||||
(define (procedure-body p) (scan-out-defines (caddr p)))
|
||||
(define (procedure-environment p) (cadddr p))
|
||||
|
||||
(define (evaluator-apply procedure arguments)
|
||||
(cond ((primitive-procedure? procedure)
|
||||
(apply (primitive-implementation procedure) arguments))
|
||||
((compound-procedure? procedure)
|
||||
(eval-sequence
|
||||
(procedure-body procedure)
|
||||
(extend-environment
|
||||
(map cons (procedure-parameters procedure) arguments)
|
||||
(procedure-environment procedure))))))
|
||||
|
||||
(define (operator exp) (cadr exp))
|
||||
(define (operands exp) (cddr exp))
|
||||
(define (no-operands? ops) (null? ops))
|
||||
(define (first-operand ops) (car ops))
|
||||
(define (rest-operands ops) (cdr ops))
|
||||
(define (list-of-values exps env)
|
||||
(if (no-operands? exps)
|
||||
'()
|
||||
(cons (evaluate (first-operand exps) env)
|
||||
(list-of-values (rest-operands exps) env))))
|
||||
(define (eval-application exp env)
|
||||
(evaluator-apply (evaluate (operator exp) env)
|
||||
(list-of-values (operands exp) env)))
|
||||
|
||||
(define (eval-quote exp env) (cadr exp))
|
||||
|
||||
(define (assignment-variable exp) (cadr exp))
|
||||
(define (assignment-value exp) (caddr exp))
|
||||
(define (eval-assignment exp env)
|
||||
(set-variable-value! (assignment-variable exp)
|
||||
(evaluate (assignment-value exp) env)
|
||||
env)
|
||||
'ok)
|
||||
|
||||
(define (make-lambda parameters body)
|
||||
(cons 'lambda (cons parameters body)))
|
||||
(define (lambda-parameters exp) (cadr exp))
|
||||
(define (lambda-body exp) (cddr exp))
|
||||
(define (eval-lambda exp env)
|
||||
(make-procedure (lambda-parameters exp)
|
||||
(lambda-body exp)
|
||||
env))
|
||||
(define (analyze exp)
|
||||
(cond ((get-analyzer exp) => (lambda (analyzer) (analyzer exp)))
|
||||
((or (number? exp) (string? exp)) (lambda (env) exp))
|
||||
((symbol? exp) (lambda (env) (lookup-variable-value exp env)))
|
||||
((pair? exp) (analyze-application (cons 'call exp)))
|
||||
(else (error "Unknown expression type: ANALYZE" exp))))
|
||||
|
||||
(define (definition? exp) (and (list? exp) (eq? (car exp) 'define)))
|
||||
(define (definition-variable exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(cadr exp)
|
||||
|
@ -138,63 +74,146 @@
|
|||
(if (symbol? (cadr exp))
|
||||
(caddr exp)
|
||||
(make-lambda (cdadr exp) (cddr exp))))
|
||||
(define (eval-definition exp env)
|
||||
(define-variable! (definition-variable exp)
|
||||
(evaluate (definition-value exp) env)
|
||||
env)
|
||||
'ok)
|
||||
(define (analyze-definition exp)
|
||||
(let ((var (definition-variable exp))
|
||||
(vproc (analyze (definition-value exp))))
|
||||
(lambda (env)
|
||||
(define-variable! var (vproc env) env)
|
||||
'ok)))
|
||||
|
||||
; Exercise 4.16.b
|
||||
(define (scan-out-defines body)
|
||||
(let* ((definitions (filter (lambda (exp) (eq? (car exp) 'define)) body))
|
||||
(vars (map definition-variable definitions))
|
||||
(vals (map definition-value definitions))
|
||||
(assignments (map (lambda (var val) (list 'set! var val)) vars vals))
|
||||
(rest (filter (lambda (exp) (not (eq? (car exp) 'define))) body))
|
||||
(place-holders (let loop ((n (length vals)))
|
||||
(if (> n 0) (cons '*unassigned* (loop (1- n))) '()))))
|
||||
(list (list* 'lambda vars (append assignments rest)) place-holders)))
|
||||
(define (begin-actions exp) (cdr exp))
|
||||
(define (last-exp? seq) (null? (cdr seq)))
|
||||
(define (first-exp seq) (car seq))
|
||||
(define (rest-exps seq) (cdr seq))
|
||||
; Exercise 4.16
|
||||
(define (define->set! exp)
|
||||
(if (definition? exp)
|
||||
(list 'set! (definition-variable exp) (definition-value exp))
|
||||
exp))
|
||||
(define (analyze-sequence exps)
|
||||
(let ((vars (map definition-variable (filter definition? exps))))
|
||||
(if (null? vars)
|
||||
(let ((procs (map analyze exps)))
|
||||
(if (null? procs)
|
||||
(error "Empty sequence: ANALYZE")
|
||||
(let loop ((first-proc (car procs))
|
||||
(rest-procs (cdr procs)))
|
||||
(if (null? rest-procs)
|
||||
first-proc
|
||||
(loop (lambda (env) (first-proc env) ((car rest-procs) env))
|
||||
(cdr rest-procs))))))
|
||||
(analyze (list* (list* 'lambda vars (map define->set! exps))
|
||||
(map (lambda (var) ''*unassigned*) vars))))))
|
||||
(define (analyze-begin exp) (analyze-sequence (begin-actions exp)))
|
||||
|
||||
(define (false? x) (eq? x #f))
|
||||
(define (true? x) (not (false? x)))
|
||||
(define (primitive-procedure? p) (and (pair? p) (eq? (car p) 'primitive)))
|
||||
(define (primitive-implementation p) (cadr p))
|
||||
|
||||
(define (make-procedure parameters body env)
|
||||
(list 'procedure parameters body env))
|
||||
(define (compound-procedure? p) (and (pair? p) (eq? (car p) 'procedure)))
|
||||
(define (procedure-parameters p) (cadr p))
|
||||
(define (procedure-body p) (caddr p))
|
||||
(define (procedure-environment p) (cadddr p))
|
||||
|
||||
(define (execute-application proc args)
|
||||
(cond ((primitive-procedure? proc)
|
||||
(apply (primitive-implementation proc) args))
|
||||
((compound-procedure? proc)
|
||||
((procedure-body proc)
|
||||
(extend-environment (map cons (procedure-parameters proc) args)
|
||||
(procedure-environment proc))))
|
||||
(else (error "Unknown procedure type: EXECUTE-APPLICATION" proc))))
|
||||
|
||||
(define (operator exp) (cadr exp))
|
||||
(define (operands exp) (cddr exp))
|
||||
(define (no-operands? ops) (null? ops))
|
||||
(define (first-operand ops) (car ops))
|
||||
(define (rest-operands ops) (cdr ops))
|
||||
(define (analyze-application exp)
|
||||
(let ((fproc (analyze (operator exp)))
|
||||
(aprocs (map analyze (operands exp))))
|
||||
(lambda (env)
|
||||
(execute-application (fproc env)
|
||||
(map (lambda (aproc) (aproc env)) aprocs)))))
|
||||
|
||||
(define (analyze-quoted exp)
|
||||
(let ((qval (cadr exp)))
|
||||
(lambda (env) qval)))
|
||||
|
||||
(define (assignment-variable exp) (cadr exp))
|
||||
(define (assignment-value exp) (caddr exp))
|
||||
(define (analyze-assignment exp)
|
||||
(let ((var (assignment-variable exp))
|
||||
(vproc (analyze (assignment-value exp))))
|
||||
(lambda (env)
|
||||
(set-variable-value! var (vproc env) env)
|
||||
'ok)))
|
||||
|
||||
(define (make-lambda parameters body)
|
||||
(cons 'lambda (cons parameters body)))
|
||||
(define (lambda-parameters exp) (cadr exp))
|
||||
(define (lambda-body exp) (cddr exp))
|
||||
(define (analyze-lambda exp)
|
||||
(let ((vars (lambda-parameters exp))
|
||||
(bproc (analyze-sequence (lambda-body exp))))
|
||||
(lambda (env) (make-procedure vars bproc env))))
|
||||
|
||||
(define analyzed-true (lambda (env) (lookup-variable-value 'true env)))
|
||||
(define analyzed-false (lambda (env) (lookup-variable-value 'false env)))
|
||||
(define (false? evaluated-exp env) (eq? evaluated-exp (analyzed-false env)))
|
||||
(define (true? evaluated-exp env) (not (false? evaluated-exp env)))
|
||||
(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 (true? (evaluate (if-predicate exp) env))
|
||||
(evaluate (if-consequent exp) env)
|
||||
(evaluate (if-alternative exp) env)))
|
||||
(define (analyze-if exp)
|
||||
(let ((pproc (analyze (if-predicate exp)))
|
||||
(cproc (analyze (if-consequent exp)))
|
||||
(aproc (analyze (if-alternative exp))))
|
||||
(lambda (env) ((if (true? (pproc env) env) cproc aproc) env))))
|
||||
|
||||
; Exercise 4.4
|
||||
(define (analyze-and exp)
|
||||
(let loop ((first-exp analyzed-true)
|
||||
(rest-exps (map analyze (cdr exp))))
|
||||
(if (null? rest-exps)
|
||||
first-exp
|
||||
(loop (lambda (env)
|
||||
(let ((pred (first-exp env)))
|
||||
(if (false? pred env) pred ((car rest-exps) env))))
|
||||
(cdr rest-exps)))))
|
||||
(define (analyze-or-exps analyzed-exps)
|
||||
(let loop ((first-exp analyzed-false) (rest-exps analyzed-exps))
|
||||
(if (null? rest-exps)
|
||||
first-exp
|
||||
(loop (lambda (env)
|
||||
(let ((pred (first-exp env)))
|
||||
(if (false? pred env) ((car rest-exps) env) pred)))
|
||||
(cdr rest-exps)))))
|
||||
(define (analyze-or exp) (analyze-or-exps (map analyze (cdr exp))))
|
||||
|
||||
; Exercise 4.5
|
||||
(define (cond-clauses exp) (cdr exp))
|
||||
(define (cond-predicate clause) (car clause))
|
||||
(define (cond-actions clause) (cdr clause))
|
||||
(define (eval-cond exp env)
|
||||
(let loop ((clauses (cond-clauses exp)))
|
||||
(if (null? clauses)
|
||||
'false
|
||||
(let* ((first (car clauses))
|
||||
(rest (cdr clauses))
|
||||
(pred (evaluate (cond-predicate first) env))
|
||||
(actions (cond-actions first)))
|
||||
(cond ((false? pred) (loop rest))
|
||||
((null? actions) pred)
|
||||
((eq? (car actions) '=>)
|
||||
(evaluator-apply (evaluate (cadr actions) env)
|
||||
(list pred)))
|
||||
(else (eval-sequence actions env)))))))
|
||||
|
||||
; Exercise 4.4
|
||||
(define (eval-and exp env)
|
||||
(let loop ((expressions (cdr exp)))
|
||||
(cond ((null? expressions) 'true)
|
||||
((last-exp? expressions) (evaluate (car expressions) env))
|
||||
((evaluate (car expressions) env) (loop (cdr expressions)))
|
||||
(else 'false))))
|
||||
(define (eval-or exp env) (eval-cond (map list exp) env))
|
||||
(define (analyze-cond-clause clause)
|
||||
(let ((pproc (analyze (cond-predicate clause)))
|
||||
(bproc (let ((actions (cond-actions clause)))
|
||||
(cond ((null? actions) (lambda (pred env) pred))
|
||||
((eq? (car actions) '=>)
|
||||
(let ((fproc (analyze (cadr actions))))
|
||||
(lambda (pred env)
|
||||
(execute-application (fproc env) (list pred)))))
|
||||
(else (let ((consequences (analyze-sequence actions)))
|
||||
(lambda (pred env) (consequences env))))))))
|
||||
(lambda (env)
|
||||
(let ((pred (pproc env)))
|
||||
(if (true? pred env) (bproc pred env) (analyzed-false env))))))
|
||||
(define (analyze-cond exp)
|
||||
(analyze-or-exps (map analyze-cond-clause (cond-clauses exp))))
|
||||
|
||||
; Exercise 4.6
|
||||
(define (let->combination exp)
|
||||
|
@ -204,10 +223,12 @@
|
|||
(list* (list* 'lambda (map car ad) dd)
|
||||
(map cadr ad))
|
||||
; Exercise 4.8
|
||||
(list 'begin
|
||||
(list* 'define (list* ad (map car (car dd))) (cdr dd))
|
||||
(list* ad (map cadr (car dd)))))))
|
||||
(define (eval-let exp env) (evaluate (let->combination exp) env))
|
||||
`((lambda (,ad)
|
||||
(set! ,ad (lambda ,(map car (car dd)) ,@(cdr dd)))
|
||||
(,ad ,@(map cadr (car dd))))
|
||||
'*unassigned*))))
|
||||
; Exercise 4.22
|
||||
(define (analyze-let exp) (analyze (let->combination exp)))
|
||||
|
||||
; Exercise 4.7
|
||||
(define (let*->nested-lets exp)
|
||||
|
@ -216,38 +237,37 @@
|
|||
(if (or (null? bindings) (last-exp? bindings))
|
||||
(list* 'let bindings body)
|
||||
(list 'let (list (car bindings)) (loop (cdr bindings)))))))
|
||||
(define (eval-let* exp env) (evaluate (let*->nested-lets exp) env))
|
||||
(define (analyze-let* exp) (analyze (let*->nested-lets exp)))
|
||||
|
||||
; Exercise 4.9
|
||||
(define (eval-while exp env) ; (while pred body)
|
||||
(let ((pred (cadr exp))
|
||||
(body (cddr exp)))
|
||||
(let loop ((keep-going (evaluate pred env)))
|
||||
(if (true? keep-going)
|
||||
(begin (eval-sequence body env)
|
||||
(loop (evaluate pred env)))))))
|
||||
(define (eval-for exp env) ; (for init pred body)
|
||||
(evaluate (list 'let (cadr exp)
|
||||
(list* 'while (caddr exp) (cdddr exp)))
|
||||
env))
|
||||
(define (analyze-while exp) ; (while pred body)
|
||||
(let ((pproc (analyze (cadr exp)))
|
||||
(bproc (analyze-sequence (cddr exp))))
|
||||
(lambda (env)
|
||||
(let loop ((pred (pproc env)))
|
||||
(if (true? pred env)
|
||||
(begin (bproc env)
|
||||
(loop (pproc env))))))))
|
||||
(define (analyze-for exp) ; (for init pred body)
|
||||
(analyze (list 'let (cadr exp) (cons 'while (cddr exp)))))
|
||||
|
||||
; Exercise 4.2
|
||||
(define (add-evaluator! tag evaluator)
|
||||
((evaluation-table 'insert-proc!) tag evaluator))
|
||||
(add-evaluator! 'call eval-application)
|
||||
(add-evaluator! 'quote eval-quote)
|
||||
(add-evaluator! 'set! eval-assignment)
|
||||
(add-evaluator! 'define eval-definition)
|
||||
(add-evaluator! 'if eval-if)
|
||||
(add-evaluator! 'lambda eval-lambda)
|
||||
(add-evaluator! 'begin eval-begin)
|
||||
(add-evaluator! 'cond eval-cond)
|
||||
(add-evaluator! 'and eval-and)
|
||||
(add-evaluator! 'or eval-or)
|
||||
(add-evaluator! 'let eval-let)
|
||||
(add-evaluator! 'let* eval-let*)
|
||||
(add-evaluator! 'while eval-while)
|
||||
(add-evaluator! 'for eval-for)
|
||||
(define (add-analyzer! tag analyzer)
|
||||
((anal-table 'insert-proc!) tag analyzer))
|
||||
(add-analyzer! 'call analyze-application)
|
||||
(add-analyzer! 'quote analyze-quoted)
|
||||
(add-analyzer! 'set! analyze-assignment)
|
||||
(add-analyzer! 'define analyze-definition)
|
||||
(add-analyzer! 'if analyze-if)
|
||||
(add-analyzer! 'lambda analyze-lambda)
|
||||
(add-analyzer! 'begin analyze-begin)
|
||||
(add-analyzer! 'cond analyze-cond)
|
||||
(add-analyzer! 'and analyze-and)
|
||||
(add-analyzer! 'or analyze-or)
|
||||
(add-analyzer! 'let analyze-let)
|
||||
(add-analyzer! 'let* analyze-let*)
|
||||
(add-analyzer! 'while analyze-while)
|
||||
(add-analyzer! 'for analyze-for)
|
||||
|
||||
(define primitive-procedures
|
||||
(let ((procedures (list (cons 'first car)
|
||||
|
@ -270,16 +290,16 @@
|
|||
the-empty-environment
|
||||
(extend-environment (car environments)
|
||||
(apply make-environment (cdr environments)))))
|
||||
(define (mk-init-env)
|
||||
(make-environment primitive-procedures
|
||||
(list (cons 'false #f) (cons 'true #t) (cons 'else #t))))
|
||||
|
||||
(define (evaluator-loop)
|
||||
(let loop ((environment (make-environment primitive-procedures
|
||||
(list (cons 'false #f)
|
||||
(cons 'true #t)
|
||||
(cons 'else #t)))))
|
||||
(let loop ((environment (mk-init-env)))
|
||||
(display "> ")
|
||||
(let ((input (read)))
|
||||
(if (not (eq? input 'quit))
|
||||
(let ((output (evaluate input environment)))
|
||||
(let ((output ((analyze input) environment)))
|
||||
(display output)
|
||||
(newline)
|
||||
(loop environment))))))
|
||||
|
|
Loading…
Reference in New Issue