SICP по-русски

Для простоты я буду рассматривать вариант приведения типов только для бинарных операций, который соответствует рассмотренному в основном тексте книги варианту apply-generic.

Я модифицирую процедуру apply-generic следующим образом: если операции для двух аргументов заданных типов не нашлось, я сравню их типы. Если типы одинаковы, я попытаюсь поднять оба аргумента по башне типов и, если это возможно, выполнить операцию на поднятых таким образом аргументах. Если же один из типов находится выше другого в иерархии, я подниму более низкий на один уровень вверх по иерархии и выполню операцию. Наконец, если типы аргументов несопоставимы, то есть не принадлежат одной башне типов, я немедленно выдам сообщение об ошибке.

Процедура 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 ((ra1 (raise a1))
                      (ra2 (raise a2)))
                  (cond ((eq? (type-tag a1) (type-tag a2))
                         (if (and ra1 ra2)
                             (apply-generic op ra1 ra2)
                             (error "Нет метода для этих типов"
                                    (list op type-tags))))
                        ((higher? a1 a2)
                         (apply-generic op a1 ra2))
                        ((higher? a2 a1)
                         (apply-generic op ra1 a2))
                        (else (error "Нет метода для этих типов"
                                     (list op type-tags))))))
              (error "Нет метода для этих типов"
                     (list op type-tags)))))))

Проверка, находится ли тип одного аргумента выше в башне типов, чем тип другого выполняется просто. Если второй аргумент можно поднять в башне типов и в результате получить тот же тип, что и у первого аргумента, то тип первого аргумента выше в башне. Вариант реализации проверки приведен ниже:

(define (higher? a1 a2)
  (let ((ra2 (raise a2)))
    (and ra2
         (or (eq? (type-tag a1) (type-tag ra2))
             (higher? a1 ra2)))))

Алгоритм приведения типов можно сделать более эффективным, если не останавливаться на каждом шаге при подъеме, а сразу приводить аргумент с более низким типом к типу второго аргумента. Однако при этом теряются промежуточные варианты комбинаций типов, которыми я не хотел жертвовать.