← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/allocate-instance.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/allocate-instance.lsp
 
1
;-*- Mode:     Lisp -*-
 
2
;;;; Author:   Paul Dietz
 
3
;;;; Created:  Mon Apr 28 21:06:58 2003
 
4
;;;; Contains: Tests of ALLOCATE-INSTANCE
 
5
 
 
6
(in-package :cl-test)
 
7
 
 
8
;;; According to the CLHS, the meaning of adding methods to
 
9
;;; ALLOCATE-INSTANCE is unspecified, so this will not be tested
 
10
;;; here.
 
11
 
 
12
(defclass allocate-instance-class-01 ()
 
13
  ((a :initform 'x) (b :initarg :b)
 
14
   (c :type float) (d :allocation :class)
 
15
   (e :initarg :e) (f :documentation "foo"))
 
16
  (:default-initargs :b 'y))
 
17
 
 
18
(deftest allocate-instance.1
 
19
  (let* ((class (find-class 'allocate-instance-class-01))
 
20
         (obj (allocate-instance class)))
 
21
    (values
 
22
     (eqt (class-of obj) class)
 
23
     (typep* obj 'allocate-instance-class-01)
 
24
     (typep* obj class)
 
25
     (map-slot-boundp* obj '(a b c d e f))))
 
26
  t t t
 
27
  (nil nil nil nil nil nil))
 
28
 
 
29
(deftest allocate-instance.2
 
30
  (let* ((class (find-class 'allocate-instance-class-01))
 
31
         (obj (allocate-instance class
 
32
                                 :foo t :a 10 :b 12 :c 1.0 :d 'a :e 17
 
33
                                 :f nil :bar t)))
 
34
    (values
 
35
     (eqt (class-of obj) class)
 
36
     (typep* obj 'allocate-instance-class-01)
 
37
     (typep* obj class)
 
38
     (map-slot-boundp* obj '(a b c d e f))))
 
39
  t t t
 
40
  (nil nil nil nil nil nil))
 
41
 
 
42
(deftest allocate-instance.3
 
43
  (let* ((class (find-class 'allocate-instance-class-01))
 
44
         (obj (allocate-instance class :allow-other-keys nil :xyzzy t)))
 
45
    (values
 
46
     (eqt (class-of obj) class)
 
47
     (typep* obj 'allocate-instance-class-01)
 
48
     (typep* obj class)
 
49
     (map-slot-boundp* obj '(a b c d e f))))
 
50
  t t t
 
51
  (nil nil nil nil nil nil))
 
52
 
 
53
(defclass allocate-instance-class-02 ()
 
54
  (a (b :allocation :class)))
 
55
 
 
56
(deftest allocate-instance.4
 
57
  (let ((class (find-class 'allocate-instance-class-02)))
 
58
    (setf (slot-value (allocate-instance class) 'b) 'x)
 
59
    (let ((obj (allocate-instance class)))
 
60
      (values
 
61
       (eqt (class-of obj) class)
 
62
       (typep* obj 'allocate-instance-class-02)
 
63
       (typep* obj class)
 
64
       (slot-boundp* obj 'a)
 
65
       (slot-value obj 'b))))
 
66
  t t t nil x)
 
67
 
 
68
(defstruct allocate-instance-struct-01
 
69
  a
 
70
  (b 0 :type integer)
 
71
  (c #\a :type character)
 
72
  (d 'a :type symbol))
 
73
 
 
74
(deftest allocate-instance.5
 
75
  (let* ((class (find-class 'allocate-instance-struct-01))
 
76
         (obj   (allocate-instance class)))
 
77
    (setf (allocate-instance-struct-01-a obj) 'x
 
78
          (allocate-instance-struct-01-b obj) 1234567890
 
79
          (allocate-instance-struct-01-c obj) #\Z
 
80
          (allocate-instance-struct-01-d obj) 'foo)
 
81
    (values
 
82
     (eqt (class-of obj) class)
 
83
     (typep* obj 'allocate-instance-struct-01)
 
84
     (typep* obj class)
 
85
     (allocate-instance-struct-01-a obj)
 
86
     (allocate-instance-struct-01-b obj)
 
87
     (allocate-instance-struct-01-c obj)
 
88
     (allocate-instance-struct-01-d obj)))
 
89
  t t t
 
90
  x 1234567890 #\Z foo)
 
91
 
 
92
;;; Order of evaluation tests
 
93
 
 
94
(deftest allocate-instance.order.1
 
95
  (let* ((class (find-class 'allocate-instance-class-01))
 
96
         (i 0) x y z w
 
97
         (obj (allocate-instance (progn (setf x (incf i)) class)
 
98
                                 :e (setf y (incf i))
 
99
                                 :b (setf z (incf i))
 
100
                                 :e (setf w (incf i)))))
 
101
    (values
 
102
     (eqt (class-of obj) class)
 
103
     (typep* obj 'allocate-instance-class-01)
 
104
     (typep* obj class)
 
105
     i x y z w))
 
106
  t t t 4 1 2 3 4)
 
107
 
 
108
;;; Error tests
 
109
 
 
110
(deftest allocate-instance.error.1
 
111
  (signals-error (allocate-instance) program-error)
 
112
  t)
 
113
 
 
114
;;; Duane Rettig made a convincing argument that the next two
 
115
;;; tests are bad, since the caller of allocate-instance
 
116
;;; is supposed to have checked that the initargs are valid
 
117
 
 
118
#|
 
119
(deftest allocate-instance.error.2
 
120
  (signals-error (allocate-instance (find-class 'allocate-instance-class-01)
 
121
                                     :b)
 
122
                 program-error)
 
123
  t)
 
124
 
 
125
(deftest allocate-instance.error.3
 
126
  (signals-error (allocate-instance (find-class 'allocate-instance-class-01)
 
127
                                     '(a b c) nil)
 
128
                 program-error)
 
129
  t)
 
130
|#