/[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.3 by pfdietz, Sat May 17 12:49:53 2003 UTC revision 1.4 by pfdietz, Fri Jun 13 12:01:28 2003 UTC
# Line 38  Line 38 
38    
39  ;; Definitions of methods  ;; Definitions of methods
40    
41  (defmethod make-instance ((x (eql 'foo)) &rest initargs &key &allow-other-keys)  (defmethod make-instance ((x make-instance-class-01)
42    (cons x initargs))                            &rest initargs &key &allow-other-keys)
43      initargs)
44    
45  (deftest make-instance.1  (deftest make-instance.1
46    (make-instance 'foo)    (make-instance (make-instance 'make-instance-class-01))
   (foo))  
   
 (deftest make-instance.2  
   (make-instance 'foo :a 1 :b 2)  
   (foo :a 1 :b 2))  
   
 (defclass make-instance-class-02 ()  
   (a b c))  
   
 (defmethod make-instance ((class (eql (find-class 'make-instance-class-02)))  
                           &rest initargs &key (x nil) (y nil) (z nil)  
                           &allow-other-keys)  
   (declare (ignore initargs))  
   (let ((obj (allocate-instance class)))  
     (setf (slot-value obj 'a) x  
           (slot-value obj 'b) y  
           (slot-value obj 'c) z)  
     obj))  
   
 (deftest make-instance.3  
   (let ((obj (make-instance 'make-instance-class-02)))  
     (values  
      (eqt (class-of obj) (find-class 'make-instance-class-02))  
      (slot-value obj 'a)  
      (slot-value obj 'b)  
      (slot-value obj 'c)))  
   t nil nil nil)  
   
 (deftest make-instance.4  
   (let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd)))  
     (values  
      (eqt (class-of obj) (find-class 'make-instance-class-02))  
      (slot-value obj 'a)  
      (slot-value obj 'b)  
      (slot-value obj 'c)))  
   t d 45 10)  
   
   
 (deftest make-instance.5  
   (let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g)))  
     (values  
      (eqt (class-of obj) (find-class 'make-instance-class-02))  
      (slot-value obj 'a)  
      (slot-value obj 'b)  
      (slot-value obj 'c)))  
   t nil g nil)  
   
 (deftest make-instance.6  
   (eq (make-instance 'make-instance-class-02)  
       (make-instance 'make-instance-class-02))  
47    nil)    nil)
48    
49  ;; Customization of make-instance  (deftest make-instance.2
50      (make-instance (make-instance 'make-instance-class-01) :a 1 :b 2)
51  (defclass make-instance-class-03 ()    (:a 1 :b 2))
   ((a :initform 1) (b :initarg :b) c))  
52    
53  (defmethod make-instance ((class (eql (find-class 'make-instance-class-03)))  #|
54                            &rest initargs  (when *can-define-metaclasses*
55                            &key (x nil x-p) (y nil y-p) (z nil z-p)    
56                            &allow-other-keys)    (defclass make-instance-class-02 ()
57    (declare (ignore initargs))      (a b c)
58    (let ((obj (allocate-instance (find-class 'make-instance-class-03))))      (:metaclass substandard-class))
59      (when x-p (setf (slot-value obj 'a) x))    
60      (when y-p (setf (slot-value obj 'b) y))    (defmethod make-instance ((class (eql (find-class 'make-instance-class-02)))
61      (when z-p (setf (slot-value obj 'c) z))                              &rest initargs &key (x nil) (y nil) (z nil)
62      obj))                              &allow-other-keys)
63        (declare (ignore initargs))
64  (deftest make-instance.7      (let ((obj (allocate-instance class)))
65    (let ((obj (make-instance 'make-instance-class-03)))        (setf (slot-value obj 'a) x
66      (values              (slot-value obj 'b) y
67       (eqt (class-of obj)              (slot-value obj 'c) z)
68            (find-class 'make-instance-class-03))        obj))
69       (map-slot-boundp* obj '(a b c))))    
70    t (nil nil nil))    (deftest make-instance.3
71        (let ((obj (make-instance 'make-instance-class-02)))
72  (deftest make-instance.8        (values
73    (let* ((class (find-class 'make-instance-class-03))         (eqt (class-of obj) (find-class 'make-instance-class-02))
74           (obj (make-instance class :b 10)))         (slot-value obj 'a)
75      (values         (slot-value obj 'b)
76       (eqt (class-of obj) class)         (slot-value obj 'c)))
77       (map-slot-boundp* obj '(a b c))))      t nil nil nil)
78    t (nil nil nil))    
79      (deftest make-instance.4
80  (deftest make-instance.9      (let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd)))
81    (let* ((class (find-class 'make-instance-class-03))        (values
82           (obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad)))         (eqt (class-of obj) (find-class 'make-instance-class-02))
83      (values         (slot-value obj 'a)
84       (eqt (class-of obj) class)         (slot-value obj 'b)
85       (map-slot-boundp* obj '(a b c))         (slot-value obj 'c)))
86       (map-slot-value obj '(a b c))))      t d 45 10)
87    t (t t t) (g k i))    
88      
89  ;;; After method combination    (deftest make-instance.5
90        (let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g)))
91  (defparameter *make-instance-class-04-var* 0)        (values
92           (eqt (class-of obj) (find-class 'make-instance-class-02))
93  (defclass make-instance-class-04 ()         (slot-value obj 'a)
94    ((a :initform *make-instance-class-04-var*)))         (slot-value obj 'b)
95           (slot-value obj 'c)))
96  (defmethod make-instance :after      t nil g nil)
97    ((class (eql (find-class 'make-instance-class-04)))    
98     &rest initargs &key &allow-other-keys)    (deftest make-instance.6
99    (declare (ignore initargs))      (eq (make-instance 'make-instance-class-02)
100    (incf *make-instance-class-04-var* 10))          (make-instance 'make-instance-class-02))
101        nil)
102  (deftest make-instance.10  
103    (let* ((*make-instance-class-04-var* 0)    ;; Customization of make-instance
104           (obj (make-instance 'make-instance-class-04)))    
105      (values    (defclass make-instance-class-03 ()
106       (slot-value obj 'a)      ((a :initform 1) (b :initarg :b) c)
107       *make-instance-class-04-var*))      (:metaclass substandard-class))
108    0 10)  
109      (defmethod make-instance ((class (eql (find-class 'make-instance-class-03)))
110  ;;; Around method combination                              &rest initargs
111                                &key (x nil x-p) (y nil y-p) (z nil z-p)
112  (defclass make-instance-class-05 ()                              &allow-other-keys)
113    ((a :initarg :a) (b :initarg :b :initform 'foo) c))      (declare (ignore initargs))
114        (let ((obj (allocate-instance (find-class 'make-instance-class-03))))
115  (defmethod make-instance :around        (when x-p (setf (slot-value obj 'a) x))
116    ((class (eql (find-class 'make-instance-class-05)))        (when y-p (setf (slot-value obj 'b) y))
117     &rest initargs &key &allow-other-keys)        (when z-p (setf (slot-value obj 'c) z))
118    (declare (ignore initargs))        obj))
119    (let ((obj (call-next-method)))    
120      (setf (slot-value obj 'c) 'bar)    (deftest make-instance.7
121      obj))      (let ((obj (make-instance 'make-instance-class-03)))
122          (values
123  (deftest make-instance.11         (eqt (class-of obj)
124    (let ((obj (make-instance 'make-instance-class-05)))              (find-class 'make-instance-class-03))
125      (values         (map-slot-boundp* obj '(a b c))))
126       (map-slot-boundp* obj '(a b c))      t (nil nil nil))
127       (map-slot-value obj '(b c))))    
128    (nil t t)    (deftest make-instance.8
129    (foo bar))      (let* ((class (find-class 'make-instance-class-03))
130               (obj (make-instance class :b 10)))
131          (values
132           (eqt (class-of obj) class)
133           (map-slot-boundp* obj '(a b c))))
134        t (nil nil nil))
135      
136      (deftest make-instance.9
137        (let* ((class (find-class 'make-instance-class-03))
138               (obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad)))
139          (values
140           (eqt (class-of obj) class)
141           (map-slot-boundp* obj '(a b c))
142           (map-slot-value obj '(a b c))))
143        t (t t t) (g k i))
144    
145      ;; After method combination
146    
147      (defparameter *make-instance-class-04-var* 0)
148    
149      (defclass make-instance-class-04 ()
150        ((a :initform *make-instance-class-04-var*))
151        (:metaclass substandard-class))
152    
153      (defmethod make-instance :after
154        ((class (eql (find-class 'make-instance-class-04)))
155         &rest initargs &key &allow-other-keys)
156        (declare (ignore initargs))
157        (incf *make-instance-class-04-var* 10))
158      
159      (deftest make-instance.10
160        (let* ((*make-instance-class-04-var* 0)
161               (obj (make-instance 'make-instance-class-04)))
162          (values
163           (slot-value obj 'a)
164           *make-instance-class-04-var*))
165        0 10)
166      
167      ;; Around method combination
168    
169      (defclass make-instance-class-05 ()
170        ((a :initarg :a) (b :initarg :b :initform 'foo) c)
171        (:metaclass substandard-class))
172    
173      (defmethod make-instance :around
174        ((class (eql (find-class 'make-instance-class-05)))
175         &rest initargs &key &allow-other-keys)
176        (declare (ignore initargs))
177        (let ((obj (call-next-method)))
178          (setf (slot-value obj 'c) 'bar)
179          obj))
180      
181      (deftest make-instance.11
182        (let ((obj (make-instance 'make-instance-class-05)))
183          (values
184           (map-slot-boundp* obj '(a b c))
185           (map-slot-value obj '(b c))))
186        (nil t t)
187        (foo bar))
188      )
189    |#
190    
191  ;;; Order of argument evaluation  ;;; Order of argument evaluation
192    

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

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