X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=fc7ed296f292a9a40e9a67d13b89b50967ff502c;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=8905c3469327677894cb5a9b4b80f3e3c9c72f24;hpb=dd04bd449535e9016b5652a708a3cac2ca24c87d;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index 8905c34..fc7ed29 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; @@ -685,7 +685,7 @@ (:make-load-form-fun (lambda (c) `(find-classoid-cell ',(classoid-cell-name c) - :errorp t))) + :create t))) #-no-ansi-print-object (:print-object (lambda (s stream) (print-unreadable-object (s stream :type t) @@ -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