;;;; 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")
\f
;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
;;; structure types defined earlier in the file.
(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))))
\f
;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
;;; preserved through the bootstrap process until sbcl-0.7.8.39.
(call-next-method)))
(assert (= (call-next-method-lexical-args 3) 3))
\f
-;;;; success
+;;; 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")))
+\f
+;;; 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)))
+\f
+;;; 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))
+\f
+;;; we should be able to make classes with uninterned names:
+(defclass #:class-with-uninterned-name () ())
+\f
+;;; 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))
+\f
+;;;; success
(sb-ext:quit :unix-status 104)
projects / sbcl.git / blobdiff