Skip to content
Snippets Groups Projects
Commit 6b223b43 authored by dtc's avatar dtc
Browse files

Add support for computing class precedence lists, and use this to

correctly calculate the CPL for the condition classes.
parent e390f5a4
No related branches found
No related tags found
No related merge requests found
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.45 2000/08/07 14:27:25 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.46 2000/08/08 13:41:18 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -34,7 +34,7 @@
built-in-class-direct-superclasses
find-class-cell class-cell-name class-cell-class
make-layout make-undefined-class insured-find-class
redefine-layout-warning))
redefine-layout-warning std-compute-class-precedence-list))
(in-package "LISP")
(export '(class structure-class standard-class class-name find-class class-of
......@@ -1125,6 +1125,90 @@
old)))
(t old))))
;;; Class precedence lists
;;; topological-sort -- Public.
;;;
;;; Topologically sort the list of objects to meet a set of ordering
;;; constraints given by pairs (A . B) constraining A to precede B. When
;;; there are multiple objects to choose, the tie-breaker function is called
;;; with both the list of object to choose from and the reverse ordering built
;;; so far.
;;;
(defun topological-sort (objects constraints tie-breaker)
(declare (list objects constraints)
(function tie-breaker))
(let ((obj-info (make-hash-table :size (length objects)))
(free-objs nil)
(result nil))
(dolist (constraint constraints)
(let ((obj1 (car constraint))
(obj2 (cdr constraint)))
(let ((info2 (gethash obj2 obj-info)))
(if info2
(incf (first info2))
(setf (gethash obj2 obj-info) (list 1))))
(let ((info1 (gethash obj1 obj-info)))
(if info1
(push obj2 (rest info1))
(setf (gethash obj1 obj-info) (list 0 obj2))))))
(dolist (obj objects)
(let ((info (gethash obj obj-info)))
(when (or (not info) (zerop (first info)))
(push obj free-objs))))
(loop
(flet ((next-result (obj)
(push obj result)
(dolist (successor (rest (gethash obj obj-info)))
(let* ((successor-info (gethash successor obj-info))
(count (1- (first successor-info))))
(setf (first successor-info) count)
(when (zerop count)
(push successor free-objs))))))
(cond ((endp free-objs)
(do-hash (obj info obj-info)
(unless (zerop (first info))
(error "Topological sort failed due to constrain on ~S."
obj)))
(return (nreverse result)))
((endp (rest free-objs))
(next-result (pop free-objs)))
(t
(let ((obj (funcall tie-breaker free-objs result)))
(setf free-objs (remove obj free-objs))
(next-result obj))))))))
;;; std-compute-class-precedence-list -- Internal.
;;;
;;; Standard class precedence list computation.
;;;
(defun std-compute-class-precedence-list (class)
(let ((classes nil)
(constraints nil))
(labels ((note-class (class)
(unless (member class classes)
(push class classes)
(let ((superclasses (class-direct-superclasses class)))
(do ((prev class)
(rest superclasses (rest rest)))
((endp rest))
(let ((next (first rest)))
(push (cons prev next) constraints)
(setf prev next)))
(dolist (class superclasses)
(note-class class)))))
(std-cpl-tie-breaker (free-classes rev-cpl)
(dolist (class rev-cpl (first free-classes))
(let* ((superclasses (class-direct-superclasses class))
(intersection (intersection free-classes
superclasses)))
(when intersection
(return (first intersection)))))))
(note-class class)
(topological-sort classes constraints #'std-cpl-tie-breaker))))
;;; PCL stuff:
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.56 2000/08/06 19:12:17 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.57 2000/08/08 13:41:18 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -437,9 +437,6 @@
;;;; Condition reporting:
;;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
;;; superclasses in define-condition call!
(defun %print-condition (s stream d)
(declare (ignore d))
(if *print-escape*
......@@ -583,18 +580,10 @@
(setf (find-class name) class)
;;
;; Initialize CPL slot from layout.
(collect ((cpl))
(cpl class)
(let ((inherits (layout-inherits layout)))
(do ((i (1- (length inherits)) (1- i)))
((minusp i))
(let ((super (find-class
(class-name
(layout-class (svref inherits i))))))
(when (typep super 'condition-class)
(cpl super)))))
(setf (condition-class-cpl class) (cpl))))
;; Initialize CPL slot.
(setf (condition-class-cpl class)
(remove-if-not #'condition-class-p
(std-compute-class-precedence-list class))))
(undefined-value))
); eval-when (compile load eval)
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.171 2000/08/06 19:12:18 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.172 2000/08/08 13:41:19 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -1594,6 +1594,7 @@
"SIMPLE-ARRAY-SIGNED-BYTE-32-P" "SIMPLE-ARRAY-SIGNED-BYTE-8-P"
"SIMPLE-UNBOXED-ARRAY" "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
"SINGLE-FLOAT-P" "SINGLE-VALUE-TYPE" "SPECIFIER-TYPE" "STACK-REF"
"STD-COMPUTE-CLASS-PRECEDENCE-LIST"
"STREAMLIKE" "STRINGABLE" "STRINGLIKE"
"%INSTANCE-LENGTH"
"%INSTANCE-REF" "%INSTANCE-SET"
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment