mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-13 21:02:47 -08:00
Code Issues Projects Releases Packages Wiki Activity

Fix the routine that computes the class precedence list.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2008-12-10 12:13:02 +01:00
parent a3fdf8f7da
commit 38ef5fad47
2 changed files with 50 additions and 131 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/CHANGELOG
View file

@ -202,6 +202,10 @@ ECL 8.9.0:
- When working with Gray streams, READ-LINE did not handle the EOF properly.
- The routine that computed the class precedence list produced the wrong
result for moderately complex class hierarchies. It has been replaced with
a version that exactly implements the algorithm in the ANSI specification.
;;; Local Variables: ***
;;; mode:text ***
;;; fill-column:79 ***

177
src/clos/defclass.lsp
View file

@ -157,137 +157,52 @@
;;; ----------------------------------------------------------------------
;;; support for standard-class
(defun pair-list (l)
(declare (si::c-local))
(if (or (null l) (endp (cdr l)))
nil
(cons (cons (first l) (second l))
(pair-list (rest l)))))
(defun walk-supers (parent superclasses class-list precedence-alist)
(let ((new-alist (pair-list (if parent
(list* parent superclasses)
superclasses))))
(setf precedence-alist (nconc new-alist precedence-alist)
class-list (union superclasses class-list)))
(dolist (c superclasses)
(multiple-value-setq (class-list precedence-alist)
(walk-supers c (class-direct-superclasses c) class-list precedence-alist)))
(values class-list precedence-alist))
(defun compute-clos-class-precedence-list (class-name superclasses)
;; 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 depth-first right-to-left 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.
;;
;; PRECEDENCE-ALIST
;; An alist of the precedence relations. The car of each element
;; of the precedence-alist is a class C, the cdr is all the classes C'
;; which should precede C because either:
;; C is a local super of C'
;; or
;; C' appears before C in some class's local-supers.
;;
;; Thus, the precedence-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
((must-move-p (element list precedence-alist &aux move)
(dolist (must-precede (cdr (assoc element
precedence-alist
:test #'eq)))
(when (setq move (member must-precede (cdr list)
:test #'eq))
(return move))))
(find-farthest-move
(element move precedence-alist)
(dolist (must-precede (transitive-closure element precedence-alist))
(setq move (or (member must-precede move :test #'eq) move)))
move)
(transitive-closure
(class precedence-alist)
(let* ((closure ()))
(labels ((walk (element path)
(when (member element path :test #'eq)
(class-ordering-error
class-name element path precedence-alist))
(dolist (precede
(cdr (assoc element
precedence-alist :test #'eq)))
(unless (member precede closure :test #'eq)
(pushnew precede closure)
(walk precede (cons element path))))))
(walk class nil)
closure))))
(multiple-value-bind
(cpl precedence-alist)
(walk-supers superclasses nil nil)
(let* ((tail cpl)
(element nil)
(move nil))
;; 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.
(loop (when (null tail) (return))
(setq element (car tail)
move (must-move-p element tail precedence-alist))
(cond (move
(setq move (find-farthest-move element move precedence-alist))
(setf (cdr move) (cons element (cdr move)))
(setf (car tail) (cadr tail))
(setf (cdr tail) (cddr tail))
)
(t
(setq tail (cdr tail)))))
cpl))))
(defun walk-supers (supers cpl precedence-alist)
(declare (si::c-local))
(do* ((pre (reverse supers))
(sup)
(precedence))
((null pre) (values cpl precedence-alist))
(setq sup (pop pre))
(when pre
(if (setq precedence (assoc sup precedence-alist :test #'eq))
;; don't use rplacd here:
(setq precedence (cons (car precedence) (union pre precedence)))
(push (cons sup pre) precedence-alist)))
(multiple-value-setq (cpl precedence-alist)
(walk-supers (class-direct-superclasses sup) cpl precedence-alist))
(setq cpl (adjoin sup cpl))))
(defun class-ordering-error (root element path precedence-alist)
(declare (si::c-local))
(setq path (cons element (reverse (member element (reverse path) :test #'eq))))
(flet ((pretty (class)
(declare (type class class)
(optimize (safety 0)))
(or (class-name class) class)))
(let ((explanations ()))
(do ((tail path (cdr tail)))
((null (cdr tail)))
(let* ((after (cadr tail))
(before (car tail)))
(if (member after (class-direct-superclasses before) :test #'eq)
(push (format nil
"~% ~A must precede ~A -- ~
~A is in the local supers of ~A."
(pretty before) (pretty after)
(pretty after) (pretty before))
explanations)
(dolist (common-precede
(intersection
(cdr (assoc after precedence-alist :test #'eq))
(cdr (assoc before precedence-alist :test #'eq))))
(when (member after (member before
(class-direct-superclasses common-precede)
:test #'eq)
:test #'eq)
(push (format nil
"~% ~A must precede ~A -- ~
~A has local supers ~S."
(pretty before) (pretty after)
(pretty common-precede)
(mapcar #'pretty
(class-direct-superclasses common-precede)))
explanations))))))
(error "While computing the class-precedence-list for the class ~A:~%~
There is a circular constraint through the classes:~{ ~A~}.~%~
This arises because:~{~A~}"
root
(mapcar #'pretty path)
(reverse explanations)))))
(if (endp (rest superclasses))
(let ((class (first superclasses)))
(list* class (class-precedence-list class)))
(multiple-value-bind (class-list precedence-alist)
(walk-supers nil superclasses nil nil)
(flet ((cycle-error (class-name)
(error "A cycle has been detected in the class precedence list for ~A."
class-name))
(free-elements (class-list precedence-alist)
(set-difference class-list
(delete-duplicates (mapcar #'cdr precedence-alist))))
(next-element (free-list cpl)
(if (or (null cpl) (endp free-list) (endp (rest free-list)))
(first free-list)
(dolist (i cpl nil)
(dolist (j (class-direct-superclasses i))
(when (member j free-list)
(return-from next-element j)))))))
(do ((cpl '()))
((null class-list)
(if precedence-alist (cycle-error class-name) (nreverse cpl)))
(let* ((candidates (free-elements class-list precedence-alist))
(next (next-element candidates cpl)))
(unless next
(cycle-error class-name))
(setf precedence-alist (delete next precedence-alist :key #'car)
class-list (delete next class-list)
cpl (cons next cpl))))))))
;;; ----------------------------------------------------------------------