X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=14787f56967a117b1eaeccd3e2f841a626aca2eb;hb=d76c81b0ca4dcfc99f0cd805f5c20493fa80b2b6;hp=7b80f6bc7f488e27f27057ac8b76e5a397c5a92d;hpb=a96eb725c8b9082a576d2ea51a42cdc31fde3ea0;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 7b80f6b..14787f5 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.
@@ -174,8 +176,16 @@
 ;;; that it doesn't happen again.
 ;;;
 ;;; First, the forward references:
-(defclass a (b) ())
-(defclass b () ())
+(defclass forward-ref-a (forward-ref-b) ())
+(defclass forward-ref-b () ())
+;;; (a couple more complicated examples found by Paul Dietz' test
+;;; suite):
+(defclass forward-ref-c1 (forward-ref-c2) ())
+(defclass forward-ref-c2 (forward-ref-c3) ())
+
+(defclass forward-ref-d1 (forward-ref-d2 forward-ref-d3) ())
+(defclass forward-ref-d2 (forward-ref-d4 forward-ref-d5) ())
+
 ;;; Then change-class
 (defclass class-with-slots ()
   ((a-slot :initarg :a-slot :accessor a-slot)
@@ -293,12 +303,24 @@
   (assert-program-error (defclass foo004 ()
 			  ((a :silly t))))
   ;; and some more, found by Wolfhard Buss and fixed for cmucl by Gerd
-  ;; Moellmann in 0.7.8.x:
+  ;; Moellmann in sbcl-0.7.8.x:
   (assert-program-error (progn
 			  (defmethod odd-key-args-checking (&key (key 42)) key)
 			  (odd-key-args-checking 3)))
   (assert (= (odd-key-args-checking) 42))
-  (assert (eq (odd-key-args-checking :key t) t)))
+  (assert (eq (odd-key-args-checking :key t) t))
+  ;; yet some more, fixed in sbcl-0.7.9.xx
+  (assert-program-error (defclass foo005 ()
+			  (:metaclass sb-pcl::funcallable-standard-class)
+			  (:metaclass 1)))
+  (assert-program-error (defclass foo006 ()
+			  ((a :reader (setf a)))))
+  (assert-program-error (defclass foo007 ()
+			  ((a :initarg 1))))
+  (assert-program-error (defclass foo008 ()
+			  (a :initarg :a)
+			  (:default-initargs :a 1)
+			  (:default-initargs :a 2))))
 
 ;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
 ;;; preserved through the bootstrap process until sbcl-0.7.8.39.
@@ -479,5 +501,112 @@
 (assert (equal *d-m-c-args-test*
 	       '("unlock" "object-lock" "lock" "object-lock")))
 
+;;; The walker (on which DEFMETHOD depended) didn't know how to handle
+;;; SYMBOL-MACROLET properly.  In fact, as of sbcl-0.7.10.20 it still
+;;; doesn't, but it does well enough to compile the following without
+;;; error (the problems remain in asking for a complete macroexpansion
+;;; of an arbitrary form).
+(symbol-macrolet ((x 1))
+  (defmethod bug222 (z)
+    (macrolet ((frob (form) `(progn ,form ,x)))
+      (frob (print x)))))
+(assert (= (bug222 t) 1))
+
+;;; also, a test case to guard against bogus environment hacking:
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setq bug222-b 3))
+;;; this should at the least compile:
+(let ((bug222-b 1))
+  (defmethod bug222-b (z stream)
+    (macrolet ((frob (form) `(progn ,form ,bug222-b)))
+      (frob (format stream "~D~%" bug222-b)))))
+;;; and it would be nice (though not specified by ANSI) if the answer
+;;; were as follows:
+(let ((x (make-string-output-stream)))
+  ;; not specified by ANSI
+  (assert (= (bug222-b t x) 3))
+  ;; 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))
+
+;;; we should be able to specialize on anything that names a class.
+(defclass name-for-class () ())
+(defmethod something-that-specializes ((x name-for-class)) 1)
+(setf (find-class 'other-name-for-class) (find-class 'name-for-class))
+(defmethod something-that-specializes ((x other-name-for-class)) 2)
+(assert (= (something-that-specializes (make-instance 'name-for-class)) 2))
+(assert (= (something-that-specializes (make-instance 'other-name-for-class))
+	   2))
+
+;;; more forward referenced classes stuff
+(defclass frc-1 (frc-2) ())
+(assert (subtypep 'frc-1 (find-class 'frc-2)))
+(assert (subtypep (find-class 'frc-1) 'frc-2))
+(assert (not (subtypep (find-class 'frc-2) 'frc-1)))
+(defclass frc-2 (frc-3) ((a :initarg :a)))
+(assert (subtypep 'frc-1 (find-class 'frc-3)))
+(defclass frc-3 () ())
+(assert (typep (make-instance 'frc-1 :a 2) (find-class 'frc-1)))
+(assert (typep (make-instance 'frc-2 :a 3) (find-class 'frc-2)))
+
+;;; check that we can define classes with two slots of different names
+;;; (even if it STYLE-WARNs).
+(defclass odd-name-class ()
+  ((name :initarg :name)
+   (cl-user::name :initarg :name2)))
+(let ((x (make-instance 'odd-name-class :name 1 :name2 2)))
+  (assert (= (slot-value x 'name) 1))
+  (assert (= (slot-value x 'cl-user::name) 2)))
+
 ;;;; success
 (sb-ext:quit :unix-status 104)