X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=6b868bd0f596ec0b8997f91dc50ef918ccff70a9;hb=cd1b14acf6f548b28b8a14e554d779f0473122ec;hp=38fbef051f8ee107bb57fbecab533d89008e85f5;hpb=71bc8b09fc75083ea4bb2aee954abca1f1e1f214;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index 38fbef0..6b868bd 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -51,7 +51,7 @@ ;; :SEALED = We can't even add subclasses. ;; NIL = Anything could happen. (state nil :type (member nil :read-only :sealed)) - ;; direct superclasses of this class + ;; direct superclasses of this class. Always NIL for CLOS classes. (direct-superclasses () :type list) ;; representation of all of the subclasses (direct or indirect) of ;; this class. This is NIL if no subclasses or not initalized yet; @@ -808,8 +808,12 @@ ;; getting a different cell for a classoid with the same name ;; just would not do. - ;; Remove the proper name of the classoid. - (setf (classoid-name (classoid-cell-classoid cell)) nil) + ;; Remove the proper name of the classoid, if this was it. + (let* ((classoid (classoid-cell-classoid cell)) + (proper-name (classoid-name classoid))) + (when (eq proper-name name) + (setf (classoid-name classoid) nil))) + ;; Clear the cell. (setf (classoid-cell-classoid cell) nil (classoid-cell-pcl-class cell) nil)) @@ -854,33 +858,43 @@ ;;; We might be passed classoids with invalid layouts; in any pairwise ;;; class comparison, we must ensure that both are valid before ;;; proceeding. -(defun %ensure-classoid-valid (classoid layout) +(defun %ensure-classoid-valid (classoid layout error-context) (aver (eq classoid (layout-classoid layout))) - (when (layout-invalid layout) - (if (typep classoid 'standard-classoid) - (let ((class (classoid-pcl-class classoid))) - (cond - ((sb!pcl:class-finalized-p class) - (sb!pcl::%force-cache-flushes class)) - ((sb!pcl::class-has-a-forward-referenced-superclass-p class) - (error "Invalid, unfinalizeable class ~S (classoid ~S)." - class classoid)) - (t - (sb!pcl:finalize-inheritance class)))) - (error "Don't know how to ensure validity of ~S (not ~ - a STANDARD-CLASSOID)." classoid)))) - -(defun %ensure-both-classoids-valid (class1 class2) + (or (not (layout-invalid layout)) + (if (typep classoid 'standard-classoid) + (let ((class (classoid-pcl-class classoid))) + (cond + ((sb!pcl:class-finalized-p class) + (sb!pcl::%force-cache-flushes class) + t) + ((sb!pcl::class-has-a-forward-referenced-superclass-p class) + (when error-context + (bug "~@" + class + (sb!pcl::class-has-a-forward-referenced-superclass-p class) + error-context)) + nil) + (t + (sb!pcl:finalize-inheritance class) + t))) + (bug "~@" + classoid (or error-context 'subtypep))))) + +(defun %ensure-both-classoids-valid (class1 class2 &optional errorp) (do ((layout1 (classoid-layout class1) (classoid-layout class1)) (layout2 (classoid-layout class2) (classoid-layout class2)) (i 0 (+ i 1))) - ((and (not (layout-invalid layout1)) (not (layout-invalid layout2)))) + ((and (not (layout-invalid layout1)) (not (layout-invalid layout2))) + t) (aver (< i 2)) - (%ensure-classoid-valid class1 layout1) - (%ensure-classoid-valid class2 layout2))) + (unless (and (%ensure-classoid-valid class1 layout1 errorp) + (%ensure-classoid-valid class2 layout2 errorp)) + (return-from %ensure-both-classoids-valid nil)))) (defun update-object-layout-or-invalid (object layout) - (if (typep (classoid-of object) 'standard-classoid) + (if (layout-for-std-class-p (layout-of object)) (sb!pcl::check-wrapper-validity object) (sb!c::%layout-invalid-error object layout))) @@ -894,11 +908,22 @@ (!define-type-method (classoid :simple-subtypep) (class1 class2) (aver (not (eq class1 class2))) (with-world-lock () - (%ensure-both-classoids-valid class1 class2) - (let ((subclasses (classoid-subclasses class2))) - (if (and subclasses (gethash class1 subclasses)) - (values t t) - (values nil t))))) + (if (%ensure-both-classoids-valid class1 class2) + (let ((subclasses2 (classoid-subclasses class2))) + (if (and subclasses2 (gethash class1 subclasses2)) + (values t t) + (if (and (typep class1 'standard-classoid) + (typep class2 'standard-classoid) + (or (sb!pcl::class-has-a-forward-referenced-superclass-p + (classoid-pcl-class class1)) + (sb!pcl::class-has-a-forward-referenced-superclass-p + (classoid-pcl-class class2)))) + ;; If there's a forward-referenced class involved we don't know for sure. + ;; (There are cases which we /could/ figure out, but that doesn't seem + ;; to be required or important, really.) + (values nil nil) + (values nil t)))) + (values nil nil)))) ;;; When finding the intersection of a sealed class and some other ;;; class (not hierarchically related) the intersection is the union @@ -919,7 +944,7 @@ (!define-type-method (classoid :simple-intersection2) (class1 class2) (declare (type classoid class1 class2)) (with-world-lock () - (%ensure-both-classoids-valid class1 class2) + (%ensure-both-classoids-valid class1 class2 "type intersection") (cond ((eq class1 class2) class1) ;; If one is a subclass of the other, then that is the @@ -1079,6 +1104,11 @@ :inherits (complex number) :codes (#.sb!vm:complex-long-float-widetag) :prototype-form (complex 42l0 42l0)) + #!+sb-simd-pack + (simd-pack + :translation simd-pack + :codes (#.sb!vm:simd-pack-widetag) + :prototype-form (%make-simd-pack-ub64 42 42)) (real :translation real :inherits (number)) (float :translation float @@ -1114,7 +1144,7 @@ :translation (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum) :inherits (integer rational real number) - :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag) + :codes #.(mapcar #'symbol-value sb!vm::fixnum-lowtags) :prototype-form 42) (bignum :translation (and integer (not fixnum)) @@ -1188,13 +1218,15 @@ :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 16))) - #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) - (simple-array-unsigned-byte-29 - :translation (simple-array (unsigned-byte 29) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-29-widetag) + + (simple-array-unsigned-fixnum + :translation (simple-array (unsigned-byte #.sb!vm:n-positive-fixnum-bits) (*)) + :codes (#.sb!vm:simple-array-unsigned-fixnum-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) - :prototype-form (make-array 0 :element-type '(unsigned-byte 29))) + :prototype-form (make-array 0 + :element-type '(unsigned-byte #.sb!vm:n-positive-fixnum-bits))) + (simple-array-unsigned-byte-31 :translation (simple-array (unsigned-byte 31) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-31-widetag) @@ -1208,13 +1240,6 @@ :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 32))) #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (simple-array-unsigned-byte-60 - :translation (simple-array (unsigned-byte 60) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-60-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence) - :prototype-form (make-array 0 :element-type '(unsigned-byte 60))) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) (simple-array-unsigned-byte-63 :translation (simple-array (unsigned-byte 63) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-63-widetag) @@ -1240,13 +1265,17 @@ :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(signed-byte 16))) - #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) - (simple-array-signed-byte-30 - :translation (simple-array (signed-byte 30) (*)) - :codes (#.sb!vm:simple-array-signed-byte-30-widetag) + + (simple-array-fixnum + :translation (simple-array (signed-byte #.sb!vm:n-fixnum-bits) + (*)) + :codes (#.sb!vm:simple-array-fixnum-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) - :prototype-form (make-array 0 :element-type '(signed-byte 30))) + :prototype-form (make-array 0 + :element-type + '(signed-byte #.sb!vm:n-fixnum-bits))) + (simple-array-signed-byte-32 :translation (simple-array (signed-byte 32) (*)) :codes (#.sb!vm:simple-array-signed-byte-32-widetag) @@ -1254,13 +1283,6 @@ :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(signed-byte 32))) #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (simple-array-signed-byte-61 - :translation (simple-array (signed-byte 61) (*)) - :codes (#.sb!vm:simple-array-signed-byte-61-widetag) - :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence) - :prototype-form (make-array 0 :element-type '(signed-byte 61))) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) (simple-array-signed-byte-64 :translation (simple-array (signed-byte 64) (*)) :codes (#.sb!vm:simple-array-signed-byte-64-widetag)