/[gcl]/gcl/ansi-tests/make-instance.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/make-instance.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by pfdietz, Thu May 15 12:12:32 2003 UTC revision 1.3 by pfdietz, Sat May 17 12:49:53 2003 UTC
# Line 95  Line 95 
95        (make-instance 'make-instance-class-02))        (make-instance 'make-instance-class-02))
96    nil)    nil)
97    
98    ;; Customization of make-instance
99    
100    (defclass make-instance-class-03 ()
101      ((a :initform 1) (b :initarg :b) c))
102    
103    (defmethod make-instance ((class (eql (find-class 'make-instance-class-03)))
104                              &rest initargs
105                              &key (x nil x-p) (y nil y-p) (z nil z-p)
106                              &allow-other-keys)
107      (declare (ignore initargs))
108      (let ((obj (allocate-instance (find-class 'make-instance-class-03))))
109        (when x-p (setf (slot-value obj 'a) x))
110        (when y-p (setf (slot-value obj 'b) y))
111        (when z-p (setf (slot-value obj 'c) z))
112        obj))
113    
114    (deftest make-instance.7
115      (let ((obj (make-instance 'make-instance-class-03)))
116        (values
117         (eqt (class-of obj)
118              (find-class 'make-instance-class-03))
119         (map-slot-boundp* obj '(a b c))))
120      t (nil nil nil))
121    
122    (deftest make-instance.8
123      (let* ((class (find-class 'make-instance-class-03))
124             (obj (make-instance class :b 10)))
125        (values
126         (eqt (class-of obj) class)
127         (map-slot-boundp* obj '(a b c))))
128      t (nil nil nil))
129    
130    (deftest make-instance.9
131      (let* ((class (find-class 'make-instance-class-03))
132             (obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad)))
133        (values
134         (eqt (class-of obj) class)
135         (map-slot-boundp* obj '(a b c))
136         (map-slot-value obj '(a b c))))
137      t (t t t) (g k i))
138    
139    ;;; After method combination
140    
141    (defparameter *make-instance-class-04-var* 0)
142    
143    (defclass make-instance-class-04 ()
144      ((a :initform *make-instance-class-04-var*)))
145    
146    (defmethod make-instance :after
147      ((class (eql (find-class 'make-instance-class-04)))
148       &rest initargs &key &allow-other-keys)
149      (declare (ignore initargs))
150      (incf *make-instance-class-04-var* 10))
151    
152    (deftest make-instance.10
153      (let* ((*make-instance-class-04-var* 0)
154             (obj (make-instance 'make-instance-class-04)))
155        (values
156         (slot-value obj 'a)
157         *make-instance-class-04-var*))
158      0 10)
159    
160    ;;; Around method combination
161    
162    (defclass make-instance-class-05 ()
163      ((a :initarg :a) (b :initarg :b :initform 'foo) c))
164    
165    (defmethod make-instance :around
166      ((class (eql (find-class 'make-instance-class-05)))
167       &rest initargs &key &allow-other-keys)
168      (declare (ignore initargs))
169      (let ((obj (call-next-method)))
170        (setf (slot-value obj 'c) 'bar)
171        obj))
172    
173    (deftest make-instance.11
174      (let ((obj (make-instance 'make-instance-class-05)))
175        (values
176         (map-slot-boundp* obj '(a b c))
177         (map-slot-value obj '(b c))))
178      (nil t t)
179      (foo bar))
180    
181  ;;; Order of argument evaluation  ;;; Order of argument evaluation
182    
183  (deftest make-instance.order.1  (deftest make-instance.order.1

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26