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

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

Comment out a test in transition

File size: 37.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  :unknown-type-declaration)
91
92
93(defclass ccl.bug#285 () ())
94
95(defmethod initialize-instance ((c ccl.bug#285) &rest args)
96  (declare (optimize (safety 3)))
97  (apply #'call-next-method c args))
98
99(deftest ccl.bug#285
100    (typep (make-instance 'ccl.bug#285) 'ccl.bug#285)
101  t)
102
103(deftest ccl.bug#286
104    (and (test-compile '(lambda ()
105                         (typep nil '(or ccl.bug#286-unknown-type-1 null)))
106                       :hide-warnings t)
107         (test-compile '(lambda ()
108                         (ccl:require-type nil '(or ccl.bug#286-unknown-type-2 null)))
109                       :hide-warnings t)
110         :no-crash)
111  :no-crash)
112
113
114(deftest ccl.bug#287
115    (progn
116      (defmethod ccl.bug#287 (x) x)
117      (trace ccl.bug#287)
118      (let ((*trace-output* (make-broadcast-stream))) ;; don't care about trace output
119        (prog1
120            (ccl.bug#287 :no-crash)
121          (untrace))))
122  :no-crash)
123
124
125(deftest ccl.41226
126    (let ((file (test-source-file "(defmacro ccl.41226 (x) (eq (caar x)))")))
127      (handler-case
128          (test-compile file :hide-warnings t :break-on-program-errors nil)
129        ;; Might still signal due to macros being implicitly eval-when compile.
130        ;; Ok so long as it's not the make-load-form error (which is not a program-error).
131        (program-error () nil))
132      :no-crash)
133  :no-crash)
134
135(deftest ccl.bug#288
136    (let ((file (test-source-file "(prog1 (declare (ignore foo)))")))
137      (test-compile file :hide-warnings t :break-on-program-errors nil)
138      :no-crash)
139  :no-crash)
140
141(deftest ccl.bug#288-1 ;; follow-on bug, not really the same
142    (let ((file (test-source-file "(defun cl-test::ccl.bug#288-1-fn ((x integer)) x)")))
143      (test-compile file :hide-warnings t :break-on-program-errors nil :load t)
144      (handler-case
145          (progn (ccl.bug#288-1-fn 17) :no-warnings)
146        (program-error (c) (if (search "(X INTEGER)" (princ-to-string c)) :lambda-list-error c))))
147  :lambda-list-error)
148
149(deftest ccl.40055-1
150    (let ((file (test-source-file "
151
152 (defclass ccl.40055-1-class () ())
153 (eval-when (eval compile load)
154  (defstruct ccl.40055-1-struct (slot nil :type (or ccl.40055-1-class null))))
155 (defun ccl.40055-1-fn ()
156   (make-array 0 :element-type 'ccl.40055-1-struct))
157 ")))
158      (handler-case
159          (progn (test-compile file) :no-warnings)
160        (warning (c) (format nil "~a" c))))
161  :no-warnings)
162
163(deftest ccl.40055-2
164    (let ((file (test-source-file "
165
166 (defclass ccl.40055-2-class () ())
167 (defstruct ccl.40055-2-struct (slot nil :type (or ccl.40055-2-class null)))
168 (defun ccl.40055-2-class-arr ()
169   (make-array 0 :element-type 'ccl.40055-2-class))
170 (defun ccl.40055-2-struct-arr ()
171   (make-array 0 :element-type 'ccl.40055-2-struct))
172 (defun ccl.40055-2-struct-arr-2 ()
173   (make-array 0 :element-type '(or (member 17 32) ccl.40055-2-struct)))
174 (defun ccl.40055-2-fn (x) (setf (ccl.40055-2-struct-slot x) nil))
175 ")))
176      (handler-case
177          (progn (test-compile file :break-on-program-errors nil) :no-warnings)
178        (warning (c) c)))
179  :no-warnings)
180
181
182(deftest ccl.40055-3
183    (let ((file (test-source-file "
184 (defclass ccl.40055-3-class () ())
185 (defun ccl.40055-3-cfn () (require-type nil '(or ccl.40055-3-class null)))
186 (defstruct ccl.40055-3-struct)
187 (defun ccl.40055-3-rfn () (require-type nil '(or ccl.40055-3-struct null)))")))
188      (handler-case
189          (progn (test-compile file :break-on-program-errors nil) :no-warnings)
190        (warning (c) c)))
191  :no-warnings)
192
193(deftest ccl.bug#289
194    (let ((file (test-source-file "
195 (defclass ccl.bug#289-meta (standard-class) ())
196 (defclass ccl.bug#289-class () () (:metaclass ccl.bug#289-meta))")))
197      (test-compile file)
198      :no-crash)
199  :no-crash)
200
201(deftest ccl.bug#295
202    (let ((file (test-source-file "
203  (defun outer-fun ()
204     (defun inner-fun () nil)
205     (inner-fun))")))
206      (handler-case (progn (test-compile file :safety 3) :no-warnings)
207        (warning (c) c)))
208  :no-warnings)
209
210
211(deftest ccl.41836  ;; fixed in r9391
212    (let ((file (test-source-file "
213  (defvar *a* 1)
214  (defvar *b* (load-time-value *a*))")))
215      (handler-case (progn (test-compile file :break-on-program-errors nil) :no-warnings)
216        (warning (c) c)))
217  :no-warnings)
218
219
220(deftest ccl.42698  ;; fixed in r9589/r9590
221    (handler-case (schar "abc" -1) ;; used to crash hard
222      (error () :error))
223  :error)
224
225(deftest ccl.42232-1
226    (let ((file (test-source-file "
227  (defun ccl.42232-1 (foo)
228    (declare (ignore foo))
229    foo)")))
230      (handler-case (progn (test-compile file) :no-warnings)
231        (warning (c) :warning)))
232  :warning)
233
234(deftest ccl.42232-2
235    (let ((file (test-source-file "
236  (defun ccl.42232-2 ()
237    (declare (ignore bar)))")))
238      (handler-case (progn (test-compile file :break-on-program-errors nil) :no-warnings)
239        (warning (c) :warning)))
240  :warning)
241
242(deftest ccl.42830
243    (let ((*standard-output* (make-broadcast-stream)))
244      (defun cl-user::ccl.42830 (stream int colon-p at-sign-p)
245        (declare (ignore at-sign-p colon-p))
246        (check-type int integer)
247        (write int :stream stream))
248      (defun test-ccl.42830 (a b stream)
249        (format stream "~A ~/ccl.42830/" a b))
250      (and (eq (test-ccl.42830 "a" 1 t) nil)
251           (string-equal (test-ccl.42830 "a" 1 nil) "a 1")
252           :no-errors))
253  :no-errors)
254
255
256(deftest ccl.bug#305
257    (let* ((file (test-source-file "
258  (in-package :cl-test)
259  (defclass ccl.bug#305-inner () ((ccl.bug#305-inner-slot :accessor ccl.bug#305-inner-slot)))
260  (macrolet ((generator ()
261               `(defclass ccl.bug#305 (ccl.bug#305-inner)
262                  ,(loop for i from 0 to 600
263                         for slot = (intern (format nil \"CCL.BUG#305-SLOT-~~A\" i) :cl-user)
264                         collect `(,slot :initform ,i)))))
265    (generator))
266  (defmethod initialize-instance :after ((x ccl.bug#305-inner) &key)
267    (setf (ccl.bug#305-inner-slot x) 42))
268  (defun ccl.bug#305-test () (make-instance 'ccl.bug#305))"))
269           (fasl (test-compile file)))
270      (load fasl :verbose nil)
271      (ccl.bug#305-inner-slot (ccl.bug#305-test)))
272  42)
273
274(deftest ccl.42923
275    (progn
276      (fmakunbound 'ccl.42923)
277      (defmethod ccl.42923 ((x (eql 'x)) &key y &allow-other-keys)
278        (list x y) 'x)
279      (defmethod ccl.42923 ((x (eql 'foo)) &key y &allow-other-keys)
280        (list x y) 'foo)
281      (defmethod ccl.42923 ((x (eql 'bar)) &key y z a b c)
282        (list x y z (list a b c)) 'bar)
283      (ccl::maybe-hack-eql-methods #'ccl.42923)
284      (ccl:advise ccl.42923 'advise)
285      (ccl.42923 'foo :y 1 :z 2 :a 1 :b 2 :c 3))
286  foo)
287
288(deftest ccl.bug#252a
289    (let ((pn "bug252.dat"))
290      (when (probe-file pn)
291        (delete-file pn))
292      (let ((stream (open pn :direction :output :if-exists :error)))
293        (print "something" stream)
294        (close stream :abort t)
295        (probe-file pn)))
296  nil)
297
298(deftest ccl.bug#252b
299    (let ((pn "bug252.dat"))
300      (when (probe-file pn)
301        (delete-file pn))
302      (let ((stream (open pn :direction :output)))
303        (format stream "something~%")
304        (close stream))
305      (let ((stream (open pn :direction :output :if-exists :supersede)))
306        (format stream "other~%")
307        (force-output stream)
308        (close stream :abort t))
309      (with-open-file (stream pn)
310        (let ((line  (read-line stream)))
311          (if (equalp line "something") :something line))))
312  :something)
313
314(deftest ccl.bug#310
315    (remove-duplicates '(1 0 1 1 1 0 0 0 1 0 1 0 1) :end 11)
316  (0 1 0 1))
317
318(deftest ccl.bug#294-1
319  (handler-case
320      (let ((ccl::*nx-safety* 1)) ;; At safety 3, we don't know from EQ...
321        (eval '(defun cl-test::ccl.bug#294-1 (x y)
322                (eq x) y)))
323    (program-error () :program-error))
324  :program-error)
325
326(deftest ccl.bug#294-2
327  (let* ((file (test-source-file
328                "(defun cl-test::ccl.bug#294-2 (x y) (eq x) y)")))
329    (fmakunbound ' cl-test::ccl.bug#294-2)
330    (handler-case (test-compile file :break-on-program-errors t)
331      (program-error () :program-error)))
332  :program-error)
333
334(deftest ccl.buf#294-3
335  (let* ((file (test-source-file
336                "(defun cl-test::ccl.bug#294-3 (x y) (eq x) y)"))
337         (warnings nil))
338    (fmakunbound ' cl-test::ccl.bug#294-3)
339    (list
340     (let ((*error-output* (make-broadcast-stream)))
341       (handler-case
342           (handler-bind ((warning (lambda (c) (setq warnings t))))
343             (test-compile file :break-on-program-errors :defer))
344         (error (c) :error)))
345     warnings))
346  (:error t))
347
348
349(deftest ccl.buf#294-4
350  (let* ((file (test-source-file
351                "(defun cl-test::ccl.bug#294-4 (x y) (eq x) y)"))
352         (warnings nil))
353    (fmakunbound 'cl-test::ccl.bug#294-4)
354    (list
355     (let ((*error-output* (make-broadcast-stream)))
356       (handler-bind ((warning (lambda (c) (setq warnings t))))
357         (test-compile file :break-on-program-errors nil :load t))
358       (handler-case (and (fboundp 'cl-test::ccl.bug#294-4)
359                          (funcall 'cl-test::ccl.bug#294-4 1 2))
360         (program-error (c) :program-error)))
361     warnings))
362  (:program-error t))
363
364(deftest ccl.bug#315
365    (let* ((file (test-source-file
366                  "(defmethod ccl.bug#315-fn ((a sequence))
367                       (reduce #'or a :key #'identity))"))
368           (warning nil))
369      (handler-bind ((warning
370                      (lambda (c)
371                        (let ((s (princ-to-string c)))
372                          (setq warning
373                                (if (and (search "FUNCTION" s) (search "macro OR" s))
374                                  (or warning :macro-or)
375                                  c))))))
376        (test-compile file :hide-warnings t :break-on-program-errors nil :load t))
377      warning)
378  :macro-or)
379
380(deftest ccl.43101a
381    (progn
382      (untrace)
383      (fmakunbound 'ccl.43101a-fun)
384      (defun ccl.43101a-fun (x) x)
385      (trace ccl.43101a-fun)
386      (let ((file (test-source-file "(defun cl-test::ccl.43101a-fun (x) (1+ x))")))
387        (test-compile file :hide-warnings t :load t))
388      (not (equal "" (with-output-to-string (*trace-output*)
389                       (assert (eql (ccl.43101a-fun 4) 5))))))
390  t)
391
392(deftest ccl.43101b
393    (progn
394      (untrace)
395      (fmakunbound 'ccl.43101b-gf)
396      (defmethod ccl.43101b-gf (x) x)
397      (trace ccl.43101b-gf)
398      (let ((file (test-source-file "(defmethod cl-test::ccl.43101b-gf (x) (1+ x))")))
399        (test-compile file :hide-warnings t :load t))
400      (not (equal "" (with-output-to-string (*trace-output*)
401                       (assert (eql (ccl.43101b-gf 4) 5))))))
402  t)
403
404
405
406(deftest ccl.file-stream-typep
407    (with-open-file (f "temp.dat" :direction :output :if-exists :supersede)
408      (funcall (lambda (f) (let ((type (type-of f)))
409                             (and (typep f 'file-stream) (subtypep type 'file-stream) t)))
410               f))
411  t)
412
413
414(deftest ccl.complex-cos
415    (< (imagpart (cos (complex 1 1))) 0)
416  t)
417
418(deftest ccl.space-symbol
419    (let* ((list '(|aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa|
420                   | | | | | | | | | | | | | | | | | | | | | |
421                   |aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa|))
422           (result (read-from-string
423                    (with-output-to-string (s)
424                      (let ((*print-readably* t))
425                        (pprint list s))))))
426      (or (equal list result) result))
427  t)
428
429(deftest ccl.46016
430    (let ((file (test-source-file "
431  (defvar var.46016 nil)
432  (declaim (boolean var.46016))")))
433      (handler-case (progn (test-compile file :load t :break-on-program-errors nil) :no-warnings)
434        (warning (c) :warning)))
435  :no-warnings)
436
437
438#+ccl-0711
439(deftest ccl.47102
440    (handler-case
441        (progn
442          (defclass ccl.47102 () ((slot :allocation :class)))
443          ;; This happens as part of snap-reader-methods optimization
444          (ccl::optimize-make-instance-for-class-cell (gethash 'ccl.47102 ccl::%find-classes%))
445          :no-warnings)
446      (warning (c) :warning))
447  :no-warnings)
448 
449
450(deftest ccl.47762
451    (let ((file (test-source-file
452                  "(defun ccl.47762 ()
453                     (funcall (find-symbol \"TEST.47762a\" \"NO_SUCH_PACKAGE\"))
454                     (funcall (intern \"TEST.47762b\" \"NO_SUCH_PACKAGE-1\")))")))
455      (handler-case
456          (progn (test-compile file :load t) :no-error)
457        (error (c) c)))
458  :no-error)
459
460
461(deftest ccl.bug#254
462  (let ((warnings nil)
463        (test "
464(define-method-combination ccl.bug#254 ()
465         ((around (:around))
466          (before (:before))
467          (primary () :required t)
468          (after (:after)))
469   (:arguments &optional args)
470
471   (flet ((call-methods (methods)
472            (mapcar #'(lambda (method)
473                        `(call-method ,method))
474                    methods)))
475     (let ((form (if (or before after (rest primary))
476                     `(multiple-value-prog1
477                        (progn ,@(call-methods before)
478                               (call-method ,(first primary)
479                                            ,(rest primary)))
480                        ,@(call-methods (reverse after)))
481                     `(call-method ,(first primary)))))
482        `(progn (print ,args)
483       ,(if around
484           `(call-method ,(first around)
485                         (,@(rest around)
486                          (make-method ,form)))
487           form)))))
488"))
489    (handler-bind ((warning (lambda (c)
490                              (push c warnings)
491                              (muffle-warning c))))
492      (test-compile (test-source-file test)))
493    warnings)
494  ())
495
496(defun test-dup-warnings (test1 &optional test2)
497  (let ((warnings nil))
498    (handler-bind ((warning (lambda (c)
499                              (let ((msg (format nil "~a" c)))
500                                (push (if (search "Duplicate" msg :test #'equalp)
501                                        :duplicate-definition
502                                        c) warnings)
503                                (muffle-warning c)))))
504      (if test2
505        (with-compilation-unit (: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#+not-yet
626(deftest ccl.50130
627    ;; The compiler policy hack is just to have a predicatable way to catch the bug.
628    ;; It doesn't have anything to do with causing the bug to happen.
629    (let ((ccl::*default-file-compilation-policy* (ccl::new-compiler-policy #+ccl-0711 :declarations-typecheck
630                                                                            #-ccl-0711 :the-typechecks
631                                                                            t))
632          (f (test-source-file "(defun cl-test::ccl.50130-fn (arr idx)
633                                  (aref (the (or (vector fixnum) (vector (unsigned-byte 8))) arr) idx))")))
634      (test-compile f :load t)
635      (funcall 'cl-test::ccl.50130-fn (make-array 4 :element-type 'fixnum :initial-element 17) 2))
636  17)
637
638(deftest ccl.50646-bug#378
639    (progn
640      (define-method-combination ccl.50646-method-combination ()
641        ((around (:around)) (primary ()))
642        `(call-method ,(first around) ((make-method (call-method ,(first primary))))))
643      (defgeneric ccl.50646-gf (x) (:method-combination ccl.50646-method-combination))
644      (defmethod ccl.50646-gf ((x integer)) x)
645      (defmethod ccl.50646-gf :around ((x integer)) (call-next-method x))
646      (ccl.50646-gf 23))
647  23)
648
649(deftest ccl.50911
650    (progn
651      (defclass ccl.50911-class () ((slot-a :initarg :a :reader ccl.50911-slot-a)))
652      (ccl::%snap-reader-method #'ccl.50911-slot-a)
653      (ccl:finalize-inheritance (find-class 'ccl.50911-class))
654      (ccl.50911-slot-a (make-instance 'ccl.50911-class :a :test)))
655  :test)
656
657(deftest ccl.50911-a
658    (let ((called 0))
659      (defclass ccl.50911-a () ())
660      (defun ccl.50911-a-fn () (make-instance 'ccl.50911-a))
661      (defmethod initialize-instance ((x ccl.50911-a) &rest keys) keys (incf called))
662      (ccl.50911-a-fn)
663      (defmethod initialize-instance :after ((x ccl.50911-a) &rest keys) keys (incf called))
664      (ccl.50911-a-fn)
665      (ccl::optimize-make-instance-for-class-name 'ccl.50911-a)
666      (ccl.50911-a-fn)
667      called)
668  5)
669
670
671(deftest ccl.bug-misc-init
672    (progn
673      (funcall (lambda () (make-array 1 :element-type '(signed-byte 16) :initial-element -1)))
674      t)
675  t)
676 
677(deftest ccl.bug#382
678    (string= (with-output-to-string (s)
679               (funcall #'(lambda () (write-string "foobar" s :end 2))))
680             "fo")
681  t)
682 
683(deftest ccl.52006
684    (progn
685      (defclass ccl.52006-class () ((slot :initarg :slot)) (:default-initargs :slot nil))
686      (defun test-1 (args) (apply #'make-instance 'ccl.52006-class args))
687      (ccl::optimize-make-instance-for-class-name 'ccl.52006-class)
688      (slot-value (test-1 nil) 'slot))
689  nil)
690
691
692(deftest ccl.bug#387
693    (handler-case
694        (coerce #(127 0 0 256) '(simple-array (unsigned-byte 8) (*)))
695      (type-error () :type-error))
696  :type-error)
697
698(deftest ccl.49462
699    (let ((file (test-source-file "(defun ccl.49462-fn (x) x)
700(defmacro ccl.49462-macro (x) (error \"(macro ~~s)\" x))
701(ccl.49462-macro 1)")))
702      (handler-case
703          (with-compilation-unit (:override t)
704            (handler-bind ((error (lambda (c)
705                                    (declare (ignore c))
706                                    (with-open-file (f file :direction :output)
707                                      (format f "(defun ccl.49462-fn (x) x)"))
708                                    (invoke-restart 'ccl::retry-compile-file))))
709              (test-compile file :hide-warnings t))
710            nil)
711        (warning (c) c)))
712  nil)
713
714(deftest ccl.49462-redux-1
715    (let ((file (test-source-file "(defun ccl.49462-redux-1-fn (x) x)")))
716      (handler-case
717          (with-compilation-unit (:override t)
718            (test-compile file :hide-warnings t)
719            (test-compile file :hide-warnings t)
720            nil)
721        (warning (c) c)))
722  nil)
723
724
725(deftest ccl.49462-redux-2
726    (let ((file (test-source-file "(defun ccl.49462-redux-2-fn (x) x)"))
727          (warnings ()))
728      (handler-bind ((warning (lambda (c) (push c warnings))))
729        (with-compilation-unit (:override t)
730          (with-compilation-unit ()
731            (test-compile file))
732          (test-compile file :hide-warnings t)))
733      (length warnings))
734  1)
735
736
737(deftest ccl.bug-overflow-handling
738    (funcall (test-compile '(lambda ()
739                             (let ((upper-bound most-positive-fixnum))
740                               (let ((lower-bound (- (1+ upper-bound))))
741                                 lower-bound)))))
742  #.most-negative-fixnum)
743
744
745(deftest ccl.bug#412
746    (funcall (test-compile '(lambda ()
747                             (let* ((x most-negative-fixnum)
748                                    (y 1))
749                               (- x y)))))
750  #.(1- most-negative-fixnum))
751
752(deftest ccl.bug#411
753    (funcall (test-compile '(lambda ()
754                             (let ((x 0)) (+ 3416133997 x)))))
755  3416133997)
756
757(deftest ccl.51790
758    (let ((var))
759      (setq var t)
760      (list
761       (handler-case (format nil "~:[First case;second case~]" var)
762         (error () :error))
763       (handler-case (format nil "~:[First case;second case~]" (not var))
764         (error () :error))))
765  (:error :error))
766
767(deftest ccl.bug#409
768    (let ((errors ()))
769      (handler-bind ((ccl::compiler-warning
770                      (lambda (c)
771                        (push (ccl::compiler-warning-function-name c) errors)
772                        (muffle-warning c))))
773        (let ((file (test-source-file "(in-package :cl-test)
774                                       (defun ccl.bug#409a1 (x) (declare (type 17 x)) x)
775                                       (defun ccl.bug#409a2 (x) x (the 17 x))
776                                       (defun ccl.bug#409a3 (x) x (typep x 17))
777                                       (defun ccl.bug#409a4 (x) x (make-array 3 :element-type 17))
778
779                                       (defun ccl.bug#409b1 (x) (declare (type (cons number number list) x)) x)
780                                       (defun ccl.bug#409b2 (x) x (the (cons number number list) x))
781                                       (defun ccl.bug#409b3 (x) x (typep x '(cons number number list)))
782                                       (defun ccl.bug#409b4 (x) x (make-array 3 :element-type '(cons number number list)))
783
784                                       (defun ccl.bug#409c1 (x) (declare (type (sequence symbol) x)) x)
785                                       (defun ccl.bug#409c2 (x) x (the (sequence symbol) x))
786                                       (defun ccl.bug#409c3 (x) x (typep x '(sequence symbol)))
787                                       (defun ccl.bug#409c4 (x) x (make-array 3 :element-type '(sequence symbol) :initial-element x))
788                                      ")))
789          (test-compile file :hide-warnings t :break-on-program-errors nil)))
790      errors)
791  ((ccl.bug#409c4) (ccl.bug#409c3) (ccl.bug#409c2) (ccl.bug#409c1)
792   (ccl.bug#409b4) (ccl.bug#409b3) (ccl.bug#409b2) (ccl.bug#409b1)
793   (ccl.bug#409a4) (ccl.bug#409a3) (ccl.bug#409a2) (ccl.bug#409a1)))
794
795(deftest ccl.53584
796    (let ((file (test-source-file "(defclass cl-test::ccl.53584 () ((x :type (sequence integer) :initarg :x)))"))
797          (warnings ()))
798      (handler-case
799          (handler-bind ((ccl::compiler-warning
800                          (lambda (c) (push :compile-time warnings) (muffle-warning c)))
801                         (warning
802                          (lambda (c) (push :load-time warnings) (muffle-warning c))))
803            (test-compile file :hide-warnings t :load t)
804            (make-instance 'ccl.53584 :x '(17)))
805        (error () (push :run-time warnings)  warnings)))
806  (:run-time :load-time :compile-time))
807
808(deftest ccl.bug#321
809    (handler-case
810        (progn
811          (format nil "~a" (make-condition 'style-warning))
812          :no-error)
813      (error () :error))
814  :no-error)
815
816;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
817;;; ADVISE
818
819(defun function-to-advise (x) (car x))
820(defun another-function-to-advise (x) (cdr x))
821(defun (setf function-to-advise) (val arg) (setf (car arg) val))
822
823(declaim (notinline function-to-advise
824                    another-function-to-advise
825                    (setf function-to-advise)))
826
827(defvar *advise-var* nil)
828
829
830(deftest advise.1
831  (progn
832    (ccl:unadvise t)
833    (function-to-advise '(a)))
834  a)
835
836(deftest advise.2
837  (progn
838    (ccl:unadvise t)
839    (ccl:advise function-to-advise (return 'advise.2))
840    (function-to-advise '(b)))
841  advise.2)
842
843(deftest advise.3
844  (progn
845    (ccl:unadvise t)
846    (ccl:advise function-to-advise 'advised.3 :when :around :name test)
847    (assert (eq 'advised.3 (function-to-advise '(a))))
848    (prog1 (ccl:advisedp t)
849      (ccl:unadvise t)
850      (assert (null (ccl:advisedp t)))))
851  ((function-to-advise :around test)))
852
853
854(deftest advise.4
855  (progn
856    (ccl:unadvise t)
857    (ccl:advise function-to-advise (return 'advise.4) :name test)
858    (handler-bind ((warning #'muffle-warning))
859      (ccl:advise function-to-advise (return 'readvised) :name test))
860    (prog1 (ccl:advisedp t)
861      (ccl:unadvise t)
862      (assert (null (ccl:advisedp t)))))
863  ((function-to-advise :before test)))
864
865(deftest advise.4a
866  (progn
867    (ccl:unadvise t)
868    (setq *advise-var* '(none))
869    (ccl:advise function-to-advise (push 'advise.4a *advise-var*) :name test)
870    (handler-bind ((warning #'muffle-warning))
871      (ccl:advise function-to-advise (push 'readvise.4a *advise-var*) :name test))
872    (assert (eq (function-to-advise '(c)) 'c))
873    *advise-var*)
874  (readvise.4a none))
875
876(deftest advise.5
877  (progn
878    (ccl:unadvise t)
879    (setq *advise-var* '(none))
880    (ccl:advise (setf function-to-advise) (push 'advise.5 *advise-var*))
881    (prog1 (ccl:advisedp t)
882      (ccl:unadvise t)
883      (assert (null (ccl:advisedp t)))))
884  (((setf function-to-advise) :before nil)))
885
886(deftest advise.6
887  (progn
888    (ccl:unadvise t)
889    (setq *advise-var* '(none))
890    (ccl:advise (setf function-to-advise) (push 'advise.6 *advise-var*))
891    (handler-bind ((warning #'muffle-warning))
892      (ccl:advise (setf function-to-advise) (push 'readvise.6 *advise-var*)))
893    (prog1 (ccl:advisedp t)
894      (ccl:unadvise t)
895      (assert (null (ccl:advisedp t)))))
896  (((setf function-to-advise) :before nil)))
897
898(deftest advise.6a
899  (progn
900    (ccl:unadvise t)
901    (setq *advise-var* '(none))
902    (ccl:advise (setf function-to-advise) (push 'advise.6a *advise-var*) :when :after)
903    (handler-bind ((warning #'muffle-warning))
904      (ccl:advise (setf function-to-advise) (push 'readvise.6a *advise-var*) :when :after))
905    (let ((x (list nil)))
906      (list* (setf (function-to-advise x) 17)
907             (car x)
908             *advise-var*)))
909  (17 17 readvise.6a none))
910
911(deftest advise.7
912  (progn
913    (ccl:unadvise t)
914    (setq *advise-var* '(none))
915    (let ((x (list nil)))
916      (assert (eql (setf (function-to-advise x) 'a) 'a))
917      (assert (equal x '(a)))
918      *advise-var*))
919  (none))
920
921(deftest advise.8
922  (progn
923    (ccl:unadvise t)
924    (setq *advise-var* '(none))
925    (ccl:advise (setf function-to-advise) (push 'advise.8 *advise-var*))
926    (let ((x (list nil)))
927      (assert (eql (setf (function-to-advise x) 'a) 'a))
928      (assert (equal x '(a)))
929      *advise-var*))
930  (advise.8 none))
931
932(deftest advise.9
933  (progn
934    (ccl:unadvise t)
935    (setq *advise-var* '(none))
936    (ccl:advise function-to-advise (push 'advise.9 *advise-var*))
937    (ccl:advise another-function-to-advise (push 'another-advise.9 *advise-var*))
938    (assert (eql (function-to-advise '(b)) 'b))
939    (assert (eql (another-function-to-advise '(c . d)) 'd))
940    (assert (equal *advise-var* '(another-advise.9 advise.9 none)))
941    (prog1
942        (sort (copy-list (ccl:advisedp t))
943              #'(lambda (k1 k2) (string< (princ-to-string k1)
944                                         (princ-to-string k2))))
945      (ccl:unadvise t)))
946  ((another-function-to-advise :before nil) (function-to-advise :before nil)))
947
948(deftest advise.10
949  (progn
950    (ccl:unadvise t)
951    (setq *advise-var* '(none))
952    (assert (null (ccl:advisedp t)))
953    (ccl:advise function-to-advise (push 'advise.10 *advise-var*))
954    (ccl:unadvise function-to-advise)
955    (assert (null (ccl:advisedp t)))
956    (handler-bind ((warning #'muffle-warning)) (ccl:unadvise function-to-advise))
957    (assert (null (ccl:advisedp t)))
958    nil)
959  nil)
960
961(deftest advise.11
962  (progn
963    (ccl:unadvise t)
964    (ccl:advise function-to-advise  (return 17))
965    (ccl:advise another-function-to-advise (return 18))
966    (ccl:unadvise function-to-advise)
967    (ccl:unadvise another-function-to-advise)
968    (ccl:advisedp t))
969  nil)
970
971;;; advising a generic function
972
973(declaim (notinline generic-function-to-advise))
974
975(deftest advise.12
976  (progn
977    (ccl:unadvise t)
978    (setq *advise-var* '(none))
979    (eval '(defgeneric generic-function-to-advise (x y)))
980    (ccl:advise generic-function-to-advise (push 'advise.12 *advise-var*))
981    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
982  ((generic-function-to-advise :before nil)))
983
984(deftest advise.13
985  (progn
986    (ccl:unadvise t)
987    (setq *advise-var* '(none))
988    (eval '(defgeneric generic-function-to-advise (x y)))
989    (ccl:advise generic-function-to-advise (push 'advise.13 *advise-var*))
990    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
991    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
992  ((generic-function-to-advise :before nil)))
993
994(deftest advise.14
995  (progn
996    (ccl:unadvise t)
997    (setq *advise-var* '(none))
998    (eval '(defgeneric generic-function-to-advise (x y)))
999    (ccl:advise generic-function-to-advise (push 'advise.14 *advise-var*))
1000    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
1001    (assert (null (generic-function-to-advise 'a 'b)))
1002    (assert (equal *advise-var* '(advise.14 none)))
1003    (prog1
1004        (ccl:advisedp t)
1005      (ccl:unadvise generic-function-to-advise)
1006      (assert (null (ccl:advisedp t)))))
1007  ((generic-function-to-advise :before nil)))
1008
1009(declaim (notinline generic-function-to-advise2))
1010
1011(deftest advise.15
1012  (progn
1013    (ccl:unadvise t)
1014    (setq *advise-var* '(none))
1015    (let* ((gf (eval '(defgeneric generic-function-to-advise2 (x y))))
1016           (m (eval '(defmethod generic-function-to-advise2
1017                       ((x integer)(y integer))
1018                       :foo))))
1019      (eval '(defmethod generic-function-to-advise2
1020               ((x symbol)(y symbol)) :bar))
1021      (assert (eql (generic-function-to-advise2 1 2) :foo))
1022      (assert (eql (generic-function-to-advise2 'a 'b) :bar))
1023      (ccl:advise generic-function-to-advise2 (push 'advise.15 *advise-var*))
1024      (assert (equal (ccl:advisedp t) '((generic-function-to-advise2 :before nil))))
1025      (remove-method gf m)
1026      (prog1 (ccl:advisedp t) (ccl:unadvise t))))
1027  ((generic-function-to-advise2 :before nil)))
1028
1029
1030(deftest advise.16
1031  (progn
1032    (ccl:unadvise t)
1033    (setq *advise-var* '(none))
1034    (ccl:advise function-to-advise (push 'advise.16-1 *advise-var*) :name test-1)
1035    (ccl:advise function-to-advise (push 'advise.16-2 *advise-var*) :name test-2)
1036    (prog1 (cons (function-to-advise '(foo)) *advise-var*) (ccl:unadvise t)))
1037  (foo advise.16-1 advise.16-2 none))
1038
1039(deftest advise.17
1040  (progn
1041    (ccl:unadvise t)
1042    (setq *advise-var* '(none))
1043    (untrace)
1044    (ccl:advise function-to-advise (push 'advise.17-1 *advise-var*) :name test-1)
1045    (trace function-to-advise)
1046    (ccl:advise function-to-advise (push 'advise.17-2 *advise-var*) :name test-2)
1047    (prog1
1048        (list (not (equal "" (with-output-to-string (*trace-output*)
1049                               (function-to-advise '(foo)))))
1050              *advise-var*
1051              (ccl:unadvise function-to-advise :name test-1)
1052              (not (equal "" (with-output-to-string (*trace-output*)
1053                               (function-to-advise '(bar)))))
1054              *advise-var*
1055              (untrace)
1056              (with-output-to-string (*trace-output*)
1057                (function-to-advise '(bar)))
1058              *advise-var*)
1059      (ccl:unadvise t)
1060      (untrace)))
1061  (t (advise.17-1 advise.17-2 none) ((function-to-advise :before test-1))
1062     t (advise.17-2 advise.17-1 advise.17-2 none) (function-to-advise) ""
1063     (advise.17-2 advise.17-2 advise.17-1 advise.17-2 none)))
1064
1065
1066(deftest advise.18
1067  (progn
1068    (ccl:unadvise t)
1069    (setq *advise-var* '(none))
1070    (untrace)
1071    (fmakunbound 'generic-function-to-advise.18)
1072    (eval '(defgeneric generic-function-to-advise.18 (x y)))
1073    (eval '(defmethod generic-function-to-advise.18 ((x integer)(y integer)) :foo))
1074    (eval '(defmethod generic-function-to-advise.18 ((x symbol)(y symbol)) :bar))
1075    (ccl:advise generic-function-to-advise.18 (push 'advise.18-1 *advise-var*) :name test-1)
1076    (trace generic-function-to-advise.18)
1077    (ccl:advise generic-function-to-advise.18 (push 'advise.18-2 *advise-var*) :name test-2)
1078    (prog1
1079        (list (not (equal "" (with-output-to-string (*trace-output*)
1080                               (assert (eq :bar (generic-function-to-advise.18 'a 'b))))))
1081              *advise-var*
1082              (ccl:unadvise generic-function-to-advise.18 :name test-1)
1083              (not (equal "" (with-output-to-string (*trace-output*)
1084                               (assert (eq :foo (generic-function-to-advise.18 1 2))))))
1085              *advise-var*
1086              (untrace)
1087              (with-output-to-string (*trace-output*)
1088                (generic-function-to-advise.18 'x 'y))
1089              *advise-var*)
1090      (ccl:unadvise t)
1091      (untrace)))
1092  (t (advise.18-1 advise.18-2 none) ((generic-function-to-advise.18 :before test-1))
1093     t (advise.18-2 advise.18-1 advise.18-2 none) (generic-function-to-advise.18) ""
1094     (advise.18-2 advise.18-2 advise.18-1 advise.18-2 none)))
1095
1096
Note: See TracBrowser for help on using the repository browser.