Louis Reasoner has noticed that
apply-generic may try to coerce the arguments to each other's type even if they already have the same type. Therefore, he reasons, we need to put procedures in the coercion table to "coerce" arguments of each type to their own type. For example, in addition to the scheme-number->complex coercion shown above, he would do:
(define (scheme-number->scheme-number n) n)
(define (complex->complex z) z)
(put-coercion 'scheme-number 'scheme-number
scheme-number->scheme-number)
(put-coercion 'complex 'complex complex->complex)
- With Louis's coercion procedures installed, what happens if
apply-genericis called with two arguments of typescheme-numberor two arguments of typecomplexfor an operation that is not found in the table for those types? For example, assume that we've defined a generic exponentiation operation:(define (exp x y) (apply-generic 'exp x y))
and have put a procedure for exponentiation in the Scheme-number package but not in any other package:;; following added to Scheme-number package (put 'exp '(scheme-number scheme-number) (lambda (x y) (tag (expt x y)))) ; using primitive exptWhat happens if we callexpwith two complex numbers as arguments? - Is Louis correct that something had to be done about coercion with arguments of the same type, or does
apply-genericwork correctly as is? - Modify
apply-genericso that it doesn't try coercion if the two arguments have the same type.
(a) Same-Type Arguments, No Matching Operation - What Happens?
Let's do a manual evaluation to see what happens! First, let's start by defining a couple of complex numbers to work with:(define z1 (make-complex-from-real-imag 1 2)) (define z2 (make-complex-from-real-imag 3 4))Now let's evaluate
(exp z1 z2). As we've done before we'll simplify this evaluation a bit by skipping the details of map and get.
(exp z1 z2)
= (apply-generic 'exp z1 z2)
= (let ((type-tags (map type-tag (list z1 z2))))
(let ((proc (get 'exp type-tags)))
(if proc
(apply proc (map contents (list z1 z2)))
(if (= (length (list z1 z2)) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car (list z1 z2)))
(a2 (cadr (list z1 z2))))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 a1) a2))
(t2->t1
(apply-generic 'exp a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list 'exp type-tags))))))
(error "No method for these types"
(list 'exp type-tags))))))
= (let ((type-tags '(complex complex)))
(let ((proc (get 'exp type-tags)))
(if proc
(apply proc (map contents (list z1 z2)))
(if (= (length (list z1 z2)) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car (list z1 z2)))
(a2 (cadr (list z1 z2))))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 a1) a2))
(t2->t1
(apply-generic 'exp a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list 'exp type-tags))))))
(error "No method for these types"
(list 'exp type-tags))))))
= (let ((proc (get 'exp '(complex complex))))
(if proc
(apply proc (map contents (list z1 z2)))
(if (= (length (list z1 z2)) 2)
(let ((type1 (car '(complex complex)))
(type2 (cadr '(complex complex)))
(a1 (car (list z1 z2)))
(a2 (cadr (list z1 z2))))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 a1) a2))
(t2->t1
(apply-generic 'exp a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list 'exp '(complex complex)))))))
(error "No method for these types"
(list 'exp '(complex complex))))))
= (let ((proc false))
(if proc
(apply proc (map contents (list z1 z2)))
(if (= (length (list z1 z2)) 2)
(let ((type1 (car '(complex complex)))
(type2 (cadr '(complex complex)))
(a1 (car (list z1 z2)))
(a2 (cadr (list z1 z2))))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 a1) a2))
(t2->t1
(apply-generic 'exp a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list 'exp '(complex complex)))))))
(error "No method for these types"
(list 'exp '(complex complex))))))
= (if false
(apply false (map contents (list z1 z2)))
(if (= (length (list z1 z2)) 2)
(let ((type1 (car '(complex complex)))
(type2 (cadr '(complex complex)))
(a1 (car (list z1 z2)))
(a2 (cadr (list z1 z2))))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 a1) a2))
(t2->t1
(apply-generic 'exp a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list 'exp '(complex complex)))))))
(error "No method for these types"
(list 'exp '(complex complex)))))
= (if (= (length (list z1 z2)) 2)
(let ((type1 (car '(complex complex)))
(type2 (cadr '(complex complex)))
(a1 (car (list z1 z2)))
(a2 (cadr (list z1 z2))))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 a1) a2))
(t2->t1
(apply-generic 'exp a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list 'exp '(complex complex)))))))
(error "No method for these types"
(list 'exp '(complex complex)))))
= (if (= 2 2)
(let ((type1 (car '(complex complex)))
(type2 (cadr '(complex complex)))
(a1 (car (list z1 z2)))
(a2 (cadr (list z1 z2))))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 a1) a2))
(t2->t1
(apply-generic 'exp a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list 'exp '(complex complex)))))))
(error "No method for these types"
(list 'exp '(complex complex)))))
= (if true
(let ((type1 (car '(complex complex)))
(type2 (cadr '(complex complex)))
(a1 (car (list z1 z2)))
(a2 (cadr (list z1 z2))))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 a1) a2))
(t2->t1
(apply-generic 'exp a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list 'exp '(complex complex)))))))
(error "No method for these types"
(list 'exp '(complex complex)))))
= (let ((type1 (car '(complex complex)))
(type2 (cadr '(complex complex)))
(a1 (car (list z1 z2)))
(a2 (cadr (list z1 z2))))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 a1) a2))
(t2->t1
(apply-generic 'exp a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list 'exp '(complex complex)))))))
= (let ((type1 'complex)
(type2 'complex)
(a1 z1)
(a2 z2))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 a1) a2))
(t2->t1
(apply-generic 'exp a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list 'exp '(complex complex)))))))
= (let ((t1->t2 (get-coercion 'complex 'complex))
(t2->t1 (get-coercion 'complex 'complex)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 z1) z2))
(t2->t1
(apply-generic 'exp z1 (t2->t1 z2)))
(else
(error "No method for these types"
(list 'exp '(complex complex))))))
= (let ((t1->t2 complex->complex)
(t2->t1 complex->complex))
(cond (t1->t2
(apply-generic 'exp (t1->t2 z1) z2))
(t2->t1
(apply-generic 'exp z1 (t2->t1 z2)))
(else
(error "No method for these types"
(list 'exp '(complex complex))))))
= (cond (complex->complex
(apply-generic 'exp (complex->complex z1) z2))
(complex->complex
(apply-generic 'exp z1 (complex->complex z2)))
(else
(error "No method for these types"
(list 'exp '(complex complex)))))
= (apply-generic 'exp (complex->complex z1) z2)
= (apply-generic 'exp z1 z2)
At this point we'll stop the evaluation. We're about evaluate (apply-generic 'exp z1 z2). Now if you recall (or if you have a quick peak back up at the start of the evaluation), this matches the second step in our evaluation. This means that we're about to enter an infinite loop!So there's our answer. If we install same-type coercion procedures in the system then, if no matching procedure can be found for an operation called with a pair of same-type arguments,
apply-generic will enter an infinite evaluation loop.
(b) Do We Need Same-Type Coercion?
Strictly speaking, no we don't need to do anything about coercion with arguments of the same type. If an operation is not found in the table for same-type arguments thenapply-generic will correctly raise an error.Let's prove this to ourselves by tracing through the same example as in part (a), but assuming that Louis has not installed the same-type coercion procedure for
complex numbers. We'll skip a large number of the initial steps, as they're identical to the evaluation above, and jump in at the point where we try to obtain the coercion procedures.
(exp z1 z2)
= (apply-generic 'exp z1 z2)
= …
= (let ((t1->t2 (get-coercion 'complex 'complex))
(t2->t1 (get-coercion 'complex 'complex)))
(cond (t1->t2
(apply-generic 'exp (t1->t2 z1) z2))
(t2->t1
(apply-generic 'exp z1 (t2->t1 z2)))
(else
(error "No method for these types"
(list 'exp '(complex complex))))))
= (let ((t1->t2 false)
(t2->t1 false))
(cond (t1->t2
(apply-generic 'exp (t1->t2 z1) z2))
(t2->t1
(apply-generic 'exp z1 (t2->t1 z2)))
(else
(error "No method for these types"
(list 'exp '(complex complex))))))
= (cond (false
(apply-generic 'exp (t1->t2 z1) z2))
(false
(apply-generic 'exp z1 (t2->t1 z2)))
(else
(error "No method for these types"
(list 'exp '(complex complex)))))
= (error "No method for these types"
(list 'exp '(complex complex)))
So, as you can see, we get the required behaviour.Note that I said "strictly speaking" above. The procedure is functionally correct. However, it does perform a number of unnecessary operations, particularly extracting the individual arguments and trying to look up coercion procedures. By eliminating these steps we could make the procedure slightly more efficient in this case.
If only we had some excuse to do this.
Oh look, it's part (c)...
(c) Removing Same-Type Coercion from apply-generic
In order to prevent coercion of same-type arguments we can modify apply-generic so that, after it has determined that there are two arguments and it has extracted the types of those arguments, it checks to see if they are of the same type or not before proceeding. If they are then it should raise an error, otherwise it should continue as before.Programmatically this can be expressed as:
(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 ((type1 (car type-tags))
(type2 (cadr type-tags)))
(if (not (eq? type1 type2))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1))
(a1 (car args))
(a2 (cadr args)))
(cond (t1->t2
(apply-generic op (t1->t2 a1) a2))
(t2->t1
(apply-generic op a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list op type-tags)))))
(error "No method for these types"
(list op type-tags))))
(error "No method for these types"
(list op type-tags)))))))
No comments:
Post a Comment