source: trunk/tests/ansi-tests/ccl.lsp @ 9865

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

Test for bug #315

File size: 22.1 KB
Line 
1;;;-*-Mode: LISP; Package: CL-TEST -*-
2;;;
3;;;   Copyright (C) 2008 Clozure Associates
4
5(in-package :cl-test)
6
7(defun test-source-file (format-string &rest format-args)
8  (let ((file "temp.dat"))
9    (with-open-file (s file :direction :output :if-exists :supersede)
10      (apply #'format s format-string format-args)
11      (terpri s)
12      (truename s))))
13
14(defun test-compile (lambda-or-file &rest args &key hide-warnings (safety 1) &allow-other-keys)
15  ;; Compile in a more-or-less standard environment
16  (let ((*error-output* (if hide-warnings (make-broadcast-stream) *error-output*))
17        (ccl::*nx-speed* 1)
18        (ccl::*nx-space* 1)
19        (ccl::*nx-safety* safety)
20        (ccl::*nx-cspeed* 1)
21        (ccl::*nx-debug* 1))
22    (remf args :hide-warnings)
23    (remf args :safety)
24    (if (consp lambda-or-file)
25      (apply #'compile nil lambda-or-file args)
26      (apply #'compile-file lambda-or-file args))))
27
28;;; CCL-specific regression tests, for CCL-specific behavior.
29
30(deftest ccl.40199  ;; fixed in r9116 and r9121
31    (when (equalp (let ((*print-pretty* t))
32                    (format nil "~a" (make-array nil :initial-element 0)))
33                  "#0A0")
34      :good)
35  :good)
36
37(deftest ccl.40492 ;; fixed in r9134 and r9131
38    (let (obj (slot (gensym)))
39      (eval `(defclass ccl.40492 ()
40               ((,slot :accessor ,slot :initform :good))))
41      (setq obj (make-instance 'ccl.40492))
42      (ccl::%snap-reader-method (symbol-function slot))
43      (unwind-protect
44           (let ((*trace-output* (make-broadcast-stream))) ;; don't care about trace output
45             (ccl:trace-function slot)
46             (funcall slot obj))
47        (eval `(untrace ,slot))))
48  :good)
49
50(deftest ccl.40207  ;; fixed in r9163 and r9165
51  (progn
52    (fmakunbound 'cl-test::ccl.40207-fn)
53    ;; Check that these compile-time errors don't abort compilation.
54    (let* ((test (test-source-file "(defun cl-test::ccl.40207-fn ()
55                                     (and (typep (lambda (x) (setq x)) 'function)
56                                          (typep (lambda (x) (setf x)) 'function)
57                                          (typep (lambda (((foo))) foo) 'function)
58                                          :good))")))
59      (test-compile test :hide-warnings t :break-on-program-errors nil :load t)
60      (funcall 'cl-test::ccl.40207-fn)))
61  :good)
62
63(deftest ccl.40927  ;; fixed in r9183 and r9184
64    (let ((s (make-string-output-stream))
65          (line1 "Line1
66")
67          (line2 "Line2"))
68      (count #\Newline (format nil "~a~&~a" line1 line2)))
69  1)
70
71(defstruct ccl.40055 (a 0 :type integer))
72
73(deftest ccl.40055 ;; fixed in r9237 and r9240
74    (locally
75        (declare (optimize (safety 3)))
76      (and (signals-error (make-ccl.40055 :a nil) type-error)
77           (signals-error (setf (ccl.40055-a (make-ccl.40055)) nil) type-error)))
78  t)
79
80
81(deftest ccl.bug#235
82    (handler-case
83        (test-compile `(lambda (x)
84                         (make-array x :element-type ',(gensym))))
85      (warning (c)
86        (when (typep c 'ccl::compiler-warning)
87          (ccl::compiler-warning-warning-type c))))
88  :unknown-type-declaration)
89
90
91(defclass ccl.bug#285 () ())
92
93(defmethod initialize-instance ((c ccl.bug#285) &rest args)
94  (declare (optimize (safety 3)))
95  (apply #'call-next-method c args))
96
97(deftest ccl.bug#285
98    (typep (make-instance 'ccl.bug#285) 'ccl.bug#285)
99  t)
100
101(deftest ccl.bug#286
102    (and (test-compile '(lambda ()
103                         (typep nil '(or ccl.bug#286-unknown-type-1 null)))
104                       :hide-warnings t)
105         (test-compile '(lambda ()
106                         (ccl:require-type nil '(or ccl.bug#286-unknown-type-2 null)))
107                       :hide-warnings t)
108         :no-crash)
109  :no-crash)
110
111
112(deftest ccl.bug#287
113    (progn
114      (defmethod ccl.bug#287 (x) x)
115      (trace ccl.bug#287)
116      (let ((*trace-output* (make-broadcast-stream))) ;; don't care about trace output
117        (prog1
118            (ccl.bug#287 :no-crash)
119          (untrace))))
120  :no-crash)
121
122
123(deftest ccl.41226
124    (let ((file (test-source-file "(defmacro ccl.41226 (x) (eq (caar x)))")))
125      (handler-case
126          (test-compile file :hide-warnings t :break-on-program-errors nil)
127        ;; Might still signal due to macros being implicitly eval-when compile.
128        ;; Ok so long as it's not the make-load-form error (which is not a program-error).
129        (program-error () nil))
130      :no-crash)
131  :no-crash)
132
133(deftest ccl.bug#288
134    (let ((file (test-source-file "(prog1 (declare (ignore foo)))")))
135      (test-compile file :hide-warnings t :break-on-program-errors nil)
136      :no-crash)
137  :no-crash)
138
139(deftest ccl.bug#288-1 ;; follow-on bug, not really the same
140    (let ((file (test-source-file "(defun cl-test::ccl.bug#288-1-fn ((x integer)) x)")))
141      (test-compile file :hide-warnings t :break-on-program-errors nil :load t)
142      (handler-case
143          (progn (ccl.bug#288-1-fn 17) :no-warnings)
144        (program-error (c) (if (search "(X INTEGER)" (princ-to-string c)) :lambda-list-error c))))
145  :lambda-list-error)
146
147(deftest ccl.40055-1
148    (let ((file (test-source-file "
149
150 (defclass ccl.40055-1-class () ())
151 (eval-when (eval compile load)
152  (defstruct ccl.40055-1-struct (slot nil :type (or ccl.40055-1-class null))))
153 (defun ccl.40055-1-fn ()
154   (make-array 0 :element-type 'ccl.40055-1-struct))
155 ")))
156      (handler-case
157          (progn (test-compile file) :no-warnings)
158        (warning (c) (format nil "~a" c))))
159  :no-warnings)
160
161(deftest ccl.40055-2
162    (let ((file (test-source-file "
163
164 (defclass ccl.40055-2-class () ())
165 (defstruct ccl.40055-2-struct (slot nil :type (or ccl.40055-2-class null)))
166 (defun ccl.40055-2-class-arr ()
167   (make-array 0 :element-type 'ccl.40055-2-class))
168 (defun ccl.40055-2-struct-arr ()
169   (make-array 0 :element-type 'ccl.40055-2-struct))
170 (defun ccl.40055-2-struct-arr-2 ()
171   (make-array 0 :element-type '(or (member 17 32) ccl.40055-2-struct)))
172 (defun ccl.40055-2-fn (x) (setf (ccl.40055-2-struct-slot x) nil))
173 ")))
174      (handler-case
175          (progn (test-compile file :break-on-program-errors nil) :no-warnings)
176        (warning (c) c)))
177  :no-warnings)
178
179
180(deftest ccl.40055-3
181    (let ((file (test-source-file "
182 (defclass ccl.40055-3-class () ())
183 (defun ccl.40055-3-cfn () (require-type nil '(or ccl.40055-3-class null)))
184 (defstruct ccl.40055-3-struct () ())
185 (defun ccl.40055-3-rfn () (require-type nil '(or ccl.40055-3-struct null)))")))
186      (handler-case
187          (progn (test-compile file :break-on-program-errors nil) :no-warnings)
188        (warning (c) c)))
189  :no-warnings)
190
191(deftest ccl.bug#289
192    (let ((file (test-source-file "
193 (defclass ccl.bug#289-meta (standard-class) ())
194 (defclass ccl.bug#289-class () () (:metaclass ccl.bug#289-meta))")))
195      (test-compile file)
196      :no-crash)
197  :no-crash)
198
199(deftest ccl.bug#295
200    (let ((file (test-source-file "
201  (defun outer-fun ()
202     (defun inner-fun () nil)
203     (inner-fun))")))
204      (handler-case (progn (test-compile file :safety 3) :no-warnings)
205        (warning (c) c)))
206  :no-warnings)
207
208
209(deftest ccl.41836  ;; fixed in r9391
210    (let ((file (test-source-file "
211  (defvar *a* 1)
212  (defvar *b* (load-time-value *a*))")))
213      (handler-case (progn (test-compile file :break-on-program-errors nil) :no-warnings)
214        (warning (c) c)))
215  :no-warnings)
216
217
218(deftest ccl.42698  ;; fixed in r9589/r9590
219    (handler-case (schar "abc" -1) ;; used to crash hard
220      (error () :error))
221  :error)
222
223(deftest ccl.42232-1
224    (let ((file (test-source-file "
225  (defun ccl.42232-1 (foo)
226    (declare (ignore foo))
227    foo)")))
228      (handler-case (progn (test-compile file) :no-warnings)
229        (warning (c) :warning)))
230  :warning)
231
232(deftest ccl.42232-2
233    (let ((file (test-source-file "
234  (defun ccl.42232-2 ()
235    (declare (ignore bar)))")))
236      (handler-case (progn (test-compile file :break-on-program-errors nil) :no-warnings)
237        (warning (c) :warning)))
238  :warning)
239
240(deftest ccl.42830
241    (let ((*standard-output* (make-broadcast-stream)))
242      (defun cl-user::ccl.42830 (stream int colon-p at-sign-p)
243        (declare (ignore at-sign-p colon-p))
244        (check-type int integer)
245        (write int :stream stream))
246      (defun test-ccl.42830 (a b stream)
247        (format stream "~A ~/ccl.42830/" a b))
248      (and (eq (test-ccl.42830 "a" 1 t) nil)
249           (string-equal (test-ccl.42830 "a" 1 nil) "a 1")
250           :no-errors))
251  :no-errors)
252
253
254(deftest ccl.bug#305
255    (let* ((file (test-source-file "
256  (in-package :cl-test)
257  (defclass ccl.bug#305-inner () ((ccl.bug#305-inner-slot :accessor ccl.bug#305-inner-slot)))
258  (macrolet ((generator ()
259               `(defclass ccl.bug#305 (ccl.bug#305-inner)
260                  ,(loop for i from 0 to 600
261                         for slot = (intern (format nil \"CCL.BUG#305-SLOT-~~A\" i) :cl-user)
262                         collect `(,slot :initform ,i)))))
263    (generator))
264  (defmethod initialize-instance :after ((x ccl.bug#305-inner) &key)
265    (setf (ccl.bug#305-inner-slot x) 42))
266  (defun ccl.bug#305-test () (make-instance 'ccl.bug#305))"))
267           (fasl (test-compile file)))
268      (load fasl :verbose nil)
269      (ccl.bug#305-inner-slot (ccl.bug#305-test)))
270  42)
271
272(deftest ccl.42923
273    (progn
274      (fmakunbound 'ccl.42923)
275      (defmethod ccl.42923 ((x (eql 'x)) &key y &allow-other-keys)
276        (list x y) 'x)
277      (defmethod ccl.42923 ((x (eql 'foo)) &key y &allow-other-keys)
278        (list x y) 'foo)
279      (defmethod ccl.42923 ((x (eql 'bar)) &key y z a b c)
280        (list x y z (list a b c)) 'bar)
281      (ccl::maybe-hack-eql-methods #'ccl.42923)
282      (ccl:advise ccl.42923 'advise)
283      (ccl.42923 'foo :y 1 :z 2 :a 1 :b 2 :c 3))
284  foo)
285
286(deftest ccl.bug#294-1
287  (handler-case
288      (let ((ccl::*nx-safety* 1)) ;; At safety 3, we don't know from EQ...
289        (eval '(defun cl-test::ccl.bug#294-1 (x y)
290                (eq x) y)))
291    (program-error () :program-error))
292  :program-error)
293
294(deftest ccl.bug#294-2
295  (let* ((file (test-source-file
296                "(defun cl-test::ccl.bug#294-2 (x y) (eq x) y)")))
297    (fmakunbound ' cl-test::ccl.bug#294-2)
298    (handler-case (test-compile file :break-on-program-errors t)
299      (program-error () :program-error)))
300  :program-error)
301
302(deftest ccl.buf#294-3
303  (let* ((file (test-source-file
304                "(defun cl-test::ccl.bug#294-3 (x y) (eq x) y)"))
305         (warnings nil))
306    (fmakunbound ' cl-test::ccl.bug#294-3)
307    (list
308     (let ((*error-output* (make-broadcast-stream)))
309       (handler-case
310           (handler-bind ((warning (lambda (c) (setq warnings t))))
311             (test-compile file :break-on-program-errors :defer))
312         (error (c) :error)))
313     warnings))
314  (:error t))
315
316
317(deftest ccl.buf#294-4
318  (let* ((file (test-source-file
319                "(defun cl-test::ccl.bug#294-4 (x y) (eq x) y)"))
320         (warnings nil))
321    (fmakunbound 'cl-test::ccl.bug#294-4)
322    (list
323     (let ((*error-output* (make-broadcast-stream)))
324       (handler-bind ((warning (lambda (c) (setq warnings t))))
325         (test-compile file :break-on-program-errors nil :load t))
326       (handler-case (and (fboundp 'cl-test::ccl.bug#294-4)
327                          (funcall 'cl-test::ccl.bug#294-4 1 2))
328         (program-error (c) :program-error)))
329     warnings))
330  (:program-error t))
331
332(deftest ccl.bug#315
333    (let* ((file (test-source-file
334                  "(defmethod ccl.bug#315-fn ((a sequence))
335                       (reduce #'or a :key #'identity))"))
336           (warning nil))
337      (handler-bind ((warning
338                      (lambda (c)
339                        (let ((s (princ-to-string c)))
340                          (setq warning
341                                (if (and (search "FUNCTION" s) (search "macro OR" s))
342                                  (or warning :macro-or)
343                                  c))))))
344        (test-compile file :hide-warnings t :break-on-program-errors nil :load t))
345      warning)
346  :macro-or)
347
348(deftest ccl.43101a
349    (progn
350      (untrace)
351      (fmakunbound 'ccl.43101a-fun)
352      (defun ccl.43101a-fun (x) x)
353      (trace ccl.43101a-fun)
354      (let ((file (test-source-file "(defun cl-test::ccl.43101a-fun (x) (1+ x))")))
355        (test-compile file :hide-warnings t :load t))
356      (not (equal "" (with-output-to-string (*trace-output*)
357                       (assert (eql (ccl.43101a-fun 4) 5))))))
358  t)
359
360(deftest ccl.43101b
361    (progn
362      (untrace)
363      (fmakunbound 'ccl.43101b-gf)
364      (defmethod ccl.43101b-gf (x) x)
365      (trace ccl.43101b-gf)
366      (let ((file (test-source-file "(defmethod cl-test::ccl.43101b-gf (x) (1+ x))")))
367        (test-compile file :hide-warnings t :load t))
368      (not (equal "" (with-output-to-string (*trace-output*)
369                       (assert (eql (ccl.43101b-gf 4) 5))))))
370  t)
371
372
373
374;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
375;;; ADVISE
376
377(defun function-to-advise (x) (car x))
378(defun another-function-to-advise (x) (cdr x))
379(defun (setf function-to-advise) (val arg) (setf (car arg) val))
380
381(declaim (notinline function-to-advise
382                    another-function-to-advise
383                    (setf function-to-advise)))
384
385(defvar *advise-var* nil)
386
387
388(deftest advise.1
389  (progn
390    (ccl:unadvise t)
391    (function-to-advise '(a)))
392  a)
393
394(deftest advise.2
395  (progn
396    (ccl:unadvise t)
397    (ccl:advise function-to-advise (return 'advise.2))
398    (function-to-advise '(b)))
399  advise.2)
400
401(deftest advise.3
402  (progn
403    (ccl:unadvise t)
404    (ccl:advise function-to-advise 'advised.3 :when :around :name test)
405    (assert (eq 'advised.3 (function-to-advise '(a))))
406    (prog1 (ccl:advisedp t)
407      (ccl:unadvise t)
408      (assert (null (ccl:advisedp t)))))
409  ((function-to-advise :around test)))
410
411
412(deftest advise.4
413  (progn
414    (ccl:unadvise t)
415    (ccl:advise function-to-advise (return 'advise.4) :name test)
416    (handler-bind ((warning #'muffle-warning))
417      (ccl:advise function-to-advise (return 'readvised) :name test))
418    (prog1 (ccl:advisedp t)
419      (ccl:unadvise t)
420      (assert (null (ccl:advisedp t)))))
421  ((function-to-advise :before test)))
422
423(deftest advise.4a
424  (progn
425    (ccl:unadvise t)
426    (setq *advise-var* '(none))
427    (ccl:advise function-to-advise (push 'advise.4a *advise-var*) :name test)
428    (handler-bind ((warning #'muffle-warning))
429      (ccl:advise function-to-advise (push 'readvise.4a *advise-var*) :name test))
430    (assert (eq (function-to-advise '(c)) 'c))
431    *advise-var*)
432  (readvise.4a none))
433
434(deftest advise.5
435  (progn
436    (ccl:unadvise t)
437    (setq *advise-var* '(none))
438    (ccl:advise (setf function-to-advise) (push 'advise.5 *advise-var*))
439    (prog1 (ccl:advisedp t)
440      (ccl:unadvise t)
441      (assert (null (ccl:advisedp t)))))
442  (((setf function-to-advise) :before nil)))
443
444(deftest advise.6
445  (progn
446    (ccl:unadvise t)
447    (setq *advise-var* '(none))
448    (ccl:advise (setf function-to-advise) (push 'advise.6 *advise-var*))
449    (handler-bind ((warning #'muffle-warning))
450      (ccl:advise (setf function-to-advise) (push 'readvise.6 *advise-var*)))
451    (prog1 (ccl:advisedp t)
452      (ccl:unadvise t)
453      (assert (null (ccl:advisedp t)))))
454  (((setf function-to-advise) :before nil)))
455
456(deftest advise.6a
457  (progn
458    (ccl:unadvise t)
459    (setq *advise-var* '(none))
460    (ccl:advise (setf function-to-advise) (push 'advise.6a *advise-var*) :when :after)
461    (handler-bind ((warning #'muffle-warning))
462      (ccl:advise (setf function-to-advise) (push 'readvise.6a *advise-var*) :when :after))
463    (let ((x (list nil)))
464      (list* (setf (function-to-advise x) 17)
465             (car x)
466             *advise-var*)))
467  (17 17 readvise.6a none))
468
469(deftest advise.7
470  (progn
471    (ccl:unadvise t)
472    (setq *advise-var* '(none))
473    (let ((x (list nil)))
474      (assert (eql (setf (function-to-advise x) 'a) 'a))
475      (assert (equal x '(a)))
476      *advise-var*))
477  (none))
478
479(deftest advise.8
480  (progn
481    (ccl:unadvise t)
482    (setq *advise-var* '(none))
483    (ccl:advise (setf function-to-advise) (push 'advise.8 *advise-var*))
484    (let ((x (list nil)))
485      (assert (eql (setf (function-to-advise x) 'a) 'a))
486      (assert (equal x '(a)))
487      *advise-var*))
488  (advise.8 none))
489
490(deftest advise.9
491  (progn
492    (ccl:unadvise t)
493    (setq *advise-var* '(none))
494    (ccl:advise function-to-advise (push 'advise.9 *advise-var*))
495    (ccl:advise another-function-to-advise (push 'another-advise.9 *advise-var*))
496    (assert (eql (function-to-advise '(b)) 'b))
497    (assert (eql (another-function-to-advise '(c . d)) 'd))
498    (assert (equal *advise-var* '(another-advise.9 advise.9 none)))
499    (prog1
500        (sort (copy-list (ccl:advisedp t))
501              #'(lambda (k1 k2) (string< (princ-to-string k1)
502                                         (princ-to-string k2))))
503      (ccl:unadvise t)))
504  ((another-function-to-advise :before nil) (function-to-advise :before nil)))
505
506(deftest advise.10
507  (progn
508    (ccl:unadvise t)
509    (setq *advise-var* '(none))
510    (assert (null (ccl:advisedp t)))
511    (ccl:advise function-to-advise (push 'advise.10 *advise-var*))
512    (ccl:unadvise function-to-advise)
513    (assert (null (ccl:advisedp t)))
514    (handler-bind ((warning #'muffle-warning)) (ccl:unadvise function-to-advise))
515    (assert (null (ccl:advisedp t)))
516    nil)
517  nil)
518
519(deftest advise.11
520  (progn
521    (ccl:unadvise t)
522    (ccl:advise function-to-advise  (return 17))
523    (ccl:advise another-function-to-advise (return 18))
524    (ccl:unadvise function-to-advise)
525    (ccl:unadvise another-function-to-advise)
526    (ccl:advisedp t))
527  nil)
528
529;;; advising a generic function
530
531(declaim (notinline generic-function-to-advise))
532
533(deftest advise.12
534  (progn
535    (ccl:unadvise t)
536    (setq *advise-var* '(none))
537    (eval '(defgeneric generic-function-to-advise (x y)))
538    (ccl:advise generic-function-to-advise (push 'advise.12 *advise-var*))
539    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
540  ((generic-function-to-advise :before nil)))
541
542(deftest advise.13
543  (progn
544    (ccl:unadvise t)
545    (setq *advise-var* '(none))
546    (eval '(defgeneric generic-function-to-advise (x y)))
547    (ccl:advise generic-function-to-advise (push 'advise.13 *advise-var*))
548    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
549    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
550  ((generic-function-to-advise :before nil)))
551
552(deftest advise.14
553  (progn
554    (ccl:unadvise t)
555    (setq *advise-var* '(none))
556    (eval '(defgeneric generic-function-to-advise (x y)))
557    (ccl:advise generic-function-to-advise (push 'advise.14 *advise-var*))
558    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
559    (assert (null (generic-function-to-advise 'a 'b)))
560    (assert (equal *advise-var* '(advise.14 none)))
561    (prog1
562        (ccl:advisedp t)
563      (ccl:unadvise generic-function-to-advise)
564      (assert (null (ccl:advisedp t)))))
565  ((generic-function-to-advise :before nil)))
566
567(declaim (notinline generic-function-to-advise2))
568
569(deftest advise.15
570  (progn
571    (ccl:unadvise t)
572    (setq *advise-var* '(none))
573    (let* ((gf (eval '(defgeneric generic-function-to-advise2 (x y))))
574           (m (eval '(defmethod generic-function-to-advise2
575                       ((x integer)(y integer))
576                       :foo))))
577      (eval '(defmethod generic-function-to-advise2
578               ((x symbol)(y symbol)) :bar))
579      (assert (eql (generic-function-to-advise2 1 2) :foo))
580      (assert (eql (generic-function-to-advise2 'a 'b) :bar))
581      (ccl:advise generic-function-to-advise2 (push 'advise.15 *advise-var*))
582      (assert (equal (ccl:advisedp t) '((generic-function-to-advise2 :before nil))))
583      (remove-method gf m)
584      (prog1 (ccl:advisedp t) (ccl:unadvise t))))
585  ((generic-function-to-advise2 :before nil)))
586
587
588(deftest advise.16
589  (progn
590    (ccl:unadvise t)
591    (setq *advise-var* '(none))
592    (ccl:advise function-to-advise (push 'advise.16-1 *advise-var*) :name test-1)
593    (ccl:advise function-to-advise (push 'advise.16-2 *advise-var*) :name test-2)
594    (prog1 (cons (function-to-advise '(foo)) *advise-var*) (ccl:unadvise t)))
595  (foo advise.16-1 advise.16-2 none))
596
597(deftest advise.17
598  (progn
599    (ccl:unadvise t)
600    (setq *advise-var* '(none))
601    (untrace)
602    (ccl:advise function-to-advise (push 'advise.17-1 *advise-var*) :name test-1)
603    (trace function-to-advise)
604    (ccl:advise function-to-advise (push 'advise.17-2 *advise-var*) :name test-2)
605    (prog1
606        (list (not (equal "" (with-output-to-string (*trace-output*)
607                               (function-to-advise '(foo)))))
608              *advise-var*
609              (ccl:unadvise function-to-advise :name test-1)
610              (not (equal "" (with-output-to-string (*trace-output*)
611                               (function-to-advise '(bar)))))
612              *advise-var*
613              (untrace)
614              (with-output-to-string (*trace-output*)
615                (function-to-advise '(bar)))
616              *advise-var*)
617      (ccl:unadvise t)
618      (untrace)))
619  (t (advise.17-1 advise.17-2 none) ((function-to-advise :before test-1))
620     t (advise.17-2 advise.17-1 advise.17-2 none) (function-to-advise) ""
621     (advise.17-2 advise.17-2 advise.17-1 advise.17-2 none)))
622
623
624(deftest advise.18
625  (progn
626    (ccl:unadvise t)
627    (setq *advise-var* '(none))
628    (untrace)
629    (fmakunbound 'generic-function-to-advise.18)
630    (eval '(defgeneric generic-function-to-advise.18 (x y)))
631    (eval '(defmethod generic-function-to-advise.18 ((x integer)(y integer)) :foo))
632    (eval '(defmethod generic-function-to-advise.18 ((x symbol)(y symbol)) :bar))
633    (ccl:advise generic-function-to-advise.18 (push 'advise.18-1 *advise-var*) :name test-1)
634    (trace generic-function-to-advise.18)
635    (ccl:advise generic-function-to-advise.18 (push 'advise.18-2 *advise-var*) :name test-2)
636    (prog1
637        (list (not (equal "" (with-output-to-string (*trace-output*)
638                               (assert (eq :bar (generic-function-to-advise.18 'a 'b))))))
639              *advise-var*
640              (ccl:unadvise generic-function-to-advise.18 :name test-1)
641              (not (equal "" (with-output-to-string (*trace-output*)
642                               (assert (eq :foo (generic-function-to-advise.18 1 2))))))
643              *advise-var*
644              (untrace)
645              (with-output-to-string (*trace-output*)
646                (generic-function-to-advise.18 'x 'y))
647              *advise-var*)
648      (ccl:unadvise t)
649      (untrace)))
650  (t (advise.18-1 advise.18-2 none) ((generic-function-to-advise.18 :before test-1))
651     t (advise.18-2 advise.18-1 advise.18-2 none) (generic-function-to-advise.18) ""
652     (advise.18-2 advise.18-2 advise.18-1 advise.18-2 none)))
653
654
Note: See TracBrowser for help on using the repository browser.