diff --git a/src/doc/manual/standards/structures.txi b/src/doc/manual/standards/structures.txi index 74b9dd37d..affa5c113 100644 --- a/src/doc/manual/standards/structures.txi +++ b/src/doc/manual/standards/structures.txi @@ -1,6 +1,21 @@ @node Structures @section Structures +@subsection Redefining a defstruct structure + +@ansi{} says that consequences of redefining a @code{defstruct} are +undefined. @ecl{} defines this behavior to siganal an error if the new +structure is not compatible. Structures are incompatible when: + +@table @asis +@item They have a different number of slots +This is particularily important for other structures which could have +included the current one and for already defined instances. + +@item Slot name, type or offset is different +Binary compatibility between old and new instances. +@end table + @subsection C Reference @subsubsection ANSI Dictionary diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index fbc516967..2b67c6851 100644 --- a/src/lsp/defstruct.lsp +++ b/src/lsp/defstruct.lsp @@ -22,21 +22,24 @@ slot-name)) #+threads -(defun make-atomic-accessors (name conc-name type slot-descriptions) +(defun make-atomic-accessors (name conc-name type slot-descriptions removep) ;; If the structure is implemented as a CLOS instance, we can define ;; atomic compare-and-swap expansions for its slots (when (null type) (let (accessors) (dolist (slotd slot-descriptions accessors) - (unless (nth 3 slotd) ; don't create a CAS expansion if the slot is read-only - (let ((access-function (slot-access-function conc-name (nth 0 slotd))) - (offset (nth 4 slotd))) - (push `(mp::define-cas-expander ,access-function (x) - (let ((old (gensym)) (new (gensym))) - (values nil nil old new - `(mp:compare-and-swap-structure ,x ',',name ,',offset ,old ,new) - `(sys:structure-ref ,x ',',name ,',offset)))) - accessors))))))) + (let ((access-function (slot-access-function conc-name (nth 0 slotd))) + (read-only (nth 3 slotd)) + (offset (nth 4 slotd))) + (if (and (null read-only) (null removep)) + (push `(mp::define-cas-expander ,access-function (x) + (let ((old (gensym)) (new (gensym))) + (values nil nil old new + `(mp:compare-and-swap-structure ,x ',',name ,',offset ,old ,new) + `(sys:structure-ref ,x ',',name ,',offset)))) + accessors) + ;; Don't create a CAS expansion if the slot is read-only. + (push `(mp::remcas ',access-function) accessors))))))) (defun si::structure-type-error (value slot-type struct-name slot-name) (error 'simple-type-error @@ -200,7 +203,7 @@ (sys:make-structure .structure-constructor-class. ,@slot-names))) ((subtypep type '(VECTOR T)) `(defun ,constructor-name ,keys - (vector ,@slot-names))) + (vector ,@slot-names))) ((subtypep type 'VECTOR) `(defun ,constructor-name ,keys (make-array ',(list (length slot-names)) @@ -248,30 +251,23 @@ (defun parse-slot-description (slot-description offset &optional read-only) (declare (si::c-local)) - (let* ((slot-type 'T) - slot-name default-init) - (cond ((atom slot-description) - (setq slot-name slot-description)) - ((endp (cdr slot-description)) - (setq slot-name (car slot-description))) - (t - (setq slot-name (car slot-description)) - (setq default-init (cadr slot-description)) - (do ((os (cddr slot-description) (cddr os)) (o) (v)) - ((endp os)) - (setq o (car os)) - (when (endp (cdr os)) - (error "~S is an illegal structure slot option." - os)) - (setq v (cadr os)) - (case o - (:TYPE (setq slot-type v)) - (:READ-ONLY (setq read-only v)) - (t - (error "~S is an illegal structure slot option." - os)))))) - (list slot-name default-init slot-type read-only offset nil))) - + (when (atom slot-description) + (return-from parse-slot-description + (list slot-description nil t read-only offset nil))) + (do ((slot-type T) + (slot-name (first slot-description)) + (default-init (second slot-description)) + (os (cddr slot-description) (cddr os))) + ((endp os) + (list slot-name default-init slot-type read-only offset nil)) + (when (endp (cdr os)) + (error "~S is an illegal structure slot option." os)) + (let ((option (first os)) + (value (second os))) + (case option + (:TYPE (setq slot-type value)) + (:READ-ONLY (setq read-only value)) + (t (error "~S is an illegal structure slot option." os)))))) ;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions ;;; with the new descriptions which are specified in the @@ -302,9 +298,38 @@ (sixth new-slot) (sixth old-slot)))) (push new-slot output)))) +(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))) + ((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-init 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)) + (and (eql old-slot-name new-slot-name) + (= old-offset new-offset) + (and (subtypep old-type new-type) + (subtypep new-type old-type))))) + (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))) (create-type-name name) ;; We are going to modify this list!!! (setf slot-descriptions (copy-tree slot-descriptions)) @@ -420,7 +445,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." (:INCLUDE (setq include (cdar os)) (unless (get-sysprop v 'IS-A-STRUCTURE) - (error "~S is an illegal included structure." v))) + (error "~S is an illegal included structure." v))) (:PRINT-FUNCTION (setq print-function v)) (:PRINT-OBJECT (setq print-object v)) (:TYPE (setq type v)) @@ -444,14 +469,13 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." ;; Skip the documentation string. (when (and (not (endp slot-descriptions)) (stringp (car slot-descriptions))) - (setq documentation (car slot-descriptions)) - (setq slot-descriptions (cdr slot-descriptions))) + (setq documentation (car slot-descriptions)) + (setq slot-descriptions (cdr slot-descriptions))) ;; Check the include option. - (when include - (unless (equal type (get-sysprop (car include) 'STRUCTURE-TYPE)) - (error "~S is an illegal structure include." - (car include)))) + (when (and include + (not (equal type (get-sysprop (car include) 'STRUCTURE-TYPE)))) + (error "~S is an illegal structure include." (car include))) ;; Set OFFSET. (setq offset (if include @@ -460,13 +484,13 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." ;; Increment OFFSET. (when (and type initial-offset) - (setq offset (+ offset initial-offset))) + (setq offset (+ offset initial-offset))) (when (and type named) - (unless (or (subtypep '(vector symbol) type) - (subtypep type 'list)) - (error "Structure cannot have type ~S and be :NAMED." type)) - (setq name-offset offset) - (setq offset (1+ offset))) + (unless (or (subtypep '(vector symbol) type) + (subtypep type 'list)) + (error "Structure cannot have type ~S and be :NAMED." type)) + (setq name-offset offset) + (setq offset (1+ offset))) ;; Parse slot-descriptions, incrementing OFFSET for each one. (do ((ds slot-descriptions (cdr ds)) @@ -479,13 +503,13 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." ;; If TYPE is non-NIL and structure is named, ;; add the slot for the structure-name to the slot-descriptions. (when (and type named) - (setq slot-descriptions - (cons (list 'TYPED-STRUCTURE-NAME name) slot-descriptions))) + (setq slot-descriptions + (cons (list 'TYPED-STRUCTURE-NAME name) slot-descriptions))) ;; Pad the slot-descriptions with the initial-offset number of NILs. (when (and type initial-offset) - (setq slot-descriptions - (append (make-list initial-offset) slot-descriptions))) + (setq slot-descriptions + (append (make-list initial-offset) slot-descriptions))) ;; Append the slot-descriptions of the included structure. ;; The slot-descriptions in the include option are also counted. @@ -507,7 +531,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." ;; If a constructor option is NIL, ;; no constructor should have been specified. (when constructors - (error "Contradictory constructor options."))) + (error "Contradictory constructor options."))) ((null constructors) ;; If no constructor is specified, ;; the default-constructor is made. @@ -533,10 +557,10 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." ;; LOAD-TIME-VALUE. ;; (let ((core `(define-structure ',name ',conc-name ',type ',named ',slots - ',slot-descriptions ',copier ',include - ',print-function ',print-object ',constructors - ',offset ',name-offset - ',documentation ',predicate)) + ',slot-descriptions ',copier ',include + ',print-function ',print-object ',constructors + ',offset ',name-offset + ',documentation ',predicate)) (constructors (mapcar #'(lambda (constructor) (make-constructor name constructor type named slot-descriptions)) @@ -551,7 +575,9 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." (eval-when (:execute) (let ((.structure-constructor-class. ,core)) ,@constructors)) - ,(when atomic-accessors - `(eval-when (:compile-toplevel :load-toplevel :execute) - #+threads ,@(make-atomic-accessors name conc-name type slot-descriptions))) + + #+threads + (eval-when (:compile-toplevel :load-toplevel :execute) + ;; When ATOMIC-ACCESSORS is NIL then MP:REMCAS is collected instead. + ,@(make-atomic-accessors name conc-name type slot-descriptions (not atomic-accessors))) ',name)))) diff --git a/src/tests/normal-tests/ansi.lsp b/src/tests/normal-tests/ansi.lsp index d0518b15f..962fa18a7 100644 --- a/src/tests/normal-tests/ansi.lsp +++ b/src/tests/normal-tests/ansi.lsp @@ -45,6 +45,57 @@ (is-true (typep '* '(nest (3) 3))) (is-true (typep 3 '(nest (2) 3))))) + +;;; 8. Structures +(ext:with-clean-symbols + (my-struct make-my-struct my-struct-2 make-my-struct-2 my-struct-compatible-type) + (test ansi.8.redefine-compatible + (let (foo-1 foo-2 foo-3 foo-4) + (defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2) + (setq foo-1 (make-my-struct :slot-1 3 :slot-2 4)) + (finishes (defstruct (my-struct (:constructor make-my-struct)) + (slot-1 nil) + (slot-2 t))) + (setq foo-2 (make-my-struct :slot-1 3 :slot-2 4)) + (finishes (defstruct (my-struct (:constructor make-my-struct)) + (slot-1 3) + (slot-2 4))) + (setq foo-3 (make-my-struct)) + (finishes (defstruct (my-struct (:constructor make-my-struct)) + (slot-1 8 :type t :read-only nil) + (slot-2 8 :type t :read-only nil))) + (setq foo-4 (make-my-struct :slot-1 3 :slot-2 4)) + (is (equalp foo-1 foo-2)) + (is (equalp foo-2 foo-3)) + (is (equalp foo-3 foo-4))) + (deftype my-struct-compatible-type () `(integer 0 10)) + (defstruct (my-struct-2 (:constructor make-my-struct-2)) + (slot-1 nil :type my-struct-compatible-type :read-only t)) + (finishes + (defstruct my-struct-2 + (slot-1 nil :type (integer 0 10) :read-only t))) + (finishes + (defstruct my-struct-2 + (slot-1 4 :type (integer 0 10) :read-only t))) + (finishes + (defstruct my-struct-2 + (slot-1 4 :type (integer 0 10) :read-only nil))))) + +(ext:with-clean-symbols (my-struct make-my-struct) + (test ansi.8.redefine-incompatible + (defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2) + ;; different slot type + (signals error (defstruct (my-struct (:constructor make-my-struct)) + (slot-1 nil :type integer) + (slot-2 t))) + ;; too many slots + (signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2 slot-3)) + ;; too few slots + (signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1)) + ;; incompatible names + (signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1x slot-2x)) + (finishes (make-my-struct)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;