+
+;;; Arrange the inherited layouts to appear at their expected depth,
+;;; ensuring that hierarchical type tests succeed. Layouts with
+;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
+;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
+;;; layouts are placed in remaining elements. Then, any still-empty
+;;; elements are filled with their successors, ensuring that each
+;;; element contains a valid layout.
+;;;
+;;; This reordering may destroy CPL ordering, so the inherits should
+;;; not be read as being in CPL order.
+(defun order-layout-inherits (layouts)
+ (declare (simple-vector layouts))
+ (let ((length (length layouts))
+ (max-depth -1))
+ (dotimes (i length)
+ (let ((depth (layout-depthoid (svref layouts i))))
+ (when (> depth max-depth)
+ (setf max-depth depth))))
+ (let* ((new-length (max (1+ max-depth) length))
+ (inherits (make-array new-length)))
+ (dotimes (i length)
+ (let* ((layout (svref layouts i))
+ (depth (layout-depthoid layout)))
+ (unless (eql depth -1)
+ (let ((old-layout (svref inherits depth)))
+ (unless (or (eql old-layout 0) (eq old-layout layout))
+ (error "layout depth conflict: ~S~%" layouts)))
+ (setf (svref inherits depth) layout))))
+ (do ((i 0 (1+ i))
+ (j 0))
+ ((>= i length))
+ (declare (type index i j))
+ (let* ((layout (svref layouts i))
+ (depth (layout-depthoid layout)))
+ (when (eql depth -1)
+ (loop (when (eql (svref inherits j) 0)
+ (return))
+ (incf j))
+ (setf (svref inherits j) layout))))
+ (do ((i (1- new-length) (1- i)))
+ ((< i 0))
+ (declare (type fixnum i))
+ (when (eql (svref inherits i) 0)
+ (setf (svref inherits i) (svref inherits (1+ i)))))
+ inherits)))
+\f
+;;;; class precedence lists
+
+;;; Topologically sort the list of objects to meet a set of ordering
+;;; constraints given by pairs (A . B) constraining A to precede B.
+;;; When there are multiple objects to choose, the tie-breaker
+;;; function is called with both the list of object to choose from and
+;;; the reverse ordering built so far.
+(defun topological-sort (objects constraints tie-breaker)
+ (declare (list objects constraints)
+ (function tie-breaker))
+ (let ((obj-info (make-hash-table :size (length objects)))
+ (free-objs nil)
+ (result nil))
+ (dolist (constraint constraints)
+ (let ((obj1 (car constraint))
+ (obj2 (cdr constraint)))
+ (let ((info2 (gethash obj2 obj-info)))
+ (if info2
+ (incf (first info2))
+ (setf (gethash obj2 obj-info) (list 1))))
+ (let ((info1 (gethash obj1 obj-info)))
+ (if info1
+ (push obj2 (rest info1))
+ (setf (gethash obj1 obj-info) (list 0 obj2))))))
+ (dolist (obj objects)
+ (let ((info (gethash obj obj-info)))
+ (when (or (not info) (zerop (first info)))
+ (push obj free-objs))))
+ (loop
+ (flet ((next-result (obj)
+ (push obj result)
+ (dolist (successor (rest (gethash obj obj-info)))
+ (let* ((successor-info (gethash successor obj-info))
+ (count (1- (first successor-info))))
+ (setf (first successor-info) count)
+ (when (zerop count)
+ (push successor free-objs))))))
+ (cond ((endp free-objs)
+ (dohash (obj info obj-info)
+ (unless (zerop (first info))
+ (error "Topological sort failed due to constraint on ~S."
+ obj)))
+ (return (nreverse result)))
+ ((endp (rest free-objs))
+ (next-result (pop free-objs)))
+ (t
+ (let ((obj (funcall tie-breaker free-objs result)))
+ (setf free-objs (remove obj free-objs))
+ (next-result obj))))))))
+
+
+;;; standard class precedence list computation
+(defun std-compute-class-precedence-list (class)
+ (let ((classes nil)
+ (constraints nil))
+ (labels ((note-class (class)
+ (unless (member class classes)
+ (push class classes)
+ (let ((superclasses (class-direct-superclasses class)))
+ (do ((prev class)
+ (rest superclasses (rest rest)))
+ ((endp rest))
+ (let ((next (first rest)))
+ (push (cons prev next) constraints)
+ (setf prev next)))
+ (dolist (class superclasses)
+ (note-class class)))))
+ (std-cpl-tie-breaker (free-classes rev-cpl)
+ (dolist (class rev-cpl (first free-classes))
+ (let* ((superclasses (class-direct-superclasses class))
+ (intersection (intersection free-classes
+ superclasses)))
+ (when intersection
+ (return (first intersection)))))))
+ (note-class class)
+ (topological-sort classes constraints #'std-cpl-tie-breaker))))