mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Move source-location out of layouts and into classoids
There is no user interface for getting an obsolete layout and asking where it was defined, as opposed to just asking the classoid. (If you had an obsolete object, then any operation on it would upgrade the layout, hence not actually get the location of the obsolete layout)
This commit is contained in:
parent
2ec85e50d7
commit
547b9a1959
|
|
@ -402,12 +402,10 @@ If an unsupported TYPE is requested, the function will return NIL.
|
|||
(defun find-definition-source (object)
|
||||
(typecase object
|
||||
((or sb-pcl::condition-class sb-pcl::structure-class)
|
||||
(let ((classoid (sb-impl::find-classoid (class-name object))))
|
||||
(let ((classoid (sb-pcl::class-classoid object)))
|
||||
(when classoid
|
||||
(let ((layout (sb-impl::classoid-layout classoid)))
|
||||
(when layout
|
||||
(translate-source-location
|
||||
(sb-kernel::layout-source-location layout)))))))
|
||||
(translate-source-location
|
||||
(sb-kernel::classoid-source-location classoid)))))
|
||||
(method-combination
|
||||
(car
|
||||
(find-definition-sources-by-name
|
||||
|
|
|
|||
|
|
@ -323,9 +323,9 @@
|
|||
'condition name
|
||||
(lambda ()
|
||||
(%%compiler-define-condition name parent-types layout all-readers all-writers)
|
||||
(when source-location
|
||||
(setf (layout-source-location layout) source-location))
|
||||
(let ((classoid (find-classoid name)))
|
||||
(when source-location
|
||||
(setf (classoid-source-location classoid) source-location))
|
||||
(setf (condition-classoid-slots classoid) slots
|
||||
(condition-classoid-direct-default-initargs classoid) direct-default-initargs
|
||||
(documentation name 'type) documentation)
|
||||
|
|
|
|||
|
|
@ -1039,7 +1039,7 @@ unless :NAMED is also specified.")))
|
|||
(setf (find-classoid (dd-name dd)) classoid)
|
||||
|
||||
(when source-location
|
||||
(setf (layout-source-location layout) source-location))))
|
||||
(setf (classoid-source-location classoid) source-location))))
|
||||
|
||||
|
||||
;;; Return a form accessing the writable place used for the slot
|
||||
|
|
|
|||
|
|
@ -164,8 +164,6 @@
|
|||
(bitmap +layout-all-tagged+ :type layout-bitmap)
|
||||
;; Per-slot comparator for implementing EQUALP.
|
||||
(equalp-tests #() :type simple-vector)
|
||||
;; Definition location
|
||||
(source-location nil)
|
||||
;; If this layout is for an object of metatype STANDARD-CLASS,
|
||||
;; these are the EFFECTIVE-SLOT-DEFINITION metaobjects.
|
||||
(slot-list nil :type list)
|
||||
|
|
@ -234,6 +232,9 @@
|
|||
(state nil :type (member nil :read-only :sealed))
|
||||
;; direct superclasses of this class. Always NIL for CLOS classes.
|
||||
(direct-superclasses () :type list)
|
||||
;; Definition location
|
||||
;; Not used for standard-classoid, because pcl has its own mechanism.
|
||||
(source-location nil)
|
||||
;; representation of all of the subclasses (direct or indirect) of
|
||||
;; this class. This is NIL if no subclasses or not initalized yet;
|
||||
;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
|
||||
|
|
|
|||
|
|
@ -1165,7 +1165,6 @@ core and return a descriptor to it."
|
|||
;; Nothing in cold-init needs to call EQUALP on a structure with raw slots,
|
||||
;; but for type-correctness this slot needs to be a simple-vector.
|
||||
:equalp-tests *simple-vector-0-descriptor*
|
||||
:source-location *nil-descriptor*
|
||||
:slot-list *nil-descriptor*
|
||||
(if (member name '(null list symbol))
|
||||
;; Assign an empty slot-table. Why this is done only for three
|
||||
|
|
|
|||
|
|
@ -561,7 +561,7 @@
|
|||
(let* ((name (class-name class))
|
||||
(classoid (find-classoid name))
|
||||
(slots (condition-classoid-slots classoid))
|
||||
(source (sb-kernel::layout-source-location (classoid-layout classoid))))
|
||||
(source (sb-kernel::classoid-source-location classoid)))
|
||||
;; to balance the REMOVE-SLOT-ACCESSORS call in
|
||||
;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS).
|
||||
(flet ((add-source-location (method)
|
||||
|
|
|
|||
|
|
@ -60,15 +60,11 @@
|
|||
|
||||
(test-util:with-test (:name :bug-458015)
|
||||
;; Make sure layouts have sane source-locations
|
||||
(sb-int:call-with-each-globaldb-name
|
||||
(lambda (info-name)
|
||||
(when (and (symbolp info-name) (info :type :kind info-name))
|
||||
(let* ((classoid (find-classoid info-name nil))
|
||||
(layout (and classoid (classoid-layout classoid)))
|
||||
(srcloc (and layout (sb-kernel::layout-source-location layout))))
|
||||
(when (and layout)
|
||||
(assert (or (sb-c::definition-source-location-p srcloc)
|
||||
(null srcloc)))))))))
|
||||
(do-all-symbols (symbol)
|
||||
(let ((classoid (find-classoid symbol nil)))
|
||||
(when classoid
|
||||
(assert (typep (sb-kernel::classoid-source-location classoid)
|
||||
'(or null sb-c::definition-source-location)))))))
|
||||
|
||||
(test-util:with-test (:name :find-classoid-signal-error)
|
||||
;; (EVAL ''SILLY) dumbs down the compiler for this test.
|
||||
|
|
|
|||
Loading…
Reference in a new issue