[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
- To: COMMONLOOPS.PA@Xerox.COM
- From: primerd!DOUG@ENX.Prime.PDN.ARPA
- Date: 22 Jan 87 09:51:17 EDT
To: Common LOOPS mailing list (email@example.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)))
(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))
(error "While computing the class-precedence-list for ~
the class ~S.~%~
The class ~S (from the local supers of ~S) ~
(class-name root) sup (class-name class)))
(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 ())
(declare (special cpl must-precede-alist))
;; We start by computing two values.
;; 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.
;; 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
;; 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.
((must-move-p (element list &aux move)
(dolist (must-precede (cdr (assq element must-precede-alist)))
(when (setq move (memq must-precede (cdr list)))
(find-farthest-move (element move)
(let ((closure (compute-must-precedes-closure element)))
(dolist (must-precede closure)
(setq move (or (memq must-precede move) move)))
(let ((closure ()))
(labels ((walk (element path)
(when (memq element path)
root element path must-precede-alist))
(cdr (assq element
(pushnew precede closure)
(walk precede (cons element path)))))
(walk class nil)
(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)
(loop (when (null tail) (return))
(setq element (car tail)
move (must-move-p element tail))
(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.
(setq tail (cdr tail)))))