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
(cond ((assoc 'b '((a 1) (b 2))) => cadr)
(else false))
returns 2. Modify the handling of cond so that it supports this extended syntax.
分析
我们将在这个练习中支持 cond 的新语法。与之前 or 的练习一样，我们需要 lambda 语句来保证我们放到判断语句位置的语句只执行了一次。
例如下面的过程：
(define x 2)
(define y 3)
(define (predict-set?)
(set! y (+ y 1))
y)
(cond ((= x 1) (+ x 1))
((predict-set?) => inc)
(else 10))
也就是说我们需要把上面的语法在转变成为 if 语句的时候，变为：
(if (= x 1)
(+ x 1)
((lambda (v)
(if v
(inc v)
10))
(predict-set?)))
如果我们还是延续老的思路，转换成下面这样的形式就出错了，predict-set? 运行了两次， y 被 set 了两次：
(if (= x 1)
(+ x 1)
(if (predict-set?)
(inc (predict-set?))
10))
eval-new-cond 包
(load "3-data-directed-eval.scm")
(load "../testframe.scm")
;;; cond
(define (install-eval-new-cond)
(define (eval-cond exp env)
(eval (expand-clauses exp) env))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-arrow-clause? clause)
(and (= 3 (length clause)) (eq? (cadr clause) '=>)))
; selector
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond-arrow-action clause)
(caddr clause))
(define (sequence->exp seq)
((get 'export-1 sequence-tag) seq))
(define (make-if tst thn els)
((get 'constructor if-tag) tst thn els))
(define (make-lambda p b)
((get 'constructor lambda-tag) p b))
;; modified expand
;; supports the extended syntax
(define (expand-clauses clauses)
(if (null? clauses)
'false ; no else clause
(let ((first (car clauses))
(rest (cdr clauses)))
(cond ((and (cond-else-clause? first) (null? rest))
(sequence->exp (cond-actions first)))
((cond-else-clause? first)
(error "ELSE clause isn't last -- COND->IF"
clauses))
((cond-arrow-clause? first)
(list
(make-lambda (list 'v)
(list (make-if 'v
(list (cond-arrow-action first) 'v)
(expand-clauses rest))))
(cond-predicate first)))
(else
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))
)))))
(put 'eval cond-tag eval-cond))
;;; cond end
测试
下面的测试使用了习题中的示例。同时也使用上面分析中提到的带有 side-effect 的代码来进行测试。
(let ((test-env (setup-environment)))
(begin
(install-eval-new-cond)
(eval '(define (assoc key lst)
(cond ((null? lst) false)
((eq? key (car (car lst)))
(car lst))
(else (assoc key (cdr lst))))) test-env)
(asserteq? (eval '(assoc 'b '()) test-env) false)
(asserteq? (eval '(assoc 'b '((a 1) (c 1))) test-env) false)
(assertequal? (eval '(assoc 'b '((a 1) (b 2) (c 1))) test-env) '(b 2))
(assert= (eval '(cond ((assoc 'b '((a 1) (b 2))) => (lambda (x) (car (cdr x))))
(else false))
test-env)
2)
(assert= (eval '(cond ((assoc 'b '((a 1) (c 2))) => (lambda (x) (car (cdr x))))
(else 3))
test-env)
3)
(eval '(define x 2) test-env)
(eval '(define y 3) test-env)
(eval '(define (inc x) (+ x 1)) test-env)
(eval '(define (predict-set?)
(set! y (+ y 1))
y) test-env)
(assert= (eval '(cond ((= x 1) (+ x 1))
((predict-set?) => inc)
(else 10)) test-env)
5)
))