/[gcl]/gcl/ansi-tests/shared-initialize.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/shared-initialize.lsp

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

revision 1.1 by pfdietz, Wed Apr 30 01:34:15 2003 UTC revision 1.2 by pfdietz, Fri May 2 05:22:00 2003 UTC
# Line 124  Line 124 
124    5 37 213)    5 37 213)
125    
126    
127    ;;; Initforms in the lexical environment of the defclass
128    
129    (declaim (special *shared-init-var-02-init*
130                      *shared-init-var-02-query*))
131    
132    (let ((ainit 0) (binit 0))
133      (flet ((%init (a b) (setf ainit a binit b))
134             (%query () (list ainit binit)))
135        (setf *shared-init-var-02-init* #'%init
136              *shared-init-var-02-query* #'%query)
137        (defclass shared-init-class-02 ()
138          ((a :initform (incf ainit) :initarg :a)
139           (b :initform (incf binit) :initarg :b)
140           (c :initarg :c)
141           (d))
142          (:default-initargs :c 100))))
143    
144    (deftest shared-initialize.10
145      (progn
146        (funcall *shared-init-var-02-init* 5 10)
147        (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
148          (values
149           (funcall *shared-init-var-02-query*)
150           (eqt obj (shared-initialize obj t))
151           (slot-value obj 'a)
152           (slot-value obj 'b)
153           (map-slot-boundp* obj '(a b c d))
154           (funcall *shared-init-var-02-query*))))
155      (5 10)
156      t
157      6 11
158      (t t nil nil)
159      (6 11))
160    
161    (deftest shared-initialize.11
162      (progn
163        (funcall *shared-init-var-02-init* 5 10)
164        (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
165          (values
166           (funcall *shared-init-var-02-query*)
167           (eqt obj (shared-initialize obj nil))
168           (map-slot-boundp* obj '(a b c d))
169           (funcall *shared-init-var-02-query*))))
170      (5 10)
171      t
172      (nil nil nil nil)
173      (5 10))
174    
175    (deftest shared-initialize.12
176      (progn
177        (funcall *shared-init-var-02-init* 5 10)
178        (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
179          (values
180           (funcall *shared-init-var-02-query*)
181           (eqt obj (shared-initialize obj '(a)))
182           (slot-value obj 'a)
183           (map-slot-boundp* obj '(a b c d))
184           (funcall *shared-init-var-02-query*))))
185      (5 10)
186      t
187      6
188      (t nil nil nil)
189      (6 10))
190    
191    (deftest shared-initialize.13
192      (progn
193        (funcall *shared-init-var-02-init* 5 10)
194        (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
195          (values
196           (funcall *shared-init-var-02-query*)
197           (eqt obj (shared-initialize obj '(b)))
198           (slot-value obj 'b)
199           (map-slot-boundp* obj '(a b c d))
200           (funcall *shared-init-var-02-query*))))
201      (5 10)
202      t
203      11
204      (nil t nil nil)
205      (5 11))
206    
207    (deftest shared-initialize.14
208      (progn
209        (funcall *shared-init-var-02-init* 5 10)
210        (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
211          (values
212           (funcall *shared-init-var-02-query*)
213           (eqt obj (shared-initialize obj t :a 34 :b 49))
214           (map-slot-value obj '(a b))
215           (map-slot-boundp* obj '(a b c d))
216           (funcall *shared-init-var-02-query*))))
217      (5 10)
218      t
219      (34 49)
220      (t t nil nil)
221      (5 10))
222    
223    (deftest shared-initialize.15
224      (progn
225        (funcall *shared-init-var-02-init* 5 10)
226        (let ((obj (allocate-instance (find-class 'shared-init-class-02))))
227          (values
228           (funcall *shared-init-var-02-query*)
229           (eqt obj (shared-initialize obj '(a b c d) :a 34 :b 49))
230           (map-slot-value obj '(a b))
231           (map-slot-boundp* obj '(a b c d))
232           (funcall *shared-init-var-02-query*))))
233      (5 10)
234      t
235      (34 49)
236      (t t nil nil)
237      (5 10))
238    
239    ;;; Defining new methods on shared-initialize
240    
241    (defstruct shared-init-class-03
242      a b c)
243    
244    (defmethod shared-initialize ((obj shared-init-class-03)
245                                  slots-to-init
246                                  &key
247                                  (a nil a-p)
248                                  (b nil b-p)
249                                  (c nil c-p)
250                                  &allow-other-keys)
251      (declare (ignore slots-to-init))
252      (when a-p (setf (slot-value obj 'a) a))
253      (when b-p (setf (slot-value obj 'b) b))
254      (when c-p (setf (slot-value obj 'c) c))
255      obj)
256    
257    (deftest shared-initialize.16
258      (let ((obj (make-shared-init-class-03)))
259        (values
260         (eqt obj (shared-initialize obj nil :a 1 :b 5 :c 19))
261         (shared-init-class-03-a obj)
262         (shared-init-class-03-b obj)
263         (shared-init-class-03-c obj)))
264      t 1 5 19)
265    
266    

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

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