Commit 576aee86 authored by pfdietz's avatar pfdietz

DR pointed out to me that section 11.1.2.1.2, bullet 19 made some of the...

DR pointed out to me that section 11.1.2.1.2, bullet 19 made some of the methods used in some of the tests nonconforming.  I can work around some, but not all, of these problems, but testing make-instance requires user-defined metaclasses, which I don't think are conforming.  Those tests should be delayed to a MOP test suite.
parent e771f310
......@@ -1468,3 +1468,11 @@ the condition to go uncaught if it cannot be classified."
when (null list2) do (return-from is-noncontiguous-sublist-of nil)
when (eql x (pop list2)) do (return))
finally (return t)))
;;; This defines a new metaclass to allow us to get around
;;; the restriction in section 11.1.2.1.2, bullet 19 in some
;;; object system tests
;;; (when (typep (find-class 'standard-class) 'standard-class)
;;; (defclass substandard-class (standard-class) ())
;;; (defparameter *can-define-metaclasses* t))
......@@ -536,7 +536,7 @@
(ignore-errors
(defmethod change-class :after
((obj standard-object)
((obj change-class-class-08)
(class (eql (find-class 'change-class-class-08)))
&rest initargs &key &allow-other-keys)
(declare (ignore initargs))
......
......@@ -38,145 +38,155 @@
;; Definitions of methods
(defmethod make-instance ((x (eql 'foo)) &rest initargs &key &allow-other-keys)
(cons x initargs))
(defmethod make-instance ((x make-instance-class-01)
&rest initargs &key &allow-other-keys)
initargs)
(deftest make-instance.1
(make-instance 'foo)
(foo))
(deftest make-instance.2
(make-instance 'foo :a 1 :b 2)
(foo :a 1 :b 2))
(defclass make-instance-class-02 ()
(a b c))
(defmethod make-instance ((class (eql (find-class 'make-instance-class-02)))
&rest initargs &key (x nil) (y nil) (z nil)
&allow-other-keys)
(declare (ignore initargs))
(let ((obj (allocate-instance class)))
(setf (slot-value obj 'a) x
(slot-value obj 'b) y
(slot-value obj 'c) z)
obj))
(deftest make-instance.3
(let ((obj (make-instance 'make-instance-class-02)))
(values
(eqt (class-of obj) (find-class 'make-instance-class-02))
(slot-value obj 'a)
(slot-value obj 'b)
(slot-value obj 'c)))
t nil nil nil)
(deftest make-instance.4
(let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd)))
(values
(eqt (class-of obj) (find-class 'make-instance-class-02))
(slot-value obj 'a)
(slot-value obj 'b)
(slot-value obj 'c)))
t d 45 10)
(deftest make-instance.5
(let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g)))
(values
(eqt (class-of obj) (find-class 'make-instance-class-02))
(slot-value obj 'a)
(slot-value obj 'b)
(slot-value obj 'c)))
t nil g nil)
(deftest make-instance.6
(eq (make-instance 'make-instance-class-02)
(make-instance 'make-instance-class-02))
(make-instance (make-instance 'make-instance-class-01))
nil)
;; Customization of make-instance
(defclass make-instance-class-03 ()
((a :initform 1) (b :initarg :b) c))
(defmethod make-instance ((class (eql (find-class 'make-instance-class-03)))
&rest initargs
&key (x nil x-p) (y nil y-p) (z nil z-p)
&allow-other-keys)
(declare (ignore initargs))
(let ((obj (allocate-instance (find-class 'make-instance-class-03))))
(when x-p (setf (slot-value obj 'a) x))
(when y-p (setf (slot-value obj 'b) y))
(when z-p (setf (slot-value obj 'c) z))
obj))
(deftest make-instance.7
(let ((obj (make-instance 'make-instance-class-03)))
(values
(eqt (class-of obj)
(find-class 'make-instance-class-03))
(map-slot-boundp* obj '(a b c))))
t (nil nil nil))
(deftest make-instance.8
(let* ((class (find-class 'make-instance-class-03))
(obj (make-instance class :b 10)))
(values
(eqt (class-of obj) class)
(map-slot-boundp* obj '(a b c))))
t (nil nil nil))
(deftest make-instance.9
(let* ((class (find-class 'make-instance-class-03))
(obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad)))
(values
(eqt (class-of obj) class)
(map-slot-boundp* obj '(a b c))
(map-slot-value obj '(a b c))))
t (t t t) (g k i))
;;; After method combination
(defparameter *make-instance-class-04-var* 0)
(defclass make-instance-class-04 ()
((a :initform *make-instance-class-04-var*)))
(defmethod make-instance :after
((class (eql (find-class 'make-instance-class-04)))
&rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(incf *make-instance-class-04-var* 10))
(deftest make-instance.10
(let* ((*make-instance-class-04-var* 0)
(obj (make-instance 'make-instance-class-04)))
(values
(slot-value obj 'a)
*make-instance-class-04-var*))
0 10)
;;; Around method combination
(defclass make-instance-class-05 ()
((a :initarg :a) (b :initarg :b :initform 'foo) c))
(defmethod make-instance :around
((class (eql (find-class 'make-instance-class-05)))
&rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(let ((obj (call-next-method)))
(setf (slot-value obj 'c) 'bar)
obj))
(deftest make-instance.11
(let ((obj (make-instance 'make-instance-class-05)))
(values
(map-slot-boundp* obj '(a b c))
(map-slot-value obj '(b c))))
(nil t t)
(foo bar))
(deftest make-instance.2
(make-instance (make-instance 'make-instance-class-01) :a 1 :b 2)
(:a 1 :b 2))
#|
(when *can-define-metaclasses*
(defclass make-instance-class-02 ()
(a b c)
(:metaclass substandard-class))
(defmethod make-instance ((class (eql (find-class 'make-instance-class-02)))
&rest initargs &key (x nil) (y nil) (z nil)
&allow-other-keys)
(declare (ignore initargs))
(let ((obj (allocate-instance class)))
(setf (slot-value obj 'a) x
(slot-value obj 'b) y
(slot-value obj 'c) z)
obj))
(deftest make-instance.3
(let ((obj (make-instance 'make-instance-class-02)))
(values
(eqt (class-of obj) (find-class 'make-instance-class-02))
(slot-value obj 'a)
(slot-value obj 'b)
(slot-value obj 'c)))
t nil nil nil)
(deftest make-instance.4
(let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd)))
(values
(eqt (class-of obj) (find-class 'make-instance-class-02))
(slot-value obj 'a)
(slot-value obj 'b)
(slot-value obj 'c)))
t d 45 10)
(deftest make-instance.5
(let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g)))
(values
(eqt (class-of obj) (find-class 'make-instance-class-02))
(slot-value obj 'a)
(slot-value obj 'b)
(slot-value obj 'c)))
t nil g nil)
(deftest make-instance.6
(eq (make-instance 'make-instance-class-02)
(make-instance 'make-instance-class-02))
nil)
;; Customization of make-instance
(defclass make-instance-class-03 ()
((a :initform 1) (b :initarg :b) c)
(:metaclass substandard-class))
(defmethod make-instance ((class (eql (find-class 'make-instance-class-03)))
&rest initargs
&key (x nil x-p) (y nil y-p) (z nil z-p)
&allow-other-keys)
(declare (ignore initargs))
(let ((obj (allocate-instance (find-class 'make-instance-class-03))))
(when x-p (setf (slot-value obj 'a) x))
(when y-p (setf (slot-value obj 'b) y))
(when z-p (setf (slot-value obj 'c) z))
obj))
(deftest make-instance.7
(let ((obj (make-instance 'make-instance-class-03)))
(values
(eqt (class-of obj)
(find-class 'make-instance-class-03))
(map-slot-boundp* obj '(a b c))))
t (nil nil nil))
(deftest make-instance.8
(let* ((class (find-class 'make-instance-class-03))
(obj (make-instance class :b 10)))
(values
(eqt (class-of obj) class)
(map-slot-boundp* obj '(a b c))))
t (nil nil nil))
(deftest make-instance.9
(let* ((class (find-class 'make-instance-class-03))
(obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad)))
(values
(eqt (class-of obj) class)
(map-slot-boundp* obj '(a b c))
(map-slot-value obj '(a b c))))
t (t t t) (g k i))
;; After method combination
(defparameter *make-instance-class-04-var* 0)
(defclass make-instance-class-04 ()
((a :initform *make-instance-class-04-var*))
(:metaclass substandard-class))
(defmethod make-instance :after
((class (eql (find-class 'make-instance-class-04)))
&rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(incf *make-instance-class-04-var* 10))
(deftest make-instance.10
(let* ((*make-instance-class-04-var* 0)
(obj (make-instance 'make-instance-class-04)))
(values
(slot-value obj 'a)
*make-instance-class-04-var*))
0 10)
;; Around method combination
(defclass make-instance-class-05 ()
((a :initarg :a) (b :initarg :b :initform 'foo) c)
(:metaclass substandard-class))
(defmethod make-instance :around
((class (eql (find-class 'make-instance-class-05)))
&rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(let ((obj (call-next-method)))
(setf (slot-value obj 'c) 'bar)
obj))
(deftest make-instance.11
(let ((obj (make-instance 'make-instance-class-05)))
(values
(map-slot-boundp* obj '(a b c))
(map-slot-value obj '(b c))))
(nil t t)
(foo bar))
)
|#
;;; Order of argument evaluation
......
......@@ -7,70 +7,12 @@
(defgeneric no-app-meth-gf-01 (x))
(deftest no-applicable-method.2
(deftest no-applicable-method.1
(handler-case
(progn (no-app-meth-gf-01 'x) :bad)
(error () :good))
:good)
(defparameter *no-app-meth-gf-02*
(defgeneric no-app-meth-gf-02 (x)))
(defmethod no-applicable-method ((x (eql *no-app-meth-gf-02*)) &rest args)
(declare (ignore args x))
:good)
(deftest no-applicable-method.3
(no-app-meth-gf-02 (cons 'a 'b))
:good)
(defparameter *no-app-meth-gf-03*
(defgeneric no-app-meth-gf-03 (x)))
(defmethod no-applicable-method ((x (eql *no-app-meth-gf-03*)) &rest args)
(declare (ignore args x))
:no-method-found)
(defmethod no-app-meth-gf-03 ((x integer)) :good)
(deftest no-applicable-method.4
(no-app-meth-gf-03 (cons 'a 'b))
:no-method-found)
(deftest no-applicable-method.5
(no-app-meth-gf-03 100)
:good)
(deftest no-applicable-method.6
(no-app-meth-gf-03 100000000000000000)
:good)
(defparameter *no-app-meth-gf-04*
(defgeneric no-app-meth-gf-04 (&rest args)))
(defmethod no-applicable-method ((x (eql *no-app-meth-gf-04*)) &rest args)
(and (eql x *no-app-meth-gf-04*)
(copy-list args)))
(deftest no-applicable-method.7
(no-app-meth-gf-04 'a 'b 'c 'd)
(a b c d))
(defparameter *no-app-meth-gf-05*
(defgeneric no-app-meth-gf-05 (x &key)
(:method ((x symbol) &key) x)))
(defmethod no-applicable-method ((x (eql *no-app-meth-gf-05*)) &rest args)
(and (eql x *no-app-meth-gf-05*)
(copy-list args)))
(deftest no-applicable-method.8
(no-app-meth-gf-05 'a)
a)
;;; From section 7.6.6: 'Calling no-applicable-method takes precedence
;;; over checking for acceptable keyword arguments'
(deftest no-applicable-method.9
(no-app-meth-gf-05 10 :nonsense t)
(10 :nonsense t))
;;; I can't conformantly define useful methods for no-applicable-method
;;; without defining new generic function classes, and there's
;;; no standard way to do that. Grrr.
\ No newline at end of file
......@@ -112,9 +112,3 @@
(values (setf a 'x) (setf b 'y) (setf c 'z)
(wa-2-a obj) (wa-2-b obj) (wa-2-c obj))))
x y z x y z)
......@@ -143,8 +143,9 @@
;;; If slot is unbound, act as if slot-value had been called
(defmethod slot-unbound ((class (eql (find-class 'with-slots-class-01)))
instance slot-name)
(defmethod slot-unbound ((class t)
(instance with-slots-class-01)
slot-name)
'missing)
(deftest with-slots.18
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment