tests/mop-33.impure.lisp

   1 ;;;; Handling errors in UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (defclass foo () ())
  15
  16 (defclass bar () ((slot :initform 42)))
  17
  18 (defmethod update-instance-for-different-class :before
  19     ((foo foo) (bar bar) &rest initargs)
  20   (declare (ignore initargs))
  21   ;; This U-I-F-D-C is meant to always signal an error.
  22   (error "expected failure"))
  23
  24 ;;; Make an instance of FOO.
  25 (defparameter *foo* (make-instance 'foo))
  26
  27 ;;; This should result in an "expected failure" error.
  28 (multiple-value-bind (result error)
  29     (ignore-errors (change-class *foo* 'bar))
  30   (assert (null result))
  31   (assert (string= (princ-to-string error) "expected failure")))
  32
  33 ;;; This should *also* result in an "expected failure" error, because after
  34 ;;; the previous U-I-F-D-C call made a non-local exit, the instance should be
  35 ;;; automatically restored to its previous class.
  36 (multiple-value-bind (result error)
  37     (ignore-errors (change-class *foo* 'bar))
  38   (assert (null result))
  39   (assert (string= (princ-to-string error) "expected failure")))
  40
  41 ;;; Redefine the U-I-F-D-C method to no longer signal an error.
  42 (defmethod update-instance-for-different-class :before
  43     ((foo foo) (bar bar) &rest initargs)
  44   (declare (ignore initargs)))
  45
  46 ;;; It is now possible to change the instance's class.
  47 (change-class *foo* 'bar)
  48
  49 ;;; It should now be possible to access the new slot and fetch its
  50 ;;; initform-initialized value.
  51 (assert (= 42 (slot-value *foo* 'slot)))