From ea92cba4ceb268c22716acf3a22fe3bbe57e3b3e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 12 Dec 2021 08:50:30 +0100 Subject: [PATCH] defstruct: fix incorrect compatibility checks Previously we've checked whether the new defstruct is compatible with the old one like this: (let ((old-desc (old-descriptions struct))) (when (and old-desc (null (compat old-desc new-desc))) (error "incompatible"))) This was to allow new definitions. This is incorrect, because allows first defining a structure without slots and then adding some, like (defstruct foo) (defstruct foo xxx) The new check verifies whether the structure is a structure and then compares slot, so the verification is not inhibited when the first definition doesn't have slots. Moreover we now test for slot names being string= because: a) initargs and functions ignore the package (so functions will be redefined) b) we want to match gensymed slot names This is compatible with what sbcl does. On top of that check for duplicated names and signal an error if there are such. --- src/clos/change.lsp | 10 ++---- src/lsp/defstruct.lsp | 72 ++++++++++++++++++++++++++----------------- 2 files changed, 47 insertions(+), 35 deletions(-) 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))