Prev Up Next
It is easy to modify the object system to allow classes
to have more than one superclass. We redefine the
standard-class to have a slot called
class-precedence-list instead of superclass.
The class-precedence-list of a class is the list of
all its superclasses, not just the direct
superclasses specified during the creation of the class
with create-class. The name implies that the
superclasses are listed in a particular order, where
superclasses occurring toward the front of the list
have precedence over the ones in the back of the list.
(define standard-class
(vector 'value-of-standard-class-goes-here
(list 'slots 'class-precedence-list 'method-names 'method-vector)
'()
'(make-instance)
(vector make-instance)))
Not only has the list of slots changed to include
the new slot, but the erstwhile superclass slot is
now () instead of #t. This is because the
class-precedence-list of standard-class must be
a list. We could have had its value be (#t), but
we will not mention the zero class since it is in every
class's class-precedence-list.
The create-class macro has to modified to accept
a list of direct superclasses instead of a solitary superclass:
(define-macro create-class
(lambda (direct-superclasses slots . methods)
`(create-class-proc
(list ,@(map (lambda (su) `,su) direct-superclasses))
(list ,@(map (lambda (slot) `',slot) slots))
(list ,@(map (lambda (method) `',(car method)) methods))
(vector ,@(map (lambda (method) `,(cadr method)) methods))
)))
The create-class-proc must calculate the class precedence list from
the supplied direct superclasses, and the slot list from the
class precedence list:
(define create-class-proc
(lambda (direct-superclasses slots method-names method-vector)
(let ((class-precedence-list
(delete-duplicates
(append-map
(lambda (c) (vector-ref c 2))
direct-superclasses))))
(send 'make-instance standard-class
'class-precedence-list class-precedence-list
'slots
(delete-duplicates
(append slots (append-map
(lambda (c) (vector-ref c 1))
class-precedence-list)))
'method-names method-names
'method-vector method-vector))))
The procedure append-map is a composition of
append and map:
(define append-map
(lambda (f s)
(let loop ((s s))
(if (null? s) '()
(append (f (car s))
(loop (cdr s)))))))
The procedure send has to search through the class precedence list
left to right when it hunts for a method.
(define send
(lambda (method-name instance . args)
(let ((proc
(let ((class (class-of instance)))
(if (eqv? class #t) (error 'send)
(let loop ((class class)
(superclasses (vector-ref class 2)))
(let ((k (list-position
method-name
(vector-ref class 3))))
(cond (k (vector-ref
(vector-ref class 4) k))
((null? superclasses) (error 'send))
(else (loop (car superclasses)
(cdr superclasses))))
))))))
(apply proc instance args))))
3 We could in theory
define methods also as slots (whose values happen to be
procedures), but there is a good reason not to. The
instances of a class share methods but in general
differ in their slot values. In other words, methods
can be included in the class definition and don't have
to be allocated per instance as slots have to be.
Prev Up Next