mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-21 12:03:40 -08:00
defstruct: disallow defining structures of incompatible layouts
We signal an error if the structure is incompatible with an already defined one. We concern ourself about slot names, their types, offset and number of slots. Fixes #457.
This commit is contained in:
Daniel Kochmanski
Marius Gerbershagen
parent
38f5dea0ca
commit
a361055a3d
3 changed files with 152 additions and 60 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue