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

Last change on this file since 15136 was 15136, checked in by rme, 8 years ago

Simple tests for a few recent bugs.

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