問題2-84

raiseを使ってapply-genericを改善します。これによって、get-coercion/put-coercionやt1->t2のような型変換のベタ書きを排除することができます。まずは、オブジェクトツリーの各要素に自身のレベルを表す値を返すような手続きを追加しました。

;(define (tree-level x) (apply-generic 'tree-level x))
(define (tree-level x) ((get 'tree-level (type-tag x)) x))

(define (install-scheme-number-package) 
  ;;other code
  (put 'tree-level 'scheme-number
       (lambda (x) 1))
  ;;other code
  'done)

(define (install-rational-package)
  ;;other code
  (put 'tree-level 'rational
       (lambda (x) 2))
  ;;other code
  'done)

(define (install-scheme-real-package) 
  ;;other code
  (put 'tree-level 'scheme-real
       (lambda (x) 3))
  ;;other code
  'done)

(define (install-complex-package)
  ;;other code
  (put 'tree-level 'complex
       (lambda (z1) 4))
  ;;other code
  'done)

(tree-level 3)  ;=>1
(type-tag 3)  ;=>scheme-number

(tree-level (raise 3))  ;=>2
(type-tag (raise 3))  ;=>rational

(tree-level (raise (raise 3)))  ;=>3
(type-tag (raise (raise 3)))  ;=>scheme-real

(tree-level (raise (raise (raise 3))))  ;=>4
(type-tag (raise (raise (raise 3))))  ;=>complex

tree-levelを使うことによって、演算を行なう二つの値の各型のレベルの違いを認識することができ、どちらの値を型変換(raise)すべきなのかを判別することができます。この概念を取り入れ、apply-genericを以下のように修正しました。

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let ((a1 (car args))
                    (a2 (cadr args)))
                (let ((a1-lv (tree-level a1))
                      (a2-lv (tree-level a2)))
                  (cond ((= a1-lv a2-lv)
                         (error "No method for these same types"
                                (list op type-tags)))                              
                        ((< a1-lv a2-lv)
                         (apply-generic op (raise a1) a2))
                        ((> a1-lv a2-lv)
                         (apply-generic op a1 (raise a2)))
                        (else
                         (error "No method for these types"
                                (list op type-tags))))))
              (error "No method for these types"
                     (list op type-tags)))))))

(add 3 4)  ;=>(scheme-number . 7)
(add 1 (make-rational 1 3))  ;=>(rational 4 . 3)
(add 5 6.3)  ;=>(scheme-real . 11.3)
(add 1 (make-complex-from-real-imag 3 1))  ;=>(complex rectangular 4.0 . 1)

渡された二つの引数のtree-levelを比較して、同じならばエラー、異なっていたらレベルが低い方にraiseを適用しつつ、apply-genericを再帰的に呼び出すという構造です。