X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fclos.impure.lisp;h=25358d48b1a1da978da049749a1fbd965817b9a4;hb=fb9c34275389e23f32d80954ab4848fac48936d9;hp=d3a76aa166f4740897b92f7a59b497805720a07b;hpb=bcbcc0d0660b3b3741203b3dfdd3443b201bf690;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index d3a76aa..25358d4 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.
@@ -68,7 +70,7 @@
 (assert (expect-error (defgeneric foo2 (x a &rest))))
 (defgeneric foo3 (x &rest y))
 (defmethod foo3 ((x t) &rest y) nil)
-(defmethod foo4 ((x t) &key y &rest z) nil)
+(defmethod foo4 ((x t) &rest z &key y) nil)
 (defgeneric foo4 (x &rest z &key y))
 (assert (expect-error (defgeneric foo5 (x &rest))))
 (assert (expect-error (macroexpand-1 '(defmethod foo6 (x &rest)))))
@@ -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)
@@ -291,8 +301,470 @@
   (assert-program-error (defclass foo003 ()
 			  ((a :allocation :class :allocation :class))))
   (assert-program-error (defclass foo004 ()
-			  ((a :silly t)))))
+			  ((a :silly t))))
+  ;; and some more, found by Wolfhard Buss and fixed for cmucl by Gerd
+  ;; 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))
+  ;; 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)))
+  ;; and also BUG 47d, fixed in sbcl-0.8alpha.0.26
+  (assert-program-error (defgeneric if (x)))
+  ;; DEFCLASS should detect an error if slot names aren't suitable as
+  ;; variable names:
+  (assert-program-error (defclass foo009 ()
+			  ((:a :initarg :a))))
+  (assert-program-error (defclass foo010 ()
+			  (("a" :initarg :a))))
+  (assert-program-error (defclass foo011 ()
+			  ((#1a() :initarg :a))))
+  (assert-program-error (defclass foo012 ()
+			  ((t :initarg :t))))
+  (assert-program-error (defclass foo013 () ("a")))
+  ;; specialized lambda lists have certain restrictions on ordering,
+  ;; repeating keywords, and the like:
+  (assert-program-error (defmethod foo014 ((foo t) &rest) nil))
+  (assert-program-error (defmethod foo015 ((foo t) &rest x y) nil))
+  (assert-program-error (defmethod foo016 ((foo t) &allow-other-keys) nil))
+  (assert-program-error (defmethod foo017 ((foo t)
+					   &optional x &optional y) nil))
+  (assert-program-error (defmethod foo018 ((foo t) &rest x &rest y) nil))
+  (assert-program-error (defmethod foo019 ((foo t) &rest x &optional y) nil))
+  (assert-program-error (defmethod foo020 ((foo t) &key x &optional y) nil))
+  (assert-program-error (defmethod foo021 ((foo t) &key x &rest y) nil)))
 
-;;;; success
+;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
+;;; preserved through the bootstrap process until sbcl-0.7.8.39.
+;;; (thanks to Gerd Moellmann)
+(let ((answer (documentation '+ 'function)))
+  (assert (stringp answer))
+  (defmethod documentation ((x (eql '+)) y) "WRONG")
+  (assert (string= (documentation '+ 'function) answer)))
+
+;;; only certain declarations are permitted in DEFGENERIC
+(macrolet ((assert-program-error (form)
+	     `(multiple-value-bind (value error)
+	          (ignore-errors ,form)
+	        (assert (null value))
+	        (assert (typep error 'program-error)))))
+  (assert-program-error (defgeneric bogus-declaration (x)
+			  (declare (special y))))
+  (assert-program-error (defgeneric bogus-declaration2 (x)
+			  (declare (notinline concatenate)))))
+;;; CALL-NEXT-METHOD should call NO-NEXT-METHOD if there is no next
+;;; method.
+(defmethod no-next-method-test ((x integer)) (call-next-method))
+(assert (null (ignore-errors (no-next-method-test 1))))
+(defmethod no-next-method ((g (eql #'no-next-method-test)) m &rest args)
+  'success)
+(assert (eq (no-next-method-test 1) 'success))
+(assert (null (ignore-errors (no-next-method-test 'foo))))
+
+;;; regression test for bug 176, following a fix that seems
+;;; simultaneously to fix 140 while not exposing 176 (by Gerd
+;;; Moellmann, merged in sbcl-0.7.9.12).
+(dotimes (i 10)
+  (let ((lastname (intern (format nil "C176-~D" (1- i))))
+        (name (intern (format nil "C176-~D" i))))
+  (eval `(defclass ,name
+             (,@(if (= i 0) nil (list lastname)))
+           ()))
+  (eval `(defmethod initialize-instance :after ((x ,name) &rest any)
+           (declare (ignore any))))))
+(defclass b176 () (aslot-176))
+(defclass c176-0 (b176) ())
+(assert (= 1 (setf (slot-value (make-instance 'c176-9) 'aslot-176) 1)))
+
+;;; DEFINE-METHOD-COMBINATION was over-eager at checking for duplicate
+;;; primary methods:
+(define-method-combination dmc-test-mc (&optional (order :most-specific-first))
+  ((around (:around))
+   (primary (dmc-test-mc) :order order :required t))
+   (let ((form (if (rest primary)
+                   `(and ,@(mapcar #'(lambda (method)
+                                       `(call-method ,method))
+                                   primary))
+                   `(call-method ,(first primary)))))
+     (if around
+         `(call-method ,(first around)
+                       (,@(rest around)
+                        (make-method ,form)))
+         form)))
+
+(defgeneric dmc-test-mc (&key k)
+  (:method-combination dmc-test-mc))
+
+(defmethod dmc-test-mc dmc-test-mc (&key k)
+	   k)
+
+(dmc-test-mc :k 1)
+;;; While I'm at it, DEFINE-METHOD-COMBINATION is defined to return
+;;; the NAME argument, not some random method object. So:
+(assert (eq (define-method-combination dmc-test-return-foo)
+	    'dmc-test-return-foo))
+(assert (eq (define-method-combination dmc-test-return-bar :operator and)
+	    'dmc-test-return-bar))
+(assert (eq (define-method-combination dmc-test-return
+		(&optional (order :most-specific-first))
+	      ((around (:around))
+	       (primary (dmc-test-return) :order order :required t))
+	      (let ((form (if (rest primary)
+			      `(and ,@(mapcar #'(lambda (method)
+						  `(call-method ,method))
+					      primary))
+			      `(call-method ,(first primary)))))
+		(if around
+		    `(call-method ,(first around)
+		      (,@(rest around)
+		       (make-method ,form)))
+		    form)))
+	    'dmc-test-return))
+
+;;; DEFMETHOD should signal an ERROR if an incompatible lambda list is
+;;; given:
+(defmethod incompatible-ll-test-1 (x) x)
+(assert (raises-error? (defmethod incompatible-ll-test-1 (x y) y)))
+(assert (raises-error? (defmethod incompatible-ll-test-1 (x &rest y) y)))
+;;; Sneakily using a bit of MOPness to check some consistency
+(assert (= (length
+	    (sb-pcl:generic-function-methods #'incompatible-ll-test-1)) 1))
+
+(defmethod incompatible-ll-test-2 (x &key bar) bar)
+(assert (raises-error? (defmethod incompatible-ll-test-2 (x) x)))
+(defmethod incompatible-ll-test-2 (x &rest y) y)
+(assert (= (length
+	    (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 1))
+(defmethod incompatible-ll-test-2 ((x integer) &key bar) bar)
+(assert (= (length
+	    (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 2))
+(assert (equal (incompatible-ll-test-2 t 1 2) '(1 2)))
+(assert (eq (incompatible-ll-test-2 1 :bar 'yes) 'yes))
+
+;;; Attempting to instantiate classes with forward references in their
+;;; CPL should signal errors (FIXME: of what type?)
+(defclass never-finished-class (this-one-unfinished-too) ())
+(multiple-value-bind (result error)
+    (ignore-errors (make-instance 'never-finished-class))
+  (assert (null result))
+  (assert (typep error 'error)))
+(multiple-value-bind (result error)
+    (ignore-errors (make-instance 'this-one-unfinished-too))
+  (assert (null result))
+  (assert (typep error 'error)))
+
+;;; Classes with :ALLOCATION :CLASS slots should be subclassable (and
+;;; weren't for a while in sbcl-0.7.9.xx)
+(defclass superclass-with-slot ()
+  ((a :allocation :class)))
+(defclass subclass-for-class-allocation (superclass-with-slot) ())
+(make-instance 'subclass-for-class-allocation)
+
+;;; bug #136: CALL-NEXT-METHOD was being a little too lexical,
+;;; resulting in failure in the following:
+(defmethod call-next-method-lexical-args ((x integer))
+  x)
+(defmethod call-next-method-lexical-args :around ((x integer))
+  (let ((x (1+ x)))
+    (call-next-method)))
+(assert (= (call-next-method-lexical-args 3) 3))
+
+;;; DEFINE-METHOD-COMBINATION with arguments was hopelessly broken
+;;; until 0.7.9.5x
+(defvar *d-m-c-args-test* nil)
+(define-method-combination progn-with-lock ()
+  ((methods ()))
+  (:arguments object)
+  `(unwind-protect
+    (progn (lock (object-lock ,object))
+	   ,@(mapcar #'(lambda (method)
+			 `(call-method ,method))
+		     methods))
+    (unlock (object-lock ,object))))
+(defun object-lock (obj)
+  (push "object-lock" *d-m-c-args-test*)
+  obj)
+(defun unlock (obj)
+  (push "unlock" *d-m-c-args-test*)
+  obj)
+(defun lock (obj)
+  (push "lock" *d-m-c-args-test*)
+  obj)
+(defgeneric d-m-c-args-test (x)
+  (:method-combination progn-with-lock))
+(defmethod d-m-c-args-test ((x symbol))
+  (push "primary" *d-m-c-args-test*))
+(defmethod d-m-c-args-test ((x number))
+  (error "foo"))
+(assert (equal (d-m-c-args-test t) '("primary" "lock" "object-lock")))
+(assert (equal *d-m-c-args-test*
+	       '("unlock" "object-lock" "primary" "lock" "object-lock")))
+(setf *d-m-c-args-test* nil)
+(ignore-errors (d-m-c-args-test 1))
+(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))
+	    ;; SLOT-MISSING's value is specified to be ignored; we
+	    ;; return NEW-VALUE.
+	    'baz))
+
+;;; 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)))
+
+;;; ALLOCATE-INSTANCE should work on structures, even if defined by
+;;; DEFSTRUCT (and not DEFCLASS :METACLASS STRUCTURE-CLASS).
+(defstruct allocatable-structure a)
+(assert (typep (allocate-instance (find-class 'allocatable-structure))
+	       'allocatable-structure))
+
+;;; Bug found by Paul Dietz when devising CPL tests: somewhat
+;;; amazingly, calls to CPL would work a couple of times, and then
+;;; start returning NIL.  A fix was found (relating to the
+;;; applicability of constant-dfun optimization) by Gerd Moellmann.
+(defgeneric cpl (x)
+  (:method-combination list)
+  (:method list ((x broadcast-stream)) 'broadcast-stream)
+  (:method list ((x integer)) 'integer)
+  (:method list ((x number)) 'number)
+  (:method list ((x stream)) 'stream)
+  (:method list ((x structure-object)) 'structure-object))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl (make-broadcast-stream))
+	       '(broadcast-stream stream structure-object)))
+(assert (equal (cpl (make-broadcast-stream))
+	       '(broadcast-stream stream structure-object)))
+(assert (equal (cpl (make-broadcast-stream))
+	       '(broadcast-stream stream structure-object)))
+
+;;; Bug in CALL-NEXT-METHOD: assignment to the method's formal
+;;; parameters shouldn't affect the arguments to the next method for a
+;;; no-argument call to CALL-NEXT-METHOD
+(defgeneric cnm-assignment (x)
+  (:method (x) x)
+  (:method ((x integer)) (setq x 3)
+	   (list x (call-next-method) (call-next-method x))))
+(assert (equal (cnm-assignment 1) '(3 1 3)))
+
+;;; Bug reported by Istvan Marko 2003-07-09
+(let ((class-name (gentemp)))
+  (loop for i from 1 to 9
+        for slot-name = (intern (format nil "X~D" i))
+        for initarg-name = (intern (format nil "X~D" i) :keyword)
+        collect `(,slot-name :initarg ,initarg-name) into slot-descs
+        append `(,initarg-name (list 0)) into default-initargs
+        finally (eval `(defclass ,class-name ()
+                         (,@slot-descs)
+                         (:default-initargs ,@default-initargs))))
+  (let ((f (compile nil `(lambda () (make-instance ',class-name)))))
+    (assert (typep (funcall f) class-name))))
+
+;;; bug 262: DEFMETHOD failed on a generic function without a lambda
+;;; list
+(ensure-generic-function 'bug262)
+(defmethod bug262 (x y)
+  (list x y))
+(assert (equal (bug262 1 2) '(1 2)))
+
+;;; salex on #lisp 2003-10-13 reported that type declarations inside
+;;; WITH-SLOTS are too hairy to be checked
+(defun ensure-no-notes (form)
+  (handler-case (compile nil `(lambda () ,form))
+    (sb-ext:compiler-note (c)
+      ;; FIXME: it would be better to check specifically for the "type
+      ;; is too hairy" note
+      (error c))))
+(defvar *x*)
+(ensure-no-notes '(with-slots (a) *x*
+                   (declare (integer a))
+                   a))
+(ensure-no-notes '(with-slots (a) *x*
+                   (declare (integer a))
+                   (declare (notinline slot-value))
+                   a))
+
+;;; from CLHS 7.6.5.1
+(defclass character-class () ((char :initarg :char)))
+(defclass picture-class () ((glyph :initarg :glyph)))
+(defclass character-picture-class (character-class picture-class) ())
+
+(defmethod width ((c character-class) &key font) font)
+(defmethod width ((p picture-class) &key pixel-size) pixel-size)
+
+(assert (raises-error? 
+	 (width (make-instance 'character-class :char #\Q) 
+		:font 'baskerville :pixel-size 10)
+	 program-error))
+(assert (raises-error?
+	 (width (make-instance 'picture-class :glyph #\Q)
+		:font 'baskerville :pixel-size 10)
+	 program-error))
+(assert (eq (width (make-instance 'character-picture-class :char #\Q)
+		   :font 'baskerville :pixel-size 10)
+	    'baskerville))
 
+;;; class redefinition shouldn't give any warnings, in the usual case
+(defclass about-to-be-redefined () ((some-slot :accessor some-slot)))
+(handler-bind ((warning #'error))
+  (defclass about-to-be-redefined () ((some-slot :accessor some-slot))))
+
+;;; attempts to add accessorish methods to generic functions with more
+;;; complex lambda lists should fail
+(defgeneric accessoroid (object &key &allow-other-keys))
+(assert (raises-error?
+	 (defclass accessoroid-class () ((slot :accessor accessoroid)))
+	 program-error))
+
+;;; reported by Bruno Haible sbcl-devel 2004-04-15
+(defclass shared-slot-and-redefinition ()
+  ((size :initarg :size :initform 1 :allocation :class)))
+(let ((i (make-instance 'shared-slot-and-redefinition)))
+  (defclass shared-slot-and-redefinition ()
+    ((size :initarg :size :initform 2 :allocation :class)))
+  (assert (= (slot-value i 'size) 1)))
+
+;;; reported by Bruno Haible sbcl-devel 2004-04-15
+(defclass superclass-born-to-be-obsoleted () (a))
+(defclass subclass-born-to-be-obsoleted (superclass-born-to-be-obsoleted) ())
+(defparameter *born-to-be-obsoleted*
+  (make-instance 'subclass-born-to-be-obsoleted))
+(defparameter *born-to-be-obsoleted-obsoleted* nil)
+(defmethod update-instance-for-redefined-class
+    ((o subclass-born-to-be-obsoleted) a d pl &key)
+  (setf *born-to-be-obsoleted-obsoleted* t))
+(make-instances-obsolete 'superclass-born-to-be-obsoleted)
+(slot-boundp *born-to-be-obsoleted* 'a)
+(assert *born-to-be-obsoleted-obsoleted*)
+
+;;; additional test suggested by Bruno Haible sbcl-devel 2004-04-21
+(defclass super-super-obsoleted () (a))
+(defclass super-obsoleted-1 (super-super-obsoleted) ())
+(defclass super-obsoleted-2 (super-super-obsoleted) ())
+(defclass obsoleted (super-obsoleted-1 super-obsoleted-2) ())
+(defparameter *obsoleted* (make-instance 'obsoleted))
+(defparameter *obsoleted-counter* 0)
+(defmethod update-instance-for-redefined-class ((o obsoleted) a d pl &key)
+  (incf *obsoleted-counter*))
+(make-instances-obsolete 'super-super-obsoleted)
+(slot-boundp *obsoleted* 'a)
+(assert (= *obsoleted-counter* 1))
+
+;;;; success
 (sb-ext:quit :unix-status 104)