diff --git a/src/clos/change.lsp b/src/clos/change.lsp index f2015a5eb..565c4a490 100644 --- a/src/clos/change.lsp +++ b/src/clos/change.lsp @@ -132,6 +132,7 @@ (defmethod update-instance-for-redefined-class ((instance std-class) added-slots discarded-slots property-list &rest initargs) + (declare (ignore initargs)) ;; If the metaclass of this class changed, so did probably that of its ;; subclasses. We need those subclasses to be up-to-date. This prevents ;; errors when loading twice the following @@ -140,8 +141,7 @@ ;; (defclass y (y) ...) ;; because X might be redefined with Y not being up-to-date on the second ;; pass. - (prog1 - (call-next-method) + (prog1 (call-next-method) (dolist (class (class-direct-subclasses instance)) (ensure-up-to-date-instance class)))) @@ -188,22 +188,19 @@ (defmethod reinitialize-instance ((class class) &rest initargs &key (direct-superclasses () direct-superclasses-p) (direct-slots nil direct-slots-p)) + (declare (ignore initargs)) (let ((name (class-name class))) (when (member name '(CLASS BUILT-IN-CLASS) :test #'eq) (error "The kernel CLOS class ~S cannot be changed." name))) - ;; remove previous defined accessor methods (when (class-finalized-p class) (remove-optional-slot-accessors class)) - (call-next-method) - ;; the list of direct slots is converted to direct-slot-definitions (when direct-slots-p (setf (class-direct-slots class) (loop for s in direct-slots collect (canonical-slot-to-direct-slot class s)))) - ;; set up inheritance checking that it makes sense (when direct-superclasses-p (setf direct-superclasses @@ -214,7 +211,6 @@ (dolist (l (setf (class-direct-superclasses class) direct-superclasses)) (add-direct-subclass l class))) - ;; if there are no forward references, we can just finalize the class here (setf (class-finalized-p class) nil) (finalize-unless-forward class) diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index f3848a257..dc572fd75 100644 --- a/src/lsp/defstruct.lsp +++ b/src/lsp/defstruct.lsp @@ -301,42 +301,58 @@ (defun %struct-layout-compatible-p (old-slot-descriptions new-slot-descriptions) (declare (si::c-local)) (do* ((old-defs old-slot-descriptions (cdr old-defs)) - (new-defs new-slot-descriptions (cdr new-defs))) + (new-defs new-slot-descriptions (cdr new-defs)) + (old-def (car old-defs)) + (new-def (car new-defs))) ((or (null old-defs) (null new-defs)) ;; Structures must have the same number of compatible slots. (and (null old-defs) (null new-defs))) - (let ((old-def (car old-defs)) - (new-def (car new-defs))) - ;; We need equal first because slot-description may be a list with - ;; (slot-name init …), a list (typed-structure-name ,name) or NIL. - (or (equal old-def new-def) - (destructuring-bind (old-slot-name old-init old-type old-read-only old-offset old-ac) - old-def - (declare (ignore old-slot-name old-init old-read-only old-ac)) - (destructuring-bind (new-slot-name new-init new-type new-read-only new-offset new-ac) - new-def - (declare (ignore new-slot-name new-init new-read-only new-ac)) - ;; Name EQL is not enforced because structures may be - ;; constructed by code generators and it is likely they - ;; will have gensymed names. -- jd 2019-05-22 - (and #+ (or) (eql old-slot-name new-slot-name) - (= old-offset new-offset) - (and (multiple-value-bind (subtypep certain) - (subtypep old-type new-type) - (or (not certain) subtypep)) - (multiple-value-bind (subtypep certain) - (subtypep new-type old-type) - (or (not certain) subtypep)))))) - (return-from %struct-layout-compatible-p nil))))) + (or (cond ((or (null old-def) + (null new-def)) + (eql old-def new-def)) + ((or (eql (car old-def) 'typed-structure-name) + (eql (car new-def) 'typed-structure-name)) + (and (null (cddr old-def)) + (equal old-def new-def))) + (t + (destructuring-bind (old-slot-name old-init old-type + old-read-only old-offset old-ac) + old-def + (declare (ignore old-init old-read-only old-ac)) + (destructuring-bind (new-slot-name new-init new-type + new-read-only new-offset new-ac) + new-def + (declare (ignore new-init new-read-only new-ac)) + ;; Names are compared with STRING= because: + ;; a) structure may be macroexpanded with gensym's + ;; b) keyword initargs and accessor names ignore the package + ;; -- jd 2021-12-10 + (and (string= old-slot-name new-slot-name) + (= old-offset new-offset) + (and (multiple-value-bind (subtypep certain) + (subtypep old-type new-type) + (or (not certain) subtypep)) + (multiple-value-bind (subtypep certain) + (subtypep new-type old-type) + (or (not certain) subtypep)))))))) + (return-from %struct-layout-compatible-p nil)))) (defun define-structure (name conc-name type named slots slot-descriptions copier include print-function print-object constructors offset name-offset documentation predicate) - (let ((old-slot-descriptions (get-sysprop name 'structure-slot-descriptions))) - (when (and old-slot-descriptions - (null (%struct-layout-compatible-p old-slot-descriptions slot-descriptions))) - (error "Attempt to redefine the structure ~S incompatibly with the current definition." name))) + (mapl (lambda (descriptions) + (destructuring-bind (arg-desc . descs) descriptions + (let ((name (car arg-desc))) + (when (and arg-desc + (not (eql name 'typed-structure-name)) + (member name descs :key #'car :test #'equal)) + (error "Duplicate slot name ~a." name))))) + slot-descriptions) + (when (get-sysprop name 'is-a-structure) + (let ((old-slot-descriptions (get-sysprop name 'structure-slot-descriptions))) + (unless (%struct-layout-compatible-p old-slot-descriptions slot-descriptions) + (error "Attempt to redefine the structure ~S incompatibly with the current definition." name)))) (create-type-name name) ;; We are going to modify this list!!! (setf slot-descriptions (copy-tree slot-descriptions))