[sicp] Finish section 4.1.6: First working evaluator
This commit is contained in:
parent
79487278f0
commit
c9ff5c1f9a
|
@ -0,0 +1,301 @@
|
|||
; Exercise 4.11
|
||||
(define (make-frame bindings) (cons '*frame* bindings))
|
||||
(define (lookup-within-frame var frame) (assoc var (cdr frame)))
|
||||
(define (add-binding-to-frame! var val frame)
|
||||
(set-cdr! frame (cons (cons var val) (cdr frame))))
|
||||
|
||||
(define the-empty-environment '())
|
||||
(define (extend-environment bindings base-env)
|
||||
(cons (make-frame bindings) base-env))
|
||||
(define (enclosing-environment env) (cdr env))
|
||||
(define (first-frame env) (car env))
|
||||
|
||||
(define (define-variable! var val env)
|
||||
(let* ((frame (first-frame env))
|
||||
(binding (lookup-within-frame var frame)))
|
||||
(if binding
|
||||
(set-cdr! binding val)
|
||||
(add-binding-to-frame! var val frame))))
|
||||
; Exercise 4.12
|
||||
(define (lookup-binding variable environment)
|
||||
(let loop ((env environment))
|
||||
(if (eq? env the-empty-environment)
|
||||
#f
|
||||
(cond ((lookup-within-frame variable (first-frame env)))
|
||||
(else (loop (enclosing-environment env)))))))
|
||||
(define (set-variable-value! var val env)
|
||||
(cond ((lookup-binding var env) => (lambda (b) (set-cdr! b val)))
|
||||
(else (error "Unbound variable: SET!" var))))
|
||||
; Exercise 4.16.a
|
||||
(define (lookup-variable-value var env)
|
||||
(let ((value (cond ((lookup-binding var env) => cdr)
|
||||
(else '*unassigned*))))
|
||||
(if (eq? value '*unassigned*)
|
||||
(error "Unbound variable" var)
|
||||
value)))
|
||||
|
||||
; Exercise 4.3
|
||||
(define (make-table)
|
||||
(let ((local-table (list '*table*)))
|
||||
(define (lookup key)
|
||||
(let ((record (assoc key (cdr local-table))))
|
||||
(if record (cdr record) #f)))
|
||||
(define (insert! key value)
|
||||
(let ((record (assoc key (cdr local-table))))
|
||||
(if record
|
||||
(set-cdr! record value)
|
||||
(set-cdr! (let tail ((table local-table))
|
||||
(if (null? (cdr table)) table (tail (cdr table))))
|
||||
(list (cons key value)))))
|
||||
'ok)
|
||||
(define (dispatch m)
|
||||
(cond ((eq? m 'lookup-proc) lookup)
|
||||
((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))
|
||||
#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 (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 (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)))
|
||||
|
||||
; 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))
|
||||
|
||||
; Exercise 4.6
|
||||
(define (let->combination exp)
|
||||
(let ((ad (cadr exp))
|
||||
(dd (cddr exp)))
|
||||
(if (list? ad)
|
||||
(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))
|
||||
|
||||
; Exercise 4.7
|
||||
(define (let*->nested-lets exp)
|
||||
(let ((body (cddr exp)))
|
||||
(let loop ((bindings (cadr exp)))
|
||||
(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))
|
||||
|
||||
; 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))
|
||||
|
||||
; 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 primitive-procedures
|
||||
(let ((procedures (list (cons 'first car)
|
||||
(cons 'rest cdr)
|
||||
(cons 'cons cons)
|
||||
(cons 'null? null?)
|
||||
(cons 'assoc assoc)
|
||||
(cons 'display display)
|
||||
(cons 'newline newline)
|
||||
(cons '= =)
|
||||
(cons '< <)
|
||||
(cons '> >)
|
||||
(cons '+ +)
|
||||
(cons '- -)
|
||||
(cons '* *)
|
||||
(cons '/ /))))
|
||||
(map (lambda (p) (cons (car p) (list 'primitive (cdr p)))) procedures)))
|
||||
(define (make-environment . environments)
|
||||
(if (null? environments)
|
||||
the-empty-environment
|
||||
(extend-environment (car environments)
|
||||
(apply make-environment (cdr environments)))))
|
||||
|
||||
(define (evaluator-loop)
|
||||
(let loop ((environment (make-environment primitive-procedures
|
||||
(list (cons 'false #f)
|
||||
(cons 'true #t)
|
||||
(cons 'else #t)))))
|
||||
(display "> ")
|
||||
(let ((input (read)))
|
||||
(if (not (eq? input 'quit))
|
||||
(let ((output (evaluate input environment)))
|
||||
(display output)
|
||||
(newline)
|
||||
(loop environment))))))
|
||||
|
||||
; Exercise 4.21
|
||||
(define (factorial n)
|
||||
((lambda (fact) (fact fact n))
|
||||
(lambda (ft k) (if (= k 1) 1 (* k (ft ft (1- k)))))))
|
||||
(define (fibonacci n)
|
||||
((lambda (fib) (fib fib n))
|
||||
(lambda (f k)
|
||||
(if (or (= k 0) (= k 1))
|
||||
k
|
||||
(+ (f f (1- k))
|
||||
(f f (- k 2)))))))
|
||||
(define (f x)
|
||||
((lambda (even? odd?) (even? even? odd? x))
|
||||
(lambda (ev? od? n) (if (= n 0) #t (od? ev? od? (1- n))))
|
||||
(lambda (ev? od? n) (if (= n 0) #f (ev? ev? od? (1- n))))))
|
Loading…
Reference in New Issue