SICP 問題 2.84

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args))
        (tower '(complex real rational scheme-number)))
    ;; 同じタイプか調べる述語
    (define (same-type? a b)
      (eq? (type-tag a) (type-tag b)))
    ;; aよりもbのほうが階層が高いか調べる述語
    ;; 両方をraiseしながらcomplexに先になったほうが階層が高い
    (define (type-< a b)
        (cond ((same-type? a b) false)
              ((eq? (type-tag a) (car tower)) true)
              ((eq? (type-tag b) (car tower)) false)
              (else (type-< ((get 'raise (type-tag a)) a)
                            ((get 'raise (type-tag b)) b)))))
    ;; リストの中でもっとも高い階層の型を調べる
    (define (highest-type lst)
      (let iter ((result (car lst))
                 (rest (cdr lst)))
        (cond ((null? rest) result)
              ((type-< result (car rest))
               (iter (car rest) (cdr rest)))
              (else
               (iter result (cdr rest))))))
    ;; リストの要素すべてを最も階層の高い型highまでraiseする
    (define (same-highest-type high lst)
      (map (lambda (x) (let iter ((target x))
                         (if (eq? high target)
                             target
                             (iter ((get 'raise (type-tag target))
                                    target)))))
           lst))
    (let ((proc (get op types)))
      (if proc
          (apply proc (map contents args))
          (let ((new-args (same-highest-type (highest-type args)
                                             args)))
            (let ((proc (get op (type-tag (car new-args)))))
              (if proc
                  (apply proc (map contents new-args))
                  (error "Nomethod for these types"
                         (list op type-tags)))))))))