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..0d0946323 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},
@@ -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 2cf73fc5b..d541baeb1 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"},
@@ -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 6c2610629..c627df03f 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
@@ -777,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/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/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/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/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, ...));
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/lsp/mp.lsp b/src/lsp/mp.lsp
index f261a156c..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))
 
@@ -223,6 +232,21 @@ 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))"
+  (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
 (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/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))))
+
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/src/tests/normal-tests/multiprocessing.lsp b/src/tests/normal-tests/multiprocessing.lsp
index a165e850a..d405daa80 100644
--- a/src/tests/normal-tests/multiprocessing.lsp
+++ b/src/tests/normal-tests/multiprocessing.lsp
@@ -704,3 +704,34 @@ 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)))))
+
+;;; 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)))