Restore instances to their previous state on failed U-I-F-{R,D}-C

Neither the standard nor the MOP specify what happens when an error is
signaled in U-I-F-R-C or U-I-F-D-C and control is transferred outside.
This may result in half-baked instances which, respectively, already
have their structure or class changed, but whose newly added slots are
not yet initialized. There is no good way to "fix" the instances afterwards
since, for all purposes, SBCL considers them to be "updated" even though
their slot values are undefined.

This commit modifies the existing behavior in functions
%OBSOLETE-INSTANCE-TRAP and %CHANGE-CLASS by effectively rolling back
the transaction of updating an instance or changing its class if
U-I-F-{R,D}-C does not exit normally but via a nonlocal exit.

The new behavior is actually useful because the programmer can fix
their U-I-F-{R,D}-C code up and either attempt to access the instance
again (to trigger the update process) or call CHANGE-CLASS on it again.

src/pcl/std-class.lisp

@@ -1655,8 +1655,19 @@
            (push (car cell) added)))
 
        (replace-wrapper-and-slots instance nwrapper nslots)
-       (update-instance-for-redefined-class
-        instance added discarded plist)
+       ;; The obsolete instance protocol does not specify what happens if
+       ;; an error is signaled in U-I-F-R-C and there is a nonlocal exit
+       ;; outside; it may result in a half-updated instance whose
+       ;; structure is updated but whose added slots are not initialized.
+       ;; (See CLHS 3.7.2.)
+       ;; The approach taken here is to abort the update process, as defined
+       ;; in CLHS 4.3.6, altogether, and restore the instance to its obsolete
+       ;; state; this way the programmer can try to fix the U-I-F-R-C code
+       ;; which signaled an error and try to access the instance again
+       ;; in order to try and update it again.
+       (sb-sys:nlx-protect (update-instance-for-redefined-class
+                            instance added discarded plist)
+         (replace-wrapper-and-slots instance owrapper oslots))
 
        nwrapper))
     (*in-obsolete-instance-trap* #.(find-layout 'structure-object))
@@ -1714,7 +1725,20 @@
     ;; Users need to synchronize their own access when changing class.
     (replace-wrapper-and-slots copy old-wrapper old-slots)
     (replace-wrapper-and-slots instance new-wrapper new-slots)
-    (apply #'update-instance-for-different-class copy instance initargs)
+
+    ;; The CLHS does not specify what happens if an error is signaled in
+    ;; U-I-F-D-C and there is a nonlocal exit outside; it may result in a
+    ;; half-updated instance whose class is updated but whose added slots
+    ;; are not initialized. (See CLHS 3.7.2.)
+    ;; The approach taken here is to abort the change-class process, as
+    ;; defined in CLHS 4.3.6, altogether, and restore the instance to its
+    ;; previous state; this way the programmer can try to fix the U-I-F-D-C
+    ;; code which signaled an error and try to CHANGE-CLASS the instance
+    ;; again.
+    (sb-sys:nlx-protect (apply #'update-instance-for-different-class
+                               copy instance initargs)
+      (replace-wrapper-and-slots instance old-wrapper old-slots))
+
     instance))
 ) ; end MACROLET
 

tests/mop-32.impure.lisp

@@ -0,0 +1,75 @@
+;;;; Handling errors in UPDATE-INSTANCE-FOR-REDEFINED-CLASS
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(defclass foo-class (standard-class) ())
+
+(defmethod sb-mop:validate-superclass ((c foo-class) (s standard-class)) t)
+
+(defclass foo-object (standard-object) ())
+
+(defmethod shared-initialize :around ((class foo-class) slot-names
+                                      &rest rest
+                                      &key direct-superclasses)
+  (apply #'call-next-method
+         class slot-names
+         :direct-superclasses
+         (append (remove (find-class 'standard-object) direct-superclasses)
+                 (list (find-class 'foo-object)))
+         rest))
+
+(defmethod update-instance-for-redefined-class :before
+    ((instance foo-object)
+     added-slots discarded-slots
+     property-list
+     &rest initargs)
+  (declare (ignore initargs))
+  ;; This U-I-F-R-C is meant to always signal an error.
+  (error "expected failure"))
+
+;;; Define FOO.
+(defclass foo () () (:metaclass foo-class))
+
+;;; Make an instance of FOO.
+(defparameter *foo* (make-instance 'foo))
+
+;;; Redefine FOO, causing *FOO* to become obsolete.
+(defclass foo ()
+  ((slot :initform 42))
+  (:metaclass foo-class))
+
+;;; This should result in an "expected failure" error, because
+;;; the instance is obsolete.
+(multiple-value-bind (result error)
+    (ignore-errors (slot-value *foo* 'slot))
+  (assert (null result))
+  (assert (string= (princ-to-string error) "expected failure")))
+
+;;; This should *also* result in an "expected failure" error, because after
+;;; the previous U-I-F-R-C call made a non-local exit, the instance should be
+;;; automatically made obsolete once more.
+(multiple-value-bind (result error)
+    (ignore-errors (slot-value *foo* 'slot))
+  (assert (null result))
+  (assert (string= (princ-to-string error) "expected failure")))
+
+;;; Redefine the U-I-F-R-C method to no longer signal an error.
+(defmethod update-instance-for-redefined-class :before
+    ((instance foo-object)
+     added-slots discarded-slots
+     property-list
+     &rest initargs)
+  (declare (ignore initargs)))
+
+;;; Instance is now updateable. It should now be possible to access the new slot
+;;; and fetch its initform-initialized value.
+(assert (= 42 (slot-value *foo* 'slot)))

tests/mop-33.impure.lisp

@@ -0,0 +1,51 @@
+;;;; Handling errors in UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(defclass foo () ())
+
+(defclass bar () ((slot :initform 42)))
+
+(defmethod update-instance-for-different-class :before
+    ((foo foo) (bar bar) &rest initargs)
+  (declare (ignore initargs))
+  ;; This U-I-F-D-C is meant to always signal an error.
+  (error "expected failure"))
+
+;;; Make an instance of FOO.
+(defparameter *foo* (make-instance 'foo))
+
+;;; This should result in an "expected failure" error.
+(multiple-value-bind (result error)
+    (ignore-errors (change-class *foo* 'bar))
+  (assert (null result))
+  (assert (string= (princ-to-string error) "expected failure")))
+
+;;; This should *also* result in an "expected failure" error, because after
+;;; the previous U-I-F-D-C call made a non-local exit, the instance should be
+;;; automatically restored to its previous class.
+(multiple-value-bind (result error)
+    (ignore-errors (change-class *foo* 'bar))
+  (assert (null result))
+  (assert (string= (princ-to-string error) "expected failure")))
+
+;;; Redefine the U-I-F-D-C method to no longer signal an error.
+(defmethod update-instance-for-different-class :before
+    ((foo foo) (bar bar) &rest initargs)
+  (declare (ignore initargs)))
+
+;;; It is now possible to change the instance's class.
+(change-class *foo* 'bar)
+
+;;; It should now be possible to access the new slot and fetch its
+;;; initform-initialized value.
+(assert (= 42 (slot-value *foo* 'slot)))