From 9096514cff89f007271a278643bd3e2817b6bd78 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 7 Feb 2019 13:07:02 +0100 Subject: [PATCH 1/4] extensions: put ext:package-locked-p in core module. --- contrib/package-locks/package-locks.lisp | 8 -------- src/c/package.d | 9 ++++++++- src/c/symbols_list.h | 2 +- src/c/symbols_list2.h | 2 +- src/cmp/proclamations.lsp | 1 + src/doc/help.lsp | 8 ++++++++ src/h/external.h | 1 + 7 files changed, 20 insertions(+), 11 deletions(-) diff --git a/contrib/package-locks/package-locks.lisp b/contrib/package-locks/package-locks.lisp index 43d97a449..f39df2046 100644 --- a/contrib/package-locks/package-locks.lisp +++ b/contrib/package-locks/package-locks.lisp @@ -26,14 +26,6 @@ :one-liner t) T) -(defun package-locked-p (package &aux (package (si:coerce-to-package package))) - "Returns T when PACKAGE is locked, NIL otherwise. Signals an error -if PACKAGE doesn't designate a valid package." - (ffi:c-inline (package) (:object) :object - "(#0)->pack.locked ? ECL_T : ECL_NIL" - :side-effects nil - :one-liner t)) - (defmacro without-package-locks (&body body) "Ignores all runtime package lock violations during the execution of body. Body can begin with declarations." diff --git a/src/c/package.d b/src/c/package.d index a21295038..7b95331d7 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -563,7 +563,7 @@ void cl_export2(cl_object s, cl_object p) { int intern_flag, error; - cl_object other_p, name = ecl_symbol_name(s); + cl_object other_p = ECL_NIL, name = ecl_symbol_name(s); p = si_coerce_to_package(p); if (p->pack.locked && ECL_SYM_VAL(ecl_process_env(), @@ -966,6 +966,13 @@ si_package_lock(cl_object p, cl_object t) @(return (previous? ECL_T : ECL_NIL)); } +cl_object +si_package_locked_p (cl_object p) +{ + p = si_coerce_to_package(p); + @return (p->pack.locked ? ECL_T : ECL_NIL); +} + /* --- local nicknames ---------------------------------------------------- */ cl_object si_package_local_nicknames(cl_object p) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 1df966dd3..1f8303016 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1207,9 +1207,9 @@ cl_symbols[] = { /* package extensions */ {SYS_ "*IGNORE-PACKAGE-LOCKS*", SI_SPECIAL, NULL, -1, ECL_NIL}, {EXT_ "PACKAGE-LOCK", EXT_ORDINARY, si_package_lock, 2, OBJNULL}, +{EXT_ "PACKAGE-LOCKED-P", EXT_ORDINARY, si_package_locked_p, 1, OBJNULL}, {SYS_ "LOCK-PACKAGE", EXT_ORDINARY, NULL, 1, OBJNULL}, {SYS_ "UNLOCK-PACKAGE", EXT_ORDINARY, NULL, 1, OBJNULL}, -{SYS_ "PACKAGE-LOCKED-P", EXT_ORDINARY, NULL, 1, OBJNULL}, {SYS_ "WITHOUT-PACKAGE-LOCKS", EXT_ORDINARY, NULL, 1, OBJNULL}, {SYS_ "WITH-UNLOCKED-PACKAGES", EXT_ORDINARY, NULL, 1, OBJNULL}, {EXT_ "PACKAGE-LOCAL-NICKNAMES", EXT_ORDINARY, si_package_local_nicknames, 1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 2cf73fc5b..bea81ecc3 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1207,9 +1207,9 @@ cl_symbols[] = { /* package extensions */ {SYS_ "*IGNORE-PACKAGE-LOCKS*",NULL}, {EXT_ "PACKAGE-LOCK","si_package_lock"}, +{EXT_ "PACKAGE-LOCKED-P","si_package_locked_p"}, {SYS_ "LOCK-PACKAGE",NULL}, {SYS_ "UNLOCK-PACKAGE",NULL}, -{SYS_ "PACKAGE-LOCKED-P",NULL}, {SYS_ "WITHOUT-PACKAGE-LOCKS",NULL}, {SYS_ "WITH-UNLOCKED-PACKAGES",NULL}, {EXT_ "PACKAGE-LOCAL-NICKNAMES","si_package_local_nicknames"}, diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 6c2610629..1cac7ef09 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -453,6 +453,7 @@ (proclamation si:package-hash-tables (package-designator) (values hash-table hash-table list) :reader) (proclamation ext:package-lock (package-designator gen-bool) package) +(proclamation ext:package-locked-p (package-designator) boolean :no-side-effects) (proclamation ext:package-local-nicknames (package-designator) list :no-side-effects) (proclamation ext:package-locally-nicknamed-by-list diff --git a/src/doc/help.lsp b/src/doc/help.lsp index daf2a54e4..464eb5da8 100644 --- a/src/doc/help.lsp +++ b/src/doc/help.lsp @@ -2295,6 +2295,14 @@ built-in packages: system system internal symbols. Has nicknames SYS and SI. compiler system internal symbols for the ECL compiler.") +(docfun ext:package-lock function + (package-designator lock) " +Sets package's lock to LOCK. Returns previous lock value.") + +(docfun ext:package-locked-p function + (package-designator) " +Returns T when PACKAGE is locked, NIL otherwise.") + (docfun ext:package-local-nicknames function (package-designator) " Returns an alist of (LOCAL-NICKNAME . ACTUAL-PACKAGE) diff --git a/src/h/external.h b/src/h/external.h index acdff6273..d27b3a1ac 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1313,6 +1313,7 @@ extern ECL_API cl_object si_remove_package_local_nickname(cl_object n, cl_object extern ECL_API cl_object cl_list_all_packages(void); extern ECL_API cl_object si_package_hash_tables(cl_object p); extern ECL_API cl_object si_package_lock(cl_object p, cl_object t); +extern ECL_API cl_object si_package_locked_p(cl_object p); extern ECL_API cl_object cl_delete_package(cl_object p); extern ECL_API cl_object cl_make_package _ECL_ARGS((cl_narg narg, cl_object pack_name, ...)); extern ECL_API cl_object cl_intern _ECL_ARGS((cl_narg narg, cl_object strng, ...)); From 13a42249e2e76fa41546d831807d57c826136fef Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 7 Feb 2019 13:29:03 +0100 Subject: [PATCH 2/4] cas: add remcas operation for an expansion removal It is a (fmakunbound (setf foo)) counterpart. --- src/c/symbols_list.h | 1 + src/c/symbols_list2.h | 1 + src/cmp/proclamations.lsp | 1 + src/doc/manual/extensions/mp_ref_atomic.txi | 7 +++++++ src/lsp/mp.lsp | 6 ++++++ src/tests/normal-tests/multiprocessing.lsp | 19 +++++++++++++++++++ 6 files changed, 35 insertions(+) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 1f8303016..0d0946323 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1637,6 +1637,7 @@ cl_symbols[] = { {MP_ "ATOMIC-INCF-INSTANCE", MP_ORDINARY, IF_MP(mp_atomic_incf_instance), 3, OBJNULL}, {MP_ "DEFINE-CAS-EXPANDER", MP_CONSTANT, NULL, -1, OBJNULL}, {MP_ "DEFCAS", MP_CONSTANT, NULL, -1, OBJNULL}, +{MP_ "REMCAS", MP_CONSTANT, NULL, -1, OBJNULL}, {MP_ "GET-CAS-EXPANSION", MP_CONSTANT, NULL, -1, OBJNULL}, {MP_ "COMPARE-AND-SWAP", MP_CONSTANT, NULL, -1, OBJNULL}, {MP_ "ATOMIC-UPDATE", MP_CONSTANT, NULL, -1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index bea81ecc3..d541baeb1 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1637,6 +1637,7 @@ cl_symbols[] = { {MP_ "ATOMIC-INCF-INSTANCE",IF_MP("mp_atomic_incf_instance")}, {MP_ "DEFINE-CAS-EXPANDER",NULL}, {MP_ "DEFCAS",NULL}, +{MP_ "REMCAS",NULL}, {MP_ "GET-CAS-EXPANSION",NULL}, {MP_ "COMPARE-AND-SWAP",NULL}, {MP_ "ATOMIC-UPDATE",NULL}, diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 1cac7ef09..c627df03f 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -778,6 +778,7 @@ #+threads (proclamation mp:atomic-incf-car (cons fixnum) fixnum) #+threads (proclamation mp:compare-and-swap-cdr (cons t t) t) #+threads (proclamation mp:atomic-incf-cdr (cons fixnum) fixnum) +#+threads (proclamation mp:remcas (symbol) boolean) ;;; ;;; 15. ARRAYS diff --git a/src/doc/manual/extensions/mp_ref_atomic.txi b/src/doc/manual/extensions/mp_ref_atomic.txi index c99b34011..6b663070d 100644 --- a/src/doc/manual/extensions/mp_ref_atomic.txi +++ b/src/doc/manual/extensions/mp_ref_atomic.txi @@ -227,6 +227,13 @@ Note that it is up to the user of this macro to ensure atomicity for the resulting compare-and-swap expansions. @end defmac +@lspindex mp:remcas +@defun mp:remcas symbol + +Remove a compare-and-swap expansion. It is an equivalent of +@code{fmakeunbound (setf symbol)} for cas expansions. +@end defun + @lspindex mp:get-cas-expansion @defun mp:get-cas-expansion place &optional environment diff --git a/src/lsp/mp.lsp b/src/lsp/mp.lsp index f261a156c..ad220e2b8 100644 --- a/src/lsp/mp.lsp +++ b/src/lsp/mp.lsp @@ -223,6 +223,12 @@ the resulting COMPARE-AND-SWAP expansions." `(,',cas-fun ,@args ,old ,new) `(,',accessor ,@args))))) +#+threads +(defun remcas (symbol) + "Remove a COMPARE-AND-SWAP expansion. It is a CAS operation equivalent of + (FMAKUNBOUND (SETF SYMBOL))" + (si:rem-sysprop symbol 'cas-expander)) + #+threads (defun get-cas-expansion (place &optional environment &aux f) "Returns the COMPARE-AND-SWAP expansion forms and variables as defined diff --git a/src/tests/normal-tests/multiprocessing.lsp b/src/tests/normal-tests/multiprocessing.lsp index a165e850a..41b5d15aa 100644 --- a/src/tests/normal-tests/multiprocessing.lsp +++ b/src/tests/normal-tests/multiprocessing.lsp @@ -704,3 +704,22 @@ creating stray processes." (is (svref vector 1) 0) (is *x* 0) (is (slot-value object 'slot1) 0))))) + +;;; Date: 2019-02-05 +;;; From: Daniel Kochmański +;;; Description: +;;; +;;; Verifies that CAS expansion may be removed. +;;; +(ext:with-clean-symbols (*obj* foo) + (test defcas/remcas + (mp:defcas foo (lambda (object old new) + (assert (consp object)) + (setf (car object) old + (cdr object) new))) + (defparameter *obj* (cons nil nil)) + (eval `(mp:compare-and-swap (foo *obj*) :car :cdr)) + (is (eql (car *obj*) :car)) + (is (eql (cdr *obj*) :cdr)) + (mp:remcas 'foo) + (signals error (eval `(mp:compare-and-swap (foo *obj*) :car :cdr))))) From 38f5dea0ca05d4a5b7f0f6485e50cceebef79fc4 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 7 Feb 2019 13:59:55 +0100 Subject: [PATCH 3/4] cas: ensure that package locks are honored --- src/lsp/mp.lsp | 18 ++++++++++++++++++ src/tests/normal-tests/multiprocessing.lsp | 12 ++++++++++++ 2 files changed, 30 insertions(+) diff --git a/src/lsp/mp.lsp b/src/lsp/mp.lsp index ad220e2b8..ee8884573 100644 --- a/src/lsp/mp.lsp +++ b/src/lsp/mp.lsp @@ -204,6 +204,15 @@ the resulting COMPARE-AND-SWAP expansions." (setq lambda-list (cons env lambda-list)) (push `(declare (ignore ,env)) body)))) `(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((package (symbol-package ',accessor))) + (when (and package + (ext:package-locked-p package) + (null si:*ignore-package-locks*)) + (si:signal-simple-error 'package-error + "Ignore lock and proceed." + "Attempt to define CAS accessor ~S in locked package." + '(,accessor) + :package package))) (si:put-sysprop ',accessor 'CAS-EXPANDER #'(ext::lambda-block ,accessor ,lambda-list ,@body)) ',accessor)) @@ -227,6 +236,15 @@ the resulting COMPARE-AND-SWAP expansions." (defun remcas (symbol) "Remove a COMPARE-AND-SWAP expansion. It is a CAS operation equivalent of (FMAKUNBOUND (SETF SYMBOL))" + (let ((package (symbol-package symbol))) + (when (and package + (ext:package-locked-p package) + (null si:*ignore-package-locks*)) + (si:signal-simple-error 'package-error + "Ignore lock and proceed." + "Attempt to define CAS accessor ~S in locked package." + (list symbol) + :package package))) (si:rem-sysprop symbol 'cas-expander)) #+threads diff --git a/src/tests/normal-tests/multiprocessing.lsp b/src/tests/normal-tests/multiprocessing.lsp index 41b5d15aa..d405daa80 100644 --- a/src/tests/normal-tests/multiprocessing.lsp +++ b/src/tests/normal-tests/multiprocessing.lsp @@ -723,3 +723,15 @@ creating stray processes." (is (eql (cdr *obj*) :cdr)) (mp:remcas 'foo) (signals error (eval `(mp:compare-and-swap (foo *obj*) :car :cdr))))) + +;;; Date: 2019-02-07 +;;; From: Daniel Kochmański +;;; Description: +;;; +;;; Verifies that CAS modifications honor the package locks. +;;; +(test cas-locked-package + (signals package-error (mp:defcas cl:car (lambda (obj old new) nil))) + (signals package-error (mp:remcas 'cl:car)) + (finishes (mp:defcas cor (lambda (obj old new) nil))) + (finishes (mp:remcas 'cor))) From a361055a3dae2be86bb3947dc35c59d3168a0d83 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Fri, 8 Feb 2019 08:29:49 +0100 Subject: [PATCH 4/4] 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. --- src/doc/manual/standards/structures.txi | 15 +++ src/lsp/defstruct.lsp | 146 ++++++++++++++---------- src/tests/normal-tests/ansi.lsp | 51 +++++++++ 3 files changed, 152 insertions(+), 60 deletions(-) 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)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;