X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=73a68bbc172997ff11cd10871ad472ab92d664a2;hb=50f728671defadb8f7b1e8691c984cb0e6aba17c;hp=9041c40b631b864e401a184d0ee45d0e8dd72062;hpb=fcde5281a74cb29e21550f4f979ad6356f149ab9;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 9041c40..73a68bb 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -11,9 +11,11 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
-(defpackage "FOO"
-  (:use "CL"))
-(in-package "FOO")
+(load "assertoid.lisp")
+
+(defpackage "CLOS-IMPURE"
+  (:use "CL" "ASSERTOID"))
+(in-package "CLOS-IMPURE")
 
 ;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
 ;;; structure types defined earlier in the file.
@@ -518,5 +520,56 @@
   ;; specified.
   (assert (char= (char (get-output-stream-string x) 0) #\1)))
 
+;;; REINITIALIZE-INSTANCE, in the ctor optimization, wasn't checking
+;;; for invalid initargs where it should:
+(defclass class234 () ())
+(defclass subclass234 (class234) ())
+(defvar *bug234* 0)
+(defun bug-234 ()
+  (reinitialize-instance (make-instance 'class234) :dummy 0))
+(defun subbug-234 ()
+  (reinitialize-instance (make-instance 'subclass234) :dummy 0))
+(assert (raises-error? (bug-234) program-error))
+(defmethod shared-initialize :after ((i class234) slots &key dummy)
+  (incf *bug234*))
+(assert (typep (subbug-234) 'subclass234))
+(assert (= *bug234*
+	   ;; once for MAKE-INSTANCE, once for REINITIALIZE-INSTANCE
+	   2))
+
+;;; also, some combinations of MAKE-INSTANCE and subclassing missed
+;;; new methods (Gerd Moellmann sbcl-devel 2002-12-29):
+(defclass class234-b1 () ())
+(defclass class234-b2 (class234-b1) ())
+(defvar *bug234-b* 0)
+(defun bug234-b ()
+  (make-instance 'class234-b2))
+(compile 'bug234-b)
+(bug234-b)
+(assert (= *bug234-b* 0))
+(defmethod initialize-instance :before ((x class234-b1) &rest args)
+  (declare (ignore args))
+  (incf *bug234-b*))
+(bug234-b)
+(assert (= *bug234-b* 1))
+
+;;; we should be able to make classes with uninterned names:
+(defclass #:class-with-uninterned-name () ())
+
+;;; SLOT-MISSING should be called when there are missing slots.
+(defclass class-with-all-slots-missing () ())
+(defmethod slot-missing (class (o class-with-all-slots-missing)
+			 slot-name op
+			 &optional new-value)
+  op)
+(assert (eq (slot-value (make-instance 'class-with-all-slots-missing) 'foo)
+	    'slot-value))
+(assert (eq (funcall (lambda (x) (slot-value x 'bar))
+		     (make-instance 'class-with-all-slots-missing))
+	    'slot-value))
+(assert (eq (funcall (lambda (x) (setf (slot-value x 'baz) 'baz))
+		     (make-instance 'class-with-all-slots-missing))
+	    'setf))
+
 ;;;; success
 (sb-ext:quit :unix-status 104)