1 | ;;;-*-Mode: LISP; Package: CL-TEST -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2008 Clozure Associates |
---|
4 | |
---|
5 | (in-package :cl-test) |
---|
6 | |
---|
7 | (defvar *test-source-file-counter* 0) |
---|
8 | |
---|
9 | (defun test-source-file (format-string &rest format-args) |
---|
10 | (let ((file (format nil "temp~s.dat" (incf *test-source-file-counter*)))) |
---|
11 | (with-open-file (s file :direction :output :if-exists :supersede) |
---|
12 | (apply #'format s format-string format-args) |
---|
13 | (terpri s) |
---|
14 | (truename s)))) |
---|
15 | |
---|
16 | (defun test-compile (lambda-or-file &rest args &key hide-warnings (safety 1) &allow-other-keys) |
---|
17 | ;; Compile in a more-or-less standard environment |
---|
18 | (let ((*error-output* (if hide-warnings (make-broadcast-stream) *error-output*)) |
---|
19 | (ccl::*nx-speed* 1) |
---|
20 | (ccl::*nx-space* 1) |
---|
21 | (ccl::*nx-safety* safety) |
---|
22 | (ccl::*nx-cspeed* 1) |
---|
23 | (ccl::*nx-debug* 1)) |
---|
24 | (remf args :hide-warnings) |
---|
25 | (remf args :safety) |
---|
26 | (if (consp lambda-or-file) |
---|
27 | (apply #'compile nil lambda-or-file args) |
---|
28 | (apply #'compile-file lambda-or-file args)))) |
---|
29 | |
---|
30 | ;;; CCL-specific regression tests, for CCL-specific behavior. |
---|
31 | |
---|
32 | (deftest ccl.40199 ;; fixed in r9116 and r9121 |
---|
33 | (when (equalp (let ((*print-pretty* t)) |
---|
34 | (format nil "~a" (make-array nil :initial-element 0))) |
---|
35 | "#0A0") |
---|
36 | :good) |
---|
37 | :good) |
---|
38 | |
---|
39 | (deftest ccl.40492 ;; fixed in r9134 and r9131 |
---|
40 | (let (obj (slot (gensym))) |
---|
41 | (eval `(defclass ccl.40492 () |
---|
42 | ((,slot :accessor ,slot :initform :good)))) |
---|
43 | (setq obj (make-instance 'ccl.40492)) |
---|
44 | (ccl::%snap-reader-method (symbol-function slot)) |
---|
45 | (unwind-protect |
---|
46 | (let ((*trace-output* (make-broadcast-stream))) ;; don't care about trace output |
---|
47 | (ccl:trace-function slot) |
---|
48 | (funcall slot obj)) |
---|
49 | (eval `(untrace ,slot)))) |
---|
50 | :good) |
---|
51 | |
---|
52 | (deftest ccl.40207 ;; fixed in r9163 and r9165 |
---|
53 | (progn |
---|
54 | (fmakunbound 'cl-test::ccl.40207-fn) |
---|
55 | ;; Check that these compile-time errors don't abort compilation. |
---|
56 | (let* ((test (test-source-file "(defun cl-test::ccl.40207-fn () |
---|
57 | (and (typep (lambda (x) (setq x)) 'function) |
---|
58 | (typep (lambda (x) (setf x)) 'function) |
---|
59 | (typep (lambda (((foo))) foo) 'function) |
---|
60 | :good))"))) |
---|
61 | (test-compile test :hide-warnings t :break-on-program-errors nil :load t) |
---|
62 | (funcall 'cl-test::ccl.40207-fn))) |
---|
63 | :good) |
---|
64 | |
---|
65 | (deftest ccl.40927 ;; fixed in r9183 and r9184 |
---|
66 | (let ((s (make-string-output-stream)) |
---|
67 | (line1 "Line1 |
---|
68 | ") |
---|
69 | (line2 "Line2")) |
---|
70 | (count #\Newline (format nil "~a~&~a" line1 line2))) |
---|
71 | 1) |
---|
72 | |
---|
73 | (defstruct ccl.40055 (a 0 :type integer)) |
---|
74 | |
---|
75 | (deftest ccl.40055 ;; fixed in r9237 and r9240 |
---|
76 | (locally |
---|
77 | (declare (optimize (safety 3))) |
---|
78 | (and (signals-error (make-ccl.40055 :a nil) type-error) |
---|
79 | (signals-error (setf (ccl.40055-a (make-ccl.40055)) nil) type-error))) |
---|
80 | t) |
---|
81 | |
---|
82 | |
---|
83 | (deftest ccl.bug#235 |
---|
84 | (handler-case |
---|
85 | (test-compile `(lambda (x) |
---|
86 | (make-array x :element-type ',(gensym)))) |
---|
87 | (warning (c) |
---|
88 | (when (typep c 'ccl::compiler-warning) |
---|
89 | (ccl::compiler-warning-warning-type c)))) |
---|
90 | :unknown-type-declaration) |
---|
91 | |
---|
92 | |
---|
93 | (defclass ccl.bug#285 () ()) |
---|
94 | |
---|
95 | (defmethod initialize-instance ((c ccl.bug#285) &rest args) |
---|
96 | (declare (optimize (safety 3))) |
---|
97 | (apply #'call-next-method c args)) |
---|
98 | |
---|
99 | (deftest ccl.bug#285 |
---|
100 | (typep (make-instance 'ccl.bug#285) 'ccl.bug#285) |
---|
101 | t) |
---|
102 | |
---|
103 | (deftest ccl.bug#286 |
---|
104 | (and (test-compile '(lambda () |
---|
105 | (typep nil '(or ccl.bug#286-unknown-type-1 null))) |
---|
106 | :hide-warnings t) |
---|
107 | (test-compile '(lambda () |
---|
108 | (ccl:require-type nil '(or ccl.bug#286-unknown-type-2 null))) |
---|
109 | :hide-warnings t) |
---|
110 | :no-crash) |
---|
111 | :no-crash) |
---|
112 | |
---|
113 | |
---|
114 | (deftest ccl.bug#287 |
---|
115 | (progn |
---|
116 | (defmethod ccl.bug#287 (x) x) |
---|
117 | (trace ccl.bug#287) |
---|
118 | (let ((*trace-output* (make-broadcast-stream))) ;; don't care about trace output |
---|
119 | (prog1 |
---|
120 | (ccl.bug#287 :no-crash) |
---|
121 | (untrace)))) |
---|
122 | :no-crash) |
---|
123 | |
---|
124 | |
---|
125 | (deftest ccl.41226 |
---|
126 | (let ((file (test-source-file "(defmacro ccl.41226 (x) (eq (caar x)))"))) |
---|
127 | (handler-case |
---|
128 | (test-compile file :hide-warnings t :break-on-program-errors nil) |
---|
129 | ;; Might still signal due to macros being implicitly eval-when compile. |
---|
130 | ;; Ok so long as it's not the make-load-form error (which is not a program-error). |
---|
131 | (program-error () nil)) |
---|
132 | :no-crash) |
---|
133 | :no-crash) |
---|
134 | |
---|
135 | (deftest ccl.bug#288 |
---|
136 | (let ((file (test-source-file "(prog1 (declare (ignore foo)))"))) |
---|
137 | (test-compile file :hide-warnings t :break-on-program-errors nil) |
---|
138 | :no-crash) |
---|
139 | :no-crash) |
---|
140 | |
---|
141 | (deftest ccl.bug#288-1 ;; follow-on bug, not really the same |
---|
142 | (let ((file (test-source-file "(defun cl-test::ccl.bug#288-1-fn ((x integer)) x)"))) |
---|
143 | (test-compile file :hide-warnings t :break-on-program-errors nil :load t) |
---|
144 | (handler-case |
---|
145 | (progn (ccl.bug#288-1-fn 17) :no-warnings) |
---|
146 | (program-error (c) (if (search "(X INTEGER)" (princ-to-string c)) :lambda-list-error c)))) |
---|
147 | :lambda-list-error) |
---|
148 | |
---|
149 | (deftest ccl.40055-1 |
---|
150 | (let ((file (test-source-file " |
---|
151 | |
---|
152 | (defclass ccl.40055-1-class () ()) |
---|
153 | (eval-when (eval compile load) |
---|
154 | (defstruct ccl.40055-1-struct (slot nil :type (or ccl.40055-1-class null)))) |
---|
155 | (defun ccl.40055-1-fn () |
---|
156 | (make-array 0 :element-type 'ccl.40055-1-struct)) |
---|
157 | "))) |
---|
158 | (handler-case |
---|
159 | (progn (test-compile file) :no-warnings) |
---|
160 | (warning (c) (format nil "~a" c)))) |
---|
161 | :no-warnings) |
---|
162 | |
---|
163 | (deftest ccl.40055-2 |
---|
164 | (let ((file (test-source-file " |
---|
165 | |
---|
166 | (defclass ccl.40055-2-class () ()) |
---|
167 | (defstruct ccl.40055-2-struct (slot nil :type (or ccl.40055-2-class null))) |
---|
168 | (defun ccl.40055-2-class-arr () |
---|
169 | (make-array 0 :element-type 'ccl.40055-2-class)) |
---|
170 | (defun ccl.40055-2-struct-arr () |
---|
171 | (make-array 0 :element-type 'ccl.40055-2-struct)) |
---|
172 | (defun ccl.40055-2-struct-arr-2 () |
---|
173 | (make-array 0 :element-type '(or (member 17 32) ccl.40055-2-struct))) |
---|
174 | (defun ccl.40055-2-fn (x) (setf (ccl.40055-2-struct-slot x) nil)) |
---|
175 | "))) |
---|
176 | (handler-case |
---|
177 | (progn (test-compile file :break-on-program-errors nil) :no-warnings) |
---|
178 | (warning (c) c))) |
---|
179 | :no-warnings) |
---|
180 | |
---|
181 | |
---|
182 | (deftest ccl.40055-3 |
---|
183 | (let ((file (test-source-file " |
---|
184 | (defclass ccl.40055-3-class () ()) |
---|
185 | (defun ccl.40055-3-cfn () (require-type nil '(or ccl.40055-3-class null))) |
---|
186 | (defstruct ccl.40055-3-struct) |
---|
187 | (defun ccl.40055-3-rfn () (require-type nil '(or ccl.40055-3-struct null)))"))) |
---|
188 | (handler-case |
---|
189 | (progn (test-compile file :break-on-program-errors nil) :no-warnings) |
---|
190 | (warning (c) c))) |
---|
191 | :no-warnings) |
---|
192 | |
---|
193 | (deftest ccl.bug#289 |
---|
194 | (let ((file (test-source-file " |
---|
195 | (defclass ccl.bug#289-meta (standard-class) ()) |
---|
196 | (defclass ccl.bug#289-class () () (:metaclass ccl.bug#289-meta))"))) |
---|
197 | (test-compile file) |
---|
198 | :no-crash) |
---|
199 | :no-crash) |
---|
200 | |
---|
201 | (deftest ccl.bug#295 |
---|
202 | (let ((file (test-source-file " |
---|
203 | (defun outer-fun () |
---|
204 | (defun inner-fun () nil) |
---|
205 | (inner-fun))"))) |
---|
206 | (handler-case (progn (test-compile file :safety 3) :no-warnings) |
---|
207 | (warning (c) c))) |
---|
208 | :no-warnings) |
---|
209 | |
---|
210 | |
---|
211 | (deftest ccl.41836 ;; fixed in r9391 |
---|
212 | (let ((file (test-source-file " |
---|
213 | (defvar *a* 1) |
---|
214 | (defvar *b* (load-time-value *a*))"))) |
---|
215 | (handler-case (progn (test-compile file :break-on-program-errors nil) :no-warnings) |
---|
216 | (warning (c) c))) |
---|
217 | :no-warnings) |
---|
218 | |
---|
219 | |
---|
220 | (deftest ccl.42698 ;; fixed in r9589/r9590 |
---|
221 | (handler-case (schar "abc" -1) ;; used to crash hard |
---|
222 | (error () :error)) |
---|
223 | :error) |
---|
224 | |
---|
225 | (deftest ccl.42232-1 |
---|
226 | (let ((file (test-source-file " |
---|
227 | (defun ccl.42232-1 (foo) |
---|
228 | (declare (ignore foo)) |
---|
229 | foo)"))) |
---|
230 | (handler-case (progn (test-compile file) :no-warnings) |
---|
231 | (warning (c) :warning))) |
---|
232 | :warning) |
---|
233 | |
---|
234 | (deftest ccl.42232-2 |
---|
235 | (let ((file (test-source-file " |
---|
236 | (defun ccl.42232-2 () |
---|
237 | (declare (ignore bar)))"))) |
---|
238 | (handler-case (progn (test-compile file :break-on-program-errors nil) :no-warnings) |
---|
239 | (warning (c) :warning))) |
---|
240 | :warning) |
---|
241 | |
---|
242 | (deftest ccl.42830 |
---|
243 | (let ((*standard-output* (make-broadcast-stream))) |
---|
244 | (defun cl-user::ccl.42830 (stream int colon-p at-sign-p) |
---|
245 | (declare (ignore at-sign-p colon-p)) |
---|
246 | (check-type int integer) |
---|
247 | (write int :stream stream)) |
---|
248 | (defun test-ccl.42830 (a b stream) |
---|
249 | (format stream "~A ~/ccl.42830/" a b)) |
---|
250 | (and (eq (test-ccl.42830 "a" 1 t) nil) |
---|
251 | (string-equal (test-ccl.42830 "a" 1 nil) "a 1") |
---|
252 | :no-errors)) |
---|
253 | :no-errors) |
---|
254 | |
---|
255 | |
---|
256 | (deftest ccl.bug#305 |
---|
257 | (let* ((file (test-source-file " |
---|
258 | (in-package :cl-test) |
---|
259 | (defclass ccl.bug#305-inner () ((ccl.bug#305-inner-slot :accessor ccl.bug#305-inner-slot))) |
---|
260 | (macrolet ((generator () |
---|
261 | `(defclass ccl.bug#305 (ccl.bug#305-inner) |
---|
262 | ,(loop for i from 0 to 600 |
---|
263 | for slot = (intern (format nil \"CCL.BUG#305-SLOT-~~A\" i) :cl-user) |
---|
264 | collect `(,slot :initform ,i))))) |
---|
265 | (generator)) |
---|
266 | (defmethod initialize-instance :after ((x ccl.bug#305-inner) &key) |
---|
267 | (setf (ccl.bug#305-inner-slot x) 42)) |
---|
268 | (defun ccl.bug#305-test () (make-instance 'ccl.bug#305))")) |
---|
269 | (fasl (test-compile file))) |
---|
270 | (load fasl :verbose nil) |
---|
271 | (ccl.bug#305-inner-slot (ccl.bug#305-test))) |
---|
272 | 42) |
---|
273 | |
---|
274 | (deftest ccl.42923 |
---|
275 | (progn |
---|
276 | (fmakunbound 'ccl.42923) |
---|
277 | (defmethod ccl.42923 ((x (eql 'x)) &key y &allow-other-keys) |
---|
278 | (list x y) 'x) |
---|
279 | (defmethod ccl.42923 ((x (eql 'foo)) &key y &allow-other-keys) |
---|
280 | (list x y) 'foo) |
---|
281 | (defmethod ccl.42923 ((x (eql 'bar)) &key y z a b c) |
---|
282 | (list x y z (list a b c)) 'bar) |
---|
283 | (ccl::maybe-hack-eql-methods #'ccl.42923) |
---|
284 | (ccl:advise ccl.42923 'advise) |
---|
285 | (ccl.42923 'foo :y 1 :z 2 :a 1 :b 2 :c 3)) |
---|
286 | foo) |
---|
287 | |
---|
288 | (deftest ccl.bug#252a |
---|
289 | (let ((pn "bug252.dat")) |
---|
290 | (when (probe-file pn) |
---|
291 | (delete-file pn)) |
---|
292 | (let ((stream (open pn :direction :output :if-exists :error))) |
---|
293 | (print "something" stream) |
---|
294 | (close stream :abort t) |
---|
295 | (probe-file pn))) |
---|
296 | nil) |
---|
297 | |
---|
298 | (deftest ccl.bug#252b |
---|
299 | (let ((pn "bug252.dat")) |
---|
300 | (when (probe-file pn) |
---|
301 | (delete-file pn)) |
---|
302 | (let ((stream (open pn :direction :output))) |
---|
303 | (format stream "something~%") |
---|
304 | (close stream)) |
---|
305 | (let ((stream (open pn :direction :output :if-exists :supersede))) |
---|
306 | (format stream "other~%") |
---|
307 | (force-output stream) |
---|
308 | (close stream :abort t)) |
---|
309 | (with-open-file (stream pn) |
---|
310 | (let ((line (read-line stream))) |
---|
311 | (if (equalp line "something") :something line)))) |
---|
312 | :something) |
---|
313 | |
---|
314 | (deftest ccl.bug#310 |
---|
315 | (remove-duplicates '(1 0 1 1 1 0 0 0 1 0 1 0 1) :end 11) |
---|
316 | (0 1 0 1)) |
---|
317 | |
---|
318 | (deftest ccl.bug#294-1 |
---|
319 | (handler-case |
---|
320 | (let ((ccl::*nx-safety* 1)) ;; At safety 3, we don't know from EQ... |
---|
321 | (eval '(defun cl-test::ccl.bug#294-1 (x y) |
---|
322 | (eq x) y))) |
---|
323 | (program-error () :program-error)) |
---|
324 | :program-error) |
---|
325 | |
---|
326 | (deftest ccl.bug#294-2 |
---|
327 | (let* ((file (test-source-file |
---|
328 | "(defun cl-test::ccl.bug#294-2 (x y) (eq x) y)"))) |
---|
329 | (fmakunbound ' cl-test::ccl.bug#294-2) |
---|
330 | (handler-case (test-compile file :break-on-program-errors t) |
---|
331 | (program-error () :program-error))) |
---|
332 | :program-error) |
---|
333 | |
---|
334 | (deftest ccl.buf#294-3 |
---|
335 | (let* ((file (test-source-file |
---|
336 | "(defun cl-test::ccl.bug#294-3 (x y) (eq x) y)")) |
---|
337 | (warnings nil)) |
---|
338 | (fmakunbound ' cl-test::ccl.bug#294-3) |
---|
339 | (list |
---|
340 | (let ((*error-output* (make-broadcast-stream))) |
---|
341 | (handler-case |
---|
342 | (handler-bind ((warning (lambda (c) (setq warnings t)))) |
---|
343 | (test-compile file :break-on-program-errors :defer)) |
---|
344 | (error (c) :error))) |
---|
345 | warnings)) |
---|
346 | (:error t)) |
---|
347 | |
---|
348 | |
---|
349 | (deftest ccl.buf#294-4 |
---|
350 | (let* ((file (test-source-file |
---|
351 | "(defun cl-test::ccl.bug#294-4 (x y) (eq x) y)")) |
---|
352 | (warnings nil)) |
---|
353 | (fmakunbound 'cl-test::ccl.bug#294-4) |
---|
354 | (list |
---|
355 | (let ((*error-output* (make-broadcast-stream))) |
---|
356 | (handler-bind ((warning (lambda (c) (setq warnings t)))) |
---|
357 | (test-compile file :break-on-program-errors nil :load t)) |
---|
358 | (handler-case (and (fboundp 'cl-test::ccl.bug#294-4) |
---|
359 | (funcall 'cl-test::ccl.bug#294-4 1 2)) |
---|
360 | (program-error (c) :program-error))) |
---|
361 | warnings)) |
---|
362 | (:program-error t)) |
---|
363 | |
---|
364 | (deftest ccl.bug#315 |
---|
365 | (let* ((file (test-source-file |
---|
366 | "(defmethod ccl.bug#315-fn ((a sequence)) |
---|
367 | (reduce #'or a :key #'identity))")) |
---|
368 | (warning nil)) |
---|
369 | (handler-bind ((warning |
---|
370 | (lambda (c) |
---|
371 | (let ((s (princ-to-string c))) |
---|
372 | (setq warning |
---|
373 | (if (and (search "FUNCTION" s) (search "macro OR" s)) |
---|
374 | (or warning :macro-or) |
---|
375 | c)))))) |
---|
376 | (test-compile file :hide-warnings t :break-on-program-errors nil :load t)) |
---|
377 | warning) |
---|
378 | :macro-or) |
---|
379 | |
---|
380 | (deftest ccl.43101a |
---|
381 | (progn |
---|
382 | (untrace) |
---|
383 | (fmakunbound 'ccl.43101a-fun) |
---|
384 | (defun ccl.43101a-fun (x) x) |
---|
385 | (trace ccl.43101a-fun) |
---|
386 | (let ((file (test-source-file "(defun cl-test::ccl.43101a-fun (x) (1+ x))"))) |
---|
387 | (test-compile file :hide-warnings t :load t)) |
---|
388 | (not (equal "" (with-output-to-string (*trace-output*) |
---|
389 | (assert (eql (ccl.43101a-fun 4) 5)))))) |
---|
390 | t) |
---|
391 | |
---|
392 | (deftest ccl.43101b |
---|
393 | (progn |
---|
394 | (untrace) |
---|
395 | (fmakunbound 'ccl.43101b-gf) |
---|
396 | (defmethod ccl.43101b-gf (x) x) |
---|
397 | (trace ccl.43101b-gf) |
---|
398 | (let ((file (test-source-file "(defmethod cl-test::ccl.43101b-gf (x) (1+ x))"))) |
---|
399 | (test-compile file :hide-warnings t :load t)) |
---|
400 | (not (equal "" (with-output-to-string (*trace-output*) |
---|
401 | (assert (eql (ccl.43101b-gf 4) 5)))))) |
---|
402 | t) |
---|
403 | |
---|
404 | |
---|
405 | |
---|
406 | (deftest ccl.file-stream-typep |
---|
407 | (with-open-file (f "temp.dat" :direction :output :if-exists :supersede) |
---|
408 | (funcall (lambda (f) (let ((type (type-of f))) |
---|
409 | (and (typep f 'file-stream) (subtypep type 'file-stream) t))) |
---|
410 | f)) |
---|
411 | t) |
---|
412 | |
---|
413 | |
---|
414 | (deftest ccl.complex-cos |
---|
415 | (< (imagpart (cos (complex 1 1))) 0) |
---|
416 | t) |
---|
417 | |
---|
418 | (deftest ccl.space-symbol |
---|
419 | (let* ((list '(|aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa| |
---|
420 | | | | | | | | | | | | | | | | | | | | | | | |
---|
421 | |aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa|)) |
---|
422 | (result (read-from-string |
---|
423 | (with-output-to-string (s) |
---|
424 | (let ((*print-readably* t)) |
---|
425 | (pprint list s)))))) |
---|
426 | (or (equal list result) result)) |
---|
427 | t) |
---|
428 | |
---|
429 | (deftest ccl.46016 |
---|
430 | (let ((file (test-source-file " |
---|
431 | (defvar var.46016 nil) |
---|
432 | (declaim (boolean var.46016))"))) |
---|
433 | (handler-case (progn (test-compile file :load t :break-on-program-errors nil) :no-warnings) |
---|
434 | (warning (c) :warning))) |
---|
435 | :no-warnings) |
---|
436 | |
---|
437 | |
---|
438 | #+ccl-0711 |
---|
439 | (deftest ccl.47102 |
---|
440 | (handler-case |
---|
441 | (progn |
---|
442 | (defclass ccl.47102 () ((slot :allocation :class))) |
---|
443 | ;; This happens as part of snap-reader-methods optimization |
---|
444 | (ccl::optimize-make-instance-for-class-cell (gethash 'ccl.47102 ccl::%find-classes%)) |
---|
445 | :no-warnings) |
---|
446 | (warning (c) :warning)) |
---|
447 | :no-warnings) |
---|
448 | |
---|
449 | |
---|
450 | (deftest ccl.47762 |
---|
451 | (let ((file (test-source-file |
---|
452 | "(defun ccl.47762 () |
---|
453 | (funcall (find-symbol \"TEST.47762a\" \"NO_SUCH_PACKAGE\")) |
---|
454 | (funcall (intern \"TEST.47762b\" \"NO_SUCH_PACKAGE-1\")))"))) |
---|
455 | (handler-case |
---|
456 | (progn (test-compile file :load t) :no-error) |
---|
457 | (error (c) c))) |
---|
458 | :no-error) |
---|
459 | |
---|
460 | |
---|
461 | (deftest ccl.bug#254 |
---|
462 | (let ((warnings nil) |
---|
463 | (test " |
---|
464 | (define-method-combination ccl.bug#254 () |
---|
465 | ((around (:around)) |
---|
466 | (before (:before)) |
---|
467 | (primary () :required t) |
---|
468 | (after (:after))) |
---|
469 | (:arguments &optional args) |
---|
470 | |
---|
471 | (flet ((call-methods (methods) |
---|
472 | (mapcar #'(lambda (method) |
---|
473 | `(call-method ,method)) |
---|
474 | methods))) |
---|
475 | (let ((form (if (or before after (rest primary)) |
---|
476 | `(multiple-value-prog1 |
---|
477 | (progn ,@(call-methods before) |
---|
478 | (call-method ,(first primary) |
---|
479 | ,(rest primary))) |
---|
480 | ,@(call-methods (reverse after))) |
---|
481 | `(call-method ,(first primary))))) |
---|
482 | `(progn (print ,args) |
---|
483 | ,(if around |
---|
484 | `(call-method ,(first around) |
---|
485 | (,@(rest around) |
---|
486 | (make-method ,form))) |
---|
487 | form))))) |
---|
488 | ")) |
---|
489 | (handler-bind ((warning (lambda (c) |
---|
490 | (push c warnings) |
---|
491 | (muffle-warning c)))) |
---|
492 | (test-compile (test-source-file test))) |
---|
493 | warnings) |
---|
494 | ()) |
---|
495 | |
---|
496 | (defun test-dup-warnings (test1 &optional test2) |
---|
497 | (let ((warnings nil)) |
---|
498 | (handler-bind ((warning (lambda (c) |
---|
499 | (let ((msg (format nil "~a" c))) |
---|
500 | (push (if (search "Duplicate" msg :test #'equalp) |
---|
501 | :duplicate-definition |
---|
502 | c) warnings) |
---|
503 | (muffle-warning c))))) |
---|
504 | (if test2 |
---|
505 | (with-compilation-unit () |
---|
506 | (test-compile (test-source-file test1) :hide-warnings t) |
---|
507 | (test-compile (test-source-file test2) :hide-warnings t)) |
---|
508 | (test-compile (test-source-file test1 :hide-warnings t)))) |
---|
509 | warnings)) |
---|
510 | |
---|
511 | |
---|
512 | |
---|
513 | (deftest ccl.41334-1 |
---|
514 | (test-dup-warnings |
---|
515 | "(defun test.ccl-41334-1 (x) x) |
---|
516 | (defun test.ccl-41334-1 (x) x)") |
---|
517 | (:duplicate-definition)) |
---|
518 | |
---|
519 | |
---|
520 | (deftest ccl.41334-2 |
---|
521 | (test-dup-warnings |
---|
522 | "(defmethod test.ccl-41334-2 ((x stream)) x) |
---|
523 | (defmethod test.ccl-41334-2 ((x stream)) x)") |
---|
524 | (:duplicate-definition)) |
---|
525 | |
---|
526 | |
---|
527 | (deftest ccl.41334-3 |
---|
528 | (test-dup-warnings |
---|
529 | "(defmacro test.ccl-41334-3 (x) x) |
---|
530 | (defmacro test.ccl-41334-3 (x) x)") |
---|
531 | (:duplicate-definition)) |
---|
532 | |
---|
533 | (deftest ccl.41334-4 |
---|
534 | (test-dup-warnings |
---|
535 | "(defgeneric test.ccl-41334-4 (x)) |
---|
536 | (defun test.ccl-41334-4 (x) x)") |
---|
537 | (:duplicate-definition)) |
---|
538 | |
---|
539 | |
---|
540 | (deftest ccl.41334-1a |
---|
541 | (test-dup-warnings |
---|
542 | "(defun test.ccl-41334-1 (x) x)" |
---|
543 | "(defun test.ccl-41334-1 (x) x)") |
---|
544 | (:duplicate-definition)) |
---|
545 | |
---|
546 | |
---|
547 | (deftest ccl.41334-2a |
---|
548 | (test-dup-warnings |
---|
549 | "(defmethod test.ccl-41334-2 ((x stream)) x)" |
---|
550 | "(defmethod test.ccl-41334-2 ((x stream)) x)") |
---|
551 | (:duplicate-definition)) |
---|
552 | |
---|
553 | |
---|
554 | (deftest ccl.41334-3a |
---|
555 | (test-dup-warnings |
---|
556 | "(defmacro test.ccl-41334-3 (x) x)" |
---|
557 | "(defmacro test.ccl-41334-3 (x) x)") |
---|
558 | (:duplicate-definition)) |
---|
559 | |
---|
560 | (deftest ccl.41334-4a |
---|
561 | (test-dup-warnings |
---|
562 | "(defgeneric test.ccl-41334-4 (x &key foo))" |
---|
563 | "(defmacro test.ccl-41334-4 (x) x)") |
---|
564 | (:duplicate-definition)) |
---|
565 | |
---|
566 | |
---|
567 | (deftest ccl.41334-5 |
---|
568 | (test-dup-warnings |
---|
569 | "(defclass test.41334-5 () ((41334-5-slot :accessor test.41334-5-slot)))" |
---|
570 | "(defmethod (setf test.41334-5-slot) (v (x test.41334-5)) v)") |
---|
571 | (:duplicate-definition)) |
---|
572 | |
---|
573 | |
---|
574 | (deftest ccl.41334-6 |
---|
575 | (test-dup-warnings |
---|
576 | "(defun test.41334-6 () nil)" |
---|
577 | "(let ((closed nil)) |
---|
578 | (defun test.41334-6 () closed))") |
---|
579 | (:duplicate-definition)) |
---|
580 | |
---|
581 | (deftest ccl.41334-7 |
---|
582 | (test-dup-warnings |
---|
583 | "(defun test.41334-7 () nil)" |
---|
584 | "(unless (fboundp 'test.31334-7) |
---|
585 | (defun test.41334-7 () t))") |
---|
586 | nil) |
---|
587 | |
---|
588 | (deftest ccl.41334-8 |
---|
589 | (test-dup-warnings |
---|
590 | "(defun (setf test.41334-8) (val) val)" |
---|
591 | "(let ((closed nil)) |
---|
592 | (defun (setf test.41334-8) (val) val closed))") |
---|
593 | (:duplicate-definition)) |
---|
594 | |
---|
595 | (deftest ccl.49321 |
---|
596 | (test-dup-warnings |
---|
597 | "(defclass ccl.49321 () ((x :initarg :x))) |
---|
598 | (progn |
---|
599 | (print 'ccl.49321) |
---|
600 | (let ((go (defun make-ccl.49321 (&key x) (make-instance 'ccl.49321 :x x)))) |
---|
601 | go))") |
---|
602 | nil) |
---|
603 | |
---|
604 | #+not-yet |
---|
605 | (deftest ccl.bug#340 |
---|
606 | (labels ((fact (n) (if (zerop n) 1 (* n (fact (1- n)))))) |
---|
607 | (let ((res (format nil "~s" (log (fact 1000) 10.0d0)))) |
---|
608 | (or (string-equal "2567.60464" res :end2 10) res))) |
---|
609 | t) |
---|
610 | |
---|
611 | (deftest ccl.bug#344 |
---|
612 | (flet ((try (count) |
---|
613 | (let ((cname (gensym)) |
---|
614 | (gname (gensym))) |
---|
615 | (eval `(progn |
---|
616 | (defclass ,cname () ()) |
---|
617 | ,.(loop for n from 1 to count |
---|
618 | collect `(defmethod ,gname ((arg0 ,cname) (arg1 (eql ,n))))))) |
---|
619 | (handler-case (progn (funcall gname (make-instance cname) 1) nil) |
---|
620 | (error (c) :error))))) |
---|
621 | (list (try 46) (try 200))) |
---|
622 | (nil nil)) |
---|
623 | |
---|
624 | |
---|
625 | (deftest ccl.50130 |
---|
626 | ;; The compiler policy hack is just to have a predicatable way to catch the bug. |
---|
627 | ;; It doesn't have anything to do with causing the bug to happen. |
---|
628 | (let ((ccl::*default-file-compilation-policy* (ccl::new-compiler-policy :the-typechecks t)) |
---|
629 | (f (test-source-file "(defun cl-test::ccl.50130-fn (arr idx) |
---|
630 | (aref (the (or (vector fixnum) (vector (unsigned-byte 8))) arr) idx))"))) |
---|
631 | (test-compile f :load t) |
---|
632 | (funcall 'cl-test::ccl.50130-fn (make-array 4 :element-type 'fixnum :initial-element 17) 2)) |
---|
633 | 17) |
---|
634 | |
---|
635 | (deftest ccl.50646-bug#378 |
---|
636 | (progn |
---|
637 | (define-method-combination ccl.50646-method-combination () |
---|
638 | ((around (:around)) (primary ())) |
---|
639 | `(call-method ,(first around) ((make-method (call-method ,(first primary)))))) |
---|
640 | (defgeneric ccl.50646-gf (x) (:method-combination ccl.50646-method-combination)) |
---|
641 | (defmethod ccl.50646-gf ((x integer)) x) |
---|
642 | (defmethod ccl.50646-gf :around ((x integer)) (call-next-method x)) |
---|
643 | (ccl.50646-gf 23)) |
---|
644 | 23) |
---|
645 | |
---|
646 | (deftest ccl.50911 |
---|
647 | (progn |
---|
648 | (defclass ccl.50911-class () ((slot-a :initarg :a :reader ccl.50911-slot-a))) |
---|
649 | (ccl::%snap-reader-method #'ccl.50911-slot-a) |
---|
650 | (ccl:finalize-inheritance (find-class 'ccl.50911-class)) |
---|
651 | (ccl.50911-slot-a (make-instance 'ccl.50911-class :a :test))) |
---|
652 | :test) |
---|
653 | |
---|
654 | (deftest ccl.50911-a |
---|
655 | (let ((called 0)) |
---|
656 | (defclass ccl.50911-a () ()) |
---|
657 | (defun ccl.50911-a-fn () (make-instance 'ccl.50911-a)) |
---|
658 | (defmethod initialize-instance ((x ccl.50911-a) &rest keys) keys (incf called)) |
---|
659 | (ccl.50911-a-fn) |
---|
660 | (defmethod initialize-instance :after ((x ccl.50911-a) &rest keys) keys (incf called)) |
---|
661 | (ccl.50911-a-fn) |
---|
662 | (ccl::optimize-make-instance-for-class-name 'ccl.50911-a) |
---|
663 | (ccl.50911-a-fn) |
---|
664 | called) |
---|
665 | 5) |
---|
666 | |
---|
667 | |
---|
668 | (deftest ccl.bug-misc-init |
---|
669 | (progn |
---|
670 | (funcall (lambda () (make-array 1 :element-type '(signed-byte 16) :initial-element -1))) |
---|
671 | t) |
---|
672 | t) |
---|
673 | |
---|
674 | (deftest ccl.bug#382 |
---|
675 | (string= (with-output-to-string (s) |
---|
676 | (funcall #'(lambda () (write-string "foobar" s :end 2)))) |
---|
677 | "fo") |
---|
678 | t) |
---|
679 | |
---|
680 | (deftest ccl.52006 |
---|
681 | (progn |
---|
682 | (defclass ccl.52006-class () ((slot :initarg :slot)) (:default-initargs :slot nil)) |
---|
683 | (defun test-1 (args) (apply #'make-instance 'ccl.52006-class args)) |
---|
684 | (ccl::optimize-make-instance-for-class-name 'ccl.52006-class) |
---|
685 | (slot-value (test-1 nil) 'slot)) |
---|
686 | nil) |
---|
687 | |
---|
688 | |
---|
689 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
690 | ;;; ADVISE |
---|
691 | |
---|
692 | (defun function-to-advise (x) (car x)) |
---|
693 | (defun another-function-to-advise (x) (cdr x)) |
---|
694 | (defun (setf function-to-advise) (val arg) (setf (car arg) val)) |
---|
695 | |
---|
696 | (declaim (notinline function-to-advise |
---|
697 | another-function-to-advise |
---|
698 | (setf function-to-advise))) |
---|
699 | |
---|
700 | (defvar *advise-var* nil) |
---|
701 | |
---|
702 | |
---|
703 | (deftest advise.1 |
---|
704 | (progn |
---|
705 | (ccl:unadvise t) |
---|
706 | (function-to-advise '(a))) |
---|
707 | a) |
---|
708 | |
---|
709 | (deftest advise.2 |
---|
710 | (progn |
---|
711 | (ccl:unadvise t) |
---|
712 | (ccl:advise function-to-advise (return 'advise.2)) |
---|
713 | (function-to-advise '(b))) |
---|
714 | advise.2) |
---|
715 | |
---|
716 | (deftest advise.3 |
---|
717 | (progn |
---|
718 | (ccl:unadvise t) |
---|
719 | (ccl:advise function-to-advise 'advised.3 :when :around :name test) |
---|
720 | (assert (eq 'advised.3 (function-to-advise '(a)))) |
---|
721 | (prog1 (ccl:advisedp t) |
---|
722 | (ccl:unadvise t) |
---|
723 | (assert (null (ccl:advisedp t))))) |
---|
724 | ((function-to-advise :around test))) |
---|
725 | |
---|
726 | |
---|
727 | (deftest advise.4 |
---|
728 | (progn |
---|
729 | (ccl:unadvise t) |
---|
730 | (ccl:advise function-to-advise (return 'advise.4) :name test) |
---|
731 | (handler-bind ((warning #'muffle-warning)) |
---|
732 | (ccl:advise function-to-advise (return 'readvised) :name test)) |
---|
733 | (prog1 (ccl:advisedp t) |
---|
734 | (ccl:unadvise t) |
---|
735 | (assert (null (ccl:advisedp t))))) |
---|
736 | ((function-to-advise :before test))) |
---|
737 | |
---|
738 | (deftest advise.4a |
---|
739 | (progn |
---|
740 | (ccl:unadvise t) |
---|
741 | (setq *advise-var* '(none)) |
---|
742 | (ccl:advise function-to-advise (push 'advise.4a *advise-var*) :name test) |
---|
743 | (handler-bind ((warning #'muffle-warning)) |
---|
744 | (ccl:advise function-to-advise (push 'readvise.4a *advise-var*) :name test)) |
---|
745 | (assert (eq (function-to-advise '(c)) 'c)) |
---|
746 | *advise-var*) |
---|
747 | (readvise.4a none)) |
---|
748 | |
---|
749 | (deftest advise.5 |
---|
750 | (progn |
---|
751 | (ccl:unadvise t) |
---|
752 | (setq *advise-var* '(none)) |
---|
753 | (ccl:advise (setf function-to-advise) (push 'advise.5 *advise-var*)) |
---|
754 | (prog1 (ccl:advisedp t) |
---|
755 | (ccl:unadvise t) |
---|
756 | (assert (null (ccl:advisedp t))))) |
---|
757 | (((setf function-to-advise) :before nil))) |
---|
758 | |
---|
759 | (deftest advise.6 |
---|
760 | (progn |
---|
761 | (ccl:unadvise t) |
---|
762 | (setq *advise-var* '(none)) |
---|
763 | (ccl:advise (setf function-to-advise) (push 'advise.6 *advise-var*)) |
---|
764 | (handler-bind ((warning #'muffle-warning)) |
---|
765 | (ccl:advise (setf function-to-advise) (push 'readvise.6 *advise-var*))) |
---|
766 | (prog1 (ccl:advisedp t) |
---|
767 | (ccl:unadvise t) |
---|
768 | (assert (null (ccl:advisedp t))))) |
---|
769 | (((setf function-to-advise) :before nil))) |
---|
770 | |
---|
771 | (deftest advise.6a |
---|
772 | (progn |
---|
773 | (ccl:unadvise t) |
---|
774 | (setq *advise-var* '(none)) |
---|
775 | (ccl:advise (setf function-to-advise) (push 'advise.6a *advise-var*) :when :after) |
---|
776 | (handler-bind ((warning #'muffle-warning)) |
---|
777 | (ccl:advise (setf function-to-advise) (push 'readvise.6a *advise-var*) :when :after)) |
---|
778 | (let ((x (list nil))) |
---|
779 | (list* (setf (function-to-advise x) 17) |
---|
780 | (car x) |
---|
781 | *advise-var*))) |
---|
782 | (17 17 readvise.6a none)) |
---|
783 | |
---|
784 | (deftest advise.7 |
---|
785 | (progn |
---|
786 | (ccl:unadvise t) |
---|
787 | (setq *advise-var* '(none)) |
---|
788 | (let ((x (list nil))) |
---|
789 | (assert (eql (setf (function-to-advise x) 'a) 'a)) |
---|
790 | (assert (equal x '(a))) |
---|
791 | *advise-var*)) |
---|
792 | (none)) |
---|
793 | |
---|
794 | (deftest advise.8 |
---|
795 | (progn |
---|
796 | (ccl:unadvise t) |
---|
797 | (setq *advise-var* '(none)) |
---|
798 | (ccl:advise (setf function-to-advise) (push 'advise.8 *advise-var*)) |
---|
799 | (let ((x (list nil))) |
---|
800 | (assert (eql (setf (function-to-advise x) 'a) 'a)) |
---|
801 | (assert (equal x '(a))) |
---|
802 | *advise-var*)) |
---|
803 | (advise.8 none)) |
---|
804 | |
---|
805 | (deftest advise.9 |
---|
806 | (progn |
---|
807 | (ccl:unadvise t) |
---|
808 | (setq *advise-var* '(none)) |
---|
809 | (ccl:advise function-to-advise (push 'advise.9 *advise-var*)) |
---|
810 | (ccl:advise another-function-to-advise (push 'another-advise.9 *advise-var*)) |
---|
811 | (assert (eql (function-to-advise '(b)) 'b)) |
---|
812 | (assert (eql (another-function-to-advise '(c . d)) 'd)) |
---|
813 | (assert (equal *advise-var* '(another-advise.9 advise.9 none))) |
---|
814 | (prog1 |
---|
815 | (sort (copy-list (ccl:advisedp t)) |
---|
816 | #'(lambda (k1 k2) (string< (princ-to-string k1) |
---|
817 | (princ-to-string k2)))) |
---|
818 | (ccl:unadvise t))) |
---|
819 | ((another-function-to-advise :before nil) (function-to-advise :before nil))) |
---|
820 | |
---|
821 | (deftest advise.10 |
---|
822 | (progn |
---|
823 | (ccl:unadvise t) |
---|
824 | (setq *advise-var* '(none)) |
---|
825 | (assert (null (ccl:advisedp t))) |
---|
826 | (ccl:advise function-to-advise (push 'advise.10 *advise-var*)) |
---|
827 | (ccl:unadvise function-to-advise) |
---|
828 | (assert (null (ccl:advisedp t))) |
---|
829 | (handler-bind ((warning #'muffle-warning)) (ccl:unadvise function-to-advise)) |
---|
830 | (assert (null (ccl:advisedp t))) |
---|
831 | nil) |
---|
832 | nil) |
---|
833 | |
---|
834 | (deftest advise.11 |
---|
835 | (progn |
---|
836 | (ccl:unadvise t) |
---|
837 | (ccl:advise function-to-advise (return 17)) |
---|
838 | (ccl:advise another-function-to-advise (return 18)) |
---|
839 | (ccl:unadvise function-to-advise) |
---|
840 | (ccl:unadvise another-function-to-advise) |
---|
841 | (ccl:advisedp t)) |
---|
842 | nil) |
---|
843 | |
---|
844 | ;;; advising a generic function |
---|
845 | |
---|
846 | (declaim (notinline generic-function-to-advise)) |
---|
847 | |
---|
848 | (deftest advise.12 |
---|
849 | (progn |
---|
850 | (ccl:unadvise t) |
---|
851 | (setq *advise-var* '(none)) |
---|
852 | (eval '(defgeneric generic-function-to-advise (x y))) |
---|
853 | (ccl:advise generic-function-to-advise (push 'advise.12 *advise-var*)) |
---|
854 | (prog1 (ccl:advisedp t) (ccl:unadvise t))) |
---|
855 | ((generic-function-to-advise :before nil))) |
---|
856 | |
---|
857 | (deftest advise.13 |
---|
858 | (progn |
---|
859 | (ccl:unadvise t) |
---|
860 | (setq *advise-var* '(none)) |
---|
861 | (eval '(defgeneric generic-function-to-advise (x y))) |
---|
862 | (ccl:advise generic-function-to-advise (push 'advise.13 *advise-var*)) |
---|
863 | (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil)) |
---|
864 | (prog1 (ccl:advisedp t) (ccl:unadvise t))) |
---|
865 | ((generic-function-to-advise :before nil))) |
---|
866 | |
---|
867 | (deftest advise.14 |
---|
868 | (progn |
---|
869 | (ccl:unadvise t) |
---|
870 | (setq *advise-var* '(none)) |
---|
871 | (eval '(defgeneric generic-function-to-advise (x y))) |
---|
872 | (ccl:advise generic-function-to-advise (push 'advise.14 *advise-var*)) |
---|
873 | (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil)) |
---|
874 | (assert (null (generic-function-to-advise 'a 'b))) |
---|
875 | (assert (equal *advise-var* '(advise.14 none))) |
---|
876 | (prog1 |
---|
877 | (ccl:advisedp t) |
---|
878 | (ccl:unadvise generic-function-to-advise) |
---|
879 | (assert (null (ccl:advisedp t))))) |
---|
880 | ((generic-function-to-advise :before nil))) |
---|
881 | |
---|
882 | (declaim (notinline generic-function-to-advise2)) |
---|
883 | |
---|
884 | (deftest advise.15 |
---|
885 | (progn |
---|
886 | (ccl:unadvise t) |
---|
887 | (setq *advise-var* '(none)) |
---|
888 | (let* ((gf (eval '(defgeneric generic-function-to-advise2 (x y)))) |
---|
889 | (m (eval '(defmethod generic-function-to-advise2 |
---|
890 | ((x integer)(y integer)) |
---|
891 | :foo)))) |
---|
892 | (eval '(defmethod generic-function-to-advise2 |
---|
893 | ((x symbol)(y symbol)) :bar)) |
---|
894 | (assert (eql (generic-function-to-advise2 1 2) :foo)) |
---|
895 | (assert (eql (generic-function-to-advise2 'a 'b) :bar)) |
---|
896 | (ccl:advise generic-function-to-advise2 (push 'advise.15 *advise-var*)) |
---|
897 | (assert (equal (ccl:advisedp t) '((generic-function-to-advise2 :before nil)))) |
---|
898 | (remove-method gf m) |
---|
899 | (prog1 (ccl:advisedp t) (ccl:unadvise t)))) |
---|
900 | ((generic-function-to-advise2 :before nil))) |
---|
901 | |
---|
902 | |
---|
903 | (deftest advise.16 |
---|
904 | (progn |
---|
905 | (ccl:unadvise t) |
---|
906 | (setq *advise-var* '(none)) |
---|
907 | (ccl:advise function-to-advise (push 'advise.16-1 *advise-var*) :name test-1) |
---|
908 | (ccl:advise function-to-advise (push 'advise.16-2 *advise-var*) :name test-2) |
---|
909 | (prog1 (cons (function-to-advise '(foo)) *advise-var*) (ccl:unadvise t))) |
---|
910 | (foo advise.16-1 advise.16-2 none)) |
---|
911 | |
---|
912 | (deftest advise.17 |
---|
913 | (progn |
---|
914 | (ccl:unadvise t) |
---|
915 | (setq *advise-var* '(none)) |
---|
916 | (untrace) |
---|
917 | (ccl:advise function-to-advise (push 'advise.17-1 *advise-var*) :name test-1) |
---|
918 | (trace function-to-advise) |
---|
919 | (ccl:advise function-to-advise (push 'advise.17-2 *advise-var*) :name test-2) |
---|
920 | (prog1 |
---|
921 | (list (not (equal "" (with-output-to-string (*trace-output*) |
---|
922 | (function-to-advise '(foo))))) |
---|
923 | *advise-var* |
---|
924 | (ccl:unadvise function-to-advise :name test-1) |
---|
925 | (not (equal "" (with-output-to-string (*trace-output*) |
---|
926 | (function-to-advise '(bar))))) |
---|
927 | *advise-var* |
---|
928 | (untrace) |
---|
929 | (with-output-to-string (*trace-output*) |
---|
930 | (function-to-advise '(bar))) |
---|
931 | *advise-var*) |
---|
932 | (ccl:unadvise t) |
---|
933 | (untrace))) |
---|
934 | (t (advise.17-1 advise.17-2 none) ((function-to-advise :before test-1)) |
---|
935 | t (advise.17-2 advise.17-1 advise.17-2 none) (function-to-advise) "" |
---|
936 | (advise.17-2 advise.17-2 advise.17-1 advise.17-2 none))) |
---|
937 | |
---|
938 | |
---|
939 | (deftest advise.18 |
---|
940 | (progn |
---|
941 | (ccl:unadvise t) |
---|
942 | (setq *advise-var* '(none)) |
---|
943 | (untrace) |
---|
944 | (fmakunbound 'generic-function-to-advise.18) |
---|
945 | (eval '(defgeneric generic-function-to-advise.18 (x y))) |
---|
946 | (eval '(defmethod generic-function-to-advise.18 ((x integer)(y integer)) :foo)) |
---|
947 | (eval '(defmethod generic-function-to-advise.18 ((x symbol)(y symbol)) :bar)) |
---|
948 | (ccl:advise generic-function-to-advise.18 (push 'advise.18-1 *advise-var*) :name test-1) |
---|
949 | (trace generic-function-to-advise.18) |
---|
950 | (ccl:advise generic-function-to-advise.18 (push 'advise.18-2 *advise-var*) :name test-2) |
---|
951 | (prog1 |
---|
952 | (list (not (equal "" (with-output-to-string (*trace-output*) |
---|
953 | (assert (eq :bar (generic-function-to-advise.18 'a 'b)))))) |
---|
954 | *advise-var* |
---|
955 | (ccl:unadvise generic-function-to-advise.18 :name test-1) |
---|
956 | (not (equal "" (with-output-to-string (*trace-output*) |
---|
957 | (assert (eq :foo (generic-function-to-advise.18 1 2)))))) |
---|
958 | *advise-var* |
---|
959 | (untrace) |
---|
960 | (with-output-to-string (*trace-output*) |
---|
961 | (generic-function-to-advise.18 'x 'y)) |
---|
962 | *advise-var*) |
---|
963 | (ccl:unadvise t) |
---|
964 | (untrace))) |
---|
965 | (t (advise.18-1 advise.18-2 none) ((generic-function-to-advise.18 :before test-1)) |
---|
966 | t (advise.18-2 advise.18-1 advise.18-2 none) (generic-function-to-advise.18) "" |
---|
967 | (advise.18-2 advise.18-2 advise.18-1 advise.18-2 none))) |
---|
968 | |
---|
969 | |
---|