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

Last change on this file since 12586 was 12586, checked in by gz, 10 years ago

Tests for more compile-time defmethod checking

File size: 52.2 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  :undefined-type)
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 (:override t)
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 :declarations-typecheck
629                                                                            t))
630          (f (test-source-file "(defun cl-test::ccl.50130-fn (arr idx)
631                                  (aref (the (or (vector fixnum) (vector (unsigned-byte 8))) arr) idx))")))
632      (test-compile f :load t)
633      (funcall 'cl-test::ccl.50130-fn (make-array 4 :element-type 'fixnum :initial-element 17) 2))
634  17)
635
636(deftest ccl.50646-bug#378
637    (progn
638      (define-method-combination ccl.50646-method-combination ()
639        ((around (:around)) (primary ()))
640        `(call-method ,(first around) ((make-method (call-method ,(first primary))))))
641      (defgeneric ccl.50646-gf (x) (:method-combination ccl.50646-method-combination))
642      (defmethod ccl.50646-gf ((x integer)) x)
643      (defmethod ccl.50646-gf :around ((x integer)) (call-next-method x))
644      (ccl.50646-gf 23))
645  23)
646
647(deftest ccl.50911
648    (progn
649      (defclass ccl.50911-class () ((slot-a :initarg :a :reader ccl.50911-slot-a)))
650      (ccl::%snap-reader-method #'ccl.50911-slot-a)
651      (ccl:finalize-inheritance (find-class 'ccl.50911-class))
652      (ccl.50911-slot-a (make-instance 'ccl.50911-class :a :test)))
653  :test)
654
655(deftest ccl.50911-a
656    (let ((called 0))
657      (defclass ccl.50911-a () ())
658      (defun ccl.50911-a-fn () (make-instance 'ccl.50911-a))
659      (defmethod initialize-instance ((x ccl.50911-a) &rest keys) keys (incf called))
660      (ccl.50911-a-fn)
661      (defmethod initialize-instance :after ((x ccl.50911-a) &rest keys) keys (incf called))
662      (ccl.50911-a-fn)
663      (ccl::optimize-make-instance-for-class-name 'ccl.50911-a)
664      (ccl.50911-a-fn)
665      called)
666  5)
667
668
669(deftest ccl.bug-misc-init
670    (progn
671      (funcall (lambda () (make-array 1 :element-type '(signed-byte 16) :initial-element -1)))
672      t)
673  t)
674 
675(deftest ccl.bug#382
676    (string= (with-output-to-string (s)
677               (funcall #'(lambda () (write-string "foobar" s :end 2))))
678             "fo")
679  t)
680 
681(deftest ccl.52006
682    (progn
683      (defclass ccl.52006-class () ((slot :initarg :slot)) (:default-initargs :slot nil))
684      (defun test-1 (args) (apply #'make-instance 'ccl.52006-class args))
685      (ccl::optimize-make-instance-for-class-name 'ccl.52006-class)
686      (slot-value (test-1 nil) 'slot))
687  nil)
688
689
690(deftest ccl.bug#387
691    (handler-case
692        (coerce #(127 0 0 256) '(simple-array (unsigned-byte 8) (*)))
693      (type-error () :type-error))
694  :type-error)
695
696(deftest ccl.49462
697    (let ((file (test-source-file "(defun ccl.49462-fn (x) x)
698(defmacro ccl.49462-macro (x) (error \"(macro ~~s)\" x))
699(ccl.49462-macro 1)")))
700      (handler-case
701          (with-compilation-unit (:override t)
702            (handler-bind ((error (lambda (c)
703                                    (declare (ignore c))
704                                    (with-open-file (f file :direction :output)
705                                      (format f "(defun ccl.49462-fn (x) x)"))
706                                    (invoke-restart 'ccl::retry-compile-file))))
707              (test-compile file :hide-warnings t))
708            nil)
709        (warning (c) c)))
710  nil)
711
712(deftest ccl.49462-redux-1
713    (let ((file (test-source-file "(defun ccl.49462-redux-1-fn (x) x)")))
714      (handler-case
715          (with-compilation-unit (:override t)
716            (test-compile file :hide-warnings t)
717            (test-compile file :hide-warnings t)
718            nil)
719        (warning (c) c)))
720  nil)
721
722
723(deftest ccl.49462-redux-2
724    (let ((file (test-source-file "(defun ccl.49462-redux-2-fn (x) x)"))
725          (warnings ()))
726      (handler-bind ((warning (lambda (c) (push c warnings))))
727        (with-compilation-unit (:override t)
728          (with-compilation-unit ()
729            (test-compile file))
730          (test-compile file :hide-warnings t)))
731      (length warnings))
732  1)
733
734
735(deftest ccl.bug-overflow-handling
736    (funcall (test-compile '(lambda ()
737                             (let ((upper-bound most-positive-fixnum))
738                               (let ((lower-bound (- (1+ upper-bound))))
739                                 lower-bound)))))
740  #.most-negative-fixnum)
741
742
743(deftest ccl.bug#412
744    (funcall (test-compile '(lambda ()
745                             (let* ((x most-negative-fixnum)
746                                    (y 1))
747                               (- x y)))))
748  #.(1- most-negative-fixnum))
749
750(deftest ccl.bug#411
751    (funcall (test-compile '(lambda ()
752                             (let ((x 0)) (+ 3416133997 x)))))
753  3416133997)
754
755(deftest ccl.51790
756    (let ((var))
757      (setq var t)
758      (list
759       (handler-case (format nil "~:[First case;second case~]" var)
760         (error () :error))
761       (handler-case (format nil "~:[First case;second case~]" (not var))
762         (error () :error))))
763  (:error :error))
764
765(deftest ccl.bug#409
766    (let ((errors ()))
767      (handler-bind ((ccl::compiler-warning
768                      (lambda (c)
769                        (push (ccl::compiler-warning-function-name c) errors)
770                        (muffle-warning c))))
771        (let ((file (test-source-file "(in-package :cl-test)
772                                       (defun ccl.bug#409a1 (x) (declare (type 17 x)) x)
773                                       (defun ccl.bug#409a2 (x) x (the 17 x))
774                                       (defun ccl.bug#409a3 (x) x (typep x 17))
775                                       (defun ccl.bug#409a4 (x) x (make-array 3 :element-type 17))
776
777                                       (defun ccl.bug#409b1 (x) (declare (type (cons number number list) x)) x)
778                                       (defun ccl.bug#409b2 (x) x (the (cons number number list) x))
779                                       (defun ccl.bug#409b3 (x) x (typep x '(cons number number list)))
780                                       (defun ccl.bug#409b4 (x) x (make-array 3 :element-type '(cons number number list)))
781
782                                       (defun ccl.bug#409c1 (x) (declare (type (sequence symbol) x)) x)
783                                       (defun ccl.bug#409c2 (x) x (the (sequence symbol) x))
784                                       (defun ccl.bug#409c3 (x) x (typep x '(sequence symbol)))
785                                       (defun ccl.bug#409c4 (x) x (make-array 3 :element-type '(sequence symbol) :initial-element x))
786                                      ")))
787          (test-compile file :hide-warnings t :break-on-program-errors nil)))
788      errors)
789  ((ccl.bug#409c4) (ccl.bug#409c3) (ccl.bug#409c2) (ccl.bug#409c1)
790   (ccl.bug#409b4) (ccl.bug#409b3) (ccl.bug#409b2) (ccl.bug#409b1)
791   (ccl.bug#409a4) (ccl.bug#409a3) (ccl.bug#409a2) (ccl.bug#409a1)))
792
793(deftest ccl.53584
794    (let ((file (test-source-file "(defclass cl-test::ccl.53584 () ((x :type (sequence integer) :initarg :x)))"))
795          (warnings ()))
796      (handler-case
797          (handler-bind ((ccl::compiler-warning
798                          (lambda (c) (push :compile-time warnings) (muffle-warning c)))
799                         (warning
800                          (lambda (c) (push :load-time warnings) (muffle-warning c))))
801            (test-compile file :hide-warnings t :load t)
802            (make-instance 'ccl.53584 :x '(17)))
803        (error () (push :run-time warnings)  warnings)))
804  (:run-time :load-time :compile-time))
805
806(deftest ccl.bug#321
807    (handler-case
808        (progn
809          (format nil "~a" (make-condition 'style-warning))
810          :no-error)
811      (error () :error))
812  :no-error)
813
814(deftest ccl.loop-array
815    (let ((x nil))
816      (declare (optimize (safety 3) (speed 1)))
817      (setq x nil)
818      (handler-case
819          (loop for a across x collect a)
820        (type-error () :error)))
821  :error)
822
823(deftest ccl.loop-on
824    (locally (declare (optimize (safety 3) (speed 1)))
825      (loop for (head . tail) on '(a . b) when head collect tail))
826  (b))
827
828
829;;; This is likely to return random nonsense (without necessarily
830;;; getting a memory fault) on some platforms.
831#-ppc64-target
832(deftest ccl.57900.1 ;; don't crash on simple access errors
833    (handler-case (funcall (lambda (x) (declare (optimize (safety 1) (speed 1))) (ccl::%caar x))
834                           *standard-input*)
835      (storage-condition () :storage-condition))
836  :storage-condition)
837
838(deftest ccl.57900.2
839    (handler-case (funcall (lambda (x) (declare (optimize (safety 1) (speed 1))) (ccl::%caar x))
840                           0)
841      (storage-condition () :storage-condition))
842  :storage-condition)
843
844(deftest ccl.next-method-p
845    (let ((file (test-source-file "(defmethod cl-test::ccl.next-method-gf (x) (if (next-method-p) (call-next-method) x))")))
846      (fmakunbound 'cl-test::ccl.next-method-gf)
847      (test-compile file :load t)
848      (funcall 'cl-test::ccl.next-method-gf 3))
849  3)
850
851(deftest ccl.49345-1
852    (test-dup-warnings
853     "(defclass test.ccl-49345-1 () ())
854      (defclass test.ccl-49345-1 () ())")
855  (:duplicate-definition))
856
857(deftest ccl.49345-2
858    (test-dup-warnings
859     "(defstruct (test.ccl-49345-2 (:copier  nil) (:predicate nil) (:constructor nil)))
860      (defstruct (test.ccl-49345-2 (:copier  nil) (:predicate nil) (:constructor nil)))")
861  (:duplicate-definition))
862
863(deftest ccl.49345-3
864    (test-dup-warnings
865     "(deftype test.ccl-49345-3 () 'integer)
866      (deftype test.ccl-49345-3 () 'integer)")
867  (:duplicate-definition))
868
869(deftest ccl.49345-4
870    (test-dup-warnings
871     "(defclass test.ccl-49345-4 () ())
872      (deftype test.ccl-49345-4 () 'integer)")
873  (:duplicate-definition))
874
875#+not-yet
876(deftest ccl.49345-5
877    (test-dup-warnings
878     "(defclass test.ccl-49345-5 () ())
879      (let ((closed nil))
880         (defclass test.ccl-49345-5 () ((slot :initform closed))))")
881  (:duplicate-definition))
882
883#+not-yet
884(deftest ccl.49345-6
885    (test-dup-warnings
886     "(defclass test.ccl-49345-6 () ())"
887     "(let ((closed nil))
888         (defstruct test.ccl-49345-6 (x closed)))")
889  (:duplicate-definition))
890
891(deftest ccl.49345-7
892    (test-dup-warnings
893     "(defclass test.ccl-49345-7 () ())
894      (when (find-class 'test.ccl-49345-7 nil)
895         (defclass test.ccl-49345-7 () ()))")
896  ())
897
898(defun test-compiler-warning (text)
899  (let ((warnings nil))
900    (handler-bind ((ccl::compiler-warning (lambda (c)
901                                            (push (ccl::compiler-warning-warning-type c) warnings)
902                                            (muffle-warning c))))
903      (test-compile (test-source-file text) :hide-warnings t))
904    (nreverse warnings)))
905 
906(deftest ccl.49345-u1
907    (test-compiler-warning "(defun ccl.49345-u1 (x) (typep x 'ccl.49345-u1-type))")
908  (:undefined-type))
909
910(deftest ccl.49345-u2
911    (test-compiler-warning "(defun ccl.49345-u2 (x) (declare (type ccl.49345-u2-type x)) x)")
912  (:unknown-type-in-declaration))
913
914(deftest ccl.49345-u3
915    (test-compiler-warning "(defun ccl.49345-u3 (x) (the ccl.49345-u3-type x))")
916  (:unknown-type-in-declaration))
917
918(deftest ccl.49345-u4
919    (test-compiler-warning "(defun ccl.49345-u4 (x) (make-array x :element-type 'ccl.49345-u4-type))")
920  (:undefined-type))
921
922(deftest ccl.49345-u5
923    (test-compiler-warning "(defun ccl.49345-u5 (x) (coerce x 'ccl.49345-u5-type))")
924  (:undefined-type))
925
926(deftest ccl.49345-u6
927    (test-compiler-warning "(declaim (type ccl.49345-u6-type *ccl.49345-u6*))")
928  (:undefined-type))
929
930(deftest ccl.49345-i1
931    (test-compiler-warning "(defun ccl.49345-i1 (x) (typep x '(sequence integer)))")
932  (:invalid-type))
933
934(deftest ccl.49345-i2
935    (test-compiler-warning "(defun ccl.49345-i2 (x) (declare (type (sequence integer) x)) x)")
936  (:unknown-type-in-declaration))
937
938(deftest ccl.49345-i3
939    (test-compiler-warning "(defun ccl.49345-i3 (x) (the (sequence integer) x))")
940  (:invalid-type))
941
942(deftest ccl.49345-i4
943    (test-compiler-warning "(defun ccl.49345-i4 (x) (make-array x :element-type '(sequence integer)))")
944  (:invalid-type))
945
946(deftest ccl.49345-i5
947    (test-compiler-warning "(defun ccl.49345-i5 (x) (coerce x '(sequence integer)))")
948  (:invalid-type))
949
950(deftest ccl.49345-i6
951    (test-compiler-warning "(declaim (type (sequence integer) *ccl.49345-i6*))")
952  (:invalid-type))
953
954(deftest ccl.49345-fwd
955    (test-compiler-warning "(defun ccl.49345-fwd-fn (x ) (typep x 'ccl.49345-fwd-type))
956                            (defclass ccl.49345-fwd-type () ())")
957  ())
958
959(deftest ccl.57879-1
960    (test-compiler-warning "(defun foo (x) (declare (ccl.57879-1 'foo)) x)")
961  (:bad-declaration))
962
963(deftest ccl.57879-2
964    (handler-case
965        (test-compile (test-source-file "(proclaim '(ccl.57879-2 3))") :hide-warnings t :load t)
966      (program-error () :error))
967  :error)
968
969(deftest ccl.57879-3
970    (test-compiler-warning "(declaim (ccl.57879-3 3))")
971  (:bad-declaration))
972
973(deftest ccl.57879-4
974    (handler-case
975        (test-compile (test-source-file "(proclaim '(optimize (ccl.57879-4a ccl.57879-4b)))") :hide-warnings t :load t)
976      (program-error () :error))
977  :error)
978
979(deftest ccl.57879-5
980    (test-compiler-warning "(declaim (optimize (ccl.57879-5a ccl.57879-5b)))")
981  (:bad-declaration))
982
983;; By special dispensation, don't complain, even though can't optimize the slot reference.
984(deftest ccl.57879-6
985    (test-compiler-warning "(defstruct ccl.57879-6-struct (slot nil :type (or null ccl.57879-6-type)))
986                            (defun ccl.57879-6-fn (x) (ccl.57879-6-struct-slot x))
987
988                            (deftype ccl.57879-6-type () 'null)")
989  ())
990
991(deftest ccl.59726
992    (test-compiler-warning "(defun ccl.59726-fn () #'ccl.59726-unknown)")
993  (:undefined-function))
994
995(deftest ccl.bug#470
996    (funcall (lambda ()
997               (declare (optimize (safety 1) (speed 1)))
998               (let ((array (make-array '(1 1) :initial-element 2.0
999                                        :element-type 'single-float))
1000                     (var 1.0))
1001                 (setf (aref array 0 0) var
1002                       var nil))))
1003  nil)
1004
1005(deftest ccl.55959.bug#474
1006    (block test
1007      (handler-bind ((program-error (lambda (c)
1008                                      (declare (ignore c))
1009                                      (return-from test
1010                                        (handler-case (progn
1011                                                        (with-output-to-string (s)
1012                                                          (ccl:print-call-history :stream s))
1013                                                        :success)
1014                                          (error (c) c))))))
1015        (labels ((inner (x &key a)
1016                   ;; try to make sure this will use at least one saved register
1017                   (loop (concatenate x a) (concatenate x a) (concatenate x a)))
1018                 (outer (x)
1019                   ;; try to make sure this will use a saved register for X so backtrace will try to find it.
1020                   (setq x (list (list x) :bogus-key (list (list x) (list x))))
1021                   ;; call inner with bad keyword arg, to cause error before it saves its saved regs
1022                   (apply #'inner x)
1023                   x))
1024          (declare (notinline inner outer))
1025          (outer 3))))
1026  :success)
1027
1028(deftest ccl.r12217
1029    (with-input-from-string (s "123")
1030      (file-position s 3))
1031  3)
1032
1033(deftest ccl.the-with-constant-values
1034  (eval '(the (values integer) 23))
1035  23)
1036
1037(defmacro ccl.bug#543.macro (init) `(make-array (length ,init)))
1038
1039(deftest ccl.bug#543
1040    (length (funcall (lambda () (progn (the array (ccl.bug#543.macro '(a b)))))))
1041  2)
1042
1043(deftest ccl.bug#543a
1044    (handler-case
1045        (progn
1046          (test-compile '(lambda (x y)
1047                          (the fixnum (- (the fixnum (aref (the (array fixnum 1) x) (aref (the (simple-array fixnum 1) y) 0)))))))
1048          :win)
1049      (serious-condition (c) c))
1050  :win)
1051
1052(deftest ccl.r12429
1053    (let ((ccl::*print-string-length* 10))
1054      (with-standard-io-syntax
1055          (values (read-from-string (prin1-to-string "123456789012345")))))
1056  "123456789012345")
1057
1058(deftest ccl.63842a
1059    (test-compiler-warning "(defun ccl.63842a-1 () (declare (inline ccl.63842a-2)))")
1060  (:unknown-declaration-function))
1061
1062(deftest ccl.63842b
1063    (test-compiler-warning "(defun ccl.63842b-1 () (declare (dynamic-extent #'ccl.63842b-2)))")
1064  (:unknown-declaration-function))
1065
1066(deftest ccl.decl.1
1067    (test-compiler-warning "(defun ccl.decl.1 (a) (lambda () (declare (fixnum a)) a))")
1068  ())
1069
1070(deftest ccl.decl.2
1071    (test-compiler-warning "(defun ccl.decl.2 (a) (flet ((fn () (declare (fixnum a)) a)) #'fn))")
1072  ())
1073
1074(deftest ccl.decl.3
1075    (test-compiler-warning "(defun ccl.decl.3 ()
1076                              (declare (dynamic-extent #'ccl.decl.3-none-such)
1077                                       (notinline ccl.decl.3-none-other)))")
1078  (:unknown-declaration-function :unknown-declaration-function))
1079
1080(deftest ccl.decl.4
1081    (test-compiler-warning "(defun ccl.decl.4 () (flet ((fn () t) (fn1 () t)) (declare (inline fn) (dynamic-extent #'fn1)) (list (fn) (fn1))))")
1082  ())
1083
1084(deftest ccl.decl.5
1085    (test-compiler-warning "(defun ccl.decl.5 () (flet ((fn () t)) (declare (notinline ccl.decl.5-none-sch) (dynamic-extent #'ccl.decl.5-non-other)) #'fn))")
1086  (:unknown-declaration-function :unknown-declaration-function))
1087
1088(deftest ccl.ftype.1
1089    (test-compiler-warning "(lambda () (declare (ftype integer ccl.ftype.1)))")
1090  (:bad-declaration))
1091
1092(deftest ccl.ftype.2
1093    (test-compiler-warning "(lambda () (declare (ftype function ccl.ftype.2)) #'ccl.ftype.2)")
1094  ())
1095
1096(deftest ccl.ftype.3
1097    (test-compiler-warning "(declaim (ftype (function (t) (values integer)) ccl.ftype.3))
1098                            (defun ccl.ftype.3-caller () (the cons (ccl.ftype.3 nil)))")
1099  (:type-conflict))
1100
1101
1102(deftest ccl.ftype.4
1103    (test-compiler-warning "(declaim (ftype (function (t) (values integer)) ccl.ftype.4))
1104                            (defun ccl.ftype.4-caller () (ccl.ftype.4))")
1105  (:ftype-mismatch))
1106
1107(deftest ccl.ftype.5
1108    (test-compiler-warning "(declaim (ftype (function (t &key (:a integer)) (values integer)) ccl.ftype.5))
1109                            (defun ccl.ftype.5-caller () (ccl.ftype.5 1 :a :x))")
1110  (:type))
1111
1112(deftest ccl.ftype.6
1113    (test-compiler-warning "(declaim (ftype (function (t &key (:a integer)) (values integer)) ccl.ftype.6))
1114                            (defun ccl.ftype.6-caller () (ccl.ftype.6 :b 17))")
1115  (:ftype-mismatch))
1116
1117
1118(deftest ccl.ftype.7
1119    (test-compiler-warning "(declaim (ftype (function (t t t) t) ccl.ftype.7))
1120                            (defun ccl.ftype.7-caller () (ccl.ftype.7))")
1121  (:ftype-mismatch))
1122
1123(deftest ccl.ftype.8
1124    (test-compiler-warning "(declaim (ftype (function (t t t) t) ccl.ftype.8))
1125                            (defun ccl.ftype.8-caller ()
1126                               (flet ((ccl.ftype.8 () t)) (ccl.ftype.8)))")
1127  ())
1128
1129(deftest ccl.ftype.9-pre
1130    (test-compiler-warning "(declaim (ftype (function (unknown) t) ccl.ftype.9-pre))")
1131  (:undefined-type))
1132
1133(deftest ccl.ftype.9
1134    (test-compiler-warning "(defun ccl.ftype.9 (x) x)
1135                            (declaim (ftype (function (unknown) t) ccl.ftype.9))
1136                            (defun ccl.ftype.9-caller () (ccl.ftype.9 17))")
1137  ;; The :undefined-type is from the declaim itself (see ccl.ftype.9-pre).  There
1138  ;; should be no added type warnings from the actual use of the fn
1139  (:undefined-type))
1140
1141(deftest ccl.ftype.10
1142    (test-compiler-warning "(defun ccl.ftype.10-caller (x)
1143                              (declare (ftype (function (t) t) ccl.ftype.10))
1144                              (ccl.ftype.10 x))")
1145  ())
1146
1147
1148(deftest ccl.ftype.11-pre
1149    (test-compiler-warning "(defun ccl.ftype.11-pre-caller (x)
1150                              (declare (ftype (function (unknown) t) ccl.ftype.11-pre))
1151                              x)")
1152  (:unknown-type-in-declaration))
1153
1154(deftest ccl.ftype.11
1155    (test-compiler-warning "(defun ccl.ftype.11-caller (x)
1156                              (declare (ftype (function (unknown) t) ccl.ftype.11))
1157                              (ccl.ftype.11 x))")
1158  ;; The :unknown-type-in-declaration is from the declare itself (see ccl.ftype.11-pre).  There
1159  ;; should be no added type warnings from the actual use of the fn
1160  (:unknown-type-in-declaration :undefined-function))
1161
1162(deftest ccl.ftype.54161
1163  (test-compiler-warning "(declaim (ftype (function (integer) (values integer)) ccl.ftype.54161))
1164  (defun ccl.ftype.54161-caller () (ccl.ftype.54161 :x))")
1165  (:type))
1166
1167
1168(deftest ccl.macroexpand-all.r12550a
1169  (ccl:macroexpand-all '(macrolet ((foo () 'macro)) (flet ((foo () (foo))) (foo))))
1170  (progn (flet ((foo () macro)) (foo))))
1171
1172(deftest ccl.macroexpand-all.r12550b
1173  (ccl:macroexpand-all '(macrolet ((foo () 'macro)) (labels ((foo () (foo))) (foo))))
1174  (progn (labels ((foo () (foo))) (foo))))
1175
1176
1177;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1178;;; ADVISE
1179
1180(defun function-to-advise (x) (car x))
1181(defun another-function-to-advise (x) (cdr x))
1182(defun (setf function-to-advise) (val arg) (setf (car arg) val))
1183
1184(declaim (notinline function-to-advise
1185                    another-function-to-advise
1186                    (setf function-to-advise)))
1187
1188(defvar *advise-var* nil)
1189
1190
1191(deftest advise.1
1192  (progn
1193    (ccl:unadvise t)
1194    (function-to-advise '(a)))
1195  a)
1196
1197(deftest advise.2
1198  (progn
1199    (ccl:unadvise t)
1200    (ccl:advise function-to-advise (return 'advise.2))
1201    (function-to-advise '(b)))
1202  advise.2)
1203
1204(deftest advise.3
1205  (progn
1206    (ccl:unadvise t)
1207    (ccl:advise function-to-advise 'advised.3 :when :around :name test)
1208    (assert (eq 'advised.3 (function-to-advise '(a))))
1209    (prog1 (ccl:advisedp t)
1210      (ccl:unadvise t)
1211      (assert (null (ccl:advisedp t)))))
1212  ((function-to-advise :around test)))
1213
1214
1215(deftest advise.4
1216  (progn
1217    (ccl:unadvise t)
1218    (ccl:advise function-to-advise (return 'advise.4) :name test)
1219    (handler-bind ((warning #'muffle-warning))
1220      (ccl:advise function-to-advise (return 'readvised) :name test))
1221    (prog1 (ccl:advisedp t)
1222      (ccl:unadvise t)
1223      (assert (null (ccl:advisedp t)))))
1224  ((function-to-advise :before test)))
1225
1226(deftest advise.4a
1227  (progn
1228    (ccl:unadvise t)
1229    (setq *advise-var* '(none))
1230    (ccl:advise function-to-advise (push 'advise.4a *advise-var*) :name test)
1231    (handler-bind ((warning #'muffle-warning))
1232      (ccl:advise function-to-advise (push 'readvise.4a *advise-var*) :name test))
1233    (assert (eq (function-to-advise '(c)) 'c))
1234    *advise-var*)
1235  (readvise.4a none))
1236
1237(deftest advise.5
1238  (progn
1239    (ccl:unadvise t)
1240    (setq *advise-var* '(none))
1241    (ccl:advise (setf function-to-advise) (push 'advise.5 *advise-var*))
1242    (prog1 (ccl:advisedp t)
1243      (ccl:unadvise t)
1244      (assert (null (ccl:advisedp t)))))
1245  (((setf function-to-advise) :before nil)))
1246
1247(deftest advise.6
1248  (progn
1249    (ccl:unadvise t)
1250    (setq *advise-var* '(none))
1251    (ccl:advise (setf function-to-advise) (push 'advise.6 *advise-var*))
1252    (handler-bind ((warning #'muffle-warning))
1253      (ccl:advise (setf function-to-advise) (push 'readvise.6 *advise-var*)))
1254    (prog1 (ccl:advisedp t)
1255      (ccl:unadvise t)
1256      (assert (null (ccl:advisedp t)))))
1257  (((setf function-to-advise) :before nil)))
1258
1259(deftest advise.6a
1260  (progn
1261    (ccl:unadvise t)
1262    (setq *advise-var* '(none))
1263    (ccl:advise (setf function-to-advise) (push 'advise.6a *advise-var*) :when :after)
1264    (handler-bind ((warning #'muffle-warning))
1265      (ccl:advise (setf function-to-advise) (push 'readvise.6a *advise-var*) :when :after))
1266    (let ((x (list nil)))
1267      (list* (setf (function-to-advise x) 17)
1268             (car x)
1269             *advise-var*)))
1270  (17 17 readvise.6a none))
1271
1272(deftest advise.7
1273  (progn
1274    (ccl:unadvise t)
1275    (setq *advise-var* '(none))
1276    (let ((x (list nil)))
1277      (assert (eql (setf (function-to-advise x) 'a) 'a))
1278      (assert (equal x '(a)))
1279      *advise-var*))
1280  (none))
1281
1282(deftest advise.8
1283  (progn
1284    (ccl:unadvise t)
1285    (setq *advise-var* '(none))
1286    (ccl:advise (setf function-to-advise) (push 'advise.8 *advise-var*))
1287    (let ((x (list nil)))
1288      (assert (eql (setf (function-to-advise x) 'a) 'a))
1289      (assert (equal x '(a)))
1290      *advise-var*))
1291  (advise.8 none))
1292
1293(deftest advise.9
1294  (progn
1295    (ccl:unadvise t)
1296    (setq *advise-var* '(none))
1297    (ccl:advise function-to-advise (push 'advise.9 *advise-var*))
1298    (ccl:advise another-function-to-advise (push 'another-advise.9 *advise-var*))
1299    (assert (eql (function-to-advise '(b)) 'b))
1300    (assert (eql (another-function-to-advise '(c . d)) 'd))
1301    (assert (equal *advise-var* '(another-advise.9 advise.9 none)))
1302    (prog1
1303        (sort (copy-list (ccl:advisedp t))
1304              #'(lambda (k1 k2) (string< (princ-to-string k1)
1305                                         (princ-to-string k2))))
1306      (ccl:unadvise t)))
1307  ((another-function-to-advise :before nil) (function-to-advise :before nil)))
1308
1309(deftest advise.10
1310  (progn
1311    (ccl:unadvise t)
1312    (setq *advise-var* '(none))
1313    (assert (null (ccl:advisedp t)))
1314    (ccl:advise function-to-advise (push 'advise.10 *advise-var*))
1315    (ccl:unadvise function-to-advise)
1316    (assert (null (ccl:advisedp t)))
1317    (handler-bind ((warning #'muffle-warning)) (ccl:unadvise function-to-advise))
1318    (assert (null (ccl:advisedp t)))
1319    nil)
1320  nil)
1321
1322(deftest advise.11
1323  (progn
1324    (ccl:unadvise t)
1325    (ccl:advise function-to-advise  (return 17))
1326    (ccl:advise another-function-to-advise (return 18))
1327    (ccl:unadvise function-to-advise)
1328    (ccl:unadvise another-function-to-advise)
1329    (ccl:advisedp t))
1330  nil)
1331
1332;;; advising a generic function
1333
1334(declaim (notinline generic-function-to-advise))
1335
1336(deftest advise.12
1337  (progn
1338    (ccl:unadvise t)
1339    (setq *advise-var* '(none))
1340    (eval '(defgeneric generic-function-to-advise (x y)))
1341    (ccl:advise generic-function-to-advise (push 'advise.12 *advise-var*))
1342    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
1343  ((generic-function-to-advise :before nil)))
1344
1345(deftest advise.13
1346  (progn
1347    (ccl:unadvise t)
1348    (setq *advise-var* '(none))
1349    (eval '(defgeneric generic-function-to-advise (x y)))
1350    (ccl:advise generic-function-to-advise (push 'advise.13 *advise-var*))
1351    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
1352    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
1353  ((generic-function-to-advise :before nil)))
1354
1355(deftest advise.14
1356  (progn
1357    (ccl:unadvise t)
1358    (setq *advise-var* '(none))
1359    (eval '(defgeneric generic-function-to-advise (x y)))
1360    (ccl:advise generic-function-to-advise (push 'advise.14 *advise-var*))
1361    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
1362    (assert (null (generic-function-to-advise 'a 'b)))
1363    (assert (equal *advise-var* '(advise.14 none)))
1364    (prog1
1365        (ccl:advisedp t)
1366      (ccl:unadvise generic-function-to-advise)
1367      (assert (null (ccl:advisedp t)))))
1368  ((generic-function-to-advise :before nil)))
1369
1370(declaim (notinline generic-function-to-advise2))
1371
1372(deftest advise.15
1373  (progn
1374    (ccl:unadvise t)
1375    (setq *advise-var* '(none))
1376    (let* ((gf (eval '(defgeneric generic-function-to-advise2 (x y))))
1377           (m (eval '(defmethod generic-function-to-advise2
1378                       ((x integer)(y integer))
1379                       :foo))))
1380      (eval '(defmethod generic-function-to-advise2
1381               ((x symbol)(y symbol)) :bar))
1382      (assert (eql (generic-function-to-advise2 1 2) :foo))
1383      (assert (eql (generic-function-to-advise2 'a 'b) :bar))
1384      (ccl:advise generic-function-to-advise2 (push 'advise.15 *advise-var*))
1385      (assert (equal (ccl:advisedp t) '((generic-function-to-advise2 :before nil))))
1386      (remove-method gf m)
1387      (prog1 (ccl:advisedp t) (ccl:unadvise t))))
1388  ((generic-function-to-advise2 :before nil)))
1389
1390
1391(deftest advise.16
1392  (progn
1393    (ccl:unadvise t)
1394    (setq *advise-var* '(none))
1395    (ccl:advise function-to-advise (push 'advise.16-1 *advise-var*) :name test-1)
1396    (ccl:advise function-to-advise (push 'advise.16-2 *advise-var*) :name test-2)
1397    (prog1 (cons (function-to-advise '(foo)) *advise-var*) (ccl:unadvise t)))
1398  (foo advise.16-1 advise.16-2 none))
1399
1400(deftest advise.17
1401  (progn
1402    (ccl:unadvise t)
1403    (setq *advise-var* '(none))
1404    (untrace)
1405    (ccl:advise function-to-advise (push 'advise.17-1 *advise-var*) :name test-1)
1406    (trace function-to-advise)
1407    (ccl:advise function-to-advise (push 'advise.17-2 *advise-var*) :name test-2)
1408    (prog1
1409        (list (not (equal "" (with-output-to-string (*trace-output*)
1410                               (function-to-advise '(foo)))))
1411              *advise-var*
1412              (ccl:unadvise function-to-advise :name test-1)
1413              (not (equal "" (with-output-to-string (*trace-output*)
1414                               (function-to-advise '(bar)))))
1415              *advise-var*
1416              (untrace)
1417              (with-output-to-string (*trace-output*)
1418                (function-to-advise '(bar)))
1419              *advise-var*)
1420      (ccl:unadvise t)
1421      (untrace)))
1422  (t (advise.17-1 advise.17-2 none) ((function-to-advise :before test-1))
1423     t (advise.17-2 advise.17-1 advise.17-2 none) (function-to-advise) ""
1424     (advise.17-2 advise.17-2 advise.17-1 advise.17-2 none)))
1425
1426
1427(deftest advise.18
1428  (progn
1429    (ccl:unadvise t)
1430    (setq *advise-var* '(none))
1431    (untrace)
1432    (fmakunbound 'generic-function-to-advise.18)
1433    (eval '(defgeneric generic-function-to-advise.18 (x y)))
1434    (eval '(defmethod generic-function-to-advise.18 ((x integer)(y integer)) :foo))
1435    (eval '(defmethod generic-function-to-advise.18 ((x symbol)(y symbol)) :bar))
1436    (ccl:advise generic-function-to-advise.18 (push 'advise.18-1 *advise-var*) :name test-1)
1437    (trace generic-function-to-advise.18)
1438    (ccl:advise generic-function-to-advise.18 (push 'advise.18-2 *advise-var*) :name test-2)
1439    (prog1
1440        (list (not (equal "" (with-output-to-string (*trace-output*)
1441                               (assert (eq :bar (generic-function-to-advise.18 'a 'b))))))
1442              *advise-var*
1443              (ccl:unadvise generic-function-to-advise.18 :name test-1)
1444              (not (equal "" (with-output-to-string (*trace-output*)
1445                               (assert (eq :foo (generic-function-to-advise.18 1 2))))))
1446              *advise-var*
1447              (untrace)
1448              (with-output-to-string (*trace-output*)
1449                (generic-function-to-advise.18 'x 'y))
1450              *advise-var*)
1451      (ccl:unadvise t)
1452      (untrace)))
1453  (t (advise.18-1 advise.18-2 none) ((generic-function-to-advise.18 :before test-1))
1454     t (advise.18-2 advise.18-1 advise.18-2 none) (generic-function-to-advise.18) ""
1455     (advise.18-2 advise.18-2 advise.18-1 advise.18-2 none)))
1456
1457
1458;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1459
1460(deftest ccl.56248a
1461    (test-compiler-warning "(defmacro ccl.56248a (&whole whole) t)")
1462  (:unused))
1463
1464(deftest ccl.56248b
1465    (test-compiler-warning "(defmacro ccl.56248b (&environment env) t)")
1466  (:unused))
1467
1468
1469(deftest ccl.ctype-hashing
1470    (let ((path #P"x"))
1471      (and (not (typep path '(member #P"x")))
1472           (typep path `(member ,path))
1473           t))
1474  t)
1475
1476
1477(deftest ccl.61783-1
1478    (test-compiler-warning "(defgeneric ccl.61783-1 (x y))
1479                            (defmethod ccl.61783-1 ((x integer)) x)")
1480  (:incongruent-method-lambda-list))
1481
1482(deftest ccl.61783-1-rev
1483    (test-compiler-warning "(defmethod ccl.61783-1-rev ((x integer)) x)
1484                            (defgeneric ccl.61783-1-rev (x y))")
1485  (:incongruent-gf-lambda-list))
1486
1487
1488(deftest ccl.61783-2
1489    (test-compiler-warning "(defmethod ccl.61783-2 ((x integer)) x)
1490                            (defmethod ccl.61783-2 ((x string) &key) x)")
1491  (:incongruent-method-lambda-list))
1492
1493(deftest ccl.61783-3
1494    (test-compiler-warning "(defgeneric ccl.61783-3 (&key a b))
1495                            (defmethod ccl.61783-3 (&key a) a)")
1496  (:gf-keys-not-accepted))
1497
1498(deftest ccl.61783-3-rev
1499    (test-compiler-warning "(defmethod ccl.61783-3-rev (&key a) a)
1500                            (defgeneric ccl.61783-3-rev (&key a b))")
1501  (:gf-keys-not-accepted))
1502
1503(deftest ccl.61783-4
1504    (test-compiler-warning "(defgeneric ccl.61783-4 (&key a))
1505                            (defgeneric ccl.61783-4 (&key a))")
1506  (:duplicate-definition))
1507
1508(deftest ccl.61783-5
1509    (test-compiler-warning "(defmethod ccl.61783-5 ((x integer) &key a) a)
1510                            (defun ccl.61783-5-caller () (ccl.61783-5 1 :a 12 :b 0))")
1511  (:environment-mismatch))
1512
1513(deftest ccl.61783-5-rev
1514    (test-compiler-warning "(defun ccl.61783-5-rev-caller () (ccl.61783-5-rev 1 :a 12 :b 0))
1515                            (defmethod ccl.61783-5-rev ((x integer) &key a) a)")
1516  (:environment-mismatch))
1517
1518
1519(deftest ccl.61783-6
1520    (test-compiler-warning "(defgeneric ccl.61783-6 (x &key a &allow-other-keys))
1521                            (defun ccl.61783-6-caller () (ccl.61783-6 1 :a 12 :b 0))")
1522  ())
1523
1524(deftest ccl.61783-6-rev
1525    (test-compiler-warning "(defun ccl.61783-6-rev-caller () (ccl.61783-6-rev 1 :a 12 :b 0))
1526                            (defgeneric ccl.61783-6-rev (x &key a &allow-other-keys))")
1527  ())
1528
1529
Note: See TracBrowser for help on using the repository browser.