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

Last change on this file since 10997 was 10997, checked in by gz, 11 years ago

couple more dup definition tests

File size: 27.9 KB
Line 
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      (delete-file pn)
291      (let ((stream (open pn :direction :output :if-exists :error)))
292        (print "something" stream)
293        (close stream :abort t)
294        (probe-file pn)))
295  nil)
296
297(deftest ccl.bug#252b
298    (let ((pn "bug252.dat"))
299      (delete-file pn)
300      (let ((stream (open pn :direction :output)))
301        (format stream "something~%")
302        (close stream))
303      (let ((stream (open pn :direction :output :if-exists :supersede)))
304        (format stream "other~%")
305        (force-output stream)
306        (close stream :abort t))
307      (with-open-file (stream pn)
308        (let ((line  (read-line stream)))
309          (if (equalp line "something") :something line))))
310  :something)
311
312(deftest ccl.bug#310
313    (remove-duplicates '(1 0 1 1 1 0 0 0 1 0 1 0 1) :end 11)
314  (0 1 0 1))
315
316(deftest ccl.bug#294-1
317  (handler-case
318      (let ((ccl::*nx-safety* 1)) ;; At safety 3, we don't know from EQ...
319        (eval '(defun cl-test::ccl.bug#294-1 (x y)
320                (eq x) y)))
321    (program-error () :program-error))
322  :program-error)
323
324(deftest ccl.bug#294-2
325  (let* ((file (test-source-file
326                "(defun cl-test::ccl.bug#294-2 (x y) (eq x) y)")))
327    (fmakunbound ' cl-test::ccl.bug#294-2)
328    (handler-case (test-compile file :break-on-program-errors t)
329      (program-error () :program-error)))
330  :program-error)
331
332(deftest ccl.buf#294-3
333  (let* ((file (test-source-file
334                "(defun cl-test::ccl.bug#294-3 (x y) (eq x) y)"))
335         (warnings nil))
336    (fmakunbound ' cl-test::ccl.bug#294-3)
337    (list
338     (let ((*error-output* (make-broadcast-stream)))
339       (handler-case
340           (handler-bind ((warning (lambda (c) (setq warnings t))))
341             (test-compile file :break-on-program-errors :defer))
342         (error (c) :error)))
343     warnings))
344  (:error t))
345
346
347(deftest ccl.buf#294-4
348  (let* ((file (test-source-file
349                "(defun cl-test::ccl.bug#294-4 (x y) (eq x) y)"))
350         (warnings nil))
351    (fmakunbound 'cl-test::ccl.bug#294-4)
352    (list
353     (let ((*error-output* (make-broadcast-stream)))
354       (handler-bind ((warning (lambda (c) (setq warnings t))))
355         (test-compile file :break-on-program-errors nil :load t))
356       (handler-case (and (fboundp 'cl-test::ccl.bug#294-4)
357                          (funcall 'cl-test::ccl.bug#294-4 1 2))
358         (program-error (c) :program-error)))
359     warnings))
360  (:program-error t))
361
362(deftest ccl.bug#315
363    (let* ((file (test-source-file
364                  "(defmethod ccl.bug#315-fn ((a sequence))
365                       (reduce #'or a :key #'identity))"))
366           (warning nil))
367      (handler-bind ((warning
368                      (lambda (c)
369                        (let ((s (princ-to-string c)))
370                          (setq warning
371                                (if (and (search "FUNCTION" s) (search "macro OR" s))
372                                  (or warning :macro-or)
373                                  c))))))
374        (test-compile file :hide-warnings t :break-on-program-errors nil :load t))
375      warning)
376  :macro-or)
377
378(deftest ccl.43101a
379    (progn
380      (untrace)
381      (fmakunbound 'ccl.43101a-fun)
382      (defun ccl.43101a-fun (x) x)
383      (trace ccl.43101a-fun)
384      (let ((file (test-source-file "(defun cl-test::ccl.43101a-fun (x) (1+ x))")))
385        (test-compile file :hide-warnings t :load t))
386      (not (equal "" (with-output-to-string (*trace-output*)
387                       (assert (eql (ccl.43101a-fun 4) 5))))))
388  t)
389
390(deftest ccl.43101b
391    (progn
392      (untrace)
393      (fmakunbound 'ccl.43101b-gf)
394      (defmethod ccl.43101b-gf (x) x)
395      (trace ccl.43101b-gf)
396      (let ((file (test-source-file "(defmethod cl-test::ccl.43101b-gf (x) (1+ x))")))
397        (test-compile file :hide-warnings t :load t))
398      (not (equal "" (with-output-to-string (*trace-output*)
399                       (assert (eql (ccl.43101b-gf 4) 5))))))
400  t)
401
402
403
404(deftest ccl.file-stream-typep
405    (with-open-file (f "temp.dat" :direction :output :if-exists :supersede)
406      (funcall (lambda (f) (let ((type (type-of f)))
407                             (and (typep f 'file-stream) (subtypep type 'file-stream) t)))
408               f))
409  t)
410
411
412(deftest ccl.complex-cos
413    (< (imagpart (cos (complex 1 1))) 0)
414  t)
415
416(deftest ccl.space-symbol
417    (let* ((list '(|aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa|
418                   | | | | | | | | | | | | | | | | | | | | | |
419                   |aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa|))
420           (result (read-from-string
421                    (with-output-to-string (s)
422                      (let ((*print-readably* t))
423                        (pprint list s))))))
424      (or (equal list result) result))
425  t)
426
427(deftest ccl.46016
428    (let ((file (test-source-file "
429  (defvar var.46016 nil)
430  (declaim (boolean var.46016))")))
431      (handler-case (progn (test-compile file :load t :break-on-program-errors nil) :no-warnings)
432        (warning (c) :warning)))
433  :no-warnings)
434
435
436#+ccl-0711
437(deftest ccl.47102
438    (handler-case
439        (progn
440          (defclass ccl.47102 () ((slot :allocation :class)))
441          ;; This happens as part of snap-reader-methods optimization
442          (ccl::optimize-make-instance-for-class-cell (gethash 'ccl.47102 ccl::%find-classes%))
443          :no-warnings)
444      (warning (c) :warning))
445  :no-warnings)
446 
447
448(deftest ccl.47762
449    (let ((file (test-source-file
450                  "(defun ccl.47762 ()
451                     (funcall (find-symbol \"TEST.47762a\" \"NO_SUCH_PACKAGE\"))
452                     (funcall (intern \"TEST.47762b\" \"NO_SUCH_PACKAGE-1\")))")))
453      (handler-case
454          (progn (test-compile file :load t) :no-error)
455        (error (c) c)))
456  :no-error)
457
458
459(defun test-dup-warnings (test1 &optional test2)
460  (let ((warnings nil))
461    (handler-bind ((warning (lambda (c)
462                              (let ((msg (format nil "~a" c)))
463                                (push (if (search "Duplicate" msg :test #'equalp)
464                                        :duplicate-definition
465                                        c) warnings)
466                                (muffle-warning c)))))
467      (if test2
468        (with-compilation-unit ()
469          (test-compile (test-source-file test1) :hide-warnings t)
470          (test-compile (test-source-file test2) :hide-warnings t))
471        (test-compile (test-source-file test1 :hide-warnings t))))
472    warnings))
473
474
475
476(deftest ccl.41334-1
477    (test-dup-warnings
478     "(defun test.ccl-41334-1 (x) x)
479      (defun test.ccl-41334-1 (x) x)")
480  (:duplicate-definition))
481
482
483(deftest ccl.41334-2
484    (test-dup-warnings
485     "(defmethod test.ccl-41334-2 ((x stream)) x)
486      (defmethod test.ccl-41334-2 ((x stream)) x)")
487  (:duplicate-definition))
488
489
490(deftest ccl.41334-3
491    (test-dup-warnings
492     "(defmacro test.ccl-41334-3 (x) x)
493      (defmacro test.ccl-41334-3 (x) x)")
494  (:duplicate-definition))
495
496(deftest ccl.41334-4
497    (test-dup-warnings
498     "(defgeneric test.ccl-41334-4 (x))
499      (defun test.ccl-41334-4 (x) x)")
500  (:duplicate-definition))
501
502
503(deftest ccl.41334-1a
504    (test-dup-warnings
505     "(defun test.ccl-41334-1 (x) x)"
506     "(defun test.ccl-41334-1 (x) x)")
507  (:duplicate-definition))
508
509
510(deftest ccl.41334-2a
511    (test-dup-warnings
512     "(defmethod test.ccl-41334-2 ((x stream)) x)"
513     "(defmethod test.ccl-41334-2 ((x stream)) x)")
514  (:duplicate-definition))
515
516
517(deftest ccl.41334-3a
518    (test-dup-warnings
519     "(defmacro test.ccl-41334-3 (x) x)"
520     "(defmacro test.ccl-41334-3 (x) x)")
521  (:duplicate-definition))
522
523(deftest ccl.41334-4a
524    (test-dup-warnings
525     "(defgeneric test.ccl-41334-4 (x &key foo))"
526     "(defmacro test.ccl-41334-4 (x) x)")
527  (:duplicate-definition))
528
529
530(deftest ccl.41334-5
531    (test-dup-warnings
532     "(defclass test.41334-5 () ((41334-5-slot :accessor test.41334-5-slot)))"
533     "(defmethod (setf test.41334-5-slot) (v (x test.41334-5)) v)")
534  (:duplicate-definition))
535
536
537(deftest ccl.41334-6
538    (test-dup-warnings
539     "(defun test.41334-6 () nil)"
540     "(let ((closed nil))
541        (defun test.41334-6 () closed))")
542  (:duplicate-definition))
543
544(deftest ccl.41334-7
545    (test-dup-warnings
546     "(defun test.41334-7 () nil)"
547     "(unless (fboundp 'test.31334-7)
548        (defun test.41334-7 () t))")
549  nil)
550
551#+not-yet
552(deftest ccl.bug#340
553    (labels ((fact (n) (if (zerop n) 1 (* n (fact (1- n))))))
554      (let ((res (format nil "~s" (log (fact 1000) 10.0d0))))
555        (or (string-equal "2567.60464" res :end2 10) res)))
556  t)
557
558(deftest ccl.bug#344
559    (flet ((try (count)
560             (let ((cname (gensym))
561                   (gname (gensym)))
562               (eval `(progn
563                        (defclass ,cname () ())
564                        ,.(loop for n from 1 to count
565                                collect `(defmethod ,gname ((arg0 ,cname) (arg1 (eql ,n)))))))
566               (handler-case (progn (funcall gname (make-instance cname) 1) nil)
567                 (error (c) :error)))))
568      (list (try 46) (try 200)))
569  (nil nil))
570
571
572;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
573;;; ADVISE
574
575(defun function-to-advise (x) (car x))
576(defun another-function-to-advise (x) (cdr x))
577(defun (setf function-to-advise) (val arg) (setf (car arg) val))
578
579(declaim (notinline function-to-advise
580                    another-function-to-advise
581                    (setf function-to-advise)))
582
583(defvar *advise-var* nil)
584
585
586(deftest advise.1
587  (progn
588    (ccl:unadvise t)
589    (function-to-advise '(a)))
590  a)
591
592(deftest advise.2
593  (progn
594    (ccl:unadvise t)
595    (ccl:advise function-to-advise (return 'advise.2))
596    (function-to-advise '(b)))
597  advise.2)
598
599(deftest advise.3
600  (progn
601    (ccl:unadvise t)
602    (ccl:advise function-to-advise 'advised.3 :when :around :name test)
603    (assert (eq 'advised.3 (function-to-advise '(a))))
604    (prog1 (ccl:advisedp t)
605      (ccl:unadvise t)
606      (assert (null (ccl:advisedp t)))))
607  ((function-to-advise :around test)))
608
609
610(deftest advise.4
611  (progn
612    (ccl:unadvise t)
613    (ccl:advise function-to-advise (return 'advise.4) :name test)
614    (handler-bind ((warning #'muffle-warning))
615      (ccl:advise function-to-advise (return 'readvised) :name test))
616    (prog1 (ccl:advisedp t)
617      (ccl:unadvise t)
618      (assert (null (ccl:advisedp t)))))
619  ((function-to-advise :before test)))
620
621(deftest advise.4a
622  (progn
623    (ccl:unadvise t)
624    (setq *advise-var* '(none))
625    (ccl:advise function-to-advise (push 'advise.4a *advise-var*) :name test)
626    (handler-bind ((warning #'muffle-warning))
627      (ccl:advise function-to-advise (push 'readvise.4a *advise-var*) :name test))
628    (assert (eq (function-to-advise '(c)) 'c))
629    *advise-var*)
630  (readvise.4a none))
631
632(deftest advise.5
633  (progn
634    (ccl:unadvise t)
635    (setq *advise-var* '(none))
636    (ccl:advise (setf function-to-advise) (push 'advise.5 *advise-var*))
637    (prog1 (ccl:advisedp t)
638      (ccl:unadvise t)
639      (assert (null (ccl:advisedp t)))))
640  (((setf function-to-advise) :before nil)))
641
642(deftest advise.6
643  (progn
644    (ccl:unadvise t)
645    (setq *advise-var* '(none))
646    (ccl:advise (setf function-to-advise) (push 'advise.6 *advise-var*))
647    (handler-bind ((warning #'muffle-warning))
648      (ccl:advise (setf function-to-advise) (push 'readvise.6 *advise-var*)))
649    (prog1 (ccl:advisedp t)
650      (ccl:unadvise t)
651      (assert (null (ccl:advisedp t)))))
652  (((setf function-to-advise) :before nil)))
653
654(deftest advise.6a
655  (progn
656    (ccl:unadvise t)
657    (setq *advise-var* '(none))
658    (ccl:advise (setf function-to-advise) (push 'advise.6a *advise-var*) :when :after)
659    (handler-bind ((warning #'muffle-warning))
660      (ccl:advise (setf function-to-advise) (push 'readvise.6a *advise-var*) :when :after))
661    (let ((x (list nil)))
662      (list* (setf (function-to-advise x) 17)
663             (car x)
664             *advise-var*)))
665  (17 17 readvise.6a none))
666
667(deftest advise.7
668  (progn
669    (ccl:unadvise t)
670    (setq *advise-var* '(none))
671    (let ((x (list nil)))
672      (assert (eql (setf (function-to-advise x) 'a) 'a))
673      (assert (equal x '(a)))
674      *advise-var*))
675  (none))
676
677(deftest advise.8
678  (progn
679    (ccl:unadvise t)
680    (setq *advise-var* '(none))
681    (ccl:advise (setf function-to-advise) (push 'advise.8 *advise-var*))
682    (let ((x (list nil)))
683      (assert (eql (setf (function-to-advise x) 'a) 'a))
684      (assert (equal x '(a)))
685      *advise-var*))
686  (advise.8 none))
687
688(deftest advise.9
689  (progn
690    (ccl:unadvise t)
691    (setq *advise-var* '(none))
692    (ccl:advise function-to-advise (push 'advise.9 *advise-var*))
693    (ccl:advise another-function-to-advise (push 'another-advise.9 *advise-var*))
694    (assert (eql (function-to-advise '(b)) 'b))
695    (assert (eql (another-function-to-advise '(c . d)) 'd))
696    (assert (equal *advise-var* '(another-advise.9 advise.9 none)))
697    (prog1
698        (sort (copy-list (ccl:advisedp t))
699              #'(lambda (k1 k2) (string< (princ-to-string k1)
700                                         (princ-to-string k2))))
701      (ccl:unadvise t)))
702  ((another-function-to-advise :before nil) (function-to-advise :before nil)))
703
704(deftest advise.10
705  (progn
706    (ccl:unadvise t)
707    (setq *advise-var* '(none))
708    (assert (null (ccl:advisedp t)))
709    (ccl:advise function-to-advise (push 'advise.10 *advise-var*))
710    (ccl:unadvise function-to-advise)
711    (assert (null (ccl:advisedp t)))
712    (handler-bind ((warning #'muffle-warning)) (ccl:unadvise function-to-advise))
713    (assert (null (ccl:advisedp t)))
714    nil)
715  nil)
716
717(deftest advise.11
718  (progn
719    (ccl:unadvise t)
720    (ccl:advise function-to-advise  (return 17))
721    (ccl:advise another-function-to-advise (return 18))
722    (ccl:unadvise function-to-advise)
723    (ccl:unadvise another-function-to-advise)
724    (ccl:advisedp t))
725  nil)
726
727;;; advising a generic function
728
729(declaim (notinline generic-function-to-advise))
730
731(deftest advise.12
732  (progn
733    (ccl:unadvise t)
734    (setq *advise-var* '(none))
735    (eval '(defgeneric generic-function-to-advise (x y)))
736    (ccl:advise generic-function-to-advise (push 'advise.12 *advise-var*))
737    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
738  ((generic-function-to-advise :before nil)))
739
740(deftest advise.13
741  (progn
742    (ccl:unadvise t)
743    (setq *advise-var* '(none))
744    (eval '(defgeneric generic-function-to-advise (x y)))
745    (ccl:advise generic-function-to-advise (push 'advise.13 *advise-var*))
746    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
747    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
748  ((generic-function-to-advise :before nil)))
749
750(deftest advise.14
751  (progn
752    (ccl:unadvise t)
753    (setq *advise-var* '(none))
754    (eval '(defgeneric generic-function-to-advise (x y)))
755    (ccl:advise generic-function-to-advise (push 'advise.14 *advise-var*))
756    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
757    (assert (null (generic-function-to-advise 'a 'b)))
758    (assert (equal *advise-var* '(advise.14 none)))
759    (prog1
760        (ccl:advisedp t)
761      (ccl:unadvise generic-function-to-advise)
762      (assert (null (ccl:advisedp t)))))
763  ((generic-function-to-advise :before nil)))
764
765(declaim (notinline generic-function-to-advise2))
766
767(deftest advise.15
768  (progn
769    (ccl:unadvise t)
770    (setq *advise-var* '(none))
771    (let* ((gf (eval '(defgeneric generic-function-to-advise2 (x y))))
772           (m (eval '(defmethod generic-function-to-advise2
773                       ((x integer)(y integer))
774                       :foo))))
775      (eval '(defmethod generic-function-to-advise2
776               ((x symbol)(y symbol)) :bar))
777      (assert (eql (generic-function-to-advise2 1 2) :foo))
778      (assert (eql (generic-function-to-advise2 'a 'b) :bar))
779      (ccl:advise generic-function-to-advise2 (push 'advise.15 *advise-var*))
780      (assert (equal (ccl:advisedp t) '((generic-function-to-advise2 :before nil))))
781      (remove-method gf m)
782      (prog1 (ccl:advisedp t) (ccl:unadvise t))))
783  ((generic-function-to-advise2 :before nil)))
784
785
786(deftest advise.16
787  (progn
788    (ccl:unadvise t)
789    (setq *advise-var* '(none))
790    (ccl:advise function-to-advise (push 'advise.16-1 *advise-var*) :name test-1)
791    (ccl:advise function-to-advise (push 'advise.16-2 *advise-var*) :name test-2)
792    (prog1 (cons (function-to-advise '(foo)) *advise-var*) (ccl:unadvise t)))
793  (foo advise.16-1 advise.16-2 none))
794
795(deftest advise.17
796  (progn
797    (ccl:unadvise t)
798    (setq *advise-var* '(none))
799    (untrace)
800    (ccl:advise function-to-advise (push 'advise.17-1 *advise-var*) :name test-1)
801    (trace function-to-advise)
802    (ccl:advise function-to-advise (push 'advise.17-2 *advise-var*) :name test-2)
803    (prog1
804        (list (not (equal "" (with-output-to-string (*trace-output*)
805                               (function-to-advise '(foo)))))
806              *advise-var*
807              (ccl:unadvise function-to-advise :name test-1)
808              (not (equal "" (with-output-to-string (*trace-output*)
809                               (function-to-advise '(bar)))))
810              *advise-var*
811              (untrace)
812              (with-output-to-string (*trace-output*)
813                (function-to-advise '(bar)))
814              *advise-var*)
815      (ccl:unadvise t)
816      (untrace)))
817  (t (advise.17-1 advise.17-2 none) ((function-to-advise :before test-1))
818     t (advise.17-2 advise.17-1 advise.17-2 none) (function-to-advise) ""
819     (advise.17-2 advise.17-2 advise.17-1 advise.17-2 none)))
820
821
822(deftest advise.18
823  (progn
824    (ccl:unadvise t)
825    (setq *advise-var* '(none))
826    (untrace)
827    (fmakunbound 'generic-function-to-advise.18)
828    (eval '(defgeneric generic-function-to-advise.18 (x y)))
829    (eval '(defmethod generic-function-to-advise.18 ((x integer)(y integer)) :foo))
830    (eval '(defmethod generic-function-to-advise.18 ((x symbol)(y symbol)) :bar))
831    (ccl:advise generic-function-to-advise.18 (push 'advise.18-1 *advise-var*) :name test-1)
832    (trace generic-function-to-advise.18)
833    (ccl:advise generic-function-to-advise.18 (push 'advise.18-2 *advise-var*) :name test-2)
834    (prog1
835        (list (not (equal "" (with-output-to-string (*trace-output*)
836                               (assert (eq :bar (generic-function-to-advise.18 'a 'b))))))
837              *advise-var*
838              (ccl:unadvise generic-function-to-advise.18 :name test-1)
839              (not (equal "" (with-output-to-string (*trace-output*)
840                               (assert (eq :foo (generic-function-to-advise.18 1 2))))))
841              *advise-var*
842              (untrace)
843              (with-output-to-string (*trace-output*)
844                (generic-function-to-advise.18 'x 'y))
845              *advise-var*)
846      (ccl:unadvise t)
847      (untrace)))
848  (t (advise.18-1 advise.18-2 none) ((generic-function-to-advise.18 :before test-1))
849     t (advise.18-2 advise.18-1 advise.18-2 none) (generic-function-to-advise.18) ""
850     (advise.18-2 advise.18-2 advise.18-1 advise.18-2 none)))
851
852
Note: See TracBrowser for help on using the repository browser.