8.16
4 Chapter 4. Metalinguistic Abstraction
4.1 The Metacircular Evaluator
4.1.1 The Core of the Evaluator
4.1.1.1 Exercise 4.1
Notice that we cannot tell whether the metacircular evaluator evaluates operands from left to right or from right to left. Its evaluation order is inherited from the underlying Lisp: If the arguments to cons in list-of-values are evaluated from left to right, then list-of-values will evaluate operands from left to right; and if the arguments to cons are evaluated from right to left, then list-of-values will evaluate operands from right to left.
Write a version of list-of-values that evaluates operands from left to right regardless of the order of evaluation in the underlying Lisp. Also write a version of list-of-values that evaluates operands from right to left.
Solution:
#lang racket/base (define ((list-of-values-ltr eval) exps) (if (null? exps) '() (let ([first-value (eval (car exps))]) (cons first-value ((list-of-values-ltr eval) (cdr exps)))))) (define ((list-of-values-rtl eval) exps) (if (null? exps) '() (let ([rest-values ((list-of-values-rtl eval) (cdr exps))]) (cons (eval (car exps)) rest-values)))) (module+ test (require akari-sicp/lib/testing) (define eval-sequence '()) ;; Mock eval function that records evaluation order (define (mock-eval exp) (set! eval-sequence (append eval-sequence (list exp))) exp) ;; Create test list-of-values functions with our mock eval (define list-of-values-ltr-test (list-of-values-ltr mock-eval)) (define list-of-values-rtl-test (list-of-values-rtl mock-eval)) ;; Test expressions (define test-expressions '(1 2 3 4 5)) ;; Test suite (run-tests (describe "Exercise 4.1: list-of-values evaluation order" (it "evaluates expressions from left to right with list-of-values-ltr" (set! eval-sequence '()) (list-of-values-ltr-test test-expressions) (expect [eval-sequence => '(1 2 3 4 5)])) (it "evaluates expressions from right to left with list-of-values-rtl" (set! eval-sequence '()) (list-of-values-rtl-test test-expressions) (expect [eval-sequence => '(5 4 3 2 1)])) (it "returns the correct results regardless of evaluation order (ltr)" (expect [(list-of-values-ltr-test test-expressions) => '(1 2 3 4 5)])) (it "returns the correct results regardless of evaluation order (rtl)" (expect [(list-of-values-rtl-test test-expressions) => '(1 2 3 4 5)])) (it "handles empty expressions list for ltr" (expect [(list-of-values-ltr-test '()) => '()])) (it "handles empty expressions list for rtl" (expect [(list-of-values-rtl-test '()) => '()])))))
4.1.2 Representing Expressions
4.1.2.1 Exercise 4.3
Rewrite eval so that the dispatch is done in data-directed style. Compare this with the data-directed differentiation procedure of Exercise 2.73. (You may use the car of a compound expression as the type of the expression, as is appropriate for the syntax implemented in this section.)
#lang racket/base (provide primitive-procedure@ compound-procedure@ evaluator-environment@ metacircular-evaluator@ evaluator-compound@) (require racket/match racket/unit (only-in akari-sicp/lib/common apply-in-underlying-scheme) "signatures.rkt" "ch4-ex12.rkt") (define-unit primitive-procedure@ (import) (export primitive-procedure^) (define (make-primitive proc) (list 'primitive proc)) (define (primitive-procedure? proc) (match proc [(list 'primitive _) #t] [_ #f])) (define (primitive-implementation proc) (cadr proc)) (define (apply-primitive-procedure proc args) (apply-in-underlying-scheme (primitive-implementation proc) args))) (define-unit compound-procedure@ (import) (export compound-procedure^) (define (make-procedure parameters body env) (list 'procedure parameters body env)) (define (compound-procedure? proc) (match proc [(list 'procedure _ _ _) #t] [_ #f])) (define procedure-parameters cadr) (define procedure-body caddr) (define procedure-environment cadddr)) (define-unit metacircular-evaluator@ (import primitive-procedure^ compound-procedure^ evaluator-environment^) (export metacircular-evaluator^) (define primitive-procedures (list (list 'car (make-primitive mcar)) (list 'cdr (make-primitive mcdr)) (list 'cons (make-primitive mcons)) (list 'null? (make-primitive null?)) (list '+ (make-primitive +)) (list '- (make-primitive -)) (list '* (make-primitive *)) (list '/ (make-primitive /)) (list '= (make-primitive =)) (list '> (make-primitive >)) (list '< (make-primitive <)) (list '>= (make-primitive >=)) (list '<= (make-primitive <=)) (list 'eq? (make-primitive eq?)) (list 'eqv? (make-primitive eqv?)))) (define (setup-base-environment) (extend-environment (map car primitive-procedures) (map cadr primitive-procedures) the-empty-environment)) (define (true? x) (not (false? x))) (define (false? x) (eq? x #f)) (define (cons->mcons lst) (let loop ([elements lst]) (cond [(not (pair? elements)) elements] [(null? elements) '()] [(pair? (car elements)) (mcons (cons->mcons (car elements)) (loop (cdr elements)))] [else (mcons (car elements) (loop (cdr elements)))]))) (define text-of-quotation (match-lambda [(list 'quote datum) (cons->mcons datum)] [otherwise (error 'text-of-quotation "expected a quote expression, got ~a" otherwise)])) (define eval-if (match-lambda [(list 'if predicate consequent alternative) (if (true? (eval predicate)) (eval consequent) (eval alternative))] [otherwise (error 'eval-if "expected an if expression, got ~a" otherwise)])) (define (eval-sequence seq) (define last-exp? (null? (cdr seq))) (cond [last-exp? (eval (car seq))] [else (eval (car seq)) (eval-sequence (cdr seq))])) (define eval-begin (match-lambda [(list 'begin statements ...) (eval-sequence statements)] [otherwise (error 'eval-begin "expected a begin expression, got ~a" otherwise)])) (define eval-assignment (match-lambda [(list 'set! var val) (set-variable-value! var (eval val) (current-environment)) ] [otherwise (error 'eval-assignment "expected a set! expression, got ~a" otherwise)])) (define eval-definition (match-lambda [(list 'define (list fun params ...) body ...) (define-variable! fun (eval `(lambda ,params ,@body)) (current-environment))] [(list 'define var val) (define-variable! var (eval val) (current-environment))] [otherwise (error 'eval-definition "expected a define expression, got ~a" otherwise)])) (define eval-lambda (match-lambda [(list 'lambda params body ...) (make-procedure params body (current-environment))] [otherwise (error 'eval-lambda " expected a lambda expression, got ~a" otherwise)])) (define (self-evaluating? exp) (or (number? exp) (string? exp) (boolean? exp))) (define (variable? exp) (symbol? exp)) (define (application? exp) (pair? exp)) (define (list-of-values exps) (map eval exps)) (define (setup-base-special-form-handlers) (hasheq 'quote text-of-quotation 'lambda eval-lambda 'if eval-if 'begin eval-begin 'define eval-definition 'set! eval-assignment)) (define current-environment (make-parameter (setup-base-environment))) (define special-form-handlers (make-parameter (setup-base-special-form-handlers))) (define (eval exp) (cond [(self-evaluating? exp) exp] [(variable? exp) (lookup-variable-value exp (current-environment))] [(hash-has-key? (special-form-handlers) (car exp)) ((hash-ref (special-form-handlers) (car exp)) exp)] [(application? exp) (apply (eval (car exp)) (list-of-values (cdr exp)))] [else (error 'eval "Unknown expression type" exp)])) (define (application-environment proc args) (extend-environment (procedure-parameters proc) args (procedure-environment proc))) (define (apply procedure arguments) (cond [(primitive-procedure? procedure) (apply-primitive-procedure procedure arguments)] [(compound-procedure? procedure) (parameterize ([current-environment (application-environment procedure arguments)]) (eval-sequence (procedure-body procedure)))] [else (error 'apply "Unknown procedure type ~a" procedure)]))) (define-compound-unit/infer evaluator-compound@ (import) (export primitive-procedure^ compound-procedure^ evaluator-environment^ metacircular-evaluator^) (link primitive-procedure@ compound-procedure@ evaluator-environment@ metacircular-evaluator@)) (module+ test (require akari-sicp/lib/testing akari-sicp/lib/mcons) (define-values/invoke-unit/infer evaluator-compound@) (run-tests (describe "exercise 4.3" (it "evaluates self-evaluating expressions" (expect [(eval 42) => 42] [(eval "hello") => "hello"])) (it "handles variable lookup" (parameterize ([current-environment (extend-environment '(x y z) '(1 2 3) (current-environment))]) (expect [(eval 'x) => 1] [(eval 'y) => 2] [(eval 'z) => 3]))) (it "evaluates quote expressions" (expect [(eval '(quote hello)) => 'hello] [(eval '(quote (1 2 3))) => (mlist 1 2 3)])) (it "applies primitive procedures" (expect [(eval '(car (quote (1 2 3)))) => 1] [(eval '(cdr (quote (1 2 3)))) => (mlist 2 3)] [(eval '(cons 1 (quote (2 3)))) => (mlist 1 2 3)] [(eval '(null? (quote ()))) => #t] [(eval '(null? (quote (1)))) => #f] [(eval '(+ 2 3)) => 5] [(eval '(- 5 2)) => 3] [(eval '(* 2 3)) => 6] [(eval '(/ 6 2)) => 3] [(eval '(= 2 2)) => #t])) (it "evaluates if expressions" (expect [(eval '(if #t 1 2)) => 1] [(eval '(if #f 1 2)) => 2] [(eval '(if (= 2 2) 'yes 'no)) => 'yes] [(eval '(if (= 2 3) 'yes 'no)) => 'no])) (it "evaluates begin expressions" (eval '(define x 0)) (eval '(begin (set! x 1) (set! x (+ x 1)))) (expect [(eval 'x) => 2])) (it "evaluates set! expressions" (eval '(define x 1)) (eval '(set! x 42)) (expect [(eval 'x) => 42])) (it "evaluates define expressions" (eval '(define x 10)) (expect [(eval 'x) => 10]) (eval '(define (double y) (+ y y))) (expect [(eval '(double 5)) => 10])) (it "evaluates lambda expressions and applies compound procedures" (eval '(define square (lambda (x) (* x x)))) (expect [(eval '(square 5)) => 25]) (eval '(define (factorial n) (if (= n 0) 1 (* n (factorial (- n 1)))))) (expect [(eval '(factorial 5)) => 120])))))
4.1.2.2 Exercise 4.4
Install and and or as new special forms for the evaluator by defining appropriate syntax procedures and evaluation procedures eval-and and eval-or. Alternatively, show how to implement and and or as derived expressions.
#lang racket/base (provide eval-and eval-or) (require racket/match) (define (expand-and-expressions exps) (if (null? exps) '#t `(if ,(car exps) ,(expand-and-expressions (cdr exps)) #f))) (define ((eval-and eval) datum) (match datum [(list 'and exps ...) (eval (expand-and-expressions exps))])) (define (expand-or-expressions exps) (if (null? exps) '#f `(if ,(car exps) #t ,(expand-or-expressions (cdr exps))))) (define ((eval-or eval) datum) (match datum [(list 'or exps ...) (eval (expand-or-expressions exps))])) (module+ test (require akari-sicp/lib/testing) (run-tests (describe "Logical Expression Expansion Tests" (describe "expand-and-expressions" (it "should expand empty and expression to #t" (expect [(expand-and-expressions '()) => '#t])) (it "should correctly expand and with a single expression" (expect [(expand-and-expressions '(a)) => '(if a #t #f)])) (it "should correctly expand and with multiple expressions" (expect [(expand-and-expressions '(a b c)) => '(if a (if b (if c #t #f) #f) #f)]))) (describe "expand-or-expressions" (it "should expand empty or expression to #f" (expect [(expand-or-expressions '()) => '#f])) (it "should correctly expand or with a single expression" (expect [(expand-or-expressions '(a)) => '(if a #t #f)])) (it "should correctly expand or with multiple expressions" (expect [(expand-or-expressions '(a b c)) => '(if a #t (if b #t (if c #t #f)))]))) ;; Test the evaluator functions with mock eval function (describe "eval-and function" (it "should use the expanded form for evaluation" (let ([mock-eval (lambda (expr) (expect [expr => '(if a (if b #t #f) #f)]) 'result)]) (expect [((eval-and mock-eval) '(and a b)) => 'result])))) (describe "eval-or function" (it "should use the expanded form for evaluation" (let ([mock-eval (lambda (expr) (expect [expr => '(if a #t (if b #t #f))]) 'result)]) (expect [((eval-or mock-eval) '(or a b)) => 'result])))))))
4.1.2.3 Exercise 4.5
Scheme allows an additional syntax for cond clauses, (⟨test⟩ => ⟨recipient⟩). If ⟨test⟩ evaluates to a true value, then ⟨recipient⟩ is evaluated. Its value must be a procedure of one argument; this procedure is then invoked on the value of the ⟨test⟩, and the result is returned as the value of the cond expression. For example
returns 2. Modify the handling of cond so that it supports
this extended syntax.
#lang racket/base (require racket/match racket/unit "ch4-ex03.rkt" "signatures.rkt") (define-unit cond-extension@ (import metacircular-evaluator^) (export cond-extension^) (define eval-cond (match-lambda [(list 'cond cond-clauses ...) (eval (expand-cond-clauses cond-clauses))] [otherwise (error 'eval-cond "Invalid cond form: ~a" otherwise)]))) (define (expand-cond-clauses clauses) (if (null? clauses) #f (match (car clauses) [(list 'else body ...) `(begin ,@body)] [(list predicate '=> recipient) `((lambda (predicate-result) (if predicate-result (,recipient predicate-result) ,(expand-cond-clauses (cdr clauses)))) ,predicate)] [(list predicate body ...) `(if ,predicate (begin ,@body) ,(expand-cond-clauses (cdr clauses)))] [_ (error 'eval-cond "Invalid cond clause: ~a" (car clauses))]))) (module+ test (require akari-sicp/lib/testing) (define-values/invoke-unit/infer (link cond-extension@ evaluator-compound@)) (special-form-handlers (hash-set (special-form-handlers) 'cond eval-cond)) (run-tests (describe "expand-cond-clauses" (it "transforms basic cond to nested if expressions" (let ([datum '(cond (#t 1) (#f 2))]) (expect [(expand-cond-clauses (cdr datum)) => '(if #t (begin 1) (if #f (begin 2) #f))]))) (it "transforms arrow syntax cond correctly" (let ([datum '(cond (#t => display))]) (expect [(expand-cond-clauses (cdr datum)) => '((lambda (predicate-result) (if predicate-result (display predicate-result) #f)) #t)]))) (describe "cond as a special form" (it "evaluates basic cond expressions" (parameterize ([current-environment (extend-environment '(a b) '(10 20) (current-environment))]) (expect [(eval '(cond ((> a 5) a) ((> b 5) b) (else 0))) => 10] [(eval '(cond ((> a 15) a) ((> b 15) b) (else 0))) => 20]))) (it "evaluates cond with arrow syntax" (parameterize ([current-environment (extend-environment '(a square identity) (list 4 (eval '(lambda (x) (* x x))) (eval '(lambda (x) x))) (current-environment))]) (expect [(eval '(cond (a => square) (else 0))) => 16] [(eval '(cond ((< a 0) => square) (else 0))) => 0]))) (it "handles complex cond expressions with arrow syntax" (parameterize ([current-environment (extend-environment '(x y inc double bool->num) (list 5 10 (eval '(lambda (n) (+ n 1))) (eval '(lambda (n) (* n 2))) (eval '(lambda (b) (if b 1 0)))) (current-environment))]) (expect [(eval '(cond (x => inc) ((= y 10) y) (else 0))) => 6] [(eval '(cond ((= x 5) => bool->num) ((> y 20) y) (else 0))) => 1] [(eval '(cond ((> x 10) => inc) (y => double) (else 0))) => 20])))))))
4.1.2.4 Exercise 4.6
Let expressions are derived expressions, because
is equivalent to
Implement a syntactic transformation let->combination that reduces let expressions to procedure calls as shown, and add the appropriate clause to eval to handle let expressions.
#lang racket/base (provide let-extension@) (require racket/match racket/unit "signatures.rkt" "ch4-ex03.rkt") (define (let->combination datum) (match datum [(list 'let decls body ...) (define vars (map car decls)) (define exps (map cadr decls)) `((lambda ,vars ,@body) ,@exps)])) ;; Handler for let special form (define-unit let-extension@ (import metacircular-evaluator^) (export let-extension^) (define (eval-let datum) (eval (let->combination datum)))) (module+ test (require akari-sicp/lib/testing) (define-values/invoke-unit/infer (link evaluator-compound@ let-extension@)) (special-form-handlers (hash-set (special-form-handlers) 'let eval-let)) (run-tests (describe "let->combination" (it "transforms let into a lambda expression" (let ((datum '(let ((x 1) (y 2)) (+ x y)))) (expect [(let->combination datum) => '((lambda (x y) (+ x y)) 1 2)]))) (describe "let as a special form" (it "evaluates let expressions directly" (parameterize ([current-environment (extend-environment '(a b) '(10 20) (current-environment))]) (expect [(eval '(let ((x 3) (y 4)) (+ x y))) => 7] [(eval '(let ((x a) (y b)) (+ x y))) => 30]))) (it "supports nested let expressions" (parameterize ([current-environment (extend-environment '(z) '(5) (current-environment))]) (expect [(eval '(let ((x 1)) (let ((y z)) (+ x y)))) => 6])))))))
4.1.2.5 Exercise 4.7
let* is similar to let, except that the bindings of the let* variables are performed
sequentially from left to right, and each binding is made in an environment in which all of the
preceding bindings are visible. For example
returns 39. Explain how a let* expression can be rewritten as a set of nested let expressions, and write a procedure let*->nested-lets that performs this transformation. If we have already implemented let (Exercise 4.6) and we want to extend the evaluator to handle let*, is it sufficient to add a clause to eval whose action is
or must we explicitly expand let* in terms of non-derived expressions?
Solution:
#lang racket/base (require racket/match racket/unit "signatures.rkt" "ch4-ex03.rkt" "ch4-ex06.rkt") (define (let*->nested-lets exp) (match exp [(list 'let* bindings body) (let loop ([bds bindings]) (if (null? bds) body `(let (,(car bds)) ,(loop (cdr bds)))))])) (define-unit let*-extensions@ (import let-extension^) (export let*-extension^) (define (eval-let* exp) (eval-let (let*->nested-lets exp)))) (module+ test (require akari-sicp/lib/testing) (define-values/invoke-unit/infer (link evaluator-compound@ let-extension@ let*-extensions@)) (special-form-handlers (hash-set (special-form-handlers) 'let* eval-let*)) (run-tests (describe "test eval-let*" (it "expand to nested let" (expect [(let*->nested-lets '(let* ([x 1] [y 2]) (+ x y))) => '(let ([x 1]) (let ([y 2]) (+ x y)))])) (it "eval let* directly" (expect [(eval (let* ([x 1] [y (+ x 1)]) (+ x y))) => 3])))))
4.1.2.6 Exercise 4.8
“Named let” is a variant of let that has the form
(let ⟨var⟩ ⟨bindings⟩ ⟨body⟩)
The ⟨bindings⟩ and ⟨body⟩ are just as in ordinary let, except that ⟨var⟩ is bound within ⟨body⟩ to a procedure whose body is ⟨body⟩ and whose parameters are the variables in the ⟨bindings⟩. Thus, one can repeatedly execute the ⟨body⟩ by invoking the procedure named ⟨var⟩. For example, the iterative Fibonacci procedure (Section 1.2.2) can be rewritten using named let as follows:
(define (fib n) (let fib-iter ((a 1) (b 0) (count n)) (if (= count 0) b (fib-iter (+ a b) a (- count 1)))))
Modify let->combination of Exercise 4.6 to also support named let.
Solution:
#lang racket/base (provide let-extension@) (require racket/match racket/unit "signatures.rkt" "ch4-ex03.rkt") (define-unit let-extension@ (import metacircular-evaluator^ evaluator-environment^ compound-procedure^) (export let-extension^) (define (eval-let datum) (match datum [(list 'let (? symbol? name) (list (list vars vals) ...) body ...) (define lmb (parameterize ([current-environment (extend-environment (list name) (list '**unassigned**) (current-environment))]) (define lmb (make-procedure vars body (current-environment))) (set-variable-value! name lmb (current-environment)) lmb)) (apply lmb (let loop ([args vals]) (if (null? args) '() (cons (eval (car args)) (loop (cdr args))))))] [(list 'let (list (list vars vals) ...) body ...) (eval `((lambda ,vars ,@body) ,@vals))] [_ (error 'eval-let "invalid let form ~a" datum)])) ) (module+ test (require akari-sicp/lib/testing) (define-values/invoke-unit/infer (link evaluator-compound@ let-extension@)) (special-form-handlers (hash-set (special-form-handlers) 'let eval-let)) (run-tests (describe "eval-let with named let support" (it "evaluates let expressions directly" (parameterize ([current-environment (extend-environment '(a b) '(10 20) (current-environment))]) (expect [(eval '(let ((x 3) (y 4)) (+ x y))) => 7] [(eval '(let ((x a) (y b)) (+ x y))) => 30]))) (it "supports nested let expressions" (parameterize ([current-environment (extend-environment '(z) '(5) (current-environment))]) (expect [(eval '(let ((x 1)) (let ((y z)) (+ x y)))) => 6]))) (it "support named let" (eval '(define (fib n) (let fib-iter ([a 1] [b 0] [count n]) (if (= count 0) b (fib-iter (+ a b) a (- count 1)))))) (expect [(eval '(fib 1)) => 1] [(eval '(fib 2)) => 1] [(eval '(fib 3)) => 2] [(eval '(fib 4)) => 3] [(eval '(fib 5)) => 5] [(eval '(fib 6)) => 8])))))
4.1.2.7 Exercise 4.9
Many languages support a variety of iteration constructs, such as do, for, while, and until. In Scheme, iterative processes can be expressed in terms of ordinary procedure calls, so special iteration constructs provide no essential gain in computational power. On the other hand, such constructs are often convenient. Design some iteration constructs, give examples of their use, and show how to implement them as derived expressions.
Solution:
#lang racket/base (require racket/match racket/unit "signatures.rkt" "ch4-ex03.rkt") (define-signature while-extension^ (eval-while)) (define-unit while-extension@ (import metacircular-evaluator^) (export while-extension^) (define (eval-while datum) (define while-sym (gensym "while-loop")) (match datum [(list 'while predicate body ...) (eval `(begin (define (,while-sym) (if ,predicate (begin ,@body (,while-sym)) 'done)) (,while-sym)))]))) (module+ test (require akari-sicp/lib/testing) (define-values/invoke-unit/infer (link evaluator-compound@ while-extension@)) (special-form-handlers (hash-set (special-form-handlers) 'while eval-while)) (run-tests (describe "test while loop" (it "exit immediately" (expect [(eval '(while #f (displayln "X"))) =$> '()])) (it "calculate sum" (define exp '(begin (define s 0) (define i 1) (while (< i 10) (set! s (+ s i)) (set! i (+ i 1))) (cons s i))) (expect [(eval exp) => (mcons 45 10)])))))
4.1.2.8 Exercise 4.10
By using data abstraction, we were able to write an eval procedure that is independent of the particular syntax of the language to be evaluated. To illustrate this, design and implement a new syntax for Scheme by modifying the procedures in this section, without changing eval or apply.
Solution:
See Exercise 4.3
4.1.3 Evaluator Data Structures
4.1.3.1 Exercise 4.11
Instead of representing a frame as a pair of lists, we can represent a frame as a list of bindings, where each binding is a name-value pair. Rewrite the environment operations to use this alternative representation.
#lang racket/base (provide evaluator-environment@) (require racket/unit akari-sicp/lib/mcons "signatures.rkt") ;; a binding is the variable name with corresponding value (define (make-binding var val) (mcons var val)) (define (binding-var binding) (mcar binding)) (define (binding-val binding) (mcdr binding)) (define (set-binding-val! binding val) (set-mcdr! binding val)) (define-unit evaluator-environment@ (import) (export evaluator-environment^) ;; a frame is a mlist of bindings ;; represent an environment as a mlist of frames (define (enclosing-environment env) (mcdr env)) (define (first-frame env) (mcar env)) (define (add-binding-to-first-frame! var val env) (set-mcar! env (mcons (mcons var val) (mcar env)))) (define the-empty-environment '()) ;; to extend an environment, we make a frame consisting of the bindings ;; and adjoin this frame to the environment (define (extend-environment vars vals base-env) (define bindings (list->mlist (map make-binding vars vals))) (mcons bindings base-env)) ;; loop up a variable in an environment (define (lookup-variable-value var env) (define (env-loop env) ;; scan the mlist of bindings in the frame (define (scan bindings) (cond [(null? bindings) ; we have reached the end of current frame (env-loop (enclosing-environment env))] ; scan the next frame [(eq? var (binding-var (mcar bindings))) ; found the variable (binding-val (mcar bindings))] ; return the value [else (scan (mcdr bindings))])) ; continue scanning (if (eq? env the-empty-environment) ; no more frames (error "Unbound variable" var) ; error (scan (first-frame env)))) ;; start the loop (env-loop env)) ;; set a variable to a new value in a specified environment (define (set-variable-value! var val env) (define (env-loop env) (define (scan bindings) (cond [(null? bindings) ; the end of a frame (env-loop (enclosing-environment env))] ; look up the next frame [(eq? var (binding-var (mcar bindings))) (set-binding-val! (mcar bindings) val)] ; set the value [else (scan (mcdr bindings))])) (if (eq? env the-empty-environment) (error "Unbound variable -- SET!" var) (scan (first-frame env)))) (env-loop env)) ;; define a variable (define (define-variable! var val env) (define (scan bindings) ;; if we can't find the variable in the current frame (cond [(null? bindings) ;; add the variable to the current frame (add-binding-to-first-frame! var val env)] ;; if we find the variable in the current frame [(eq? var (binding-var (mcar bindings))) ;; set the value of the variable (set-binding-val! (mcar bindings) val)] [else (scan (mcdr bindings))])) ; continue scanning (scan (first-frame env)))) (module+ test (require akari-sicp/lib/testing) (define-values/invoke-unit/infer evaluator-environment@) (define base-env (mlist (mlist (make-binding 'a 10) (make-binding 'b 20)))) (run-tests (describe "test environment" (it "extend-environment" (define extended-env (extend-environment (list 'x 'y) (list 1 2) base-env)) (expect [(mlength extended-env) => 2] [(mcar extended-env) => (mlist (make-binding 'x 1) (make-binding 'y 2))] [(equal? (msecond extended-env) (mfirst base-env)) => #t])) (it "lookup-variable-value" (define env (extend-environment (list 'x 'y) (list 1 2) base-env)) (expect [(lookup-variable-value 'x env) => 1] [(lookup-variable-value 'y env) => 2] [(lookup-variable-value 'a env) => 10] [(lookup-variable-value 'b env) => 20] [(lookup-variable-value 'z env) =!> #rx"Unbound variable"])) (it "set-variable-value!" (define env (extend-environment (list 'x 'y) (list 1 2) base-env)) (set-variable-value! 'x 100 env) (set-variable-value! 'a 1000 env) (expect [(lookup-variable-value 'x env) => 100] [(lookup-variable-value 'y env) => 2] [(lookup-variable-value 'a env) => 1000] [(lookup-variable-value 'b env) => 20] [(set-variable-value! 'z 30 env) =!> #rx"Unbound variable"])) (it "define-variable!" (define env (extend-environment (list 'x 'y) (list 1 2) base-env)) ;; Update existing variable (define-variable! 'x 100 env) (expect [(lookup-variable-value 'x env) => 100]) ;; Add new variable to first frame (define-variable! 'z 30 env) (expect [(lookup-variable-value 'z env) => 30] ;; Base environment shouldn't be affected [(lookup-variable-value 'z base-env) =!> #rx"Unbound variable"]))) ))
4.1.3.2 Exercise 4.12
The procedures define-variable!, set-variable-value!, and lookup-variable-value can be expressed in terms of more abstract procedures for traversing the environment structure. Define abstractions that capture the common patterns and redefine the three procedures in terms of these abstractions.
#lang racket/base (provide evaluator-environment@) (require racket/unit akari-sicp/lib/mcons "signatures.rkt") ;; each frame of an environment is represented as a pair of lists: ;; - a list of the variables bound in the frame ;; - a list of the associated values (define (make-frame variables values) (mcons variables values)) (define (frame-variables frame) (mcar frame)) (define (frame-values frame) (mcdr frame)) (define (add-binding-to-frame! var val frame) (set-mcar! frame (mcons var (mcar frame))) (set-mcdr! frame (mcons val (mcdr frame)))) (module+ test (require akari-sicp/lib/testing racket/list) (define test-frame (make-frame (mlist 'x 'y) (mlist 1 2))) (define frame-tests (describe "test frame" (it "frame-variables / frame-values" (expect [(frame-variables test-frame) => (mlist 'x 'y)] [(frame-values test-frame) => (mlist 1 2)])) (it "add-binding-to-frame!" (add-binding-to-frame! 'z 3 test-frame) (expect [(frame-variables test-frame) => (mlist 'z 'x 'y)] [(frame-values test-frame) => (mlist 3 1 2)]))))) (define-unit evaluator-environment@ (import) (export evaluator-environment^) ;; represent an environment as a list of frames (define (enclosing-environment env) (cdr env)) (define (first-frame env) (car env)) (define the-empty-environment '()) ;; to extend an environment, we make a frame consisting of ;; the list of variables and the list of values ;; and we adjoin this frame to the environment (define (extend-environment vars vals base-env) (when (< (length vars) (length vals)) (error "Too many arguments supplied" vars vals)) (when (> (length vars) (length vals)) (error "Too few arguments supplied" vars vals)) (cons (make-frame (list->mlist vars) (list->mlist vals)) base-env)) (define (find-in-environment env var found not-found) (define (scan vars vals) (cond [(null? vars) (not-found (first-frame env) (enclosing-environment env))] [(eq? var (mcar vars)) (found vals)] [else (scan (mcdr vars) (mcdr vals))])) (if (eq? env the-empty-environment) (error 'find-in-environment "Unbound variable ~v" var) (let ([frame (first-frame env)]) (scan (frame-variables frame) (frame-values frame))))) ;; loop up a variable in an environment (define (lookup-variable-value var env) (find-in-environment env var (lambda (vals) (mcar vals)) (lambda (_ enclosing) (lookup-variable-value var enclosing)))) ;; set a variable to a new value in a specified environment (define (set-variable-value! var val env) (find-in-environment env var (lambda (vals) (set-mcar! vals val)) (lambda (_ enclosing) (set-variable-value! var val enclosing)))) (define (define-variable! var val env) (find-in-environment env var (lambda (vals) (set-mcar! vals val)) (lambda (frame _) (add-binding-to-frame! var val frame))))) (module+ test (define base-env (list (make-frame (mlist 'a 'b) (mlist 10 20)))) (define-values/invoke-unit/infer evaluator-environment@) (define environment-tests (describe "test environment" (it "extend-environment" (define extended-env (extend-environment (list 'x 'y) (list 1 2) base-env)) (expect [(length extended-env) => 2] [(frame-variables (first extended-env)) => (mlist 'x 'y)] [(frame-values (first extended-env)) => (mlist 1 2)] [(equal? (second extended-env) (first base-env)) => #t])) (it "lookup-variable-value" (define env (extend-environment (list 'x 'y) (list 1 2) base-env)) (expect [(lookup-variable-value 'x env) => 1] [(lookup-variable-value 'y env) => 2] [(lookup-variable-value 'a env) => 10] [(lookup-variable-value 'b env) => 20] [(lookup-variable-value 'z env) =!> #rx"Unbound variable"])) (it "set-variable-value!" (define env (extend-environment (list 'x 'y) (list 1 2) base-env)) (set-variable-value! 'x 100 env) (set-variable-value! 'a 1000 env) (expect [(lookup-variable-value 'x env) => 100] [(lookup-variable-value 'y env) => 2] [(lookup-variable-value 'a env) => 1000] [(lookup-variable-value 'b env) => 20] [(set-variable-value! 'z 30 env) =!> #rx"Unbound variable"])) (it "define-variable!" (define env (extend-environment (list 'x 'y) (list 1 2) base-env)) ;; Update existing variable (define-variable! 'x 100 env) (expect [(lookup-variable-value 'x env) => 100]) ;; Add new variable to first frame (define-variable! 'z 30 env) (expect [(lookup-variable-value 'z env) => 30] ;; Base environment shouldn't be affected [(lookup-variable-value 'z base-env) =!> #rx"Unbound variable"]))))) (module+ test (run-tests (describe "exercise 4.12" frame-tests environment-tests)))