[sicp] Section 4.1.7: Do anal(ysis) before ejaculating for better performance

sicp/chapter4.scm

@@ -53,83 +53,19 @@
             ((eq? m 'insert-proc!) insert!)
             (else (error "Unknown operation: TABLE" m))))
     dispatch))
-(define evaluation-table (make-table))
+(define anal-table (make-table))
-(define (get-evaluator exp)
+(define (get-analyzer exp)
-  (if (pair? exp)
+  (if (list? exp)
-      ((evaluation-table 'lookup-proc) (car exp))
+      ((anal-table 'lookup-proc) (car exp))
       #f))
-(define (evaluate exp env)
+(define (analyze exp)
-  (cond ((get-evaluator exp) => (lambda (evaluator) (evaluator exp env)))
+  (cond ((get-analyzer exp) => (lambda (analyzer) (analyzer exp)))
-        ((or (number? exp) (string? exp)) exp)
+        ((or (number? exp) (string? exp)) (lambda (env) exp))
-        ((symbol? exp) (lookup-variable-value exp env))
+        ((symbol? exp) (lambda (env) (lookup-variable-value exp env)))
-        ((pair? exp) (eval-application (cons 'call exp) env))
+        ((pair? exp) (analyze-application (cons 'call exp)))
-        (else (error "Unknown expression type: EVAL" exp))))
+        (else (error "Unknown expression type: ANALYZE" 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 (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 (analyze-definition exp)
-  (define-variable! (definition-variable exp)
+  (let ((var (definition-variable exp))
-                    (evaluate (definition-value exp) env)
+        (vproc (analyze (definition-value exp))))
-                    env)
+    (lambda (env)
-  'ok)
+      (define-variable! var (vproc env) env)
+      'ok)))
 
-; Exercise 4.16.b
+(define (begin-actions exp) (cdr exp))
-(define (scan-out-defines body)
+(define (last-exp? seq) (null? (cdr seq)))
-  (let* ((definitions (filter (lambda (exp) (eq? (car exp) 'define)) body))
+(define (first-exp seq) (car seq))
-         (vars (map definition-variable definitions))
+(define (rest-exps seq) (cdr seq))
-         (vals (map definition-value definitions))
+; Exercise 4.16
-         (assignments (map (lambda (var val) (list 'set! var val)) vars vals))
+(define (define->set! exp)
-         (rest (filter (lambda (exp) (not (eq? (car exp) 'define))) body))
+  (if (definition? exp)
-         (place-holders (let loop ((n (length vals)))
+      (list 'set! (definition-variable exp) (definition-value exp))
-                          (if (> n 0) (cons '*unassigned* (loop (1- n))) '()))))
+      exp))
-    (list (list* 'lambda vars (append assignments rest)) place-holders)))
+(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 (primitive-procedure? p) (and (pair? p) (eq? (car p) 'primitive)))
-(define (true? x) (not (false? x)))
+(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)
+(define (analyze-if exp)
-  (if (true? (evaluate (if-predicate exp) env))
+  (let ((pproc (analyze (if-predicate exp)))
-      (evaluate (if-consequent exp) env)
+        (cproc (analyze (if-consequent exp)))
-      (evaluate (if-alternative exp) env)))
+        (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)
+(define (analyze-cond-clause clause)
-  (let loop ((clauses (cond-clauses exp)))
+  (let ((pproc (analyze (cond-predicate clause)))
-    (if (null? clauses)
+        (bproc (let ((actions (cond-actions clause)))
-        'false
+                 (cond ((null? actions) (lambda (pred env) pred))
-        (let* ((first (car clauses))
+                       ((eq? (car actions) '=>)
-               (rest (cdr clauses))
+                        (let ((fproc (analyze (cadr actions))))
-               (pred (evaluate (cond-predicate first) env))
+                          (lambda (pred env)
-               (actions (cond-actions first)))
+                            (execute-application (fproc env) (list pred)))))
-          (cond ((false? pred) (loop rest))
+                       (else (let ((consequences (analyze-sequence actions)))
-                ((null? actions) pred)
+                               (lambda (pred env) (consequences env))))))))
-                ((eq? (car actions) '=>)
+    (lambda (env)
-                 (evaluator-apply (evaluate (cadr actions) env)
+      (let ((pred (pproc env)))
-                                  (list pred)))
+        (if (true? pred env) (bproc pred env) (analyzed-false env))))))
-                (else (eval-sequence actions env)))))))
+(define (analyze-cond exp)
-
+  (analyze-or-exps (map analyze-cond-clause (cond-clauses exp))))
-; 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))
 
 ; 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
+        `((lambda (,ad)
-              (list* 'define (list* ad (map car (car dd))) (cdr dd))
+            (set! ,ad (lambda ,(map car (car dd)) ,@(cdr dd)))
-              (list* ad (map cadr (car dd)))))))
+            (,ad ,@(map cadr (car dd))))
-(define (eval-let exp env) (evaluate (let->combination exp) env))
+          '*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)
+(define (analyze-while exp) ; (while pred body)
-  (let ((pred (cadr exp))
+  (let ((pproc (analyze (cadr exp)))
-        (body (cddr exp)))
+        (bproc (analyze-sequence (cddr exp))))
-    (let loop ((keep-going (evaluate pred env)))
+    (lambda (env)
-      (if (true? keep-going)
+      (let loop ((pred (pproc env)))
-          (begin (eval-sequence body env)
+        (if (true? pred env)
-                 (loop (evaluate pred env)))))))
+            (begin (bproc env)
-(define (eval-for exp env) ; (for init pred body)
+                   (loop (pproc env))))))))
-  (evaluate (list 'let (cadr exp)
+(define (analyze-for exp) ; (for init pred body)
-                  (list* 'while (caddr exp) (cdddr exp)))
+  (analyze (list 'let (cadr exp) (cons 'while (cddr exp)))))
-            env))
 
 ; Exercise 4.2
-(define (add-evaluator! tag evaluator)
+(define (add-analyzer! tag analyzer)
-  ((evaluation-table 'insert-proc!) tag evaluator))
+  ((anal-table 'insert-proc!) tag analyzer))
-(add-evaluator! 'call eval-application)
+(add-analyzer! 'call analyze-application)
-(add-evaluator! 'quote eval-quote)
+(add-analyzer! 'quote analyze-quoted)
-(add-evaluator! 'set! eval-assignment)
+(add-analyzer! 'set! analyze-assignment)
-(add-evaluator! 'define eval-definition)
+(add-analyzer! 'define analyze-definition)
-(add-evaluator! 'if eval-if)
+(add-analyzer! 'if analyze-if)
-(add-evaluator! 'lambda eval-lambda)
+(add-analyzer! 'lambda analyze-lambda)
-(add-evaluator! 'begin eval-begin)
+(add-analyzer! 'begin analyze-begin)
-(add-evaluator! 'cond eval-cond)
+(add-analyzer! 'cond analyze-cond)
-(add-evaluator! 'and eval-and)
+(add-analyzer! 'and analyze-and)
-(add-evaluator! 'or eval-or)
+(add-analyzer! 'or analyze-or)
-(add-evaluator! 'let eval-let)
+(add-analyzer! 'let analyze-let)
-(add-evaluator! 'let* eval-let*)
+(add-analyzer! 'let* analyze-let*)
-(add-evaluator! 'while eval-while)
+(add-analyzer! 'while analyze-while)
-(add-evaluator! 'for eval-for)
+(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
+  (let loop ((environment (mk-init-env)))
-                                            (list (cons 'false #f)
-                                                  (cons 'true #t)
-                                                  (cons 'else #t)))))
     (display "> ")
     (let ((input (read)))
       (if (not (eq? input 'quit))
-          (let ((output (evaluate input environment)))
+          (let ((output ((analyze input) environment)))
             (display output)
             (newline)
             (loop environment))))))