src/pcl/cpl.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3
   4 ;;;; This software is derived from software originally released by Xerox
   5 ;;;; Corporation. Copyright and release statements follow. Later modifications
   6 ;;;; to the software are in the public domain and are provided with
   7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
   8 ;;;; information.
   9
  10 ;;;; copyright information from original PCL sources:
  11 ;;;;
  12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  13 ;;;; All rights reserved.
  14 ;;;;
  15 ;;;; Use and copying of this software and preparation of derivative works based
  16 ;;;; upon this software are permitted. Any distribution of this software or
  17 ;;;; derivative works must comply with all applicable United States export
  18 ;;;; control laws.
  19 ;;;;
  20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  21 ;;;; warranty about the software, its performance or its conformity to any
  22 ;;;; specification.
  23
  24 (in-package "SB-PCL")
  25
  26 (sb-int:file-comment
  27   "$Header$")
  28 \f
  29 ;;; compute-class-precedence-list
  30 ;;;
  31 ;;; Knuth section 2.2.3 has some interesting notes on this.
  32 ;;;
  33 ;;; What appears here is basically the algorithm presented there.
  34 ;;;
  35 ;;; The key idea is that we use class-precedence-description (CPD) structures
  36 ;;; to store the precedence information as we proceed. The CPD structure for
  37 ;;; a class stores two critical pieces of information:
  38 ;;;
  39 ;;;  - a count of the number of "reasons" why the class can't go
  40 ;;;    into the class precedence list yet.
  41 ;;;
  42 ;;;  - a list of the "reasons" this class prevents others from
  43 ;;;    going in until after it
  44 ;;
  45 ;;; A "reason" is essentially a single local precedence constraint. If a
  46 ;;; constraint between two classes arises more than once it generates more
  47 ;;; than one reason. This makes things simpler, linear, and isn't a problem
  48 ;;; as long as we make sure to keep track of each instance of a "reason".
  49 ;;;
  50 ;;; This code is divided into three phases.
  51 ;;;
  52 ;;;  - the first phase simply generates the CPD's for each of the class
  53 ;;;    and its superclasses. The remainder of the code will manipulate
  54 ;;;    these CPDs rather than the class objects themselves. At the end
  55 ;;;    of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs
  56 ;;;    of the direct superclasses of the class.
  57 ;;;
  58 ;;;  - the second phase folds all the local constraints into the CPD
  59 ;;;    structure. The CPD-COUNT of each CPD is built up, and the
  60 ;;;    CPD-AFTER fields are augmented to include precedence constraints
  61 ;;;    from the CPD-SUPERS field and from the order of classes in other
  62 ;;;    CPD-SUPERS fields.
  63 ;;;
  64 ;;;    After this phase, the CPD-AFTER field of a class includes all the
  65 ;;;    direct superclasses of the class plus any class that immediately
  66 ;;;    follows the class in the direct superclasses of another. There
  67 ;;;    can be duplicates in this list. The CPD-COUNT field is equal to
  68 ;;;    the number of times this class appears in the CPD-AFTER field of
  69 ;;;    all the other CPDs.
  70 ;;;
  71 ;;;  - In the third phase, classes are put into the precedence list one
  72 ;;;    at a time, with only those classes with a CPD-COUNT of 0 being
  73 ;;;    candidates for insertion. When a class is inserted , every CPD
  74 ;;;    in its CPD-AFTER field has its count decremented.
  75 ;;;
  76 ;;;    In the usual case, there is only one candidate for insertion at
  77 ;;;    any point. If there is more than one, the specified tiebreaker
  78 ;;;    rule is used to choose among them.
  79
  80 (defmethod compute-class-precedence-list ((root slot-class))
  81   (compute-std-cpl root (class-direct-superclasses root)))
  82
  83 (defstruct (class-precedence-description
  84              (:conc-name nil)
  85              (:print-object (lambda (obj str)
  86                               (print-unreadable-object (obj str :type t)
  87                                 (format str "~D" (cpd-count obj)))))
  88              (:constructor make-cpd ()))
  89   (cpd-class  nil)
  90   (cpd-supers ())
  91   (cpd-after  ())
  92   (cpd-count  0))
  93
  94 (defun compute-std-cpl (class supers)
  95   (cond ((null supers)                          ;First two branches of COND
  96          (list class))                          ;are implementing the single
  97         ((null (cdr supers))                    ;inheritance optimization.
  98          (cons class
  99                (compute-std-cpl (car supers)
 100                                 (class-direct-superclasses (car supers)))))
 101         (t
 102          (multiple-value-bind (all-cpds nclasses)
 103              (compute-std-cpl-phase-1 class supers)
 104            (compute-std-cpl-phase-2 all-cpds)
 105            (compute-std-cpl-phase-3 class all-cpds nclasses)))))
 106
 107 (defvar *compute-std-cpl-class->entry-table-size* 60)
 108
 109 (defun compute-std-cpl-phase-1 (class supers)
 110   (let ((nclasses 0)
 111         (all-cpds ())
 112         (table (make-hash-table :size *compute-std-cpl-class->entry-table-size*
 113                                 :test #'eq)))
 114     (declare (fixnum nclasses))
 115     (labels ((get-cpd (c)
 116                (or (gethash c table)
 117                    (setf (gethash c table) (make-cpd))))
 118              (walk (c supers)
 119                (if (forward-referenced-class-p c)
 120                    (cpl-forward-referenced-class-error class c)
 121                    (let ((cpd (get-cpd c)))
 122                      (unless (cpd-class cpd)    ;If we have already done this
 123                                                 ;class before, we can quit.
 124                        (setf (cpd-class cpd) c)
 125                        (incf nclasses)
 126                        (push cpd all-cpds)
 127                        (setf (cpd-supers cpd) (mapcar #'get-cpd supers))
 128                        (dolist (super supers)
 129                          (walk super (class-direct-superclasses super))))))))
 130       (walk class supers)
 131       (values all-cpds nclasses))))
 132
 133 (defun compute-std-cpl-phase-2 (all-cpds)
 134   (dolist (cpd all-cpds)
 135     (let ((supers (cpd-supers cpd)))
 136       (when supers
 137         (setf (cpd-after cpd) (nconc (cpd-after cpd) supers))
 138         (incf (cpd-count (car supers)) 1)
 139         (do* ((t1 supers t2)
 140               (t2 (cdr t1) (cdr t1)))
 141              ((null t2))
 142           (incf (cpd-count (car t2)) 2)
 143           (push (car t2) (cpd-after (car t1))))))))
 144
 145 (defun compute-std-cpl-phase-3 (class all-cpds nclasses)
 146   (let ((candidates ())
 147         (next-cpd nil)
 148         (rcpl ()))
 149
 150     ;; We have to bootstrap the collection of those CPD's that
 151     ;; have a zero count. Once we get going, we will maintain
 152     ;; this list incrementally.
 153     (dolist (cpd all-cpds)
 154       (when (zerop (cpd-count cpd)) (push cpd candidates)))
 155
 156     (loop
 157       (when (null candidates)
 158
 159         ;; If there are no candidates, and enough classes have been put
 160         ;; into the precedence list, then we are all done. Otherwise
 161         ;; it means there is a consistency problem.
 162         (if (zerop nclasses)
 163             (return (reverse rcpl))
 164             (cpl-inconsistent-error class all-cpds)))
 165
 166       ;; Try to find the next class to put in from among the candidates.
 167       ;; If there is only one, its easy, otherwise we have to use the
 168       ;; famous RPG tiebreaker rule. There is some hair here to avoid
 169       ;; having to call DELETE on the list of candidates. I dunno if
 170       ;; its worth it but what the hell.
 171       (setq next-cpd
 172             (if (null (cdr candidates))
 173                 (prog1 (car candidates)
 174                        (setq candidates ()))
 175                 (block tie-breaker
 176                   (dolist (c rcpl)
 177                     (let ((supers (class-direct-superclasses c)))
 178                       (if (memq (cpd-class (car candidates)) supers)
 179                           (return-from tie-breaker (pop candidates))
 180                           (do ((loc candidates (cdr loc)))
 181                               ((null (cdr loc)))
 182                             (let ((cpd (cadr loc)))
 183                               (when (memq (cpd-class cpd) supers)
 184                                 (setf (cdr loc) (cddr loc))
 185                                 (return-from tie-breaker cpd))))))))))
 186       (decf nclasses)
 187       (push (cpd-class next-cpd) rcpl)
 188       (dolist (after (cpd-after next-cpd))
 189         (when (zerop (decf (cpd-count after)))
 190           (push after candidates))))))
 191 \f
 192 ;;;; support code for signalling nice error messages
 193
 194 (defun cpl-error (class format-string &rest format-args)
 195   (error "While computing the class precedence list of the class ~A.~%~A"
 196           (if (class-name class)
 197               (format nil "named ~S" (class-name class))
 198               class)
 199           (apply #'format nil format-string format-args)))
 200
 201 (defun cpl-forward-referenced-class-error (class forward-class)
 202   (flet ((class-or-name (class)
 203            (if (class-name class)
 204                (format nil "named ~S" (class-name class))
 205                class)))
 206     (let ((names (mapcar #'class-or-name
 207                          (cdr (find-superclass-chain class forward-class)))))
 208       (cpl-error class
 209                  "The class ~A is a forward referenced class.~@
 210                   The class ~A is ~A."
 211                  (class-or-name forward-class)
 212                  (class-or-name forward-class)
 213                  (if (null (cdr names))
 214                      (format nil
 215                              "a direct superclass of the class ~A"
 216                              (class-or-name class))
 217                      (format nil
 218                              "reached from the class ~A by following~@
 219                               the direct superclass chain through: ~A~
 220                               ~%  ending at the class ~A"
 221                              (class-or-name class)
 222                              (format nil
 223                                      "~{~%  the class ~A,~}"
 224                                      (butlast names))
 225                              (car (last names))))))))
 226
 227 (defun find-superclass-chain (bottom top)
 228   (labels ((walk (c chain)
 229              (if (eq c top)
 230                  (return-from find-superclass-chain (nreverse chain))
 231                  (dolist (super (class-direct-superclasses c))
 232                    (walk super (cons super chain))))))
 233     (walk bottom (list bottom))))
 234
 235 (defun cpl-inconsistent-error (class all-cpds)
 236   (let ((reasons (find-cycle-reasons all-cpds)))
 237     (cpl-error class
 238       "It is not possible to compute the class precedence list because~@
 239        there ~A in the local precedence relations.~@
 240        ~A because:~{~%  ~A~}."
 241       (if (cdr reasons) "are circularities" "is a circularity")
 242       (if (cdr reasons) "These arise" "This arises")
 243       (format-cycle-reasons (apply #'append reasons)))))
 244
 245 (defun format-cycle-reasons (reasons)
 246   (flet ((class-or-name (cpd)
 247            (let ((class (cpd-class cpd)))
 248              (if (class-name class)
 249                  (format nil "named ~S" (class-name class))
 250                  class))))
 251     (mapcar
 252       #'(lambda (reason)
 253           (ecase (caddr reason)
 254             (:super
 255               (format
 256                 nil
 257                 "The class ~A appears in the supers of the class ~A."
 258                 (class-or-name (cadr reason))
 259                 (class-or-name (car reason))))
 260             (:in-supers
 261               (format
 262                 nil
 263                 "The class ~A follows the class ~A in the supers of the class ~A."
 264                 (class-or-name (cadr reason))
 265                 (class-or-name (car reason))
 266                 (class-or-name (cadddr reason))))))
 267       reasons)))
 268
 269 (defun find-cycle-reasons (all-cpds)
 270   (let ((been-here ())     ; list of classes we have visited
 271         (cycle-reasons ()))
 272
 273     (labels ((chase (path)
 274                (if (memq (car path) (cdr path))
 275                    (record-cycle (memq (car path) (nreverse path)))
 276                    (unless (memq (car path) been-here)
 277                      (push (car path) been-here)
 278                      (dolist (after (cpd-after (car path)))
 279                        (chase (cons after path))))))
 280              (record-cycle (cycle)
 281                (let ((reasons ()))
 282                  (do* ((t1 cycle t2)
 283                        (t2 (cdr t1) (cdr t1)))
 284                       ((null t2))
 285                    (let ((c1 (car t1))
 286                          (c2 (car t2)))
 287                      (if (memq c2 (cpd-supers c1))
 288                          (push (list c1 c2 :super) reasons)
 289                          (dolist (cpd all-cpds)
 290                            (when (memq c2 (memq c1 (cpd-supers cpd)))
 291                              (return
 292                                (push (list c1 c2 :in-supers cpd) reasons)))))))
 293                  (push (nreverse reasons) cycle-reasons))))
 294
 295       (dolist (cpd all-cpds)
 296         (unless (zerop (cpd-count cpd))
 297           (chase (list cpd))))
 298
 299       cycle-reasons)))
 300