/[gcl]/gcl/ansi-tests/change-class.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/change-class.lsp

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

revision 1.1 by pfdietz, Sun May 4 11:48:00 2003 UTC revision 1.2 by pfdietz, Sun May 4 20:24:30 2003 UTC
# Line 160  Line 160 
160     (error () :expected-error))     (error () :expected-error))
161    :expected-error)    :expected-error)
162    
163    ;; test of class name as second argument
164    (deftest change-class.1.12
165      (let ((obj (make-instance 'change-class-class-01a :b 1))
166            (new-class (find-class 'change-class-class-01b)))
167        (values
168         (eqt obj (change-class obj 'change-class-class-01b :c2 3))
169         (typep* obj 'change-class-class-01a)
170         (typep* obj 'change-class-class-01b)
171         (slot-exists-p obj 'a)
172         (map-slot-boundp* obj '(b c d))
173         (map-slot-value obj '(b c))))
174      t nil t nil (t t nil) (1 3))
175    
176    
177  ;;; Shared slots  ;;; Shared slots
178    
179  (defclass change-class-class-02a ()  (defclass change-class-class-02a ()
# Line 292  Line 306 
306       (slot-value obj3 'b)       (slot-value obj3 'b)
307       ))       ))
308    (nil t) t nil t t nil (nil t) (nil t) (nil t) 17 17 17)    (nil t) t nil t t nil (nil t) (nil t) (nil t) 17 17 17)
309    
310    ;;; Destination class has slot initforms
311    
312    (defclass change-class-class-04a ()
313      ((a :initarg :a) (b :initarg :b)))
314    
315    (defclass change-class-class-04b ()
316      ((a :initform 'x :initarg :a2)
317       (c :initform 'y :initarg :c2)))
318    
319    (deftest change-class.4.1
320      (let ((obj (make-instance 'change-class-class-04a))
321            (new-class (find-class 'change-class-class-04b)))
322        (values
323         (eqt obj (change-class obj new-class))
324         (map-slot-boundp* obj '(a c))
325         (slot-value obj 'c)))
326      t
327      (nil t)
328      y)
329    
330    (deftest change-class.4.2
331      (let ((obj (make-instance 'change-class-class-04a))
332            (new-class (find-class 'change-class-class-04b)))
333        (values
334         (eqt obj (change-class obj new-class :a2 'z))
335         (map-slot-value obj '(a c))))
336      t
337      (z y))
338    
339    (deftest change-class.4.3
340      (let ((obj (make-instance 'change-class-class-04a :a 'p :b 'q))
341            (new-class (find-class 'change-class-class-04b)))
342        (values
343         (eqt obj (change-class obj new-class))
344         (map-slot-value obj '(a c))))
345      t
346      (p y))
347    
348    (deftest change-class.4.4
349      (let ((obj (make-instance 'change-class-class-04a))
350            (new-class (find-class 'change-class-class-04b)))
351        (values
352         (eqt obj (change-class obj new-class :c2 'k))
353         (map-slot-boundp* obj '(a c))
354         (slot-value obj 'c)))
355      t
356      (nil t)
357      k)
358    
359    ;;; Custom methods for change-class
360    
361    (declaim (special *changed-class-on-class-05*))
362    
363    (defclass change-class-class-05 ()
364      (a b c))
365    
366    (defmethod change-class
367      ((obj change-class-class-05)
368       (new-class (eql (find-class 'change-class-class-05)))
369       &rest initargs &key &allow-other-keys)
370      (declare (ignore initargs new-class))
371      (setq *changed-class-on-class-05* t)
372      obj)
373    
374    (deftest change-class.5
375      (let ((*changed-class-on-class-05* nil)
376            (obj (make-instance 'change-class-class-05)))
377        (values
378         (eqt obj (change-class obj (find-class 'change-class-class-05)))
379         *changed-class-on-class-05*))
380      t t)
381    
382    (defclass change-class-class-06 ()
383      ((a :initarg :a) (b :initarg :b) (c :initarg :c)))
384    
385    (defmethod change-class
386      ((obj change-class-class-06)
387       (new-class standard-class)
388       &rest initargs &key &allow-other-keys)
389      (declare (ignore initargs))
390      (setf (slot-value obj 'a) 123)
391      (call-next-method))
392    
393    (deftest change-class.6.1
394      (let* ((class (find-class 'change-class-class-06))
395             (obj (make-instance class)))
396        (values
397         (map-slot-boundp* obj '(a b c))
398         (eqt obj (change-class obj class))
399         (map-slot-boundp* obj '(a b c))
400         (slot-value obj 'a)
401         ))
402      (nil nil nil)
403      t
404      (t nil nil)
405      123)
406    
407    (deftest change-class.6.2
408      (let* ((class (find-class 'change-class-class-06))
409             (obj (make-instance class :a 'bad)))
410        (values
411         (map-slot-boundp* obj '(a b c))
412         (eqt obj (change-class obj class))
413         (map-slot-boundp* obj '(a b c))
414         (slot-value obj 'a)
415         ))
416      (t nil nil)
417      t
418      (t nil nil)
419      123)
420    
421    
422    ;;; Error tests
423    
424    (deftest change-class.error.1
425      (classify-error (change-class))
426      program-error)
427    
428    (deftest change-class.error.2
429      (classify-error
430       (change-class (make-instance 'change-class-class-01a)))
431      program-error)
432    
433    (deftest change-class.error.3
434      (classify-error
435       (let ((obj (make-instance 'change-class-class-01a))
436             (new-class (find-class 'change-class-class-01b)))
437         (change-class obj new-class :c2)))
438      program-error)
439    
440    (deftest change-class.error.4
441      (classify-error
442       (let ((obj (make-instance 'change-class-class-01a))
443             (new-class (find-class 'change-class-class-01b)))
444         (change-class obj new-class '(nonsense) 'a)))
445      program-error)
446    

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