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

Last change on this file was 16812, checked in by rme, 3 years ago

Test for http://trac.clozure.com/ccl/ticket/1400

File size: 66.0 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;;; It's not clear if it's ever been different, but typechecking done
74;;; by defstruct constructors depends on optimization settings in effect
75;;; when the constructor was compiled.
76;;; Do we inline constuctors ???
77
78(locally
79    (declare (optimize (safety 3)))
80  (defstruct ccl.40055 (a 0 :type integer)))
81
82(deftest ccl.40055 ;; fixed in r9237 and r9240
83    (locally
84        (declare (optimize (safety 3)))
85      (and (signals-error (make-ccl.40055 :a nil) type-error)
86           (signals-error (setf (ccl.40055-a (make-ccl.40055)) nil) type-error)))
87  t)
88
89
90(deftest ccl.bug#235
91    (handler-case
92        (test-compile `(lambda (x)
93                         (make-array x :element-type ',(gensym))))
94      (warning (c)
95        (when (typep c 'ccl::compiler-warning)
96          (ccl::compiler-warning-warning-type c))))
97  :undefined-type)
98
99
100(defclass ccl.bug#285 () ())
101
102(defmethod initialize-instance ((c ccl.bug#285) &rest args)
103  (declare (optimize (safety 3)))
104  (apply #'call-next-method c args))
105
106(deftest ccl.bug#285
107    (typep (make-instance 'ccl.bug#285) 'ccl.bug#285)
108  t)
109
110(deftest ccl.bug#286
111    (and (test-compile '(lambda ()
112                         (typep nil '(or ccl.bug#286-unknown-type-1 null)))
113                       :hide-warnings t)
114         (test-compile '(lambda ()
115                         (ccl:require-type nil '(or ccl.bug#286-unknown-type-2 null)))
116                       :hide-warnings t)
117         :no-crash)
118  :no-crash)
119
120
121(deftest ccl.bug#287
122    (progn
123      (defmethod ccl.bug#287 (x) x)
124      (trace ccl.bug#287)
125      (let ((*trace-output* (make-broadcast-stream))) ;; don't care about trace output
126        (prog1
127            (ccl.bug#287 :no-crash)
128          (untrace))))
129  :no-crash)
130
131
132(deftest ccl.41226
133    (let ((file (test-source-file "(defmacro ccl.41226 (x) (eq (caar x)))")))
134      (handler-case
135          (test-compile file :hide-warnings t :break-on-program-errors nil)
136        ;; Might still signal due to macros being implicitly eval-when compile.
137        ;; Ok so long as it's not the make-load-form error (which is not a program-error).
138        (program-error () nil))
139      :no-crash)
140  :no-crash)
141
142(deftest ccl.bug#288
143    (let ((file (test-source-file "(prog1 (declare (ignore foo)))")))
144      (test-compile file :hide-warnings t :break-on-program-errors nil)
145      :no-crash)
146  :no-crash)
147
148(deftest ccl.bug#288-1 ;; follow-on bug, not really the same
149    (let ((file (test-source-file "(defun cl-test::ccl.bug#288-1-fn ((x integer)) x)")))
150      (test-compile file :hide-warnings t :break-on-program-errors nil :load t)
151      (handler-case
152          (progn (ccl.bug#288-1-fn 17) :no-warnings)
153        (program-error (c) (if (search "(X INTEGER)" (princ-to-string c)) :lambda-list-error c))))
154  :lambda-list-error)
155
156(deftest ccl.40055-1
157    (let ((file (test-source-file "
158
159 (defclass ccl.40055-1-class () ())
160 (eval-when (eval compile load)
161  (defstruct ccl.40055-1-struct (slot nil :type (or ccl.40055-1-class null))))
162 (defun ccl.40055-1-fn ()
163   (make-array 0 :element-type 'ccl.40055-1-struct))
164 ")))
165      (handler-case
166          (progn (test-compile file) :no-warnings)
167        (warning (c) (format nil "~a" c))))
168  :no-warnings)
169
170(deftest ccl.40055-2
171    (let ((file (test-source-file "
172
173 (defclass ccl.40055-2-class () ())
174 (defstruct ccl.40055-2-struct (slot nil :type (or ccl.40055-2-class null)))
175 (defun ccl.40055-2-class-arr ()
176   (make-array 0 :element-type 'ccl.40055-2-class))
177 (defun ccl.40055-2-struct-arr ()
178   (make-array 0 :element-type 'ccl.40055-2-struct))
179 (defun ccl.40055-2-struct-arr-2 ()
180   (make-array 0 :element-type '(or (member 17 32) ccl.40055-2-struct)))
181 (defun ccl.40055-2-fn (x) (setf (ccl.40055-2-struct-slot x) nil))
182 ")))
183      (handler-case
184          (progn (test-compile file :break-on-program-errors nil) :no-warnings)
185        (warning (c) c)))
186  :no-warnings)
187
188
189(deftest ccl.40055-3
190    (let ((file (test-source-file "
191 (defclass ccl.40055-3-class () ())
192 (defun ccl.40055-3-cfn () (require-type nil '(or ccl.40055-3-class null)))
193 (defstruct ccl.40055-3-struct)
194 (defun ccl.40055-3-rfn () (require-type nil '(or ccl.40055-3-struct null)))")))
195      (handler-case
196          (progn (test-compile file :break-on-program-errors nil) :no-warnings)
197        (warning (c) c)))
198  :no-warnings)
199
200(deftest ccl.bug#289
201    (let ((file (test-source-file "
202 (defclass ccl.bug#289-meta (standard-class) ())
203 (defclass ccl.bug#289-class () () (:metaclass ccl.bug#289-meta))")))
204      (test-compile file)
205      :no-crash)
206  :no-crash)
207
208(deftest ccl.bug#295
209    (let ((file (test-source-file "
210  (defun outer-fun ()
211     (defun inner-fun () nil)
212     (inner-fun))")))
213      (handler-case (progn (test-compile file :safety 3) :no-warnings)
214        (warning (c) c)))
215  :no-warnings)
216
217
218(deftest ccl.41836  ;; fixed in r9391
219    (let ((file (test-source-file "
220  (defvar *a* 1)
221  (defvar *b* (load-time-value *a*))")))
222      (handler-case (progn (test-compile file :break-on-program-errors nil) :no-warnings)
223        (warning (c) c)))
224  :no-warnings)
225
226
227(deftest ccl.42698  ;; fixed in r9589/r9590
228    (locally (declare (optimize (safety 3)))
229      (handler-case (schar "abc" -1) ;; used to crash hard
230        (error () :error)))
231  :error)
232
233(deftest ccl.42232-1
234    (let ((file (test-source-file "
235  (defun ccl.42232-1 (foo)
236    (declare (ignore foo))
237    foo)")))
238      (handler-case (progn (test-compile file) :no-warnings)
239        (warning (c) :warning)))
240  :warning)
241
242(deftest ccl.42232-2
243    (let ((file (test-source-file "
244  (defun ccl.42232-2 ()
245    (declare (ignore bar)))")))
246      (handler-case (progn (test-compile file :break-on-program-errors nil) :no-warnings)
247        (warning (c) :warning)))
248  :warning)
249
250(deftest ccl.42830
251    (let ((*standard-output* (make-broadcast-stream)))
252      (defun cl-user::ccl.42830 (stream int colon-p at-sign-p)
253        (declare (ignore at-sign-p colon-p))
254        (check-type int integer)
255        (write int :stream stream))
256      (defun test-ccl.42830 (a b stream)
257        (format stream "~A ~/ccl.42830/" a b))
258      (and (eq (test-ccl.42830 "a" 1 t) nil)
259           (string-equal (test-ccl.42830 "a" 1 nil) "a 1")
260           :no-errors))
261  :no-errors)
262
263
264(deftest ccl.bug#305
265    (let* ((file (test-source-file "
266  (in-package :cl-test)
267  (defclass ccl.bug#305-inner () ((ccl.bug#305-inner-slot :accessor ccl.bug#305-inner-slot)))
268  (macrolet ((generator ()
269               `(defclass ccl.bug#305 (ccl.bug#305-inner)
270                  ,(loop for i from 0 to 600
271                         for slot = (intern (format nil \"CCL.BUG#305-SLOT-~~A\" i) :cl-user)
272                         collect `(,slot :initform ,i)))))
273    (generator))
274  (defmethod initialize-instance :after ((x ccl.bug#305-inner) &key)
275    (setf (ccl.bug#305-inner-slot x) 42))
276  (defun ccl.bug#305-test () (make-instance 'ccl.bug#305))"))
277           (fasl (test-compile file)))
278      (load fasl :verbose nil)
279      (ccl.bug#305-inner-slot (ccl.bug#305-test)))
280  42)
281
282(deftest ccl.42923
283    (progn
284      (fmakunbound 'ccl.42923)
285      (defmethod ccl.42923 ((x (eql 'x)) &key y &allow-other-keys)
286        (list x y) 'x)
287      (defmethod ccl.42923 ((x (eql 'foo)) &key y &allow-other-keys)
288        (list x y) 'foo)
289      (defmethod ccl.42923 ((x (eql 'bar)) &key y z a b c)
290        (list x y z (list a b c)) 'bar)
291      (ccl::maybe-hack-eql-methods #'ccl.42923)
292      (ccl:advise ccl.42923 'advise)
293      (ccl.42923 'foo :y 1 :z 2 :a 1 :b 2 :c 3))
294  foo)
295
296(deftest ccl.bug#252a
297    (let ((pn "bug252.dat"))
298      (when (probe-file pn)
299        (delete-file pn))
300      (let ((stream (open pn :direction :output :if-exists :error)))
301        (print "something" stream)
302        (close stream :abort t)
303        (probe-file pn)))
304  nil)
305
306(deftest ccl.bug#252b
307    (let ((pn "bug252.dat"))
308      (when (probe-file pn)
309        (delete-file pn))
310      (let ((stream (open pn :direction :output)))
311        (format stream "something~%")
312        (close stream))
313      (let ((stream (open pn :direction :output :if-exists :supersede)))
314        (format stream "other~%")
315        (force-output stream)
316        (close stream :abort t))
317      (with-open-file (stream pn)
318        (let ((line  (read-line stream)))
319          (if (equalp line "something") :something line))))
320  :something)
321
322(deftest ccl.bug#310
323    (remove-duplicates '(1 0 1 1 1 0 0 0 1 0 1 0 1) :end 11)
324  (0 1 0 1))
325
326(deftest ccl.bug#294-1
327  (handler-case
328      (let ((ccl::*nx-safety* 1)) ;; At safety 3, we don't know from EQ...
329        (eval '(defun cl-test::ccl.bug#294-1 (x y)
330                (if x) y)))
331    (program-error () :program-error))
332  :program-error)
333
334(deftest ccl.bug#294-2
335  (let* ((file (test-source-file
336                "(defun cl-test::ccl.bug#294-2 (x y) (if x) y)")))
337    (fmakunbound ' cl-test::ccl.bug#294-2)
338    (handler-case (test-compile file :break-on-program-errors t)
339      (program-error () :program-error)))
340  :program-error)
341
342(deftest ccl.buf#294-3
343  (let* ((file (test-source-file
344                "(defun cl-test::ccl.bug#294-3 (x y) (if x) y)"))
345         (warnings nil))
346    (fmakunbound ' cl-test::ccl.bug#294-3)
347    (list
348     (let ((*error-output* (make-broadcast-stream)))
349       (handler-case
350           (handler-bind ((warning (lambda (c) (setq warnings t))))
351             (test-compile file :break-on-program-errors :defer))
352         (error (c) :error)))
353     warnings))
354  (:error t))
355
356
357(deftest ccl.buf#294-4
358  (let* ((file (test-source-file
359                "(defun cl-test::ccl.bug#294-4 (x y) (eq x) y)"))
360         (warnings nil))
361    (fmakunbound 'cl-test::ccl.bug#294-4)
362    (list
363     (let ((*error-output* (make-broadcast-stream)))
364       (handler-bind ((warning (lambda (c) (setq warnings t))))
365         (test-compile file :break-on-program-errors nil :load t))
366       (handler-case (and (fboundp 'cl-test::ccl.bug#294-4)
367                          (funcall 'cl-test::ccl.bug#294-4 1 2))
368         (program-error (c) :program-error)))
369     warnings))
370  (:program-error t))
371
372(deftest ccl.bug#315
373    (let* ((file (test-source-file
374                  "(defmethod ccl.bug#315-fn ((a sequence))
375                       (reduce #'or a :key #'identity))"))
376           (warning nil))
377      (handler-bind ((warning
378                      (lambda (c)
379                        (let ((s (princ-to-string c)))
380                          (setq warning
381                                (if (and (search "FUNCTION" s) (search "macro OR" s))
382                                  (or warning :macro-or)
383                                  c))))))
384        (test-compile file :hide-warnings t :break-on-program-errors nil :load t))
385      warning)
386  :macro-or)
387
388(deftest ccl.43101a
389    (progn
390      (untrace)
391      (fmakunbound 'ccl.43101a-fun)
392      (defun ccl.43101a-fun (x) x)
393      (trace ccl.43101a-fun)
394      (let ((file (test-source-file "(defun cl-test::ccl.43101a-fun (x) (1+ x))")))
395        (test-compile file :hide-warnings t :load t))
396      (not (equal "" (with-output-to-string (*trace-output*)
397                       (assert (eql (ccl.43101a-fun 4) 5))))))
398  t)
399
400(deftest ccl.43101b
401    (progn
402      (untrace)
403      (fmakunbound 'ccl.43101b-gf)
404      (defmethod ccl.43101b-gf (x) x)
405      (trace ccl.43101b-gf)
406      (let ((file (test-source-file "(defmethod cl-test::ccl.43101b-gf (x) (1+ x))")))
407        (test-compile file :hide-warnings t :load t))
408      (not (equal "" (with-output-to-string (*trace-output*)
409                       (assert (eql (ccl.43101b-gf 4) 5))))))
410  t)
411
412
413
414(deftest ccl.file-stream-typep
415    (with-open-file (f "temp.dat" :direction :output :if-exists :supersede)
416      (funcall (lambda (f) (let ((type (type-of f)))
417                             (and (typep f 'file-stream) (subtypep type 'file-stream) t)))
418               f))
419  t)
420
421
422(deftest ccl.complex-cos
423    (< (imagpart (cos (complex 1 1))) 0)
424  t)
425
426(deftest ccl.space-symbol
427    (let* ((list '(|aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa|
428                   | | | | | | | | | | | | | | | | | | | | | |
429                   |aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa|))
430           (result (read-from-string
431                    (with-output-to-string (s)
432                      (let ((*print-readably* t))
433                        (pprint list s))))))
434      (or (equal list result) result))
435  t)
436
437(deftest ccl.46016
438    (let ((file (test-source-file "
439  (defvar var.46016 nil)
440  (declaim (boolean var.46016))")))
441      (handler-case (progn (test-compile file :load t :break-on-program-errors nil) :no-warnings)
442        (warning (c) :warning)))
443  :no-warnings)
444
445
446(deftest ccl.47102
447    (handler-case
448        (progn
449          (defclass ccl.47102 () ((slot :allocation :class)))
450          ;; This happens as part of snap-reader-methods optimization
451          (ccl::optimize-make-instance-for-class-cell (gethash 'ccl.47102 ccl::%find-classes%))
452          :no-warnings)
453      (warning (c) :warning))
454  :no-warnings)
455 
456
457(deftest ccl.47762
458    (let ((file (test-source-file
459                  "(defun ccl.47762 ()
460                     (funcall (find-symbol \"TEST.47762a\" \"NO_SUCH_PACKAGE\"))
461                     (funcall (intern \"TEST.47762b\" \"NO_SUCH_PACKAGE-1\")))")))
462      (handler-case
463          (progn (test-compile file :load t) :no-error)
464        (error (c) c)))
465  :no-error)
466
467
468(deftest ccl.bug#254
469  (let ((warnings nil)
470        (test "
471(define-method-combination ccl.bug#254 ()
472         ((around (:around))
473          (before (:before))
474          (primary () :required t)
475          (after (:after)))
476   (:arguments &optional args)
477
478   (flet ((call-methods (methods)
479            (mapcar #'(lambda (method)
480                        `(call-method ,method))
481                    methods)))
482     (let ((form (if (or before after (rest primary))
483                     `(multiple-value-prog1
484                        (progn ,@(call-methods before)
485                               (call-method ,(first primary)
486                                            ,(rest primary)))
487                        ,@(call-methods (reverse after)))
488                     `(call-method ,(first primary)))))
489        `(progn (print ,args)
490       ,(if around
491           `(call-method ,(first around)
492                         (,@(rest around)
493                          (make-method ,form)))
494           form)))))
495"))
496    (handler-bind ((warning (lambda (c)
497                              (push c warnings)
498                              (muffle-warning c))))
499      (test-compile (test-source-file test)))
500    warnings)
501  ())
502
503(defun test-dup-warnings (test1 &optional test2)
504  (let ((warnings nil))
505    (handler-bind ((warning (lambda (c)
506                              (let ((msg (format nil "~a" c)))
507                                (push (if (search "Duplicate" msg :test #'equalp)
508                                        :duplicate-definition
509                                        c) warnings)
510                                (muffle-warning c)))))
511      (if test2
512        (with-compilation-unit (:override t)
513          (test-compile (test-source-file test1) :hide-warnings t)
514          (test-compile (test-source-file test2) :hide-warnings t))
515        (test-compile (test-source-file test1) :hide-warnings t)))
516    warnings))
517
518
519
520(deftest ccl.41334-1
521    (test-dup-warnings
522     "(defun test.ccl-41334-1 (x) x)
523      (defun test.ccl-41334-1 (x) x)")
524  (:duplicate-definition))
525
526
527(deftest ccl.41334-2
528    (test-dup-warnings
529     "(defmethod test.ccl-41334-2 ((x stream)) x)
530      (defmethod test.ccl-41334-2 ((x stream)) x)")
531  (:duplicate-definition))
532
533
534(deftest ccl.41334-3
535    (test-dup-warnings
536     "(defmacro test.ccl-41334-3 (x) x)
537      (defmacro test.ccl-41334-3 (x) x)")
538  (:duplicate-definition))
539
540(deftest ccl.41334-4
541    (test-dup-warnings
542     "(defgeneric test.ccl-41334-4 (x))
543      (defun test.ccl-41334-4 (x) x)")
544  (:duplicate-definition))
545
546
547(deftest ccl.41334-1a
548    (test-dup-warnings
549     "(defun test.ccl-41334-1 (x) x)"
550     "(defun test.ccl-41334-1 (x) x)")
551  (:duplicate-definition))
552
553
554(deftest ccl.41334-2a
555    (test-dup-warnings
556     "(defmethod test.ccl-41334-2 ((x stream)) x)"
557     "(defmethod test.ccl-41334-2 ((x stream)) x)")
558  (:duplicate-definition))
559
560
561(deftest ccl.41334-3a
562    (test-dup-warnings
563     "(defmacro test.ccl-41334-3 (x) x)"
564     "(defmacro test.ccl-41334-3 (x) x)")
565  (:duplicate-definition))
566
567(deftest ccl.41334-4a
568    (test-dup-warnings
569     "(defgeneric test.ccl-41334-4 (x &key foo))"
570     "(defmacro test.ccl-41334-4 (x) x)")
571  (:duplicate-definition))
572
573
574(deftest ccl.41334-5
575    (test-dup-warnings
576     "(defclass test.41334-5 () ((41334-5-slot :accessor test.41334-5-slot)))"
577     "(defmethod (setf test.41334-5-slot) (v (x test.41334-5)) v)")
578  (:duplicate-definition))
579
580
581(deftest ccl.41334-6
582    (test-dup-warnings
583     "(defun test.41334-6 () nil)"
584     "(let ((closed nil))
585        (defun test.41334-6 () closed))")
586  (:duplicate-definition))
587
588(deftest ccl.41334-7
589    (test-dup-warnings
590     "(defun test.41334-7 () nil)"
591     "(unless (fboundp 'test.31334-7)
592        (defun test.41334-7 () t))")
593  nil)
594
595(deftest ccl.41334-8
596    (test-dup-warnings
597     "(defun (setf test.41334-8) (val) val)"
598     "(let ((closed nil))
599         (defun (setf test.41334-8) (val) val closed))")
600  (:duplicate-definition))
601
602(deftest ccl.49321
603    (test-dup-warnings
604     "(defclass ccl.49321 () ((x :initarg :x)))
605      (progn
606         (print 'ccl.49321)
607         (let ((go (defun make-ccl.49321 (&key x) (make-instance 'ccl.49321 :x x))))
608            go))")
609  nil)
610
611#+not-yet
612(deftest ccl.bug#340
613    (labels ((fact (n) (if (zerop n) 1 (* n (fact (1- n))))))
614      (let ((res (format nil "~s" (log (fact 1000) 10.0d0))))
615        (or (string-equal "2567.60464" res :end2 10) res)))
616  t)
617
618(deftest ccl.bug#344
619    (flet ((try (count)
620             (let ((cname (gensym))
621                   (gname (gensym)))
622               (eval `(progn
623                        (defclass ,cname () ())
624                        ,.(loop for n from 1 to count
625                                collect `(defmethod ,gname ((arg0 ,cname) (arg1 (eql ,n)))))))
626               (handler-case (progn (funcall gname (make-instance cname) 1) nil)
627                 (error (c) :error)))))
628      (list (try 46) (try 200)))
629  (nil nil))
630
631
632(deftest ccl.50130
633    ;; The compiler policy hack is just to have a predicatable way to catch the bug.
634    ;; It doesn't have anything to do with causing the bug to happen.
635    (let ((ccl::*default-file-compilation-policy* (ccl::new-compiler-policy :declarations-typecheck
636                                                                            t))
637          (f (test-source-file "(defun cl-test::ccl.50130-fn (arr idx)
638                                  (aref (the (or (vector fixnum) (vector (unsigned-byte 8))) arr) idx))")))
639      (test-compile f :load t)
640      (funcall 'cl-test::ccl.50130-fn (make-array 4 :element-type 'fixnum :initial-element 17) 2))
641  17)
642
643(deftest ccl.50646-bug#378
644    (progn
645      (define-method-combination ccl.50646-method-combination ()
646        ((around (:around)) (primary ()))
647        `(call-method ,(first around) ((make-method (call-method ,(first primary))))))
648      (defgeneric ccl.50646-gf (x) (:method-combination ccl.50646-method-combination))
649      (defmethod ccl.50646-gf ((x integer)) x)
650      (defmethod ccl.50646-gf :around ((x integer)) (call-next-method x))
651      (ccl.50646-gf 23))
652  23)
653
654(deftest ccl.50911
655    (progn
656      (defclass ccl.50911-class () ((slot-a :initarg :a :reader ccl.50911-slot-a)))
657      (ccl::%snap-reader-method #'ccl.50911-slot-a)
658      (ccl:finalize-inheritance (find-class 'ccl.50911-class))
659      (ccl.50911-slot-a (make-instance 'ccl.50911-class :a :test)))
660  :test)
661
662(deftest ccl.50911-a
663    (let ((called 0))
664      (defclass ccl.50911-a () ())
665      (defun ccl.50911-a-fn () (make-instance 'ccl.50911-a))
666      (defmethod initialize-instance ((x ccl.50911-a) &rest keys) keys (incf called))
667      (ccl.50911-a-fn)
668      (defmethod initialize-instance :after ((x ccl.50911-a) &rest keys) keys (incf called))
669      (ccl.50911-a-fn)
670      (ccl::optimize-make-instance-for-class-name 'ccl.50911-a)
671      (ccl.50911-a-fn)
672      called)
673  5)
674
675
676(deftest ccl.bug-misc-init
677    (progn
678      (funcall (lambda () (make-array 1 :element-type '(signed-byte 16) :initial-element -1)))
679      t)
680  t)
681 
682(deftest ccl.bug#382
683    (string= (with-output-to-string (s)
684               (funcall #'(lambda () (write-string "foobar" s :end 2))))
685             "fo")
686  t)
687 
688(deftest ccl.52006
689    (progn
690      (defclass ccl.52006-class () ((slot :initarg :slot)) (:default-initargs :slot nil))
691      (defun test-1 (args) (apply #'make-instance 'ccl.52006-class args))
692      (ccl::optimize-make-instance-for-class-name 'ccl.52006-class)
693      (slot-value (test-1 nil) 'slot))
694  nil)
695
696
697(deftest ccl.bug#387
698    (handler-case
699        (coerce #(127 0 0 256) '(simple-array (unsigned-byte 8) (*)))
700      (type-error () :type-error))
701  :type-error)
702
703(deftest ccl.49462
704    (let ((file (test-source-file "(defun ccl.49462-fn (x) x)
705(defmacro ccl.49462-macro (x) (error \"(macro ~~s)\" x))
706(ccl.49462-macro 1)")))
707      (handler-case
708          (with-compilation-unit (:override t)
709            (handler-bind ((error (lambda (c)
710                                    (declare (ignore c))
711                                    (with-open-file (f file :direction :output)
712                                      (format f "(defun ccl.49462-fn (x) x)"))
713                                    (invoke-restart 'ccl::retry-compile-file))))
714              (test-compile file :hide-warnings t))
715            nil)
716        (warning (c) c)))
717  nil)
718
719(deftest ccl.49462-redux-1
720    (let ((file (test-source-file "(defun ccl.49462-redux-1-fn (x) x)")))
721      (handler-case
722          (with-compilation-unit (:override t)
723            (test-compile file :hide-warnings t)
724            (test-compile file :hide-warnings t)
725            nil)
726        (warning (c) c)))
727  nil)
728
729
730(deftest ccl.49462-redux-2
731    (let ((file (test-source-file "(defun ccl.49462-redux-2-fn (x) x)"))
732          (warnings ()))
733      (handler-bind ((warning (lambda (c) (push c warnings))))
734        (with-compilation-unit (:override t)
735          (with-compilation-unit ()
736            (test-compile file))
737          (test-compile file :hide-warnings t)))
738      (length warnings))
739  1)
740
741
742(deftest ccl.bug-overflow-handling
743    (funcall (test-compile '(lambda ()
744                             (let ((upper-bound most-positive-fixnum))
745                               (let ((lower-bound (- (1+ upper-bound))))
746                                 lower-bound)))))
747  #.most-negative-fixnum)
748
749
750(deftest ccl.bug#412
751    (funcall (test-compile '(lambda ()
752                             (let* ((x most-negative-fixnum)
753                                    (y 1))
754                               (- x y)))))
755  #.(1- most-negative-fixnum))
756
757(deftest ccl.bug#411
758    (funcall (test-compile '(lambda ()
759                             (let ((x 0)) (+ 3416133997 x)))))
760  3416133997)
761
762(deftest ccl.51790
763    (let ((var))
764      (setq var t)
765      (list
766       (handler-case (format nil "~:[First case;second case~]" var)
767         (error () :error))
768       (handler-case (format nil "~:[First case;second case~]" (not var))
769         (error () :error))))
770  (:error :error))
771
772(deftest ccl.bug#409
773    (let ((errors ()))
774      (handler-bind ((ccl::compiler-warning
775                      (lambda (c)
776                        (push (ccl::compiler-warning-function-name c) errors)
777                        (muffle-warning c))))
778        (let ((file (test-source-file "(in-package :cl-test)
779                                       (defun ccl.bug#409a1 (x) (declare (type 17 x)) x)
780                                       (defun ccl.bug#409a2 (x) x (the 17 x))
781                                       (defun ccl.bug#409a3 (x) x (typep x 17))
782                                       (defun ccl.bug#409a4 (x) x (make-array 3 :element-type 17))
783
784                                       (defun ccl.bug#409b1 (x) (declare (type (cons number number list) x)) x)
785                                       (defun ccl.bug#409b2 (x) x (the (cons number number list) x))
786                                       (defun ccl.bug#409b3 (x) x (typep x '(cons number number list)))
787                                       (defun ccl.bug#409b4 (x) x (make-array 3 :element-type '(cons number number list)))
788
789                                       (defun ccl.bug#409c1 (x) (declare (type (sequence symbol) x)) x)
790                                       (defun ccl.bug#409c2 (x) x (the (sequence symbol) x))
791                                       (defun ccl.bug#409c3 (x) x (typep x '(sequence symbol)))
792                                       (defun ccl.bug#409c4 (x) x (make-array 3 :element-type '(sequence symbol) :initial-element x))
793                                      ")))
794          (test-compile file :hide-warnings t :break-on-program-errors nil)))
795      errors)
796  ((ccl.bug#409c4) (ccl.bug#409c3) (ccl.bug#409c2) (ccl.bug#409c1)
797   (ccl.bug#409b4) (ccl.bug#409b3) (ccl.bug#409b2) (ccl.bug#409b1)
798   (ccl.bug#409a4) (ccl.bug#409a3) (ccl.bug#409a2) (ccl.bug#409a1)))
799
800(deftest ccl.53584
801    (let ((file (test-source-file "(defclass cl-test::ccl.53584 () ((x :type (sequence integer) :initarg :x)))"))
802          (warnings ()))
803      (handler-case
804          (handler-bind ((ccl::compiler-warning
805                          (lambda (c) (push :compile-time warnings) (muffle-warning c)))
806                         (warning
807                          (lambda (c) (push :load-time warnings) (muffle-warning c))))
808            (test-compile file :hide-warnings t :load t)
809            (make-instance 'ccl.53584 :x '(17)))
810        (error () (push :run-time warnings)  warnings)))
811  (:run-time :load-time :compile-time))
812
813(deftest ccl.bug#321
814    (handler-case
815        (progn
816          (format nil "~a" (make-condition 'style-warning))
817          :no-error)
818      (error () :error))
819  :no-error)
820
821(deftest ccl.loop-array
822    (let ((x nil))
823      (declare (optimize (safety 3) (speed 1)))
824      (setq x nil)
825      (handler-case
826          (loop for a across x collect a)
827        (type-error () :error)))
828  :error)
829
830(deftest ccl.loop-on
831    (locally (declare (optimize (safety 3) (speed 1)))
832      (loop for (head . tail) on '(a . b) when head collect tail))
833  (b))
834
835
836;;; This is likely to return random nonsense (without necessarily
837;;; getting a memory fault) on some platforms.
838#+bogus-test
839(deftest ccl.57900.1 ;; don't crash on simple access errors
840    (handler-case (funcall (lambda (x) (declare (optimize (safety 1) (speed 1))) (ccl::%caar x))
841                           *standard-input*)
842      (storage-condition () :storage-condition))
843  :storage-condition)
844
845(deftest ccl.57900.2
846    (handler-case (funcall (lambda (x) (declare (optimize (safety 1) (speed 1))) (ccl::%caar x))
847                           0)
848      (storage-condition () :storage-condition))
849  :storage-condition)
850
851(deftest ccl.next-method-p
852    (let ((file (test-source-file "(defmethod cl-test::ccl.next-method-gf (x) (if (next-method-p) (call-next-method) x))")))
853      (fmakunbound 'cl-test::ccl.next-method-gf)
854      (test-compile file :load t)
855      (funcall 'cl-test::ccl.next-method-gf 3))
856  3)
857
858(deftest ccl.49345-1
859    (test-dup-warnings
860     "(defclass test.ccl-49345-1 () ())
861      (defclass test.ccl-49345-1 () ())")
862  (:duplicate-definition))
863
864(deftest ccl.49345-2
865    (test-dup-warnings
866     "(defstruct (test.ccl-49345-2 (:copier  nil) (:predicate nil) (:constructor nil)))
867      (defstruct (test.ccl-49345-2 (:copier  nil) (:predicate nil) (:constructor nil)))")
868  (:duplicate-definition))
869
870(deftest ccl.49345-3
871    (test-dup-warnings
872     "(deftype test.ccl-49345-3 () 'integer)
873      (deftype test.ccl-49345-3 () 'integer)")
874  (:duplicate-definition))
875
876(deftest ccl.49345-4
877    (test-dup-warnings
878     "(defclass test.ccl-49345-4 () ())
879      (deftype test.ccl-49345-4 () 'integer)")
880  (:duplicate-definition))
881
882#+not-yet
883(deftest ccl.49345-5
884    (test-dup-warnings
885     "(defclass test.ccl-49345-5 () ())
886      (let ((closed nil))
887         (defclass test.ccl-49345-5 () ((slot :initform closed))))")
888  (:duplicate-definition))
889
890#+not-yet
891(deftest ccl.49345-6
892    (test-dup-warnings
893     "(defclass test.ccl-49345-6 () ())"
894     "(let ((closed nil))
895         (defstruct test.ccl-49345-6 (x closed)))")
896  (:duplicate-definition))
897
898(deftest ccl.49345-7
899    (test-dup-warnings
900     "(defclass test.ccl-49345-7 () ())
901      (when (find-class 'test.ccl-49345-7 nil)
902         (defclass test.ccl-49345-7 () ()))")
903  ())
904
905(defun test-compiler-warning (text &key (safety 1))
906  (let ((warnings nil))
907    (handler-bind ((ccl::compiler-warning (lambda (c)
908                                            (push (ccl::compiler-warning-warning-type c) warnings)
909                                            (muffle-warning c))))
910      (test-compile (test-source-file "~a" text) :hide-warnings t :break-on-program-errors nil :safety safety))
911    (nreverse warnings)))
912 
913(deftest ccl.49345-u1
914    (test-compiler-warning "(defun ccl.49345-u1 (x) (typep x 'ccl.49345-u1-type))")
915  (:undefined-type))
916
917(deftest ccl.49345-u2
918    (test-compiler-warning "(defun ccl.49345-u2 (x) (declare (type ccl.49345-u2-type x)) x)")
919  (:unknown-type-in-declaration))
920
921(deftest ccl.49345-u3
922    (test-compiler-warning "(defun ccl.49345-u3 (x) (the ccl.49345-u3-type x))")
923  (:unknown-type-in-declaration))
924
925(deftest ccl.49345-u4
926    (test-compiler-warning "(defun ccl.49345-u4 (x) (make-array x :element-type 'ccl.49345-u4-type))")
927  (:undefined-type))
928
929(deftest ccl.49345-u5
930    (test-compiler-warning "(defun ccl.49345-u5 (x) (coerce x 'ccl.49345-u5-type))")
931  (:undefined-type))
932
933(deftest ccl.49345-u6
934    (test-compiler-warning "(declaim (type ccl.49345-u6-type *ccl.49345-u6*))")
935  (:undefined-type))
936
937(deftest ccl.49345-i1
938    (test-compiler-warning "(defun ccl.49345-i1 (x) (typep x '(sequence integer)))")
939  (:invalid-type))
940
941(deftest ccl.49345-i2
942    (test-compiler-warning "(defun ccl.49345-i2 (x) (declare (type (sequence integer) x)) x)")
943  (:invalid-type))
944
945(deftest ccl.49345-i3
946    (test-compiler-warning "(defun ccl.49345-i3 (x) (the (sequence integer) x))")
947  (:invalid-type))
948
949(deftest ccl.49345-i4
950    (test-compiler-warning "(defun ccl.49345-i4 (x) (make-array x :element-type '(sequence integer)))")
951  (:invalid-type))
952
953(deftest ccl.49345-i5
954    (test-compiler-warning "(defun ccl.49345-i5 (x) (coerce x '(sequence integer)))")
955  (:invalid-type))
956
957(deftest ccl.49345-i6
958    (test-compiler-warning "(declaim (type (sequence integer) *ccl.49345-i6*))")
959  (:invalid-type))
960
961(deftest ccl.49345-fwd
962    (test-compiler-warning "(defun ccl.49345-fwd-fn (x ) (typep x 'ccl.49345-fwd-type))
963                            (defclass ccl.49345-fwd-type () ())")
964  ())
965
966(deftest ccl.57879-1
967    (test-compiler-warning "(defun foo (x) (declare (ccl.57879-1 'foo)) x)")
968  (:bad-declaration))
969
970(deftest ccl.57879-2
971    (handler-case
972        (test-compile (test-source-file "(proclaim '(ccl.57879-2 3))") :hide-warnings t :load t)
973      (program-error () :error))
974  :error)
975
976(deftest ccl.57879-3
977    (test-compiler-warning "(declaim (ccl.57879-3 3))")
978  (:bad-declaration))
979
980(deftest ccl.57879-4
981    (handler-case
982        (test-compile (test-source-file "(proclaim '(optimize (ccl.57879-4a ccl.57879-4b)))") :hide-warnings t :load t)
983      (program-error () :error))
984  :error)
985
986(deftest ccl.57879-5
987    (test-compiler-warning "(declaim (optimize (ccl.57879-5a ccl.57879-5b)))")
988  (:bad-declaration))
989
990;; By special dispensation, don't complain, even though can't optimize the slot reference.
991(deftest ccl.57879-6
992    (test-compiler-warning "(defstruct ccl.57879-6-struct (slot nil :type (or null ccl.57879-6-type)))
993                            (defun ccl.57879-6-fn (x) (ccl.57879-6-struct-slot x))
994
995                            (deftype ccl.57879-6-type () 'null)")
996  ())
997
998;; Same as above, but at safety 3.
999(deftest ccl.86893
1000    (test-compiler-warning "(defstruct ccl.86893-struct (slot nil :type (or null ccl.86893-type)))
1001                            (defun ccl.86893-fn (x) (ccl.86893-struct-slot x))
1002
1003                            (deftype ccl.86893-type () 'null)"
1004                           :safety 3)
1005  ())
1006
1007(deftest ccl.sbcl-bootstrap-1 ;; For sbcl bootstrap, undefined type needs to be a style warning.
1008    (multiple-value-bind (truename warnings-p serious-p)
1009        (test-compile (test-source-file "(defun ccl.sbcl-bootstrap-1a (x)
1010                                           (declare (type unknown-type-ccl.sbcl-bootstrap-1a x))
1011                                           x)")
1012                      :hide-warnings t)
1013      (declare (ignore truename))
1014      (list warnings-p serious-p))
1015    (t nil))
1016
1017
1018(deftest ccl.59726
1019    (test-compiler-warning "(defun ccl.59726-fn () #'ccl.59726-unknown)")
1020  (:undefined-function))
1021
1022(deftest ccl.bug#470
1023    (funcall (lambda ()
1024               (declare (optimize (safety 1) (speed 1)))
1025               (let ((array (make-array '(1 1) :initial-element 2.0
1026                                        :element-type 'single-float))
1027                     (var 1.0))
1028                 (setf (aref array 0 0) var
1029                       var nil))))
1030  nil)
1031
1032(deftest ccl.55959.bug#474
1033    (block test
1034      (handler-bind ((program-error (lambda (c)
1035                                      (declare (ignore c))
1036                                      (return-from test
1037                                        (handler-case (progn
1038                                                        (with-output-to-string (s)
1039                                                          (ccl:print-call-history :stream s))
1040                                                        :success)
1041                                          (error (c) c))))))
1042        (labels ((inner (x &key a)
1043                   ;; try to make sure this will use at least one saved register
1044                   (loop (concatenate x a) (concatenate x a) (concatenate x a)))
1045                 (outer (x)
1046                   ;; try to make sure this will use a saved register for X so backtrace will try to find it.
1047                   (setq x (list (list x) :bogus-key (list (list x) (list x))))
1048                   ;; call inner with bad keyword arg, to cause error before it saves its saved regs
1049                   (apply #'inner x)
1050                   x))
1051          (declare (notinline inner outer))
1052          (outer 3))))
1053  :success)
1054
1055(deftest ccl.r12217
1056    (with-input-from-string (s "123")
1057      (file-position s 3))
1058  3)
1059
1060(deftest ccl.the-with-constant-values
1061  (eval '(the (values integer) 23))
1062  23)
1063
1064(defmacro ccl.bug#543.macro (init) `(make-array (length ,init)))
1065
1066(deftest ccl.bug#543
1067    (length (funcall (lambda () (progn (the array (ccl.bug#543.macro '(a b)))))))
1068  2)
1069
1070(deftest ccl.bug#543a
1071    (handler-case
1072        (progn
1073          (test-compile '(lambda (x y)
1074                          (the fixnum (- (the fixnum (aref (the (array fixnum 1) x) (aref (the (simple-array fixnum 1) y) 0)))))))
1075          :win)
1076      (serious-condition (c) c))
1077  :win)
1078
1079(deftest ccl.r12429
1080    (let ((ccl::*print-string-length* 10))
1081      (with-standard-io-syntax
1082          (values (read-from-string (prin1-to-string "123456789012345")))))
1083  "123456789012345")
1084
1085(deftest ccl.63842a
1086    (test-compiler-warning "(defun ccl.63842a-1 () (declare (inline ccl.63842a-2)))")
1087  (:unknown-declaration-function))
1088
1089(deftest ccl.63842b
1090    (test-compiler-warning "(defun ccl.63842b-1 () (declare (dynamic-extent #'ccl.63842b-2)))")
1091  (:unknown-declaration-function))
1092
1093(deftest ccl.decl.1
1094    (test-compiler-warning "(defun ccl.decl.1 (a) (lambda () (declare (fixnum a)) a))")
1095  ())
1096
1097(deftest ccl.decl.2
1098    (test-compiler-warning "(defun ccl.decl.2 (a) (flet ((fn () (declare (fixnum a)) a)) #'fn))")
1099  ())
1100
1101(deftest ccl.decl.3
1102    (test-compiler-warning "(defun ccl.decl.3 ()
1103                              (declare (dynamic-extent #'ccl.decl.3-none-such)
1104                                       (notinline ccl.decl.3-none-other)))")
1105  (:unknown-declaration-function :unknown-declaration-function))
1106
1107(deftest ccl.decl.4
1108    (test-compiler-warning "(defun ccl.decl.4 () (flet ((fn () t) (fn1 () t)) (declare (inline fn) (dynamic-extent #'fn1)) (list (fn) (fn1))))")
1109  ())
1110
1111(deftest ccl.decl.5
1112    (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))")
1113  (:unknown-declaration-function :unknown-declaration-function))
1114
1115(deftest ccl.ftype.1
1116    (test-compiler-warning "(lambda () (declare (ftype integer ccl.ftype.1)))")
1117  (:bad-declaration))
1118
1119(deftest ccl.ftype.2
1120    (test-compiler-warning "(lambda () (declare (ftype function ccl.ftype.2)) #'ccl.ftype.2)")
1121  ())
1122
1123(deftest ccl.ftype.3
1124    (test-compiler-warning "(declaim (ftype (function (t) (values integer)) ccl.ftype.3))
1125                            (defun ccl.ftype.3-caller () (the cons (ccl.ftype.3 nil)))")
1126  (:type-conflict))
1127
1128
1129(deftest ccl.ftype.4
1130    (test-compiler-warning "(declaim (ftype (function (t) (values integer)) ccl.ftype.4))
1131                            (defun ccl.ftype.4-caller () (ccl.ftype.4))")
1132  (:ftype-mismatch))
1133
1134(deftest ccl.ftype.5
1135    (test-compiler-warning "(declaim (ftype (function (t &key (:a integer)) (values integer)) ccl.ftype.5))
1136                            (defun ccl.ftype.5-caller () (ccl.ftype.5 1 :a :x))")
1137  (:type))
1138
1139(deftest ccl.ftype.6
1140    (test-compiler-warning "(declaim (ftype (function (t &key (:a integer)) (values integer)) ccl.ftype.6))
1141                            (defun ccl.ftype.6-caller () (ccl.ftype.6 :b 17))")
1142  (:ftype-mismatch))
1143
1144
1145(deftest ccl.ftype.7
1146    (test-compiler-warning "(declaim (ftype (function (t t t) t) ccl.ftype.7))
1147                            (defun ccl.ftype.7-caller () (ccl.ftype.7))")
1148  (:ftype-mismatch))
1149
1150(deftest ccl.ftype.8
1151    (test-compiler-warning "(declaim (ftype (function (t t t) t) ccl.ftype.8))
1152                            (defun ccl.ftype.8-caller ()
1153                               (flet ((ccl.ftype.8 () t)) (ccl.ftype.8)))")
1154  ())
1155
1156(deftest ccl.ftype.9-pre
1157    (test-compiler-warning "(declaim (ftype (function (unknown) t) ccl.ftype.9-pre))")
1158  (:undefined-type))
1159
1160(deftest ccl.ftype.9
1161    (test-compiler-warning "(defun ccl.ftype.9 (x) x)
1162                            (declaim (ftype (function (unknown) t) ccl.ftype.9))
1163                            (defun ccl.ftype.9-caller () (ccl.ftype.9 17))")
1164  ;; The :undefined-type is from the declaim itself (see ccl.ftype.9-pre).  There
1165  ;; should be no added type warnings from the actual use of the fn
1166  (:undefined-type))
1167
1168(deftest ccl.ftype.10
1169    (test-compiler-warning "(defun ccl.ftype.10-caller (x)
1170                              (declare (ftype (function (t) t) ccl.ftype.10))
1171                              (ccl.ftype.10 x))")
1172  ())
1173
1174
1175(deftest ccl.ftype.11-pre
1176    (test-compiler-warning "(defun ccl.ftype.11-pre-caller (x)
1177                              (declare (ftype (function (unknown) t) ccl.ftype.11-pre))
1178                              x)")
1179  (:unknown-type-in-declaration))
1180
1181(deftest ccl.ftype.11
1182    (test-compiler-warning "(defun ccl.ftype.11-caller (x)
1183                              (declare (ftype (function (unknown) t) ccl.ftype.11))
1184                              (ccl.ftype.11 x))")
1185  ;; The :unknown-type-in-declaration is from the declare itself (see ccl.ftype.11-pre).  There
1186  ;; should be no added type warnings from the actual use of the fn
1187  (:unknown-type-in-declaration :undefined-function))
1188
1189(deftest ccl.ftype.54161
1190  (test-compiler-warning "(declaim (ftype (function (integer) (values integer)) ccl.ftype.54161))
1191  (defun ccl.ftype.54161-caller () (ccl.ftype.54161 :x))")
1192  (:type))
1193
1194
1195(deftest ccl.macroexpand-all.r12550a
1196  (ccl:macroexpand-all '(macrolet ((foo () 'macro)) (flet ((foo () (foo))) (foo))))
1197  (progn (flet ((foo () macro)) (foo))))
1198
1199(deftest ccl.macroexpand-all.r12550b
1200  (ccl:macroexpand-all '(macrolet ((foo () 'macro)) (labels ((foo () (foo))) (foo))))
1201  (progn (labels ((foo () (foo))) (foo))))
1202
1203
1204;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1205;;; ADVISE
1206
1207(defun function-to-advise (x) (car x))
1208(defun another-function-to-advise (x) (cdr x))
1209(defun (setf function-to-advise) (val arg) (setf (car arg) val))
1210
1211(declaim (notinline function-to-advise
1212                    another-function-to-advise
1213                    (setf function-to-advise)))
1214
1215(defvar *advise-var* nil)
1216
1217
1218(deftest advise.1
1219  (progn
1220    (ccl:unadvise t)
1221    (function-to-advise '(a)))
1222  a)
1223
1224(deftest advise.2
1225  (progn
1226    (ccl:unadvise t)
1227    (ccl:advise function-to-advise (return 'advise.2))
1228    (function-to-advise '(b)))
1229  advise.2)
1230
1231(deftest advise.3
1232  (progn
1233    (ccl:unadvise t)
1234    (ccl:advise function-to-advise 'advised.3 :when :around :name test)
1235    (assert (eq 'advised.3 (function-to-advise '(a))))
1236    (prog1 (ccl:advisedp t)
1237      (ccl:unadvise t)
1238      (assert (null (ccl:advisedp t)))))
1239  ((function-to-advise :around test)))
1240
1241
1242(deftest advise.4
1243  (progn
1244    (ccl:unadvise t)
1245    (ccl:advise function-to-advise (return 'advise.4) :name test)
1246    (handler-bind ((warning #'muffle-warning))
1247      (ccl:advise function-to-advise (return 'readvised) :name test))
1248    (prog1 (ccl:advisedp t)
1249      (ccl:unadvise t)
1250      (assert (null (ccl:advisedp t)))))
1251  ((function-to-advise :before test)))
1252
1253(deftest advise.4a
1254  (progn
1255    (ccl:unadvise t)
1256    (setq *advise-var* '(none))
1257    (ccl:advise function-to-advise (push 'advise.4a *advise-var*) :name test)
1258    (handler-bind ((warning #'muffle-warning))
1259      (ccl:advise function-to-advise (push 'readvise.4a *advise-var*) :name test))
1260    (assert (eq (function-to-advise '(c)) 'c))
1261    *advise-var*)
1262  (readvise.4a none))
1263
1264(deftest advise.5
1265  (progn
1266    (ccl:unadvise t)
1267    (setq *advise-var* '(none))
1268    (ccl:advise (setf function-to-advise) (push 'advise.5 *advise-var*))
1269    (prog1 (ccl:advisedp t)
1270      (ccl:unadvise t)
1271      (assert (null (ccl:advisedp t)))))
1272  (((setf function-to-advise) :before nil)))
1273
1274(deftest advise.6
1275  (progn
1276    (ccl:unadvise t)
1277    (setq *advise-var* '(none))
1278    (ccl:advise (setf function-to-advise) (push 'advise.6 *advise-var*))
1279    (handler-bind ((warning #'muffle-warning))
1280      (ccl:advise (setf function-to-advise) (push 'readvise.6 *advise-var*)))
1281    (prog1 (ccl:advisedp t)
1282      (ccl:unadvise t)
1283      (assert (null (ccl:advisedp t)))))
1284  (((setf function-to-advise) :before nil)))
1285
1286(deftest advise.6a
1287  (progn
1288    (ccl:unadvise t)
1289    (setq *advise-var* '(none))
1290    (ccl:advise (setf function-to-advise) (push 'advise.6a *advise-var*) :when :after)
1291    (handler-bind ((warning #'muffle-warning))
1292      (ccl:advise (setf function-to-advise) (push 'readvise.6a *advise-var*) :when :after))
1293    (let ((x (list nil)))
1294      (list* (setf (function-to-advise x) 17)
1295             (car x)
1296             *advise-var*)))
1297  (17 17 readvise.6a none))
1298
1299(deftest advise.7
1300  (progn
1301    (ccl:unadvise t)
1302    (setq *advise-var* '(none))
1303    (let ((x (list nil)))
1304      (assert (eql (setf (function-to-advise x) 'a) 'a))
1305      (assert (equal x '(a)))
1306      *advise-var*))
1307  (none))
1308
1309(deftest advise.8
1310  (progn
1311    (ccl:unadvise t)
1312    (setq *advise-var* '(none))
1313    (ccl:advise (setf function-to-advise) (push 'advise.8 *advise-var*))
1314    (let ((x (list nil)))
1315      (assert (eql (setf (function-to-advise x) 'a) 'a))
1316      (assert (equal x '(a)))
1317      *advise-var*))
1318  (advise.8 none))
1319
1320(deftest advise.9
1321  (progn
1322    (ccl:unadvise t)
1323    (setq *advise-var* '(none))
1324    (ccl:advise function-to-advise (push 'advise.9 *advise-var*))
1325    (ccl:advise another-function-to-advise (push 'another-advise.9 *advise-var*))
1326    (assert (eql (function-to-advise '(b)) 'b))
1327    (assert (eql (another-function-to-advise '(c . d)) 'd))
1328    (assert (equal *advise-var* '(another-advise.9 advise.9 none)))
1329    (prog1
1330        (sort (copy-list (ccl:advisedp t))
1331              #'(lambda (k1 k2) (string< (princ-to-string k1)
1332                                         (princ-to-string k2))))
1333      (ccl:unadvise t)))
1334  ((another-function-to-advise :before nil) (function-to-advise :before nil)))
1335
1336(deftest advise.10
1337  (progn
1338    (ccl:unadvise t)
1339    (setq *advise-var* '(none))
1340    (assert (null (ccl:advisedp t)))
1341    (ccl:advise function-to-advise (push 'advise.10 *advise-var*))
1342    (ccl:unadvise function-to-advise)
1343    (assert (null (ccl:advisedp t)))
1344    (handler-bind ((warning #'muffle-warning)) (ccl:unadvise function-to-advise))
1345    (assert (null (ccl:advisedp t)))
1346    nil)
1347  nil)
1348
1349(deftest advise.11
1350  (progn
1351    (ccl:unadvise t)
1352    (ccl:advise function-to-advise  (return 17))
1353    (ccl:advise another-function-to-advise (return 18))
1354    (ccl:unadvise function-to-advise)
1355    (ccl:unadvise another-function-to-advise)
1356    (ccl:advisedp t))
1357  nil)
1358
1359;;; advising a generic function
1360
1361(declaim (notinline generic-function-to-advise))
1362
1363(deftest advise.12
1364  (progn
1365    (ccl:unadvise t)
1366    (setq *advise-var* '(none))
1367    (eval '(defgeneric generic-function-to-advise (x y)))
1368    (ccl:advise generic-function-to-advise (push 'advise.12 *advise-var*))
1369    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
1370  ((generic-function-to-advise :before nil)))
1371
1372(deftest advise.13
1373  (progn
1374    (ccl:unadvise t)
1375    (setq *advise-var* '(none))
1376    (eval '(defgeneric generic-function-to-advise (x y)))
1377    (ccl:advise generic-function-to-advise (push 'advise.13 *advise-var*))
1378    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
1379    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
1380  ((generic-function-to-advise :before nil)))
1381
1382(deftest advise.14
1383  (progn
1384    (ccl:unadvise t)
1385    (setq *advise-var* '(none))
1386    (eval '(defgeneric generic-function-to-advise (x y)))
1387    (ccl:advise generic-function-to-advise (push 'advise.14 *advise-var*))
1388    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
1389    (assert (null (generic-function-to-advise 'a 'b)))
1390    (assert (equal *advise-var* '(advise.14 none)))
1391    (prog1
1392        (ccl:advisedp t)
1393      (ccl:unadvise generic-function-to-advise)
1394      (assert (null (ccl:advisedp t)))))
1395  ((generic-function-to-advise :before nil)))
1396
1397(declaim (notinline generic-function-to-advise2))
1398
1399(deftest advise.15
1400  (progn
1401    (ccl:unadvise t)
1402    (setq *advise-var* '(none))
1403    (let* ((gf (eval '(defgeneric generic-function-to-advise2 (x y))))
1404           (m (eval '(defmethod generic-function-to-advise2
1405                       ((x integer)(y integer))
1406                       :foo))))
1407      (eval '(defmethod generic-function-to-advise2
1408               ((x symbol)(y symbol)) :bar))
1409      (assert (eql (generic-function-to-advise2 1 2) :foo))
1410      (assert (eql (generic-function-to-advise2 'a 'b) :bar))
1411      (ccl:advise generic-function-to-advise2 (push 'advise.15 *advise-var*))
1412      (assert (equal (ccl:advisedp t) '((generic-function-to-advise2 :before nil))))
1413      (remove-method gf m)
1414      (prog1 (ccl:advisedp t) (ccl:unadvise t))))
1415  ((generic-function-to-advise2 :before nil)))
1416
1417
1418(deftest advise.16
1419  (progn
1420    (ccl:unadvise t)
1421    (setq *advise-var* '(none))
1422    (ccl:advise function-to-advise (push 'advise.16-1 *advise-var*) :name test-1)
1423    (ccl:advise function-to-advise (push 'advise.16-2 *advise-var*) :name test-2)
1424    (prog1 (cons (function-to-advise '(foo)) *advise-var*) (ccl:unadvise t)))
1425  (foo advise.16-1 advise.16-2 none))
1426
1427(deftest advise.17
1428  (progn
1429    (ccl:unadvise t)
1430    (setq *advise-var* '(none))
1431    (untrace)
1432    (ccl:advise function-to-advise (push 'advise.17-1 *advise-var*) :name test-1)
1433    (trace function-to-advise)
1434    (ccl:advise function-to-advise (push 'advise.17-2 *advise-var*) :name test-2)
1435    (prog1
1436        (list (not (equal "" (with-output-to-string (*trace-output*)
1437                               (function-to-advise '(foo)))))
1438              *advise-var*
1439              (ccl:unadvise function-to-advise :name test-1)
1440              (not (equal "" (with-output-to-string (*trace-output*)
1441                               (function-to-advise '(bar)))))
1442              *advise-var*
1443              (untrace)
1444              (with-output-to-string (*trace-output*)
1445                (function-to-advise '(bar)))
1446              *advise-var*)
1447      (ccl:unadvise t)
1448      (untrace)))
1449  (t (advise.17-1 advise.17-2 none) ((function-to-advise :before test-1))
1450     t (advise.17-2 advise.17-1 advise.17-2 none) (function-to-advise) ""
1451     (advise.17-2 advise.17-2 advise.17-1 advise.17-2 none)))
1452
1453
1454(deftest advise.18
1455  (progn
1456    (ccl:unadvise t)
1457    (setq *advise-var* '(none))
1458    (untrace)
1459    (fmakunbound 'generic-function-to-advise.18)
1460    (eval '(defgeneric generic-function-to-advise.18 (x y)))
1461    (eval '(defmethod generic-function-to-advise.18 ((x integer)(y integer)) :foo))
1462    (eval '(defmethod generic-function-to-advise.18 ((x symbol)(y symbol)) :bar))
1463    (ccl:advise generic-function-to-advise.18 (push 'advise.18-1 *advise-var*) :name test-1)
1464    (trace generic-function-to-advise.18)
1465    (ccl:advise generic-function-to-advise.18 (push 'advise.18-2 *advise-var*) :name test-2)
1466    (prog1
1467        (list (not (equal "" (with-output-to-string (*trace-output*)
1468                               (assert (eq :bar (generic-function-to-advise.18 'a 'b))))))
1469              *advise-var*
1470              (ccl:unadvise generic-function-to-advise.18 :name test-1)
1471              (not (equal "" (with-output-to-string (*trace-output*)
1472                               (assert (eq :foo (generic-function-to-advise.18 1 2))))))
1473              *advise-var*
1474              (untrace)
1475              (with-output-to-string (*trace-output*)
1476                (generic-function-to-advise.18 'x 'y))
1477              *advise-var*)
1478      (ccl:unadvise t)
1479      (untrace)))
1480  (t (advise.18-1 advise.18-2 none) ((generic-function-to-advise.18 :before test-1))
1481     t (advise.18-2 advise.18-1 advise.18-2 none) (generic-function-to-advise.18) ""
1482     (advise.18-2 advise.18-2 advise.18-1 advise.18-2 none)))
1483
1484
1485;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1486
1487(deftest ccl.56248a
1488    (test-compiler-warning "(defmacro ccl.56248a (&whole whole) t)")
1489  (:unused))
1490
1491(deftest ccl.56248b
1492    (test-compiler-warning "(defmacro ccl.56248b (&environment env) t)")
1493  (:unused))
1494
1495
1496(deftest ccl.ctype-hashing
1497    (let ((path #P"x"))
1498      (and (not (typep path '(member #P"x")))
1499           (typep path `(member ,path))
1500           t))
1501  t)
1502
1503
1504(deftest ccl.61783-1
1505    (test-compiler-warning "(defgeneric ccl.61783-1 (x y))
1506                            (defmethod ccl.61783-1 ((x integer)) x)")
1507  (:incongruent-method-lambda-list))
1508
1509(deftest ccl.61783-1-rev
1510    (test-compiler-warning "(defmethod ccl.61783-1-rev ((x integer)) x)
1511                            (defgeneric ccl.61783-1-rev (x y))")
1512  (:incongruent-gf-lambda-list))
1513
1514
1515(deftest ccl.61783-2
1516    (test-compiler-warning "(defmethod ccl.61783-2 ((x integer)) x)
1517                            (defmethod ccl.61783-2 ((x string) &key) x)")
1518  (:incongruent-method-lambda-list))
1519
1520(deftest ccl.61783-3
1521    (test-compiler-warning "(defgeneric ccl.61783-3 (&key a b))
1522                            (defmethod ccl.61783-3 (&key a) a)")
1523  (:gf-keys-not-accepted))
1524
1525(deftest ccl.61783-3-rev
1526    (test-compiler-warning "(defmethod ccl.61783-3-rev (&key a) a)
1527                            (defgeneric ccl.61783-3-rev (&key a b))")
1528  (:gf-keys-not-accepted))
1529
1530(deftest ccl.61783-4
1531    (test-compiler-warning "(defgeneric ccl.61783-4 (&key a))
1532                            (defgeneric ccl.61783-4 (&key a))")
1533  (:duplicate-definition))
1534
1535(deftest ccl.61783-5
1536    (test-compiler-warning "(defmethod ccl.61783-5 ((x integer) &key a) a)
1537                            (defun ccl.61783-5-caller () (ccl.61783-5 1 :a 12 :b 0))")
1538  (:environment-mismatch))
1539
1540(deftest ccl.61783-5-rev
1541    (test-compiler-warning "(defun ccl.61783-5-rev-caller () (ccl.61783-5-rev 1 :a 12 :b 0))
1542                            (defmethod ccl.61783-5-rev ((x integer) &key a) a)")
1543  (:environment-mismatch))
1544
1545
1546(deftest ccl.61783-6
1547    (test-compiler-warning "(defgeneric ccl.61783-6 (x &key a &allow-other-keys))
1548                            (defun ccl.61783-6-caller () (ccl.61783-6 1 :a 12 :b 0))")
1549  ())
1550
1551(deftest ccl.61783-6-rev
1552    (test-compiler-warning "(defun ccl.61783-6-rev-caller () (ccl.61783-6-rev 1 :a 12 :b 0))
1553                            (defgeneric ccl.61783-6-rev (x &key a &allow-other-keys))")
1554  ())
1555
1556
1557(deftest ccl.61783-7
1558    (test-compiler-warning "(defgeneric ccl.61783-7 (x &key a &allow-other-keys))
1559                            (defmethod ccl.61783-7 ((x integer) &rest args) args)")
1560  ())
1561
1562(deftest ccl.bug#592
1563    (test-compiler-warning "(macrolet ((tag () 1))
1564                              (eval-when (:compile-toplevel :load-toplevel :execute)
1565                                (assert (= 1 (tag)))))")
1566  ())
1567
1568(deftest ccl.bug#601
1569    (flet ((dispatch-macro-char-p (char &optional (rt *readtable*))
1570             (handler-case
1571                 (prog1 t
1572                   (get-dispatch-macro-character char #\x rt))
1573               (error () nil))))
1574      (let ((*readtable* (copy-readtable nil)))
1575        (values (dispatch-macro-char-p #\$)
1576                (make-dispatch-macro-character #\$ nil)
1577                (dispatch-macro-char-p #\$))))
1578  nil t t)
1579
1580(deftest ccl.bug#612-1
1581    (flet ((fn (x)
1582             (declare (optimize (safety 2) (speed 1)))
1583             (+ (load-time-value -14930786 t) 1826522792 x)
1584             ))
1585      (fn 0))
1586  1811592006)
1587
1588(deftest ccl.bug#612-2
1589    (flet ((fn (x)
1590             (declare (optimize (safety 2)))
1591             (+ (load-time-value 1) 1826522792 x)))
1592      (fn 0))
1593  1826522793)
1594
1595;;;  This test is bogus.  CCL::%INC-PTR's second argument
1596;;;  is documented to be a FIXNUM; if some 32-bit ports
1597;;;  complain that (EXPT 2 31) isn't a FIXNUM, they're
1598;;;  just being reasonable.
1599;;;  (This may have originally been intended to test the
1600;;;  x8664 compiler's ability to deal with 32-bit constants.)
1601#+bogus-test
1602(deftest ccl.bug#612-3
1603    (flet ((fn (p)
1604             (declare (optimize (safety 1) (speed 1)))
1605             (ccl::%inc-ptr p (expt 2 31))))
1606      (fn (ccl::%null-ptr))
1607      t)
1608  t)
1609
1610(deftest ccl.symbol-macrolet-special
1611    (let ((x :special))
1612      (declare (special x))
1613      (symbol-macrolet ((x :symbol-macro))
1614        (values x (locally (declare (special x)) x))))
1615  :symbol-macro
1616  :special)
1617
1618(deftest ccl.bug#617
1619    (flet ((test ()
1620             (declare (optimize (speed 1) (safety 1)))
1621             (symbol-macrolet ((inc 0.5))
1622               (loop with y = 0 do (incf y inc) while (< y 2)))))
1623      (test))
1624  nil)
1625
1626(deftest ccl.bug#620
1627    (progn
1628      (test-compile (test-source-file "(defun ccl.bug#620.fn (buckets x y)
1629                                        (declare (type (simple-array t (* *)) buckets))
1630                                        (let ((result (aref buckets x y)))
1631                                            result))"))
1632      :win)
1633  :win)
1634
1635(deftest ccl.bug#621
1636    (test-compiler-warning "(defun ccl.bug#621.fn ()
1637                              (the (values integer real) (round 2.5)))")
1638  ())
1639
1640(deftest ccl.bug-defmethod-key-warning
1641         (progn
1642           (fmakunbound 'ccl.bug-defmethod-key-warning.gf)
1643           (defmethod ccl.bug-defmethod-key-warning.gf ((x integer) &key a))
1644           (test-compiler-warning "(in-package :cl-test)
1645                                   (defmethod ccl.bug-defmethod-key-warning.gf ((x string) &key) t)
1646                                   (defun ccl.bug-defmethod-key-warning.gf-caller (x a)
1647                                     (ccl.bug-defmethod-key-warning.gf x :a a))"))
1648  nil)
1649
1650(deftest ccl.58983-1
1651    (test-compiler-warning "(defun ccl.58983-1 () (format t \"~A ~A\" 2 3 4))")
1652  (:format-error))
1653
1654(deftest ccl.58983-2
1655    (test-compiler-warning "(defun ccl.58983-2 () (format t \"~a ~a ~2:*~a\" 1 2))")
1656  ())
1657
1658(deftest ccl.58983-3
1659    (test-compiler-warning "(defun ccl.58983-3 () (format t \"~a ~a ~2:*\" 1 2))")
1660  (:format-error))
1661
1662(deftest ccl.58983-4
1663    (test-compiler-warning "(defun ccl.58983-3 () (format t \"M~A ~A ~0@*~A\" 'adam \"I'M\"))")
1664  ())
1665
1666(deftest ccl.defmethod-bad-lambda-list
1667    ;; This should warn, but not err out.
1668    (test-compiler-warning "(defmethod ccl.defmethod-bad-lambda-list ((s stream) s) s)")
1669  (:program-error))
1670
1671(deftest ccl.bug#644
1672    (progn
1673      (test-compile (test-source-file "(defun test.bug#644 (x) (declare (optimize (speed 0) (safety 2) (debug 3)) (type (or null (function (t) t)) x)) x)
1674                                     (test.bug#644 (lambda (x) x))") :load t)
1675      :win)
1676  :win)
1677
1678(deftest ccl.bug#645
1679    (let ((arr (make-array 5 :element-type 'single-float))
1680          (f (test-source-file  "~,,v,va" 30 #\null "")))
1681      (with-open-file (s f :direction :input :element-type '(unsigned-byte 8))
1682        (ccl:stream-read-ivector s arr 0 20)
1683        (aref arr 0)))
1684  0.0s0)
1685
1686(deftest ccl.bug#660
1687    (progn
1688      (fmakunbound 'test.bug#660)
1689      (test-compile
1690       (test-source-file "(defun cl-test::test.bug#660 (x)
1691                           (declare (type (unsigned-byte ~d) x))
1692                           (ash x -1000))"
1693                         target::nbits-in-word)
1694       :load t)
1695      (test.bug#660 (ash 1 (1- target::nbits-in-word))))
1696  0)
1697
1698(deftest ccl.bug#666
1699    (progn
1700      (fmakunbound 'test.bug#666)
1701      (test-compile
1702       (test-source-file "(defun cl-test::test.bug#666 (x y)
1703                            (declare (type fixnum x y))
1704                            (truncate x y))")
1705       :load t)
1706      (eql (test.bug#666 most-negative-fixnum -1) (abs most-negative-fixnum)))
1707  t)
1708
1709(deftest ccl.bug#588
1710    (let ((*readtable* (copy-readtable)))
1711      (set-macro-character #\Left-Pointing_Double_Angle_Quotation_Mark
1712                           (lambda (stream ch)
1713                             (declare (ignore stream ch))
1714                             :win))
1715      (prog1
1716          (read-from-string (coerce '(#\Left-Pointing_Double_Angle_Quotation_Mark #\space) 'string))
1717        (set-macro-character #\Left-Pointing_Double_Angle_Quotation_Mark nil)))
1718  :win)
1719
1720(deftest ccl.bug#708
1721    (flet ((one (b)
1722             (declare (type (integer 51357426816569 68500595286128) b)
1723                      (optimize (speed 1) (safety 1)))
1724             (logand b -2))
1725           (two (b)
1726             (logand b -2)))
1727      (- (one 67660763903986) (two 67660763903986)))
1728  0)
1729
1730(deftest ccl.bug#735
1731  (flet ((diff (x)
1732           (- (locally
1733                  (declare (type (integer 1000000000 2000000000) x))
1734                (lognor -10 x))
1735              (lognor -10 x))))
1736    (diff 20))
1737  0)
1738
1739(deftest ccl.bug#736
1740  (flet ((foo (a b)
1741           (declare (type (integer -314476952 -84061465) a))
1742           (declare (type (integer 16008 1204497162) b))
1743           (logand b (the integer a))))
1744    (foo -299404531 1081111751))
1745  1075867653)
1746
1747(deftest ccl.bug#828
1748  (float-sign (realpart (atan #c(-0d0 2d0))))
1749  -1d0)
1750
1751(deftest ccl.bug#829
1752  (float-sign (imagpart (atanh #c(-2d0 -0d0))))
1753  -1d0)
1754
1755(deftest ccl.bug#830
1756  (let ((val #c(1d300 1d300)))
1757    (handler-case
1758        (progn
1759          (abs val)
1760          :win)
1761      (floating-point-overflow (c) c)))
1762  :win)
1763
1764(deftest ccl.bug#831
1765  (let ((val #c(1d300 1d300)))
1766    (handler-case
1767        (progn
1768          (log val)
1769          :win)
1770      (floating-point-overflow (c) c)))
1771  :win)
1772
1773(deftest ccl.bug#832
1774  (let ((val #c(1d300 1d300)))
1775    (handler-case
1776        (progn
1777          (sqrt val)
1778          :win)
1779      (floating-point-overflow (c) c)))
1780  :win)
1781
1782(deftest ccl.bug#674
1783  (let ((val #c(1d160 1)))
1784    (handler-case
1785        (progn
1786          (/ val)
1787          :win)
1788      (floating-point-overflow (c) c)))
1789  :win)
1790
1791(deftest ccl.bug#840
1792  (progn
1793    (fmakunbound 'test.bug#840a)
1794    (fmakunbound 'test.bug#840b)
1795    (test-compile (test-source-file "(in-package :cl-test)
1796                                     (declaim (inline test.bug#840a))
1797                                     (defun test.bug#840a (x)
1798                                       (+ x 42))
1799                                     (defun test.bug#840b ()
1800                                       (flet ((test.bug#840a (x y)
1801                                                (+ x y)))
1802                                         (test.bug#840a 1 2)))")
1803                  :load t)
1804    :win)
1805  :win)
1806
1807(deftest ccl.aset3
1808  (let ((m (make-array '(3 4 5) :initial-element 0)))
1809    (setf (aref m 2 3 4) 111)
1810    (eql 111 (aref m 2 3 4)))
1811  t)
1812
1813(deftest ccl.format-goto-error
1814    (handler-case
1815        (format nil "This is an error ~*~a")
1816      (error (c)
1817        (handler-case (progn
1818                        (ccl::report-condition c (make-broadcast-stream))
1819                        :win)
1820          (error (cc) :error))))
1821  :win)
1822
1823;;; see http://clozure.com/pipermail/openmcl-devel/2011-July/012944.html
1824(deftest ccl.mul-strength-reduce-botch
1825  (flet ((foo ()
1826           (let ((a 1))
1827             (* 144115188075855873 a -1)))
1828         (bar ()
1829           (let ((a 1))
1830             (* 33554433 a -1))))
1831    (values
1832     (= (foo) -144115188075855873)
1833     (= (bar) -33554433)))
1834  t t)
1835
1836(deftest ccl.r15134
1837    (flet ((foo (a)
1838             (declare (optimize safety)
1839                      (type (signed-byte 8) a))
1840             a))
1841      (= (foo -41) -41))
1842  t)
1843
1844(deftest ccl.arm-sbit-1
1845    (flet ((foo (a)
1846             (sbit a 234)))
1847      (= 0 (foo #*1010010110010111101001001011000001010110101111001101001010110110001101000101010110000010101110011110100111001001011111000111100010010010101100111001001110111001001011001100010110001101101100011011001000001001101101001101111110101011000)))
1848  t)
1849
1850(deftest ccl.arm-sbit-2
1851    (flet ((foo (a)
1852             (sbit a 2)))
1853      (= 0 (foo #*1001)))
1854  t)
1855
1856(deftest ccl.arm-char-constant
1857    (flet ((foo ()
1858             #\LATIN_CAPITAL_LETTER_A_WITH_MACRON))
1859      (char= (foo) #\LATIN_CAPITAL_LETTER_A_WITH_MACRON))
1860  t)
1861
1862(deftest ccl.%ilogxor2
1863    (let ((b (make-array 1 :element-type '(unsigned-byte 8)))
1864          (m (make-array 1 :element-type 'fixnum :initial-element 3)))
1865      (setf (aref b 0) (logxor (aref m 0) (aref m 0)))
1866      (= (aref b 0) 0))
1867  t)
1868
1869(deftest ccl.one-arg-float
1870    (flet ((foo (x)
1871             (declare (type double-float x))
1872             (float x)))
1873      (typep (foo 1d0) 'double-float))
1874  t)
1875
1876(deftest ccl.bug#978
1877         (let ((*default-pathname-defaults* #P"/default/for/lisp"))
1878           (string= "foo.bar" (ccl:native-translated-namestring #P"foo.bar")))
1879  t)
1880
1881(deftest ccl.bug#1070.a
1882    (progn
1883      (close (open "temp.dat" :direction :output :if-exists :supersede))
1884      (and (probe-file "temp.dat")
1885           (not (let ((*default-pathname-defaults* #P"/no/such/place/"))
1886                  (probe-file "temp.dat")))))
1887 t)
1888
1889(deftest ccl.bug#1070.b
1890    (progn
1891      (close (open "temp.dat" :direction :output :if-exists :supersede))
1892      (when (probe-file "temp") (delete-file "temp"))
1893      (let ((*default-pathname-defaults* #P".dat"))
1894        (with-open-file (f "temp") f t)))
1895 t)
1896(deftest ccl.bug#1068.a
1897    (let* ((name "a\\*x")
1898           (name/ "a\\*x/")
1899           (name/* "a\\*x/*.*")
1900           (file "a\\*x/temp.dat"))
1901      (when (probe-file name)
1902        (if (ccl:directoryp name) (ccl:delete-directory name/) (delete-file name)))
1903      (ensure-directories-exist name/)
1904      ;; create a new file
1905      (close (open file :direction :output :if-exists :error))
1906      ;; supersede an old file
1907      (close (open file :direction :output :if-exists :supersede))
1908      (length (directory "a\\*x/*.*")))
1909  1)
1910
1911(deftest ccl.bug#1068.b
1912    (pathname-match-p (make-pathname :name "foo;bar") (make-pathname :name "foo;bar"))
1913  t)
1914
1915(deftest ccl.bug#1068.c
1916    (equal (namestring "a.b.c") "a.b.c")
1917  t)
1918
1919(deftest ccl.bug#1103
1920    (string-equal :a :ba :start2 1)
1921  t)
1922
1923(deftest ccl.bug#1115
1924    (mapcar (lambda (x)
1925              (ignore-errors (not (null (ccl::require-type x '(unsigned-byte 64))))))
1926            (list (ash 1 64) (ash 1 63) (ash 1 31) (ash 1 32) -1 1 4177526783))
1927  (nil t t t nil t t))
1928
1929(deftest ccl.bug#1245
1930    (let ((h (make-hash-table :test 'equalp)))
1931      (setf (gethash #(#\a) h) t)
1932      (gethash "a" h))
1933  t t)
1934
1935(deftest ccl.bug#563
1936    (= (length (format nil "~8,2e" 0.010009956)) 8)
1937  t)
1938
1939(deftest ccl.bug#1186
1940    (let ((actual
1941           (loop for d in '(1 2 3 4 5 6)
1942                 collect
1943                 (format nil "~,ve ~,ve" d 1.2345678e-10 d 1.2345678e+10)))
1944          (desired
1945           '("1.2E-10 1.2E+10"
1946             "1.23E-10 1.23E+10"
1947             "1.235E-10 1.235E+10"
1948             "1.2346E-10 1.2346E+10"
1949             "1.23457E-10 1.23457E+10"
1950             "1.234568E-10 1.234568E+10")))
1951      (mapcar 'string-equal actual desired))
1952  (t t t t t t))
1953
1954(deftest ccl.bug#1330
1955    (string= (format nil "~:(a ~~) b~)") "A ~) B")
1956  t)
1957
1958(deftest ccl.bug#1335
1959    (flet ((grad (hash x y z)
1960             (declare (type fixnum hash)
1961                      (type double-float x y z))
1962             (let* ((h (logand hash 15))
1963                    (u (if (< h 8) x y))
1964                    (v (cond ((< h 4)
1965                              y)
1966                             ((or (= h 12) (= h 14))
1967                              x)
1968                             (t z))))
1969               (the
1970                double-float
1971                (+
1972                 (if (zerop (logand h 1)) u (- u))
1973                 (if (zerop (logand h 2)) v (- v)))))))
1974      (grad 226 0.14000000000000012D0 0.0D0 0.0D0))
1975  0.14000000000000012D0)
1976
1977(deftest ccl.bug#1278
1978    (and (not (null (code-char #xfffe)))
1979         (not (null (code-char #xffff))))
1980  t)
1981
1982(deftest ccl.bug#1203
1983    (let ((p (make-pathname :directory "x")))
1984      (equalp (pathname-directory p) '(:absolute "x")))
1985  t)
1986
1987(deftest ccl.bug#1388
1988    (minusp (coerce (- (/ (1+ (expt 2 278)) (expt 2 265))) 'short-float))
1989  t)
1990
1991(deftest ccl.bug#1398
1992    (let ((a (make-array 2 :element-type '(complex double-float))))
1993      (setf (aref a 0) #c(1d0 0d0)
1994            (aref a 1) #c(1d0 0d0))
1995      (= (aref a 0) (aref a 1)))
1996  t)
1997
1998(deftest ccl.bug#1400
1999    (loop with (a b) = '(1) repeat 1 collect (list a b))
2000  ((1 nil)))
2001
2002(deftest ccl.bug#1403
2003  (loop for nbits from (1+ (integer-length most-positive-fixnum)) to 80
2004     for bound = (ash 1 nbits)
2005     nconc (loop repeat 100 as num = (random bound)
2006              unless (eql num (read-from-string (princ-to-string num))) collect num))
2007  nil)
Note: See TracBrowser for help on using the repository browser.