計算機プログラムの構造と解釈 第二版 P222 問題4.5

そもそもcondにこんな機能がついてたなんて知らないんだけど。
使い方は教科書のとおり。

実際にやってみると、できるのでできるんだなぁと思う。

condの修正は前のページでやっていた導出された式で使われてたcondのexpand-clausesを修正すれば良さそう。

もともとはこんな感じ

(define (expand-clauses clauses)
  (if (null? clauses)
    'false                          ; no else clause
    (let ((first (car clauses))
          (rest (cdr clauses)))
      (if (cond-else-clause? first)
        (if (null? rest)
          (sequence->exp (cond-actions first))
          (error "ELSE clause isn't last -- COND->IF"
                 clauses))
        (make-if (cond-predicate first)
                 (sequence->exp (cond-actions first))
                 (expand-clauses rest))))))

じとーッと眺めていると、make-ifに与える引数を帰れば良さそう。
ちなみにmake-ifはこんな感じです。

(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

predicateにあたる引数はこのままな感じ
consequentが変わる。
sequence->expをみてみると、

(define (sequence->exp seq)
  (cond ((null? seq) seq)
        ((last-exp? seq) (first-exp seq))
        (else (make-begin seq))))

複数の式があった場合に、beginをつける位のしょりだから、
普通にリスト形式で返せば良いかと思います。

後小さいことなんだけど、assoc、cadrをprimitive-proceduresに付け足さないと、
教科書に載っているコードが機能しない。

#!/usr/local/bin/gosh
;; -*- coding: utf-8 -*-
(print (cond ((assoc 'b '((a 1) (b 2))) => cadr)
             (else false)))


(load "./modules/4th.scm")

(define (expand-clauses clauses)
  (if (null? clauses)
    'false
    (let ((first (car clauses))
          (rest (cdr clauses)))
      (if (cond-else-clause? first)
        (if (null? rest)
          (sequence->exp (cond-actions first))
          (error "ELSE clause isn't last -- COND->IF"
                 clauses))
        (make-if (cond-predicate first)
                 (let ((predicate (cond-predicate first))
                       (action (cond-actions first)))
                   (if (eq? (car action) '=>)
                     (list (cadr action) predicate)
                     (sequence->exp action)))
                 (expand-clauses rest))))))


(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cadr cadr)
        (list 'cons cons)
        (list 'null? null?)
        (list '+ +)
        (list '* *)
        (list 'assoc assoc) ;; 4.5
        ;  <基本手続きが続く>
        ))

(define the-global-environment (setup-environment))
(driver-loop)


実行

2


;;; M-Eval input:
(cond ((assoc 'b '((a 1) (b 2))) => cadr)
(else false))

;;; M-Eval value:
2

始めの2はプリミティブでの実行。