"MAKE-UNDEFINED-CLASS" "CLASS-DIRECT-SUPERCLASSES" "MAKE-LAYOUT"
"BYTE-FUNCTION-TYPE"
"REDEFINE-LAYOUT-WARNING" "SLOT-CLASS"
- "INSURED-FIND-CLASS"
+ "INSURED-FIND-CLASS" "ORDER-LAYOUT-INHERITS"
+ "STD-COMPUTE-CLASS-PRECEDENCE-LIST"
;; symbols from former SB!CONDITIONS
"*HANDLER-CLUSTERS*" "*RESTART-CLUSTERS*"
(values))
); EVAL-WHEN
+
+;;; Arrange the inherited layouts to appear at their expected depth,
+;;; ensuring that hierarchical type tests succeed. Layouts with a
+;;; specific depth are placed first, then the non- hierarchical
+;;; layouts fill remaining elements. Any empty elements are filled
+;;; with layout copies ensuring that all elements have a valid layout.
+;;; This re-ordering may destroy CPL ordering so the inherits should
+;;; not be read as being in CPL order, and further duplicates may be
+;;; introduced.
+(defun order-layout-inherits (layouts)
+ (declare (simple-vector layouts))
+ (let ((length (length layouts))
+ (max-depth -1))
+ (dotimes (i length)
+ (let ((depth (layout-depthoid (svref layouts i))))
+ (when (> depth max-depth)
+ (setf max-depth depth))))
+ (let* ((new-length (max (1+ max-depth) length))
+ (inherits (make-array new-length)))
+ (dotimes (i length)
+ (let* ((layout (svref layouts i))
+ (depth (layout-depthoid layout)))
+ (unless (eql depth -1)
+ (let ((old-layout (svref inherits depth)))
+ (unless (or (eql old-layout 0) (eq old-layout layout))
+ (error "layout depth conflict: ~S~%" layouts)))
+ (setf (svref inherits depth) layout))))
+ (do ((i 0 (1+ i))
+ (j 0))
+ ((>= i length))
+ (declare (type index i j))
+ (let* ((layout (svref layouts i))
+ (depth (layout-depthoid layout)))
+ (when (eql depth -1)
+ (loop (when (eql (svref inherits j) 0)
+ (return))
+ (incf j))
+ (setf (svref inherits j) layout))))
+ (do ((i (1- new-length) (1- i)))
+ ((< i 0))
+ (declare (type fixnum i))
+ (when (eql (svref inherits i) 0)
+ (setf (svref inherits i) (svref inherits (1+ i)))))
+ inherits)))
+\f
+;;;; class precedence lists
+
+;;; 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)
+ (dohash (obj info obj-info)
+ (unless (zerop (first info))
+ (error "Topological sort failed due to constraint 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))))))))
+
+
+;;; 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))))
\f
+;;;; object types to represent classes
+
;;; An UNDEFINED-CLASS is a cookie we make up to stick in forward
;;; referenced layouts. Users should never see them.
(def!struct (undefined-class (:include #-sb-xc sb!xc:class
generic-number)
:codes (#.sb!vm:bignum-type))
(stream
- :hierarchical-p nil
:state :read-only
- :inherits (instance t)))))
+ :depth 3
+ :inherits (instance)))))
;;; comment from CMU CL:
;;; See also type-init.lisp where we finish setting up the
codes
enumerable
state
+ depth
(hierarchical-p t) ; might be modified below
(direct-superclasses (if inherits
(list (car inherits))
(unless trans-p
(setf (info :type :builtin name) class))
(let* ((inherits-vector
- (map 'vector
+ (map 'simple-vector
(lambda (x)
(let ((super-layout
(class-layout (sb!xc:find-class x))))
(setf hierarchical-p nil))
super-layout))
inherits-list))
- (depthoid (if hierarchical-p (length inherits-vector) -1)))
+ (depthoid (if hierarchical-p
+ (or depth (length inherits-vector))
+ -1)))
(register-layout
(find-and-init-or-check-layout name
0
;;; is loaded and the class defined.
(!cold-init-forms
(/show0 "about to define temporary STANDARD-CLASSes")
- (dolist (x '((fundamental-stream (t instance stream))))
+ (dolist (x '(;; FIXME: The mysterious duplication of STREAM in the
+ ;; list here here was introduced in sbcl-0.6.12.33, in
+ ;; MNA's port of DTC's inline-type-tests patches for
+ ;; CMU CL. I'm guessing that it has something to do
+ ;; with preallocating just enough space in a table
+ ;; later used by the final definition of
+ ;; FUNDAMENTAL-STREAM (perhaps for Gray stream stuff?).
+ ;; It'd be good to document this weirdness both here
+ ;; and in the REGISTER-LAYOUT code which has to do the
+ ;; right thing with the duplicates-containing
+ ;; INHERITS-LIST.
+ (fundamental-stream (t instance stream stream))))
(/show0 "defining temporary STANDARD-CLASS")
(let* ((name (first x))
(inherits-list (second x))
(setf (class-cell-class class-cell) class
(info :type :class name) class-cell
(info :type :kind name) :instance)
- (let ((inherits (map 'vector
+ (let ((inherits (map 'simple-vector
(lambda (x)
(class-layout (sb!xc:find-class x)))
inherits-list)))
parent-types)))))
(cond-layout (info :type :compiler-layout 'condition))
(olayout (info :type :compiler-layout name))
+ ;; FIXME: Does this do the right thing in case of multiple
+ ;; inheritance? A quick look at DEFINE-CONDITION didn't make
+ ;; it obvious what ANSI intends to be done in the case of
+ ;; multiple inheritance, so it's not actually clear what the
+ ;; right thing is..
(new-inherits
- (concatenate 'simple-vector
- (layout-inherits cond-layout)
- (mapcar #'class-layout cpl))))
+ (order-layout-inherits (concatenate 'simple-vector
+ (layout-inherits cond-layout)
+ (mapcar #'class-layout cpl)))))
(if (and olayout
(not (mismatch (layout-inherits olayout) new-inherits)))
olayout
(setf (sb!xc: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 (sb!xc:find-class
- (sb!xc: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))))
(values))
) ; EVAL-WHEN
(safety 1)
(space 1)
(speed 1)))
-\f
-;;; FIXME: It would be good to unintern stuff we will no longer need
-;;; before we go on to PURIFY. E.g.
-;;; * various PCL stuff like INITIAL-CLASSES-AND-WRAPPERS; and
-;;; * *BUILT-IN-CLASSES* (which can't actually be freed by UNINTERN at
-;;; this point, since it passed through another PURIFY earlier
-;;; at cold init time).
(eq (svref (layout-inherits ,n-layout)
,depthoid)
',layout))))))))
+ ((and layout (>= (layout-depthoid layout) 0))
+ ;; hierarchical layout depths for other things (e.g.
+ ;; CONDITIONs)
+ (let ((depthoid (layout-depthoid layout))
+ (n-layout (gensym))
+ (n-inherits (gensym)))
+ `(and (,pred object)
+ (let ((,n-layout (,get-layout object)))
+ ,@(when (policy *lexenv* (>= safety speed))
+ `((when (layout-invalid ,n-layout)
+ (%layout-invalid-error object ',layout))))
+ (if (eq ,n-layout ',layout)
+ t
+ (let ((,n-inherits (layout-inherits ,n-layout)))
+ (declare (optimize (safety 0)))
+ (and (> (length ,n-inherits) ,depthoid)
+ (eq (svref ,n-inherits ,depthoid)
+ ',layout))))))))
(t
(/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
`(and (,pred object)
;;;; BOOTSTRAP-META-BRAID
;;;;
;;;; This function builds the base metabraid from the early class definitions.
-;;;;
-;;;; FIXME: This, like lotso the other stuff in PCL, is not needed in target
-;;;; Lisp, only at bootstrap time. Perhaps we should do something kludgy like
-;;;; putting a special character (#\$, perhaps) at the beginning of each
-;;;; needed-only-at-bootstrap-time symbol and then UNINTERN them all once we're
-;;;; done bootstrapping?
-(defmacro initial-classes-and-wrappers (&rest classes)
+(defmacro !initial-classes-and-wrappers (&rest classes)
`(progn
,@(mapcar #'(lambda (class)
(let ((wr (intern (format nil "~A-WRAPPER" class)
standard-effective-slot-definition
class-eq-specializer-wrapper class-eq-specializer
standard-generic-function-wrapper standard-generic-function)
- (initial-classes-and-wrappers
+ (!initial-classes-and-wrappers
standard-class funcallable-standard-class
slot-class built-in-class structure-class std-class
standard-direct-slot-definition standard-effective-slot-definition
:metaclass 'structure-class
:name symbol
:direct-superclasses
- (cond ;; Handle our CMU-CL-ish structure-based
- ;; conditions.
- ((cl:subtypep symbol 'condition)
- (mapcar #'cl:class-name
- (sb-kernel:class-direct-superclasses
- (cl:find-class symbol))))
- ;; a hack to add the STREAM class as a
- ;; mixin to the LISP-STREAM class.
- ((eq symbol 'sb-kernel:lisp-stream)
- '(structure-object stream))
- ((structure-type-included-type-name symbol)
- (list (structure-type-included-type-name
- symbol))))
+ (mapcar #'cl:class-name
+ (sb-kernel:class-direct-superclasses
+ (cl:find-class symbol)))
:direct-slots
(mapcar #'slot-initargs-from-structure-slotd
(structure-type-slot-description-list
(let* ((default-method-function #'constantly-nil)
(default-method-initargs (list :function
default-method-function))
- (default-method (make-a-method 'standard-method
- ()
- (list 'object)
- (list *the-class-t*)
- default-method-initargs
- "class predicate default method")))
+ (default-method (make-a-method
+ 'standard-method
+ ()
+ (list 'object)
+ (list *the-class-t*)
+ default-method-initargs
+ "class predicate default method")))
(setf (method-function-get default-method-function :constant-value)
nil)
(add-method gf default-method)))
(let ((lclass (sb-kernel:layout-class layout)))
(unless (eq (sb-kernel:class-layout lclass) layout)
(setf (sb-kernel:layout-inherits layout)
- (map 'vector #'class-wrapper
- (reverse (rest (class-precedence-list class)))))
+ (sb-kernel:order-layout-inherits
+ (map 'simple-vector #'class-wrapper
+ (reverse (rest (class-precedence-list class))))))
(sb-kernel:register-layout layout :invalidate nil)
;; Subclasses of formerly forward-referenced-class may be
;;;
;;; After the metabraid has been setup, and the protocol for defining
;;; classes has been defined, the real definition of LOAD-DEFCLASS is
-;;; installed by the file defclass.lisp
+;;; installed by the file std-class.lisp
(defmacro defclass (name direct-superclasses direct-slots &rest options)
(expand-defclass name direct-superclasses direct-slots options))
(assert (null (ignore-errors
(setf (slot-value (make-condition 'condition-foo1) 'x)
11))))
-
+ (assert (subtypep 'error 't))
+ (assert (subtypep 'simple-condition 'condition))
+ (assert (subtypep 'simple-error 'simple-condition))
+ (assert (subtypep 'simple-error 'error))
+ (assert (not (subtypep 'condition 'simple-condition)))
+ (assert (not (subtypep 'error 'simple-error)))
(assert (eq (car (sb-kernel:class-direct-superclasses (find-class
'simple-condition)))
(find-class 'condition)))
'simple-condition))
(mapcar #'sb-pcl:find-class '(simple-type-error simple-error
sb-int:simple-style-warning)))))
+
;; precedence lists
(assert (equal (sb-pcl:class-precedence-list
(sb-pcl:find-class 'simple-condition))
standard-object
sb-pcl::std-object
sb-pcl::slot-object stream
- sb-kernel:instance t)))))
+ sb-kernel:instance t))))
+ (assert (subtypep (find-class 'stream) (find-class t)))
+ (assert (subtypep (find-class 'fundamental-stream) 'stream))
+ (assert (not (subtypep 'stream 'fundamental-stream))))
;;; inline-type tests:
;;; Test the interpreted version.
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.12.32"
+"0.6.12.33"
projects / sbcl.git / commitdiff