Re: Apparant STklos class precedence problem

From: Erick Gallesio <>
Date: Sat, 19 Nov 1994 18:39:14 +0000

> I have a class heirarchy resembling the following:
> (define-class <a> () ())
> (define-class <b> () ())
> (define-class <c> (<b>) ())
> (define-class <d> (<c> <a>) ())
> (define-method m ((self <a>)) (display "I'm an <a>") (newline))
> (define-method m ((self <b>)) (display "I'm a <b>") (newline))
> Now if I create a <c> and a <d> and pass them to m:
> (m (make <c>))
> (m (make <d>))
> I see
> I'm a <b>
> I'm an <a>
> It seems to me that d should be a <b>, because <c> comes before <a>
> in the definition of <d>, and <b> should come before <a> because CLOS
> is supposed to keep the <c> family tree together. Isn't this right?

It is not a bug. It's only that things are not identical that in CLOS.
I don't know what algorithm is more logical". In your exemple, I'm enclained
to think that the CLOS algorithm is better .However, in the exemple which is
exhibited in the Annex of the STk reference manual the STklos algorithm seems
to me better. In AMOP (p 80 if I remeber), there are 2 other class precedence
list which are shown with different results. I think that no solution is
ideal. The important thing is that the algorithm is known by advance (and that
it is deterministic:-> ).

Note however, that if you want to change the algorithm which buid the class
precedence list, you only have to redefine the compute-cpl function (whih is
defined in the file STklos/stklos.stk). The code in this function is

    (define (compute-cpl class)

      (define (filter-cpl class)
        (let ((res '()))
          (for-each (lambda (item)
                      (unless (or (eq? item <object>)
                                  (eq? item <top>)
                                  (member item res))
                       (set! res (cons item res))))

      (let* ((supers (slot-ref class 'direct-supers))
             (big-list (apply append (cons class supers)
                                     (map compute-cpl supers))))
        (reverse (list* <top> <object> (filter-cpl big-list)))))

which is relatively simple. I have preferred to rewrite (and change) the class
precedence list algorrithm since
        - the CLOS algorithm has somtimes a "weird" behaviour (imho)
        - the only implementation I know in Scheme of the CLOS algorithm is
         the one we can find in Tiny Clos (and that I have never tried to
          understand, but which seems not simple).
        - in case of doubt, you can always use the class-precedence-list
          function to see the inheritance precedence list

The Tiny Clos algorithm is given below if you want to adapt it to

    ; A simple topological sort.
    ; It's in this file so that both TinyClos and Objects can use it.
    ; This is a fairly modified version of code I originally got from Anurag
    ; Mendhekar <>.

    (define compute-std-cpl
        (lambda (c get-direct-supers)
          (top-sort ((build-transitive-closure get-direct-supers) c)
                    ((build-constraints get-direct-supers) c)
                    (std-tie-breaker get-direct-supers))))

    (define top-sort
        (lambda (elements constraints tie-breaker)
          (let loop ((elements elements)
                     (constraints constraints)
                     (result '()))
            (if (null? elements)
                (let ((can-go-in-now
                          (lambda (x)
                            (every (lambda (constraint)
                                     (or (not (eq? (cadr constraint) x))
                                         (memq (car constraint) result)))
                  (if (null? can-go-in-now)
                      (error 'top-sort "Invalid constraints")
                      (let ((choice (if (null? (cdr can-go-in-now))
                                        (car can-go-in-now)
                                        (tie-breaker result
                          (filter-in (lambda (x) (not (eq? x choice)))
                         ;(filter-in (lambda (x) (not (eq? (cadr x) choice)))
                         ; constraints)
                          (append result (list choice))))))))))

    (define std-tie-breaker
        (lambda (get-supers)
          (lambda (partial-cpl min-elts)
            (let loop ((pcpl (reverse partial-cpl)))
                 (let ((current-elt (car pcpl)))
                   (let ((ds-of-ce (get-supers current-elt)))
                     (let ((common (filter-in (lambda (x)
                                                (memq x ds-of-ce))
                       (if (null? common)
                           (if (null? (cdr pcpl))
                               (error 'std-tie-breaker "Nothing valid")
                               (loop (cdr pcpl)))
                           (car common)))))))))

    (define build-transitive-closure
        (lambda (get-follow-ons)
          (lambda (x)
            (let track ((result '())
                        (pending (list x)))
                 (if (null? pending)
                     (let ((next (car pending)))
                       (if (memq next result)
                           (track result (cdr pending))
                           (track (cons next result)
                                  (append (get-follow-ons next)
                                          (cdr pending))))))))))

    (define build-constraints
      (lambda (get-follow-ons)
        (lambda (x)
          (let loop ((elements ((build-transitive-closure get-follow-ons) x))
                     (this-one '())
                     (result '()))
               (if (or (null? this-one) (null? (cdr this-one)))
                   (if (null? elements)
                       (loop (cdr elements)
                             (cons (car elements)
                                   (get-follow-ons (car elements)))
                   (loop elements
                         (cdr this-one)
                         (cons (list (car this-one) (cadr this-one))

                -- Erick
Received on Sat Nov 19 1994 - 18:39:15 CET

This archive was generated by hypermail 2.3.0 : Mon Jul 21 2014 - 19:38:59 CEST