From: William Harold Newman Date: Tue, 12 Jun 2001 19:24:47 +0000 (+0000) Subject: 0.6.12.33: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d34ac3bbb4a202adfc63d692c77d143e565642cd;p=sbcl.git 0.6.12.33: added a few more type test regression tests merged MNA port of DTC CMU CL inline type test patches (sbcl-devel 2001-05-28) --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 8f2e169..599d407 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1262,7 +1262,8 @@ is a good idea, but see SB-SYS for blurring of boundaries." "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*" diff --git a/src/code/class.lisp b/src/code/class.lisp index fda5bed..0377da2 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -514,7 +514,130 @@ (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))) + +;;;; 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)))) +;;;; 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 @@ -1069,9 +1192,9 @@ 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 @@ -1086,6 +1209,7 @@ codes enumerable state + depth (hierarchical-p t) ; might be modified below (direct-superclasses (if inherits (list (car inherits)) @@ -1108,7 +1232,7 @@ (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)))) @@ -1116,7 +1240,9 @@ (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 @@ -1130,7 +1256,18 @@ ;;; 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)) @@ -1139,7 +1276,7 @@ (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))) diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index 1f470f4..320a8c2 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -117,10 +117,15 @@ 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 @@ -299,19 +304,10 @@ (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 diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index a361fde..973f66b 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -266,10 +266,3 @@ (safety 1) (space 1) (speed 1))) - -;;; 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). diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 8e860f4..74aa5b3 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -459,6 +459,24 @@ (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) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 307e520..7a16f9b 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -92,14 +92,8 @@ ;;;; 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) @@ -131,7 +125,7 @@ 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 @@ -536,19 +530,9 @@ :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 @@ -565,12 +549,13 @@ (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))) @@ -593,8 +578,9 @@ (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 diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index ed10b5f..bcfb77b 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -44,7 +44,7 @@ ;;; ;;; 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)) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 467ec14..9448016 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -170,7 +170,12 @@ (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))) @@ -183,6 +188,7 @@ '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)) @@ -217,7 +223,10 @@ 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. diff --git a/version.lisp-expr b/version.lisp-expr index fef8fb7..38bde20 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; 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"