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)
          (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)
      (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
             (lambda (c) (vector-ref c 2))
      (send 'make-instance standard-class
            'class-precedence-list class-precedence-list
             (append slots (append-map
                            (lambda (c) (vector-ref c 1))
            '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 
                             (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

Log in or register to write something here or to contact authors.