The compute-cpl procedure I proposed in a previous mail solved my
specific problems on class precedence, but is not really satisfactory.
For example, it is not always possible to explicitly specify the order
between two superclasses. Furthermore, the algorithm doesn't work "by
level" like the original STklos algorithm.
Ken Anderson suggested reading a paper on class precedence algorithms
in OOPSLA'96 proceedings. The paper can also be found here:
http://www.webcom.com/~haahr/dylan/linearization-oopsla96.html. The
authors propose two algorithms with the important property of
"monotonicity". The original STklos algorithm is not monotonic on
occasion. Yet, neither of the two algorithms in the paper seems to
work by level (but this property still needs to be defined in a formal
way).
So, following the paper, I wrote another compute-cpl procedure which,
I hope, is monotonic (no formal proof of that point) and works by
level. Any comment would be appreciated.
,
Anthony BEURIVE
;;;-----------------------------------------------------------------------------
(define (compute-cpl class)
(define (reduce sequences cpl)
(define (aux sequence)
(if (and (pair? sequence) (memq (car sequence) cpl))
(aux (cdr sequence))
sequence))
(map aux sequences))
(define (delete-null-lists sequences)
(if (pair? sequences)
(let ((first (car sequences)))
(if (pair? first)
(cons first (delete-null-lists (cdr sequences)))
(delete-null-lists (cdr sequences))))
'()))
(define (select-candidate candidate sequences)
(if (pair? sequences)
(and (not (memq candidate (cdr (car sequences))))
(select-candidate candidate (cdr sequences)))
candidate))
(define (filter-candidates candidates sequences)
(if (pair? candidates)
(or (select-candidate (car candidates) sequences)
(filter-candidates (cdr candidates) sequences))
#f)) ; No valid candidate (inconsistency).
(define (next-class sequences)
(let ((candidates (map car sequences)))
(or (filter-candidates candidates sequences)
(car candidates)))) ; Arbitrarily brake the inconsistency.
(define (step cpl sequences)
(if (pair? sequences)
(let ((new-cpl (cons (next-class sequences) cpl)))
(step new-cpl (delete-null-lists (reduce sequences new-cpl))))
(reverse cpl)))
(step '() (let ((supers (slot-ref class 'direct-supers)))
(cons (cons class supers)
(map (lambda (super)
(slot-ref super 'cpl))
supers)))))
;;;-----------------------------------------------------------------------------
;;; Some tests
(require "stklos")
(define original-compute-cpl class-precedence-list)
(define new-compute-cpl compute-cpl)
(define-class <A> () ())
(define-class <B> (<A>) ())
(define-class <C> (<B>) ())
(define-class <D> (<C>) ())
(define-class <E> (<A>) ())
(define-class <F> (<E>) ())
(define-class <G> (<F>) ())
(define-class <H> (<D> <G>) ())
(format #t "~s~%" (original-compute-cpl <H>))
(format #t "~s~%" (new-compute-cpl <H>))
(define-class <A> () ())
(define-class <B> (<A>) ())
(define-class <C> (<A>) ())
(define-class <D> (<A>) ())
(define-class <E> (<B> <C>) ())
(define-class <F> (<D>) ())
(define-class <G> (<E> <F>) ())
(format #t "~s~%" (original-compute-cpl <G>))
(format #t "~s~%" (new-compute-cpl <G>))
;;; Figure 1 in [1]
;;; Inconsistency arbitrarily solved
(define-class GL () ())
(define-class HG (GL) ())
(define-class VG (GL) ())
(define-class HVG (HG VG) ())
(define-class VHG (VG HG) ())
(define-class CG (HVG VHG) ())
(format #t "~s~%" (original-compute-cpl CG))
(format #t "~s~%" (new-compute-cpl CG))
;;; Figure 2 in [1]
;;; WB comes before DB in PWB
(define-class B () ())
(define-class DB (B) ())
(define-class WB (B) ())
(define-class EL (DB) ())
(define-class SMH (DB) ())
(define-class PWB (EL WB) ())
(define-class SC (SMH) ())
(define-class P (PWB SC) ())
(format #t "~s~%" (original-compute-cpl P))
(slot-set! PWB 'cpl (new-compute-cpl PWB))
(format #t "~s~%" (new-compute-cpl P))
;;; Variation with explicit preference
(define-class B () ())
(define-class DB (B) ())
(define-class WB (B) ())
(define-class EL (DB) ())
(define-class SMH (DB) ())
(define-class PWB (EL WB) ())
(define-class SC (SMH) ())
(define-class P (PWB SC DB WB) ()) ; preferring DB over WB
(format #t "~s~%" (original-compute-cpl P))
(slot-set! PWB 'cpl (new-compute-cpl PWB))
(format #t "~s~%" (new-compute-cpl P))
;;; Figure 3 in [1]
(define-class CW () ())
(define-class PMI () ())
(define-class M (CW) ())
(define-class PM (M PMI) ())
(format #t "~s~%" (original-compute-cpl PM))
(format #t "~s~%" (new-compute-cpl PM))
;;; Variation with explicit preference
(define-class CW () ())
(define-class PMI () ())
(define-class M (CW) ())
(define-class PM (M CW PMI) ())
(format #t "~s~%" (original-compute-cpl PM))
(format #t "~s~%" (new-compute-cpl PM))
;;; Figure 4 in [1]
(define-class CW () ())
(define-class PMI () ())
(define-class M (CW) ())
(define-class PM (M PMI) ())
(define-class NPM (M PMI CW) ())
(format #t "~s~%" (original-compute-cpl NPM))
(format #t "~s~%" (new-compute-cpl NPM))
;;; Figure 5 in [1]
(define-class P () ())
(define-class SM () ())
(define-class EM () ())
(define-class SP (P SM) ())
(define-class EP (P EM) ())
(define-class ESP (SP EP) ())
(format #t "~s~%" (original-compute-cpl ESP))
(format #t "~s~%" (new-compute-cpl ESP))
;;; References
;;; [1] A Monotonic Superclass Linearization for Dylan, K. Barrett,
;;; B. Cassels, P. Haahr, D. A. Moon, K. Playford, P. Tucker
;;; Withington, OOPSLA 96.
Received on Mon Oct 18 1999 - 17:29:37 CEST