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:
Douglas Katzman 2018-10-21 23:34:12 -04:00
parent 2ec85e50d7
commit 547b9a1959
7 changed files with 15 additions and 21 deletions

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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.