;;;; specification.
(in-package "SB-PCL")
-
-(sb-int:file-comment
- "$Header$")
\f
-;;; compute-class-precedence-list
-;;;
+;;;; COMPUTE-CLASS-PRECEDENCE-LIST and friends
+
;;; Knuth section 2.2.3 has some interesting notes on this.
;;;
;;; What appears here is basically the algorithm presented there.
;;; any point. If there is more than one, the specified tiebreaker
;;; rule is used to choose among them.
-(defmethod compute-class-precedence-list ((root slot-class))
+(defmethod compute-class-precedence-list ((root class))
(compute-std-cpl root (class-direct-superclasses root)))
(defstruct (class-precedence-description
- (:conc-name nil)
- (:print-object (lambda (obj str)
- (print-unreadable-object (obj str :type t)
- (format str "~D" (cpd-count obj)))))
- (:constructor make-cpd ()))
+ (:conc-name nil)
+ (:print-object (lambda (obj str)
+ (print-unreadable-object (obj str :type t)
+ (format str "~D" (cpd-count obj)))))
+ (:constructor make-cpd ())
+ (:copier nil))
(cpd-class nil)
(cpd-supers ())
(cpd-after ())
(cpd-count 0))
(defun compute-std-cpl (class supers)
- (cond ((null supers) ;First two branches of COND
- (list class)) ;are implementing the single
- ((null (cdr supers)) ;inheritance optimization.
- (cons class
- (compute-std-cpl (car supers)
- (class-direct-superclasses (car supers)))))
- (t
- (multiple-value-bind (all-cpds nclasses)
- (compute-std-cpl-phase-1 class supers)
- (compute-std-cpl-phase-2 all-cpds)
- (compute-std-cpl-phase-3 class all-cpds nclasses)))))
+ (cond
+ ;; the first two branches of this COND are implementing an
+ ;; optimization for single inheritance.
+ ((and (null supers)
+ (not (forward-referenced-class-p class)))
+ (list class))
+ ((and (null (cdr supers))
+ (not (forward-referenced-class-p (car supers))))
+ (cons class
+ (compute-std-cpl (car supers)
+ (class-direct-superclasses (car supers)))))
+ (t
+ (multiple-value-bind (all-cpds nclasses)
+ (compute-std-cpl-phase-1 class supers)
+ (compute-std-cpl-phase-2 all-cpds)
+ (compute-std-cpl-phase-3 class all-cpds nclasses)))))
(defvar *compute-std-cpl-class->entry-table-size* 60)
(if (class-name class)
(format nil "named ~S" (class-name class))
class)))
- (let ((names (mapcar #'class-or-name
- (cdr (find-superclass-chain class forward-class)))))
- (cpl-error class
- "The class ~A is a forward referenced class.~@
- The class ~A is ~A."
- (class-or-name forward-class)
- (class-or-name forward-class)
- (if (null (cdr names))
- (format nil
- "a direct superclass of the class ~A"
- (class-or-name class))
- (format nil
- "reached from the class ~A by following~@
+ (if (eq class forward-class)
+ (cpl-error class
+ "The class ~A is a forward referenced class."
+ (class-or-name class))
+ (let ((names (mapcar #'class-or-name
+ (cdr (find-superclass-chain class forward-class)))))
+ (cpl-error class
+ "The class ~A is a forward referenced class.~@
+ The class ~A is ~A."
+ (class-or-name forward-class)
+ (class-or-name forward-class)
+ (if (null (cdr names))
+ (format nil
+ "a direct superclass of the class ~A"
+ (class-or-name class))
+ (format nil
+ "reached from the class ~A by following~@
the direct superclass chain through: ~A~
~% ending at the class ~A"
- (class-or-name class)
- (format nil
- "~{~% the class ~A,~}"
- (butlast names))
- (car (last names))))))))
+ (class-or-name class)
+ (format nil
+ "~{~% the class ~A,~}"
+ (butlast names))
+ (car (last names)))))))))
(defun find-superclass-chain (bottom top)
(labels ((walk (c chain)
(format nil "named ~S" (class-name class))
class))))
(mapcar
- #'(lambda (reason)
- (ecase (caddr reason)
- (:super
- (format
- nil
- "The class ~A appears in the supers of the class ~A."
- (class-or-name (cadr reason))
- (class-or-name (car reason))))
- (:in-supers
- (format
- nil
- "The class ~A follows the class ~A in the supers of the class ~A."
- (class-or-name (cadr reason))
- (class-or-name (car reason))
- (class-or-name (cadddr reason))))))
+ (lambda (reason)
+ (ecase (caddr reason)
+ (:super
+ (format
+ nil
+ "The class ~A appears in the supers of the class ~A."
+ (class-or-name (cadr reason))
+ (class-or-name (car reason))))
+ (:in-supers
+ (format
+ nil
+ "The class ~A follows the class ~A in the supers of the class ~A."
+ (class-or-name (cadr reason))
+ (class-or-name (car reason))
+ (class-or-name (cadddr reason))))))
reasons)))
(defun find-cycle-reasons (all-cpds)