Commit 1807b0a7 authored by pfdietz's avatar pfdietz

Tests of method customization for make-instance.

parent 17e2d7b9
......@@ -95,6 +95,89 @@
(make-instance 'make-instance-class-02))
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))
;;; Order of argument evaluation
(deftest make-instance.order.1
......
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