[no subject]

[primerd!DOUG@ENX.Prime.PDN.ARPA]

To:       Common LOOPS mailing list (commonloops.pa@xerox.com)
From:     Doug Rand (DOUGR@EDDIE.MIT.EDU)
Date:     22 Jan 87  9:48 AM
Subject:  Bug in PCL on LUCID

Their is a bug in LUCID's handling of the labels construct.  Patched
code for class-prot.lisp (replace compute-class-precedence-list):

(defun walk-supers (class &optional precedence)
         (let ((elem (assq class must-precede-alist)))
           (if elem
               (setf (cdr elem) (union (cdr elem) precedence))
               (push (cons class precedence) must-precede-alist)))
         (let ((rsupers (reverse (cons class (class-local-supers class)))))
           (iterate ((sup in rsupers)
                     (pre on (cdr rsupers))
                     (temp = nil))
             ;; Make sure this element of supers is OK.
             ;;  Actually, there is an important design decision hidden in
             ;;  here.  Namely, at what time should symbols in a class's
             ;;  local-supers be changed to the class objects they are
             ;;  forward referencing.
             ;;   1. At first make-instance (compute-class-precedence-list)?
             ;;   2. When the forward referenced class is first defined?
             ;;  This code does #1.
             (cond ((classp sup))
                   ((and (symbolp sup)
                         (setq temp (class-named sup t)))
                    ;; This is a forward reference to a class which is
                    ;; now defined.  Replace the symbol in the local
                    ;; supers with the actual class object, and set sup.
                    (nsubst temp sup (class-local-supers class))
                    (setq sup temp))
                   ((symbolp sup)
                    (error "While computing the class-precedence-list for ~
                             the class ~S.~%~
                             The class ~S (from the local supers of ~S) ~
                             is undefined."
                           (class-name root) sup (class-name class)))
                   (t
                    (error "INTERNAL ERROR --~%~
                             While computing the class-precedence-list for ~
                             the class ~S,~%~
                             ~S appeared in the local supers of ~S."
                           root sup class)))
             (walk-supers sup pre))
           (unless (memq class cpl) (push class cpl))))

(defmethod compute-class-precedence-list ((root class))
  (declare (special root))
  (let ((cpl ())
       (must-precede-alist ()))
       (declare (special cpl must-precede-alist))
    ;; We start by computing two values.
    ;;   CPL
    ;;     The depth-first left-to-right up to joins walk of the supers tree.
    ;;     This is equivalent to breadth-first left-to-right walk of the
    ;;     tree with all but the last occurence of a class removed from
    ;;     the resulting list.  This is in fact how the walk is implemented.
    ;;
    ;;   MUST-PRECEDE-ALIST
    ;;     An alist of the must-precede relations. The car of each element
    ;;     of the must-precede-alist is a class, the cdr is all the classes
    ;;     which either:
    ;;       have this class as a local super
    ;;      or
    ;;       appear before this class in some other class's local-supers.
    ;;
    ;;     Thus, the must-precede-alist reflects the two constraints that:
    ;;       1. A class must appear in the CPL before its local supers.
    ;;       2. Order of local supers is preserved in the CPL.
    ;;
;;    (labels
    (flet
       ((must-move-p (element list &aux move)
         (dolist (must-precede (cdr (assq element must-precede-alist)))
           (when (setq move (memq must-precede (cdr list)))
             (return move))))
       (find-farthest-move (element move)
         (let ((closure (compute-must-precedes-closure element)))
           (dolist (must-precede closure)
             (setq move (or (memq must-precede move) move)))
           move))
       (compute-must-precedes-closure (class)
         (let ((closure ()))
           (labels ((walk (element path)
                      (when (memq element path)
                        (class-ordering-error
                          root element path must-precede-alist))
                      (dolist (precede
                                (cdr (assq element
                                           must-precede-alist)))
                        (pushnew precede closure)
                        (walk precede (cons element path)))))
             (walk class nil)
             closure))))

      (walk-supers root)                       ;Do the walk
      ;; For each class in the cpl, make sure that there are no classes after
      ;; it which should be before it.  We do this by cdring down the list,
      ;; making sure that for each element of the list, none of its
      ;; must-precedes come after it in the list. If we find one, we use the
      ;; transitive closure of the must-precedes (call find-farthest-move) to
      ;; see where the class must really be moved. We use a hand-coded loop
      ;; so that we can splice things in and out of the CPL as we go.
      (let ((tail cpl)
           (element nil)
           (move nil))
       (loop (when (null tail) (return))
             (setq element (car tail)
                   move (must-move-p element tail))
             (cond (move
                    (setq move (find-farthest-move element move))
                    (setf (cdr move) (cons element (cdr move)))
                    (setf (car tail) (cadr tail)) ;Interlisp delete is OK
                    (setf (cdr tail) (cddr tail)) ;since it will never be
                                                  ;last element of list.
                    )
                   (t
                    (setq tail (cdr tail)))))
       (copy-list cpl)))))