diff options
| -rw-r--r-- | sicp/chapter4.scm | 292 |
1 files changed, 156 insertions, 136 deletions
diff --git a/sicp/chapter4.scm b/sicp/chapter4.scm index d3919ce..651ccff 100644 --- a/sicp/chapter4.scm +++ b/sicp/chapter4.scm @@ -53,28 +53,58 @@ ((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 (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) + (caadr exp))) +(define (definition-value exp) + (if (symbol? (cadr exp)) + (caddr exp) + (make-lambda (cdadr exp) (cddr exp)))) +(define (analyze-definition exp) + (let ((var (definition-variable exp)) + (vproc (analyze (definition-value exp)))) + (lambda (env) + (define-variable! var (vproc env) env) + 'ok))) (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)) +; 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 (primitive-procedure? p) (and (pair? p) (eq? (car p) 'primitive))) (define (primitive-implementation p) (cadr p)) @@ -83,118 +113,107 @@ (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-body p) (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 (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 (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 (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 (eval-quote exp env) (cadr exp)) +(define (analyze-quoted exp) + (let ((qval (cadr exp))) + (lambda (env) qval))) (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 (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 (eval-lambda exp env) - (make-procedure (lambda-parameters exp) - (lambda-body exp) - env)) +(define (analyze-lambda exp) + (let ((vars (lambda-parameters exp)) + (bproc (analyze-sequence (lambda-body exp)))) + (lambda (env) (make-procedure vars bproc env)))) -(define (definition-variable exp) - (if (symbol? (cadr exp)) - (cadr exp) - (caadr exp))) -(define (definition-value exp) - (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) - -; 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 (false? x) (eq? x #f)) -(define (true? x) (not (false? x))) +(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)))))) |