source: trunk/source/tests/ansi-tests/make-load-form.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 6.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat May 17 09:16:20 2003
4;;;; Contains: Tests of MAKE-LOAD-FORM
5
6(in-package :cl-test)
7
8;;; These tests are just of MAKE-LOAD-FORM itself; tests of file compilation
9;;; that depend on MAKE-LOAD-FORM will be found elsewhere.
10
11(defclass make-load-form-class-01 () (a b c))
12
13(deftest make-load-form.1
14  (let* ((fun #'make-load-form)
15         (obj (make-instance 'make-load-form-class-01)))
16    (if (eql (or (find-method fun nil '(standard-object) nil)
17                 (find-method fun nil (list (find-class t)) nil)
18                 :none)
19             (car (compute-applicable-methods fun (list obj))))
20        ;; The default method applies
21        (handler-case
22         (progn (make-load-form obj) :bad)
23         (error () :good))
24      :good))
25  :good)
26
27(defstruct make-load-form-struct-02 a b c)
28
29(deftest make-load-form.2
30  (let* ((fun #'make-load-form)
31         (obj (make-make-load-form-struct-02)))
32    (if (eql (or (find-method fun nil '(structure-object) nil)
33                 (find-method fun nil (list (find-class t)) nil)
34                 :none)
35             (car (compute-applicable-methods fun (list obj))))
36        ;; The default method applies
37        (handler-case
38         (progn (make-load-form obj) :bad)
39         (error () :good))
40      :good))
41  :good)
42
43(define-condition make-load-form-condition-03 () ((a) (b) (c)))
44
45(deftest make-load-form.3
46  (let* ((fun #'make-load-form)
47         (obj (make-condition 'make-load-form-condition-03)))
48    (if (eql (or (find-method fun nil '(condition) nil)
49                 (find-method fun nil (list (find-class t)) nil)
50                 :none)
51             (car (compute-applicable-methods fun (list obj))))
52        ;; The default method applies
53        (handler-case
54         (progn (make-load-form obj :bad))
55         (error () :good))
56      :good))
57  :good)
58
59;;; Make sure these errors are due to the method, not due to lack of
60;;; methods
61
62(deftest make-load-form.4
63  (let* ((obj (make-instance 'make-load-form-class-01))
64         (fun #'make-load-form)
65         (methods (compute-applicable-methods fun (list obj))))
66     (notnot-mv methods))
67  t)
68
69(deftest make-load-form.5
70  (let* ((obj (make-make-load-form-struct-02))
71         (fun #'make-load-form)
72         (methods (compute-applicable-methods fun (list obj))))
73    (notnot-mv methods))
74  t)
75
76(deftest make-load-form.6
77  (let* ((obj (make-condition 'make-load-form-condition-03))
78         (fun #'make-load-form)
79         (methods (compute-applicable-methods fun (list obj))))
80    (notnot-mv methods))
81  t)
82
83(deftest make-load-form.7
84  (let* ((obj (make-instance 'make-load-form-class-01))
85         (fun #'make-load-form)
86         (methods (compute-applicable-methods fun (list obj nil))))
87    (notnot-mv methods))
88  t)
89
90(deftest make-load-form.8
91  (let* ((obj (make-make-load-form-struct-02))
92         (fun #'make-load-form)
93         (methods (compute-applicable-methods fun (list obj nil))))
94    (notnot-mv methods))
95  t)
96
97(deftest make-load-form.9
98  (let* ((obj (make-condition 'make-load-form-condition-03))
99         (fun #'make-load-form)
100         (methods (compute-applicable-methods fun (list obj nil))))
101    (notnot-mv methods))
102  t)
103 
104(deftest make-load-form.10
105  (macrolet
106      ((%m (&environment env)
107           (let* ((obj (make-instance 'make-load-form-class-01))
108                  (fun #'make-load-form)
109                  (methods (compute-applicable-methods fun (list obj env))))
110             (notnot-mv methods))))
111    (%m))
112  t)
113
114(deftest make-load-form.11
115  (macrolet
116      ((%m (&environment env)
117           (let* ((obj (make-make-load-form-struct-02))
118                  (fun #'make-load-form)
119                  (methods (compute-applicable-methods fun (list obj env))))
120             (notnot-mv methods))))
121    (%m))
122  t)
123
124(deftest make-load-form.12
125  (macrolet
126      ((%m (&environment env)
127           (let* ((obj (make-condition 'make-load-form-condition-03))
128                  (fun #'make-load-form)
129                  (methods (compute-applicable-methods fun (list obj env))))
130             (notnot-mv methods))))
131    (%m))
132  t)
133
134;;; User-defined methods
135
136(defclass make-load-form-class-04 ()
137  ((a :initarg :a) (b :initarg :b) (c :initarg :c)))
138
139(defmethod make-load-form ((obj make-load-form-class-04)
140                           &optional (env t))
141  (declare (ignore env))
142  (let ((newobj (gensym)))
143    `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04))))
144       ,@(loop for slot-name in '(a b c)
145              when (slot-boundp obj slot-name)
146              collect `(setf (slot-value ,newobj ',slot-name)
147                             ',(slot-value obj slot-name)))
148       ,newobj)))
149
150(deftest make-load-form.13
151  (let* ((obj (make-instance 'make-load-form-class-04))
152         (obj2 (eval (make-load-form obj))))
153    (values
154     (eqt (class-of obj2) (class-of obj))
155     (map-slot-boundp* obj2 '(a b c))))
156  t (nil nil nil))
157
158(deftest make-load-form.14
159  (let* ((obj (make-instance 'make-load-form-class-04 :a 1 :b '(a b c) :c 'a))
160         (obj2 (eval (make-load-form obj))))
161    (values
162     (eqt (class-of obj2) (class-of obj))
163     (map-slot-boundp* obj2 '(a b c))
164     (map-slot-value obj2 '(a b c))))
165  t
166  (t t t)
167  (1 (a b c) a))
168
169(deftest make-load-form.15
170  (let* ((obj (make-instance 'make-load-form-class-04 :b '(a b c) :c 'a))
171         (obj2 (eval (make-load-form obj nil))))
172    (values
173     (eqt (class-of obj2) (class-of obj))
174     (map-slot-boundp* obj2 '(a b c))
175     (map-slot-value obj2 '(b c))))
176  t
177  (nil t t)
178  ((a b c) a))
179
180#|
181(defclass make-load-form-class-05a ()
182  ((a :initarg :a)))
183
184(defclass make-load-form-class-05b (make-load-form-class-05a)
185  ((b :initarg :b)))
186
187(defmethod make-load-form ((obj make-load-form-class-05a)
188                           &optional (env t))
189  (declare (ignore env))
190  (let ((newobj (gensym)))
191    `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04))))
192       ,@(when (slot-boundp obj 'a)
193           `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a))))
194       ,newobj)))
195
196(defmethod make-load-form :around ((obj make-load-form-class-05b)
197                                   &optional (env t))
198  (declare (ignore env))
199  (let ((newobj (gensym)))
200    `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04))))
201       ,@(when (slot-boundp obj 'a)
202           `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a))))
203       ,newobj)))
204|#
205
206
207
208;;; Other error tests
209
210(deftest make-load-form.error.1
211  (signals-error (make-load-form) program-error)
212  t)
213
214(deftest make-load-form.error.2
215  (signals-error
216   (let ((obj (make-instance 'make-load-form-class-04 :b '(a b c) :c 'a)))
217     (make-load-form obj nil nil))
218   program-error)
219  t)
Note: See TracBrowser for help on using the repository browser.