Eli Bendersky's website The code for this section is in Scheme.
A short review of the material
This section is about combining data of different types. This is where the generic type system we’re developing will really shine. But before we delve deeper into the code, it is beneficial to first gain a more thorough understanding of how we implement tagging.
Like many things in Lisp, lists can be used to simply represent tagged types. Attaching a tag type is just prepending its name to the datum:
(define (attach-tag type-tag contents)
(if (number? contents)
contents
(cons type-tag contents)))
The code above includes an optimization for scheme numbers, but other than that, it’s a simple cons.
We even saw how to use this simple technique to build hierarchical tag systems. In this case the attached tags act in a LIFO manner – the higher-level tags (“a complex number”) come before the lower-level tags (“a rectangular implementation of a complex number”).
The key function in all of this is apply-generic, and it’s worth understanding it thoroughly:
(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))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags))))))
Recall that our operation table (get and put) dispatches to functions based on the requested operation and the types of the arguments. The authors thoughtfully included provisions for multiple arguments of different types in the previous section – to use it fully only here.
apply-generic takes an operation (say, add) and a list of arguments – normal Lisp variables. It queries the arguments for their types, using the generic type-tag accessor, builds a list of types (with map) and passes it together with the operation to get. This way it gets the correct function for the requested operation and types.
Keep this point in mind – it will be crucial in the understanding of the code of this section. The whole type tagging and operation dispatching thing is implemented using the familiar abstraction of lists and accessors to list elements. There’s a small detour into more advanced data structures to implement put and get efficiently1, but that could have easily been done with lists too. There’s nothing magical and special about it – we’ve been using list abstractions from the very start of this book, and this topic should be very familiar by now.
Coercion
Here’s the code that implements the coercion table. It is very similar to the operator dispatch table:
(define *coercion-table* (make-hash-table 'equal))
(define (put-coercion type-from type-to proc)
(hash-table-put!
*coercion-table*
(list type-from type-to)
proc))
(define (get-coercion type-from type-to)
(hash-table-get
*coercion-table*
(list type-from type-to)
#f))
And the apply-generic that uses it is:
(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))
(a1 (car args))
(a2 (cadr args)))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(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)))))))
Exercise 2.81
a. Louis’s coercion procedures don’t help much. It becomes very obvious if you study the code of apply-generic – it calls itself recursively on coerced types, and hence for numbers it doesn’t add any value. For complex numbers (or any other numbers for which the requested operation is not implemented) it’s even worse – apply-generic gets into an infinite recursion1.
b. Louis is wrong. apply-generic works just fine as-is. If two arguments are of the same type and apply-generic couldn’t find an operation for them with get, self coercion won’t help.
c. Here’s apply-generic that doesn’t try coercion for two arguments of the same type:
(define (apply-generic op . args)
(define (no-method type-tags)
(error "No method for these types"
(list op type-tags)))
(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))
(a1 (car args))
(a2 (cadr args)))
(if (equal? type1 type2)
(no-method type-tags)
(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 (no-method type-tags))))))
(no-method type-tags))))))
Note that I defined no-method to avoid repetitive code.
Exercise 2.82
This strategy requires a much more complicated apply-generic. We can contain the complexity by defining a few internal functions that give convenient names to processes. Now the main flow of apply-generic should not be too hard to understand.
(define (apply-generic op . args)
(define (can-coerce-into? types target-type)
"Can all _types_ be coerced into _target-type_ ?"
(andmap
(lambda (type)
(or
(equal? type target-type)
(get-coercion type target-type)))
types))
(define (find-coercion-target types)
"Find a type among _types_ that all _types_ can be
coerced into."
(ormap
(lambda (target-type)
(if (can-coerce-into? types target-type)
target-type
#f))
types))
(define (coerce-all args target-type)
"Coerce all _args_ to _target-type_"
(map
(lambda (arg)
(let ((arg-type (type-tag arg)))
(if (equal? arg-type target-type)
arg
((get-coercion arg-type target-type) arg))))
args))
(define (no-method type-tags)
(error "No method for these types"
(list op type-tags)))
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(let ((target-type (find-coercion-target type-tags)))
(if target-type
(apply
apply-generic
(append
(list op)
(coerce-all args target-type)))
(no-method type-tags)))))))
A situation where this strategy is not sufficiently general: we are trying to coerce the arguments only to types that are present in the call, and so can miss other types.
Consider the example in Figure 2.26 in the book. Suppose we have a call with these types: (kite quadrilateral). Since kite can be coerced into quadrilateral, everything works as expected.
But now suppose we have a call with: (triangle kite quadrilateral). Going over each of these types and trying to coerce them to each other won’t work. But they can all be coerced into polygon. This demonstrates the flaw of this method. What we should be really going is finding some common “ancestor” type for all the types we work on.
Exercise 2.83
;; Into integer package
(define (integer->rational n)
(make-rational n 1))
(put 'raise '(integer)
(lambda (i) (integer->rational i)))
;; Into rational package
(define (rational->real r)
(make-real
(exact->inexact
(/ (numer r) (denom r)))))
(put 'raise '(rational)
(lambda (r) (rational->real r)))
;; Into real package
(define (real->complex r)
(make-complex-from-real-imag r 0))
(put 'raise '(real)
(lambda (r) (real->complex r)))
(define (raise x)
(apply-generic 'raise x))
Exercise 2.84
For simplicity’s sake, I’m going to use the apply-generic that only works with two arguments. Also, I’ll employ only the types we’re familiar with: scheme number, rational, complex.
(define (apply-generic-r op . args)
(define (no-method type-tags)
(error "No method for these types"
(list op type-tags)))
(define (raise-into s t)
"Tries to raise s into the type of t. On success,
returns the raised s. Otherwise, returns #f"
(let ((s-type (type-tag s))
(t-type (type-tag t)))
(cond
((equal? s-type t-type) s)
((get 'raise (list s-type))
(raise-into ((get 'raise (list s-type)) (contents s)) t))
(t #f))))
(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 ((o1 (car args))
(o2 (cadr args)))
(cond
((raise-into o1 o2)
(apply-generic-r op (raise-into o1 o2) o2))
((raise-into o2 o1)
(apply-generic-r op o2 (raise-into o2 o1)))
(t (no-method type-tags))))
(no-method type-tags))))))
The auxiliary function raise-into plays a key role here. It tries to recursively raise its first argument into the type of the second argument. If successful, it returns the first argument with the type of the second. Otherwise it returns #f.
Although this method is compatible with the rest of the system and imposes the minimal overhead to the action of adding new types, it is not very efficient. In a real system, it probably would have made sense to precompute the relationships between types and not try to figure it out every time anew.
Exercise 2.85
Let’s begin with the project functions for the various types:
(put 'project '(rational)
(lambda (r)
(make-scheme-number
(floor (/ (numer r) (denom r))))))
(put 'project '(real)
(lambda (r)
(let ((scheme-rat
(rationalize
(inexact->exact r) 1/100)))
(make-rational
(numerator scheme-rat)
(denominator scheme-rat)))))
(put 'project '(complex)
(lambda (c) (make-real (real-part c))))
The functions floor, rationalize and inexact->exact are standard Scheme functions for dealing with conversions between different numbers. The functions numerator and denominator are Scheme’s own accessors to rational numbers. It was convenient to use them together with the output of rationalize.
Here is drop and a modified apply-generic-r:
(define (drop num)
(let ((project-proc
(get 'project (list (type-tag num)))))
(if project-proc
(let ((dropped (project-proc (contents num))))
(if (equ? num (raise dropped))
(drop dropped)
num))
num)))
(define (apply-generic-r op . args)
(define (no-method type-tags)
(error "No method for these types"
(list op type-tags)))
(define (raise-into s t)
"Tries to raise s into the type of t. On success,
returns the raised s. Otherwise, returns #f"
(let ((s-type (type-tag s))
(t-type (type-tag t)))
(cond
((equal? s-type t-type) s)
((get 'raise (list s-type))
(raise-into ((get 'raise (list s-type)) (contents s)) t))
(t #f))))
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(drop (apply proc (map contents args)))
(if (= (length args) 2)
(let ((o1 (car args))
(o2 (cadr args)))
(cond
((raise-into o1 o2)
(apply-generic-r op (raise-into o1 o2) o2))
((raise-into o2 o1)
(apply-generic-r op o2 (raise-into o2 o1)))
(t (no-method type-tags))))
(no-method type-tags))))))
Note that the only change apply-generic-r has undergone is the call to drop on apply – which is the exit point, in order to simplify the answer.
The way I decided to implement drop allows, IMHO, for the most generic type system. drop tests if the type it’s given has a project function, so new types without project will also work as expected.
Exercise 2.86
We should first think about the abstraction level on which we’d want to implement this feature. On the level of complex, only accessors are used (real-part, angle etc.) so if we implement those, everything will work as expected. So, we should operate on the level of rectangular and polar.
What is needed is pretty simple; we can just make the operations: square, arctan, sine and cosine generic procedures, and implement them for each number system we’re installing. Then, the accessors of rectangular and polar will just use these generic procedures without worrying about the internals. This way we also ensure that when new types are added into the system, they can be easily be incorporated as the elements of complex numbers, by implementing the appropriate generic procedures.
1 Recall that we used Scheme’s hash tables for that.
2 It’s a curious fact to note that the Scheme interpreter (I’m using PLT’s MzScheme) doesn’t throw a stack overflow error, but dutifully engages in an infinite loop. This is because the recursive call of apply-generic is a tail call, and the Scheme interpreter automatically optimizes it into a loop. Contrast this with the CL runtime we were using in other sections – while it implements the tail call optimization for compiled code, it doesn’t do it for interpreted code, so it throws a stack overflow.