1 ;;;; This file is for compiler tests which have side effects (e.g.
2 ;;;; executing DEFUN) but which don't need any special side-effecting
3 ;;;; environmental stuff (e.g. DECLAIM of particular optimization
4 ;;;; settings). Similar tests which *do* expect special settings may
5 ;;;; be in files compiler-1.impure.lisp, compiler-2.impure.lisp, etc.
7 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; While most of SBCL is derived from the CMU CL system, the test
11 ;;;; files (like this one) were written from scratch after the fork
14 ;;;; This software is in the public domain and is provided with
15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
16 ;;;; more information.
18 ;; The tests in this file do not work under the legacy interpreter.
19 ;; They mostly do work in the fast interpreter, and are either harmless
20 ;; or actually reasonable things to test.
21 (when (and (eq sb-ext
:*evaluator-mode
* :interpret
)
22 (not (member :sb-fasteval
*features
*)))
23 (invoke-restart 'run-tests
::skip-file
))
25 (load "compiler-test-util.lisp")
27 ;;; Old CMU CL code assumed that the names of "keyword" arguments are
28 ;;; necessarily self-evaluating symbols, but ANSI Common Lisp allows
29 ;;; them to be any symbols, not necessarily keywords, and thus not
30 ;;; necessarily self-evaluating. Make sure that this works.
31 (defun newfangled-cons (&key
((left-thing x
)) ((right-thing y
)))
33 (with-test (:name
(:lambda-list
&key
:self-evaluating
))
34 (assert (equal (cons 1 2) (newfangled-cons 'right-thing
2 'left-thing
1))))
36 ;;; ANSI specifically says that duplicate keys are OK in lambda lists,
37 ;;; with no special exception for macro lambda lists. (As reported by
38 ;;; Pierre Mai on cmucl-imp 2001-03-30, Python didn't think so. The
39 ;;; rest of the thread had some entertainment value, at least for me
40 ;;; (WHN). The unbelievers were besmote and now even CMU CL will
41 ;;; conform to the spec in this regard. Who needs diplomacy when you
42 ;;; have brimstone?:-)
43 (defmacro ayup-duplicate-keys-are-ok-i-see-the-lite
(&key k
)
45 (with-test (:name
(:macro
:lambda-list
:duplicate
&key
:arguments
))
46 (checked-compile-and-assert ()
48 (ayup-duplicate-keys-are-ok-i-see-the-lite :k
112))
50 (checked-compile-and-assert ()
52 (ayup-duplicate-keys-are-ok-i-see-the-lite :k
'x
:k
'y
))
55 ;;; Lexically binding a name that is 1) bound to a global symbol macro
56 ;;; 2) at home in a locked package
58 (defpackage #:package-for-global-symbol-macro
(:lock t
))
59 (cl:in-package
#:package-for-global-symbol-macro
)
60 (cl:define-symbol-macro global-symbol-macro
1)
61 (cl:in-package
#:cl-user
)
63 (with-test (:name
(let define-symbol-macro
:locked package
))
64 (multiple-value-bind (fun failure-p warnings
)
66 '(lambda () (let ((package-for-global-symbol-macro::global-symbol-macro
1))
67 package-for-global-symbol-macro
::global-symbol-macro
))
68 :allow-failure t
:allow-warnings t
)
69 (declare (ignore fun
))
73 ;;; As reported by Alexey Dejneka (sbcl-devel 2002-01-30), in
74 ;;; sbcl-0.7.1 plus his patch (i.e. essentially sbcl-0.7.1.2), the
75 ;;; compiler barfed on this, blowing up in FIND-IN-ENVIRONMENT looking for
76 ;;; the LAMBDA-VAR named NUM. That was fixed in sbcl-0.7.1.3.
77 (defun parse-num (index)
84 (when (and (digs) (digs)) x
))))
86 ;;; Bug 132: The compiler used to fail to compile INTEGER-valued CATCH
87 ;;; tags. This was fixed by Alexey Dejneka in sbcl-0.7.1.14. (INTEGER
88 ;;; catch tags are still a bad idea because EQ is used to compare
89 ;;; tags, and EQ comparison on INTEGERs is unportable; but now it's a
90 ;;; compiler warning instead of a failure to compile.)
91 (with-test (:name
(compile catch
:integer-valued-tag
:bug-132
))
92 (multiple-value-bind (fun failure-p warnings style-warnings
)
93 (checked-compile '(lambda () (catch 0 (print 1331 (make-broadcast-stream))))
94 :allow-style-warnings t
)
95 (declare (ignore failure-p warnings
))
97 (assert style-warnings
)))
99 ;;; Bug 150: In sbcl-0.7.1.15, compiling this code caused a failure in
100 ;;; SB-C::ADD-TEST-CONSTRAINTS:
101 ;;; The value NIL is not of type SB-C::CONTINUATION.
102 ;;; This bug was fixed by APD in sbcl-0.7.1.30.
103 (defun bug150-test1 ()
105 (flet ((wufn () (glorp table1
4.9)))
106 (gleep *uustk
* #'wufn
"#1" (list)))
107 (if (eql (lo foomax
3.2))
109 (error "not ~S" '(eql (lo foomax
3.2))))
111 ;;; A simpler test case for bug 150: The compiler died with the
112 ;;; same type error when trying to compile this.
113 (defun bug150-test2 ()
117 ;;; bug 147, fixed by APD 2002-04-28
119 ;;; This test case used to crash the compiler, e.g. with
120 ;;; failed AVER: "(= (LENGTH (BLOCK-SUCC CALL-BLOCK)) 1)"
121 (defun bug147 (string ind
)
125 (typep (char string ind
) '(member #\
1)))
128 ;;; bug reported and fixed by Matthias Hoelzl sbcl-devel 2002-05-13
129 (defmacro foo-2002-05-13
() ''x
)
130 (eval '(foo-2002-05-13))
131 (compile 'foo-2002-05-13
)
132 (foo-2002-05-13) ; (The bug caused UNDEFINED-FUNCTION to be signalled here.)
134 ;;; floating point pain on the PPC.
136 ;;; This test case used to fail to compile on most powerpcs prior to
137 ;;; sbcl-0.7.4.2x, as floating point traps were being incorrectly
139 (defun floating-point-pain (x)
140 (declare (single-float x
))
143 ;;; bug found and fixed ca. sbcl-0.7.5.12: The INTERSECTION-TYPE
144 ;;; here satisfies "is a subtype of ARRAY-TYPE", but can't be
145 ;;; accessed with ARRAY-TYPE accessors like
146 ;;; ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE, so ARRAY-related
147 ;;; DEFTRANSFORMs died with TYPE-ERROR at compile time when
148 ;;; compiling the DEFUN here.
149 (defun stupid-input-to-smart-array-deftransforms-0-7-5-12 (v)
150 (declare (type (and simple-vector fwd-type-ref
) v
))
153 ;;; Ca. sbcl-0.7.5.15 the compiler would fail an internal consistency
154 ;;; check on this code because it expected all calls to %INSTANCE-REF
155 ;;; to be transformed away, but its expectations were dashed by perverse
156 ;;; code containing app programmer errors like this.
157 (defstruct something-known-to-be-a-struct x y
)
158 (with-test (:name
(compile defstruct
:instance-ref
))
161 ;; Python sees the structure accessor on the
162 ;; known-not-to-be-a-struct A5 value and is very, very
163 ;; disappointed in you. (But it doesn't signal BUG any
167 (cond (t (a4 a2 a3
))))
169 (declare (type (or simple-vector null
) a5 a6
))
170 (something-known-to-be-a-struct-x a5
))
174 (cond ((and (funcall a12 a2
)
179 (let ((a15 (a1 a2 a3
)))
182 (values #'a17
#'a11
)))
183 :allow-failure t
:allow-warnings t
:allow-style-warnings t
))))
185 ;;; On the SPARC, there was an erroneous definition of some VOPs used
186 ;;; to compile LOGANDs, which would lead to compilation of the
187 ;;; following function giving rise to a compile-time error (bug
188 ;;; spotted and fixed by Raymond Toy for CMUCL)
189 (defun logand-sparc-bogons (a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10
)
190 (declare (type (unsigned-byte 32) a0
)
191 (type (signed-byte 32) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10
)
192 ;; to ensure that the call is a candidate for
194 (optimize (speed 3) (safety 0) (compilation-speed 0) (debug 0)))
196 ;; the call that fails compilation
198 ;; a call to prevent the other arguments from being optimized away
199 (logand a1 a2 a3 a4 a5 a6 a7 a8 a9
)))
201 ;;; bug 192, reported by Einar Floystad Dorum sbcl-devel 2002-08-14,
202 ;;; fixed in sbcl-0.7.6.26: Compiling this function in 0.7.6 caused
203 ;;; the compiler to try to constant-fold DATA-VECTOR-REF, which is OK,
204 ;;; except that there was no non-VOP definition of DATA-VECTOR-REF, so
216 (DECLARE (IGNORABLE S E
))
226 (DECLARE (IGNORABLE S E
))
227 (WHEN (EQL #\b E
) (G910 (1+ I
)))))))
234 (DECLARE (IGNORABLE S
))
237 (G908 I
))) "abcdefg" 0 (length "abcdefg")))
239 ;;; bugs #65, #70, and #109, closed by APD's patch sbcl-devel 2002-08-17
241 ;;; This was "YA code deletion bug" whose symptom was the failure of
243 ;;; (EQ (C::LAMBDA-TAIL-SET C::CALLER)
244 ;;; (C::LAMBDA-TAIL-SET (C::LAMBDA-HOME C::CALLEE)))
246 (defun bug65-1 (termx termy
) ; from Carl Witty on submit bugs list, debian.org
248 ((alpha-equal-bound-term-lists (listx listy
)
249 (or (and (null listx
) (null listy
))
251 (let ((bindings-x (bindings-of-bound-term (car listx
)))
252 (bindings-y (bindings-of-bound-term (car listy
))))
253 (if (and (null bindings-x
) (null bindings-y
))
254 (alpha-equal-terms (term-of-bound-term (car listx
))
255 (term-of-bound-term (car listy
)))
256 (and (= (length bindings-x
) (length bindings-y
))
258 (enter-binding-pairs (bindings-of-bound-term (car listx
))
259 (bindings-of-bound-term (car listy
)))
260 (alpha-equal-terms (term-of-bound-term (car listx
))
261 (term-of-bound-term (car listy
)))
262 (exit-binding-pairs (bindings-of-bound-term (car listx
))
263 (bindings-of-bound-term (car listy
)))))))
264 (alpha-equal-bound-term-lists (cdr listx
) (cdr listy
)))))
266 (alpha-equal-terms (termx termy
)
267 (if (and (variable-p termx
)
269 (equal-bindings (id-of-variable-term termx
)
270 (id-of-variable-term termy
))
271 (and (equal-operators-p (operator-of-term termx
) (operator-of-term termy
))
272 (alpha-equal-bound-term-lists (bound-terms-of-term termx
)
273 (bound-terms-of-term termy
))))))
277 (with-variable-invocation (alpha-equal-terms termx termy
))))))
278 (defun bug65-2 () ; from Bob Rogers cmucl-imp 1999-07-28
279 ;; Given an FSSP alignment file named by the argument . . .
280 (labels ((get-fssp-char ()
284 ;; Stub body, enough to tickle the bug.
285 (list (read-fssp-char)
287 (defun bug70 ; from David Young cmucl-help 30 Nov 2000
288 (item sequence
&key
(test #'eql
))
289 (labels ((find-item (obj seq test
&optional
(val nil
))
290 (let ((item (first seq
)))
293 ((funcall test obj item
)
299 (nconc val
`(,item
))))))))
300 (find-item item sequence test
)))
301 (defun bug109 () ; originally from CMU CL bugs collection, reported as
302 ; SBCL bug by MNA 2001-06-25
307 ;; Uncomment and it works
311 ;;; bug 192a, fixed by APD "more strict type checking" patch
312 ;;; (sbcl-devel 2002-08-07)
314 (declare (optimize (speed 0) (safety 3)))
315 ;; Even with bug 192a, this declaration was checked as an assertion.
319 ;; Because of bug 192a, this declaration was trusted without checking.
320 (declare (single-float x
))
322 (with-test (:name
(declare type
:bug-192a
))
323 (assert-error (bug192a nil
) type-error
)
324 (multiple-value-bind (result error
) (ignore-errors (bug192a 100))
325 (assert (null result
))
326 (assert (equal (type-error-expected-type error
) 'single-float
))))
328 ;;; bug 194, fixed in part by APD "more strict type checking" patch
329 ;;; (sbcl-devel 2002-08-07)
330 (with-test (:name
(the :bug-194
))
331 (assert-error (multiple-value-prog1 (progn (the real
'(1 2 3)))) type-error
)
332 (assert-error (the real
'(1 2 3)) type-error
))
337 (arg2 (identity (the real
#(1 2 3)))))
338 (if (< arg1 arg2
) arg1 arg2
)))))
339 (with-test (:name
(the :bug-194d
))
340 (assert (eq (bug194d) t
)))
343 ;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden
344 ;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18.
346 (multiple-value-bind (function failure-p
)
347 (checked-compile form
:allow-failure t
)
349 (assert-error (funcall function
) program-error
))))
351 (with-test (:name
(compile symbol-macrolet
:bug-48a
))
353 ;; not interested in the package lock violation here
354 (declare (sb-ext:disable-package-locks t
))
355 (symbol-macrolet ((t nil
)) t
))))
357 (with-test (:name
(compile symbol-macrolet
:bug-48b
))
359 ;; not interested in the package lock violation here
360 (declare (sb-ext:disable-package-locks
*standard-input
*))
361 (symbol-macrolet ((*standard-input
* nil
))
364 (with-test (:name
(compile symbol-macrolet
:bug-48c
))
366 (symbol-macrolet ((s nil
)) (declare (special s
)) s
)))))
369 ;;; bug 120a: Turned out to be constraining code looking like (if foo
370 ;;; <X> <X>) where <X> was optimized by the compiler to be the exact
371 ;;; same block in both cases, but not turned into (PROGN FOO <X>).
372 ;;; Fixed by APD in sbcl-0.7.7.2, who provided this test:
373 (declaim (inline dont-constrain-if-too-much
))
374 (defun dont-constrain-if-too-much (frame up-frame
)
375 (declare (optimize (speed 3) (safety 1) (debug 1)))
376 (if (or (not frame
) t
)
379 (defun dont-constrain-if-too-much-aux (x y
)
380 (declare (optimize (speed 3) (safety 1) (debug 1)))
381 (if x t
(if y t
(dont-constrain-if-too-much x y
))))
383 (with-test (:name
(if :constraint-propagation
:bug-120a
))
384 (assert (null (dont-constrain-if-too-much-aux nil nil
))))
386 ;;; TYPE-ERROR confusion ca. sbcl-0.7.7.24, reported and fixed by
387 ;;; APD sbcl-devel 2002-09-14
388 (defun exercise-0-7-7-24-bug (x)
389 (declare (integer x
))
391 (setf y
(the single-float
(if (> x
0) x
3f0
)))
393 (with-test (:name
(type-error :0.7.7.24))
394 (assert-error (exercise-0-7-7-24-bug 4) type-error
)
395 (assert (equal (exercise-0-7-7-24-bug -
4) '(3f0 3f0
))))
397 ;;; non-intersecting type declarations were DWIMing in a confusing
398 ;;; fashion until sbcl-0.7.7.28, when APD reported and fixed the
400 (defun non-intersecting-the (x)
402 (setf y
(the single-float
(the integer x
)))
405 (with-test (:name
:non-intersecting-the
)
406 (assert-error (non-intersecting-the 3) type-error
)
407 (assert-error (non-intersecting-the 3f0
) type-error
))
409 ;;; until 0.8.2 SBCL did not check THEs in arguments
410 (defun the-in-arguments-aux (x)
412 (defun the-in-arguments-1 (x)
413 (list x
(the-in-arguments-aux (the (single-float 0s0
) x
))))
414 (defun the-in-arguments-2 (x)
415 (list x
(the-in-arguments-aux (the single-float x
))))
417 (with-test (:name
(the :argument
))
418 (assert-error (the-in-arguments-1 1) type-error
)
419 (assert-error (the-in-arguments-2 1) type-error
))
421 ;;; bug 153: a hole in a structure slot type checking
422 (declaim (optimize safety
))
424 (bla 0 :type fixnum
))
426 (let ((foo (make-foo153)))
427 (setf (foo153-bla foo
) '(1 .
1))
428 (format t
"Is ~a of type ~a a cons? => ~a~%"
430 (type-of (foo153-bla foo
))
431 (consp (foo153-bla foo
)))))
433 (let ((foo (make-foo153)))
434 (setf (foo153-bla foo
) x
)
435 (format t
"Is ~a of type ~a a cons? => ~a~%"
437 (type-of (foo153-bla foo
))
438 (consp (foo153-bla foo
)))))
440 (with-test (:name
(:name defstruct
:slot
:type
:bug-153
))
441 (assert-error (bug153-1) type-error
)
442 (assert-error (bug153-2 '(1 .
1)) type-error
))
444 ;;;; bug 110: the compiler flushed the argument type test and the default
445 ;;;; case in the cond.
447 ;(locally (declare (optimize (safety 3) (speed 2)))
449 ; (declare (optimize (safety 2) (speed 3)))
450 ; (declare (type (or string stream) x))
451 ; (cond ((typep x 'string) 'string)
452 ; ((typep x 'stream) 'stream)
456 ;(multiple-value-bind (result condition)
457 ; (ignore-errors (bug110 0))
458 ; (declare (ignore result))
459 ; (assert (typep condition 'type-error)))
461 ;;; bug 202: the compiler failed to compile a function, which derived
462 ;;; type contradicted declared.
463 (declaim (ftype (function () null
) bug202
))
467 ;;; bugs 178, 199: compiler failed to compile a call of a function
468 ;;; with a hairy type
470 (funcall (the function
(the standard-object x
))))
472 (defun bug199-aux (f)
473 (eq nil
(funcall f
)))
476 (declare (type (and function
(satisfies bug199-aux
)) f
))
479 (with-test (:name
(declaim &optional
&rest
:bogus style-warning
))
482 "(declaim (ftype (function (symbol &optional t &rest t)) foo))
483 (defun foo (x &optional y &rest z)
484 (declare (ignore x y z)))"
488 ;;; check non-toplevel DEFMACRO
489 (defvar *defmacro-test-status
* nil
)
491 (with-test (:name
(compile-file defmacro
))
492 (fmakunbound 'defmacro-test-aux
)
493 (let* ((src "defmacro-test.lisp")
494 (obj (scratch-file-name "fasl")))
497 (compile-file src
:output-file obj
)
498 (assert (equal *defmacro-test-status
* '(function a
)))
499 (setq *defmacro-test-status
* nil
)
501 (assert (equal *defmacro-test-status
* nil
))
502 (macroexpand '(defmacro-test-aux 'a
))
503 (assert (equal *defmacro-test-status
* '(macro 'a z-value
)))
504 (eval '(defmacro-test-aux 'a
))
505 (assert (equal *defmacro-test-status
* '(expanded 'a z-value
))))
506 (ignore-errors (delete-file obj
)))))
508 ;;; bug 204: EVAL-WHEN inside a local environment
509 (defvar *bug204-test-status
*)
511 (with-test (:name
(compile-file eval-when
:local-environment
:bug-204
))
512 (let* ((src "bug204-test.lisp")
513 (obj (scratch-file-name "fasl")))
516 (setq *bug204-test-status
* nil
)
517 (compile-file src
:output-file obj
:verbose nil
:print nil
)
518 (assert (equal *bug204-test-status
* '((:expanded
:load-toplevel
)
519 (:called
:compile-toplevel
)
520 (:expanded
:compile-toplevel
))))
521 (setq *bug204-test-status
* nil
)
523 (assert (equal *bug204-test-status
* '((:called
:load-toplevel
)))))
524 (ignore-errors (delete-file obj
)))))
526 ;;; toplevel SYMBOL-MACROLET
527 ;;; FIXME: I didn't look into why this fails in the interpreter, but it does.
528 (defvar *symbol-macrolet-test-status
*)
530 (with-test (:name
(compile-file symbol-macrolet
) :skipped-on
:interpreter
)
531 (let* ((src "symbol-macrolet-test.lisp")
532 (obj (scratch-file-name "fasl")))
535 (setq *symbol-macrolet-test-status
* nil
)
536 (compile-file src
:output-file obj
:verbose nil
:print nil
)
537 (assert (equal *symbol-macrolet-test-status
*
539 (setq *symbol-macrolet-test-status
* nil
)
541 (assert (equal *symbol-macrolet-test-status
* '(2))))
542 (ignore-errors (delete-file obj
)))))
544 ;;; On the x86, this code failed to compile until sbcl-0.7.8.37:
545 (defun x86-assembler-failure (x)
546 (declare (optimize (speed 3) (safety 0)))
547 (eq (setf (car x
) 'a
) nil
))
549 ;;; bug 211: :ALLOW-OTHER-KEYS
550 (defun bug211d (&key
(x :x x-p
) ((:allow-other-keys y
) :y y-p
))
553 (with-test (:name
(:allow-other-keys
:bug-211d
))
554 (assert (equal (bug211d) '(:x nil
:y nil
)))
555 (assert (equal (bug211d :x
1) '(1 t
:y nil
)))
556 (assert-error (bug211d :y
2) program-error
)
557 (assert (equal (bug211d :y
2 :allow-other-keys t
:allow-other-keys nil
)
559 (assert-error (bug211d :y
2 :allow-other-keys nil
) program-error
))
563 (flet ((test (&key
(x :x x-p
) ((:allow-other-keys y
) :y y-p
))
565 (assert (equal (test) '(:x nil
:y nil
)))
566 (assert (equal (test :x
1) '(1 t
:y nil
)))
567 (assert (equal (test :y
2 :allow-other-keys
11 :allow-other-keys nil
)
570 (with-test (:name
(compile :lambda-list
:bug-211b
))
573 (with-test (:name
(compile :lambda-list
:bug-211c
))
574 (checked-compile-and-assert ()
576 (flet ((test (&key
(x :x x-p
))
578 (assert (equal (test) '(:x nil
)))
579 (assert (equal (test :x
1) '(1 t
)))
580 (assert (equal (test :y
2 :allow-other-keys
11 :allow-other-keys nil
)
585 (with-test (:name
(compile :lambda-list
:allow-other-keys
586 :bug-211
:do-not-allow
))
587 (dolist (form '((test :y
2)
588 (test :y
2 :allow-other-keys nil
)
589 (test :y
2 :allow-other-keys nil
:allow-other-keys t
)))
590 (multiple-value-bind (result failure-p
)
593 (flet ((test (&key
(x :x x-p
) ((:allow-other-keys y
) :y y-p
))
596 :allow-failure t
:allow-warnings t
)
598 (assert-error (funcall result
) program-error
))))
600 ;;; bug 217: wrong type inference
601 (defun bug217-1 (x s
)
602 (let ((f (etypecase x
603 (character #'write-char
)
604 (integer #'write-byte
))))
607 (character (write-char x s
))
608 (integer (write-byte x s
)))))
609 (with-test (:name
(:bug-217
))
610 (bug217-1 #\
1 (make-broadcast-stream)))
612 ;;; bug 221: tried and died on CSUBTYPEP (not VALUES-SUBTYPEP) of the
613 ;;; function return types when inferring the type of the IF expression
614 (declaim (ftype (function (fixnum) (values package boolean
)) bug221f1
))
615 (declaim (ftype (function (t) (values package boolean
)) bug221f2
))
617 (funcall (if b
#'bug221f1
#'bug221f2
) x
))
619 ;;; bug 172: macro lambda lists were too permissive until 0.7.9.28
620 ;;; (fix provided by Matthew Danish) on sbcl-devel
621 (with-test (:name
(defmacro :lambda-list
:bug-172
))
622 (assert-error (defmacro bug172
(&rest rest foo
) `(list ,rest
,foo
))))
624 (with-test (:name
(compile :embedded the
))
625 (flet ((check-embedded-thes (policy1 policy2 x y
)
627 (funcall (checked-compile
629 (declare (optimize (speed 2) (safety ,policy1
)))
631 (the (values (integer 2 3) t
&optional
)
632 (locally (declare (optimize (safety ,policy2
)))
633 (the (values t
(single-float 2f0
3f0
) &optional
)
635 (lambda () (values x y
)))
639 (assert (equal (check-embedded-thes 0 0 :a
:b
) '(:a
:b
)))
641 (assert (equal (check-embedded-thes 0 3 :a
2.5f0
) '(:a
2.5f0
)))
642 (assert (typep (check-embedded-thes 0 3 2 3.5f0
) 'type-error
))
644 (assert (equal (check-embedded-thes 0 1 :a
3f0
) '(:a
3f0
)))
645 (assert (typep (check-embedded-thes 0 1 2 2.5d0
) 'type-error
))
647 (assert (equal (check-embedded-thes 3 0 2 :a
) '(2 :a
)))
648 (assert (typep (check-embedded-thes 3 0 4 2.5f0
) 'type-error
))
650 (assert (equal (check-embedded-thes 1 0 3 :b
) '(3 :b
)))
651 (assert (typep (check-embedded-thes 1 0 1.0 2.5f0
) 'type-error
))
654 (assert (equal (check-embedded-thes 3 3 2 2.5f0
) '(2 2.5f0
)))
655 (assert (typep (check-embedded-thes 3 3 0 2.5f0
) 'type-error
))
656 (assert (typep (check-embedded-thes 3 3 2 3.5f0
) 'type-error
))))
659 ;;; INLINE inside MACROLET
660 (declaim (inline to-be-inlined
))
661 (macrolet ((def (x) `(defun ,x
(y) (+ y
1))))
663 (defun call-inlined (z)
665 (assert (= (call-inlined 3) 4))
666 (macrolet ((frob (x) `(+ ,x
3)))
667 (defun to-be-inlined (y)
670 (assert (= (call-inlined 3)
671 ;; we should have inlined the previous definition, so the
672 ;; new one won't show up yet.
674 (defun call-inlined (z)
676 #-interpreter
(assert (= (call-inlined 3) 6))
677 (defun to-be-inlined (y)
679 #-interpreter
(assert (= (call-inlined 3) 6))
681 ;;; DEFINE-COMPILER-MACRO to work as expected, not via weird magical
682 ;;; IR1 pseudo-:COMPILE-TOPLEVEL handling
683 (defvar *bug219-a-expanded-p
* nil
)
686 (define-compiler-macro bug219-a
(&whole form y
)
687 (setf *bug219-a-expanded-p
* t
)
691 (defun bug219-a-aux ()
693 (defvar *bug219-a-temp
* 3)
694 (with-test (:name
(define-compiler-macro :bug-219a
))
695 (assert (= (bug219-a-aux) (if *bug219-a-expanded-p
* 4 3)))
696 (assert (= (bug219-a *bug219-a-temp
*) 4)))
698 (defvar *bug219-b-expanded-p
* nil
)
699 (defun bug219-b-aux1 (x)
701 (define-compiler-macro bug219-b
(y)
702 (setf *bug219-b-expanded-p
* t
)
704 (defun bug219-b-aux2 (z)
706 (assert (not *bug219-b-expanded-p
*))
707 (assert-error (bug219-b-aux2 1) undefined-function
)
709 (defun bug219-b-aux2 (z)
713 (assert (= (bug219-b-aux2 1)
714 (if *bug219-b-expanded-p
* 3 1)))
716 (with-test (:name
(:unreachable-code locally declare
:bug-224
))
717 (map-optimize-declarations
718 (lambda (declaration)
719 (multiple-value-bind (fun failure-p warnings style-warnings
)
722 (declare (optimize ,@declaration
))
723 (,(gensym "LOCALY") (declare (optimize (safety 3)))
724 (ignore-errors (progn (values-list (car (list '(1 .
2)))) t
))))
725 :allow-failure t
:allow-style-warnings t
)
726 (declare (ignore fun warnings
))
728 (assert (= (length style-warnings
) 1))))
731 (with-test (:name
(:unreachable-code error labels
:bug-224
))
732 (map-optimize-declarations
733 (lambda (declaration)
734 (checked-compile `(lambda ()
735 (declare (optimize ,@declaration
))
738 (labels ((i1 () (list (i2) (i2)))
739 (i2 () (list (int) (i1)))
741 (list (i1) (i1) (i1)))
742 :exit
(return-from ext
))))
743 (list (error "nih") (ext) (ext))))))
746 (with-test (:name
(:unreachable-code error let
:bug-224
))
747 (map-optimize-declarations
748 (lambda (declaration)
749 (checked-compile `(lambda (x)
750 (declare (optimize ,@declaration
))
751 (let ((y (error ""))) (list x y
)))))
754 ;;; bug 223: invalid moving of global function name referencing
755 (defun bug223-int (n)
758 (defun bug223-wrap ()
759 (let ((old #'bug223-int
))
760 (setf (fdefinition 'bug223-int
)
763 `(ext ,@(funcall old
(1- n
)))))))
765 (with-test (:name
(compile setf fdefinition
:bug-223
))
766 (compile 'bug223-wrap
)
767 (assert (equal (bug223-int 4) '(int 4)))
769 (assert (equal (bug223-int 4) '(ext int
3)))
771 (assert (equal (bug223-int 4) '(ext ext int
2))))
773 ;;; COERCE got its own DEFOPTIMIZER which has to reimplement most of
774 ;;; SPECIFIER-TYPE-NTH-ARG. For a while, an illegal type would throw
775 ;;; you into the debugger on compilation.
776 (defun coerce-defopt1 (x)
777 ;; illegal, but should be compilable.
778 (coerce x
'(values t
)))
779 (defun coerce-defopt2 (x)
780 ;; illegal, but should be compilable.
781 (coerce x
'(values t
&optional
)))
782 (with-test (:name
(coerce :optimizer
))
783 (assert-error (coerce-defopt1 3))
784 (assert-error (coerce-defopt2 3)))
786 ;;; Oops. In part of the (CATCH ..) implementation of DEBUG-RETURN,
787 ;;; it was possible to confuse the type deriver of the compiler
788 ;;; sufficiently that compiler invariants were broken (explained by
789 ;;; APD sbcl-devel 2003-01-11).
791 ;;; WHN's original report
792 (defun debug-return-catch-break1 ()
793 (with-open-file (s "/tmp/foo"
798 (integer-length most-positive-fixnum
))))
804 ;;; APD's simplified test case
805 (defun debug-return-catch-break2 (x)
806 (declare (type (vector (unsigned-byte 8)) x
))
807 (setq *y
* (the (unsigned-byte 8) (aref x
4))))
809 ;;; FUNCTION-LAMBDA-EXPRESSION should return something that COMPILE
810 ;;; can understand. Here's a simple test for that on a function
811 ;;; that's likely to return a hairier list than just a lambda:
812 (macrolet ((def (fn) `(progn
813 (declaim (inline ,fn
))
814 (defun ,fn
(x) (1+ x
)))))
816 (with-test (:name
(function-lambda-expression compile
:bug-228
))
817 (let ((x (function-lambda-expression #'bug228
)))
819 (checked-compile-and-assert (:optimize nil
) x
825 (declare (type (mod 4) i
))
828 (with-test (:name
:bug-192b
)
829 (assert-error (bug192b 6) type-error
))
832 (locally (declare (type fixnum x y
))
834 (with-test (:name
:bug-192c
)
835 (assert-error (bug192c 1.1 2) type-error
)
836 (assert-error (progn (the real
(list 1)) t
) type-error
))
839 (declare (optimize (speed 2) (safety 0)))
842 (multiple-value-prog1
844 (unless f
(return-from bug236
0))))))
845 (with-test (:name
:bug-236
)
846 (assert (eql (bug236 #(4) nil
) 0)))
848 ;;; Bug reported by reported by rif on c.l.l 2003-03-05
849 (defun test-type-of-special-1 (x)
852 (optimize (safety 3)))
854 (defun test-type-of-special-2 (x)
857 (optimize (safety 3)))
858 (list x
(setq x
(/ x
2)) x
))
859 (with-test (:name
(declare special type
))
860 (assert-error (test-type-of-special-1 3/2) type-error
)
861 (assert-error (test-type-of-special-2 3) type-error
)
862 (assert (equal (test-type-of-special-2 8) '(8 4 4))))
864 ;;; bug which existed in 0.8alpha.0.4 for several milliseconds before
865 ;;; APD fixed it in 0.8alpha.0.5
866 (defun frob8alpha04 (x y
)
868 (defun baz8alpha04 (this kids
)
869 (flet ((n-i (&rest rest
)
870 ;; Removing the #+NIL here makes the bug go away.
871 #+nil
(format t
"~&in N-I REST=~S~%" rest
)
872 (apply #'frob8alpha04 this rest
)))
874 ;;; failed in 0.8alpha.0.4 with "The value 13 is not of type LIST."
875 (with-test (:name
(&rest type-error
))
876 (assert (= (baz8alpha04 12 13) 25)))
878 ;;; evaluation order in structure slot writers
881 (with-test (:name
(:evaluation-order structure
:slot-writer
))
883 (s (make-sswo :a
(incf i
) :b
(incf i
)))
885 (assert (= (sswo-a s
) 1))
886 (assert (= (sswo-b s
) 2))
887 (setf (sswo-a (pop l
)) (pop l
))
889 (assert (eq (sswo-a s
) :v
))))
895 (list (bar x
) (bar x
) (bar x
))))
897 (with-test (:name
(flet declare type
:bug-249
))
898 (assert-error (bug249 1.0) type-error
))
900 ;;; bug reported by ohler on #lisp 2003-07-10
901 (defun bug-ohler-2003-07-10 (a b
)
902 (declare (optimize (speed 0) (safety 3) (space 0)
903 (debug 1) (compilation-speed 0)))
906 ;;; bug reported by Doug McNaught on sbcl-devel 2003-09-14:
907 ;;; COMPILE-FILE did not bind *READTABLE*
908 (with-test (:name
(compile-file *readtable
*))
909 (let* ((source "bug-doug-mcnaught-20030914.lisp")
910 (fasl (scratch-file-name "fasl")))
912 (assert (null (get-macro-character #\
]))))
915 (assert (typep *bug-doug-mcnaught-20030914
*
916 '(simple-array (unsigned-byte 4) (*))))
917 (assert (equalp *bug-doug-mcnaught-20030914
* #(1 2 3)))
918 (makunbound '*bug-doug-mcnaught-20030914
*)))
919 (compile-file source
:output-file fasl
)
925 (delete-file fasl
))))
927 (defun expt-derive-type-bug (a b
)
929 (truncate (expt a b
))))
930 (with-test (:name
(expt :derive-type
))
931 (assert (equal (multiple-value-list (expt-derive-type-bug 1 1))
934 ;;; Problems with type checking in functions with EXPLICIT-CHECK
935 ;;; attribute (reported by Peter Graves)
936 (with-test (:name
(:type-checking
:explicit-check
))
937 (loop for
(fun . args
) in
'((= a
) (/= a
)
938 (< a
) (<= a
) (> a
) (>= a
))
939 do
(assert-error (apply fun args
) type-error
)))
941 (defclass broken-input-stream
(sb-gray:fundamental-input-stream
) ())
942 (defmethod sb-gray:stream-read-char
((stream broken-input-stream
))
943 (throw 'break
:broken
))
944 (with-test (:name
:explicit-check
)
945 (assert (eql (block return
948 (funcall (eval ''peek-char
)
949 1 (make-instance 'broken-input-stream
))
953 (return-from return
:good
))))
956 ;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual)
957 ; FIXME: make a better test!
958 (with-test (:name muffle-conditions
:skipped-on
(or :ppc64
:x86-64
))
959 (multiple-value-bind (fun failure-p warnings style-warnings notes
)
962 (declare (optimize speed
) (fixnum x
))
963 (declare (sb-ext:muffle-conditions sb-ext
:compiler-note
))
964 (values (* x
5) ; no compiler note from this
966 (declare (sb-ext:unmuffle-conditions sb-ext
:compiler-note
))
967 ;; this one gives a compiler note
969 (declare (ignore failure-p warnings style-warnings
))
970 (assert (= (length notes
) 1))
971 (assert (equal (multiple-value-list (funcall fun
1)) '(5 -
5)))))
973 (with-test (:name
(flet labels
&key
))
974 (assert-error (eval '(flet ((%f
(&key
) nil
)) (%f nil nil
))))
975 (assert-error (eval '(labels ((%f
(&key x
) x
)) (%f nil nil
)))))
977 ;;; PROGV must not bind constants, or violate declared types -- ditto for SET.
978 (assert-error (set pi
3))
979 (assert-error (progv '(pi s
) '(3 pi
) (symbol-value x
)))
980 (declaim (cons *special-cons
*))
981 (assert-error (set '*special-cons
* "nope") type-error
)
982 (assert-error (progv '(*special-cons
*) '("no hope") (car *special-cons
*)) type-error
)
984 ;;; No bogus warnings for calls to functions with complex lambda-lists.
985 (defun complex-function-signature (&optional x
&rest y
&key z1 z2
)
986 (declare (ignore z1 z2
))
988 (with-test (:name
:complex-call-doesnt-warn
)
989 (checked-compile '(lambda (x) (complex-function-signature x
:z1
1 :z2
2))))
991 (with-test (:name
:non-required-args-update-info
)
992 (let ((name (gensym "NON-REQUIRE-ARGS-TEST"))
993 (*evaluator-mode
* :compile
))
994 (eval `(defun ,name
(x) x
))
995 (assert (equal '(function (t) (values t
&optional
))
996 (sb-kernel:type-specifier
(sb-int:global-ftype name
))))
997 (eval `(defun ,name
(x &optional y
) (or x y
)))
998 (assert (equal '(function (t &optional t
) (values t
&optional
))
999 (sb-kernel:type-specifier
(sb-int:global-ftype name
))))))
1001 ;;;; inline & maybe inline nested calls
1003 (defun quux-marker (x) x
)
1004 (declaim (inline foo-inline
))
1005 (defun foo-inline (x) (quux-marker x
))
1006 (declaim (maybe-inline foo-maybe-inline
))
1007 (defun foo-maybe-inline (x) (quux-marker x
))
1009 (with-test (:name
:nested-inline-calls
)
1010 (let ((fun '(lambda (x) (foo-inline (foo-inline (foo-inline x
))))))
1011 (assert (= 0 (ctu:count-full-calls
'foo-inline fun
)))
1012 (assert (= 3 (ctu:count-full-calls
'quux-marker fun
)))))
1014 (with-test (:name
:nested-maybe-inline-calls
)
1015 (let ((fun `(lambda (x)
1016 (declare (optimize (space 0)))
1017 (foo-maybe-inline (foo-maybe-inline (foo-maybe-inline x
))))))
1018 (assert (= 0 (ctu:count-full-calls
'foo-maybe-inline fun
)))
1019 (assert (= 1 (ctu:count-full-calls
'quux-marker fun
)))))
1021 (with-test (:name
:inline-calls
)
1022 (let ((fun `(lambda (x)
1023 (list (foo-inline x
) (foo-inline x
) (foo-inline x
)))))
1024 (assert (= 0 (ctu:count-full-calls
'foo-inline fun
)))
1025 (assert (= 3 (ctu:count-full-calls
'quux-marker fun
)))))
1027 (with-test (:name
:maybe-inline-calls
)
1028 (let ((fun `(lambda (x)
1029 (declare (optimize (space 0)))
1030 (list (foo-maybe-inline x
)
1031 (foo-maybe-inline x
)
1032 (foo-maybe-inline x
)))))
1033 (assert (= 0 (ctu:count-full-calls
'foo-maybe-inline fun
)))
1034 (assert (= 1 (ctu:count-full-calls
'quux-marker fun
)))))
1036 (with-test (:name
:maybe-inline-let-calls
)
1037 (checked-compile `(lambda (x)
1038 (declare (optimize (space 0)))
1039 (foo-maybe-inline (let ((z #'foo-maybe-inline
))
1042 (with-test (:name
:bug-405
)
1043 ;; These used to break with a TYPE-ERROR
1044 ;; The value NIL is not of type SB-C::ENVIRONMENT.
1047 '((LET (outer-let-var)
1049 (print outer-let-var
)
1050 (MULTIPLE-VALUE-CALL 'some-function
1051 (MULTIPLE-VALUE-CALL (LAMBDA (a) 'foo
)
1054 '((declaim (optimize (debug 3)))
1055 (defstruct bug-405-foo bar
)
1057 (flet ((i (x) (frob x
(bug-405-foo-bar foo
))))
1061 (declaim (ftype (function (cons) number
) bug-235a-aux
))
1062 (declaim (inline bug-235a-aux
))
1063 (defun bug-235a-aux (c)
1064 (the number
(car c
)))
1065 (with-test (:name
:bug-235a
)
1066 (let ((fun (checked-compile
1068 (values (locally (declare (optimize (safety 0)))
1070 (locally (declare (optimize (safety 3)))
1071 (bug-235a-aux y
)))))))
1075 (funcall fun
'(:one
) '(:two
))
1077 (assert (eq :two
(type-error-datum e
)))
1078 (assert (eq 'number
(type-error-expected-type e
)))
1081 ;;; This tested something which is no longer a thing. There was a hash-table
1082 ;;; named *COMPILED-DEBUG-FUNS* which held on to an arbitrary number of code blobs,
1083 ;;; and it was made weak in git rev 9abfd1a2b2 and then removed in rev a2aa5eceb5
1084 ;;; (except for cheneygc - and I'm not entirely sure that there isn't a way to
1085 ;;; remove it from cheneygc as well, but it wasn't interesting).
1086 ;;; So really it's testing nothing, except that maybe it is.
1087 ;;; But the test doesn't pass with parallel-exec because profiling the code causes
1088 ;;; potentially any and every lambda to be retained when a stack sample is taken.
1089 ;;; So I'm not sure whether to delete or disable this. I guess disable.
1090 (with-test (:name
:compiled-debug-funs-leak
:fails-on
:parallel-test-runner
)
1092 (let ((usage-before (sb-kernel::dynamic-usage
)))
1094 (let ((f (checked-compile '(lambda () (error "X")))))
1099 (let ((usage-after (sb-kernel::dynamic-usage
)))
1100 (when (< (+ usage-before
2000000) usage-after
)
1103 ;;; PROGV compilation and type checking when the declared type
1104 ;;; includes a FUNCTION subtype.
1105 (declaim (type (or (function (t) (values boolean
&optional
)) string
)
1107 (defvar *hairy-progv-var
* #'null
)
1108 (with-test (:name
:hairy-progv-type-checking
)
1111 (progv '(*hairy-progv-var
*) (list (eval 42))
1113 (type-error () :error
))))
1114 (assert (equal "GOOD!"
1115 (progv '(*hairy-progv-var
*) (list (eval "GOOD!"))
1116 *hairy-progv-var
*))))
1118 (with-test (:name
:fill-complex-single-float
)
1119 (assert (every (lambda (x) (eql x
#c
(-1.0 -
2.0)))
1123 :element-type
'(complex single-float
)
1124 :initial-element
#c
(-1.0 -
2.0)))))))
1126 (with-test (:name
:make-array-symbol-as-initial-element
)
1127 (checked-compile-and-assert ()
1129 (make-array 12 :initial-element
'a
))
1130 (() #(a a a a a a a a a a a a
) :test
'equalp
)))
1132 ;;; This non-minimal test-case catches a nasty error when loading
1133 ;;; inline constants.
1135 `(simple-array single-float
(16)))
1136 (declaim (ftype (sb-int:sfunction
(single-float single-float single-float single-float
1137 single-float single-float single-float single-float
1138 single-float single-float single-float single-float
1139 single-float single-float single-float single-float
)
1143 (defun matrix (m11 m12 m13 m14
1148 :element-type
'single-float
1149 :initial-contents
(list m11 m21 m31 m41
1153 (declaim (ftype (sb-int:sfunction
((simple-array single-float
(3)) single-float
) matrix
)
1155 (defun rotate-around (a radians
)
1156 (let ((c (cos radians
))
1158 ;; The 1.0 here was misloaded on x86-64.
1159 (g (- 1.0 (cos radians
))))
1160 (let* ((x (aref a
0))
1163 (gxx (* g x x
)) (gxy (* g x y
)) (gxz (* g x z
))
1164 (gyy (* g y y
)) (gyz (* g y z
)) (gzz (* g z z
)))
1166 (+ gxx c
) (- gxy
(* s z
)) (+ gxz
(* s y
)) 0.0
1167 (+ gxy
(* s z
)) (+ gyy c
) (- gyz
(* s x
)) 0.0
1168 (- gxz
(* s y
)) (+ gyz
(* s x
)) (+ gzz c
) 0.0
1170 (with-test (:name
:regression-1.0
.29.54)
1172 '(-1.0
0.0 0.0 0.0 0.0 -
1.0 0.0 0.0 0.0 0.0 -
1.0 0.0 0.0 0.0 0.0 1.0)
1174 (make-array 3 :element-type
'single-float
:initial-element
0f0
)
1175 (coerce pi
'single-float
))))
1176 ;; Same bug manifests in COMPLEX-ATANH as well.
1177 (assert (= (atanh #C
(-0.7d0
1.1d0
)) #C
(-0.28715567731069275d0
0.9394245539093365d0
))))
1179 (with-test (:name
:slot-value-on-structure
)
1180 (multiple-value-bind (callees f
)
1181 (ctu:ir1-named-calls
`(lambda (x a b
)
1182 (declare (something-known-to-be-a-struct x
))
1183 (setf (slot-value x
'x
) a
1184 (slot-value x
'y
) b
)
1185 (list (slot-value x
'x
)
1186 (slot-value x
'y
))))
1187 (assert (equal '(#\x
#\y
)
1189 (make-something-known-to-be-a-struct :x
"X" :y
"Y")
1191 (assert (not callees
))))
1193 (defclass some-slot-thing
()
1194 ((slot :initarg
:slot
)))
1195 (with-test (:name
:with-slots-the
)
1196 (let ((x (make-instance 'some-slot-thing
:slot
"foo")))
1197 (with-slots (slot) (the some-slot-thing x
)
1198 (assert (equal "foo" slot
)))))
1200 ;;; Missing &REST type in proclamation causing a miscompile.
1203 (sequence unsigned-byte
1204 &key
(:initial-element t
) (:initial-contents sequence
))
1205 (values sequence
&optional
))
1210 &key
(initial-element nil iep
) (initial-contents nil icp
))
1211 (declare (sb-ext:unmuffle-conditions style-warning
))
1212 (declare (ignorable keys initial-element iep initial-contents icp
))
1213 (apply #'sb-sequence
:make-sequence-like sequence length keys
))
1214 (with-test (:name
:bug-458354
)
1215 (assert (equalp #((a b
) (a b
)) (bug-458354 #(1 2) 2 :initial-element
'(a b
)))))
1217 (with-test (:name
:bug-542807
)
1218 (handler-bind ((style-warning #'error
))
1219 (eval '(defstruct bug-542807 slot
)))
1221 (handler-bind ((style-warning (lambda (c)
1223 (eval '(defstruct bug-542807 slot
)))
1225 (every (lambda (x) (typep x
'sb-kernel
:redefinition-with-defun
))
1228 (with-test (:name
:defmacro-not-list-lambda-list
)
1229 (assert-error (eval `(defmacro ,(gensym) "foo"))
1232 (with-test (:name
:bug-308951
)
1236 (when (funcall (eval #'(lambda (x) (eql x
2))) y
)
1237 (defun bug-308951-foo (z)
1238 (incf x
(incf y z
))))))
1239 (defun bug-308951-bar (z)
1242 (assert (= 4 (bug-308951-bar 1))))
1244 (declaim (inline bug-308914-storage
))
1245 (defun bug-308914-storage (x)
1246 (the (simple-array flt
(*)) (bug-308914-unknown x
)))
1248 (with-test (:name
:bug-308914-workaround
)
1249 ;; This used to hang in ORDER-UVL-SETS.
1253 `(lambda (lumps &key cg
)
1254 (let ((nodes (map 'list
(lambda (lump)
1255 (bug-308914-storage lump
))
1257 (setf (aref nodes
0) 2)
1258 (assert (every #'~
= (apply #'concatenate
'list nodes
) '(2 3 6 9)))))
1259 :allow-warnings t
:allow-style-warnings t
))
1261 (error "Hang in ORDER-UVL-SETS?"))))
1263 (declaim (inline inlined-function-in-source-path
))
1264 (defun inlined-function-in-source-path (x)
1267 (with-test (:name
:inlined-function-in-source-path
)
1269 (with-output-to-string (*error-output
*)
1270 (compile nil
`(lambda (x)
1271 (declare (optimize speed
))
1272 (funcall #'inlined-function-in-source-path x
))))))
1274 (assert (search "INLINED-FUNCTION-IN-SOURCE-PATH" output
))
1276 (assert (not (search "DEFINED-FUN" output
)))))
1278 (defmacro bug-795705
()
1281 (with-test (:name
:bug-795705
)
1282 (assert (macro-function 'bug-795705
))
1283 (fmakunbound 'bug-795705
)
1284 (assert (not (macro-function 'bug-795705
))))
1286 (with-test (:name
(load-time-value :type-derivation
))
1287 (let ((name 'load-time-value-type-derivation-test
))
1288 (labels ((funtype (fun)
1289 (sb-kernel:type-specifier
1290 (sb-kernel:single-value-type
1291 (sb-kernel:fun-type-returns
1292 (sb-kernel:specifier-type
1293 (sb-kernel:%simple-fun-type fun
))))))
1294 (test (type1 type2 form value-cell-p
)
1295 (declare (ignore value-cell-p
))
1296 (let* ((lambda-form `(lambda ()
1297 (load-time-value ,form
)))
1298 (core-fun (checked-compile lambda-form
))
1299 (core-type (funtype core-fun
))
1300 (defun-form `(defun ,name
()
1301 (load-time-value ,form
)))
1302 (file-fun (let ((*error-output
* (make-broadcast-stream)))
1303 (ctu:file-compile
(list defun-form
) :load t
)
1304 (symbol-function name
)))
1305 (file-type (funtype file-fun
)))
1306 (unless (subtypep core-type type1
)
1307 (error "core: wanted ~S, got ~S" type1 core-type
))
1308 (unless (subtypep file-type type2
)
1309 (error "file: wanted ~S, got ~S" type2 file-type
)))))
1311 (test '(integer 11 11) 'number
1314 (test '(integer 4 4) 'unsigned-byte
1316 (test '(integer 10 10) '(integer 10 10) 10 nil
)
1317 (test 'cons
'cons
'(cons t t
) t
))))
1319 (with-test (:name
(load-time-value :errors
))
1320 (multiple-value-bind (warn fail
)
1323 `((defvar *load-time-value-error-value
* 10)
1324 (declaim (fixnum *load-time-value-error-value
*)))
1327 `((defun load-time-value-error-test-1 ()
1328 (the list
(load-time-value *load-time-value-error-value
*))))
1332 (handler-case (load-time-value-error-test-1)
1334 (and (eql 10 (type-error-datum e
))
1335 (eql 'list
(type-error-expected-type e
)))))
1336 (multiple-value-bind (warn2 fail2
)
1338 `((defun load-time-value-error-test-2 ()
1339 (the list
(load-time-value 10))))
1343 (handler-case (load-time-value-error-test-2)
1345 (and (eql 10 (type-error-datum e
))
1346 (eql 'list
(type-error-expected-type e
))))))
1348 ;;;; tests for compiler output
1349 (with-test (:name
:unexpected-compiler-output
)
1350 (let* ((*error-output
* (make-string-output-stream))
1351 (output (with-output-to-string (*standard-output
*)
1352 (compile-file "compiler-output-test.lisp"
1353 :output-file
(scratch-file-name)
1354 :print nil
:verbose nil
))))
1355 (unless (zerop (length output
))
1356 (error "Unexpected output: ~S" output
))))
1358 (with-test (:name
:bug-493380
)
1359 (flet ((test (forms)
1361 (let ((*debugger-hook
* (lambda (condition if
)
1362 (declare (ignore if
))
1364 (if (typep condition
'serious-condition
)
1367 (multiple-value-bind (warned failed
) (ctu:file-compile forms
)
1368 (when (and warned failed
)
1370 (assert (eq :failed
(test "(defun")))
1371 (assert (eq :failed
(test "(defun no-pkg::foo ())")))
1372 (assert (eq :failed
(test "(cl:no-such-sym)")))
1373 (assert (eq :failed
(test "...")))))
1375 (defun cmacro-signals-error () :fun
)
1376 (define-compiler-macro cmacro-signals-error
() (error "oops"))
1378 (with-test (:name
:cmacro-signals-error
)
1379 (multiple-value-bind (fun failure-p warnings
)
1380 (checked-compile `(lambda () (cmacro-signals-error))
1381 :allow-failure t
:allow-warnings t
)
1382 (assert (and fun failure-p warnings
))
1383 (assert (eq :fun
(funcall fun
)))))
1385 (defun cmacro-with-simple-key (&key a
)
1386 (format nil
"fun=~A" a
))
1387 (define-compiler-macro cmacro-with-simple-key
(&whole form
&key a
)
1389 (format nil
"cmacro=~A" (eval a
))
1392 (with-test (:name
(:cmacro-with-simple-key
:no-key
))
1393 (checked-compile-and-assert ()
1394 `(lambda () (cmacro-with-simple-key))
1397 (with-test (:name
(:cmacro-with-simple-key
:constant-key
))
1398 (checked-compile-and-assert ()
1399 `(lambda () (cmacro-with-simple-key :a
42))
1402 (with-test (:name
(:cmacro-with-simple-key
:variable-key
))
1403 (checked-compile-and-assert ()
1404 `(lambda (x) (cmacro-with-simple-key x
42))
1407 (defun cmacro-with-nasty-key (&key
((nasty-key var
)))
1408 (format nil
"fun=~A" var
))
1409 (define-compiler-macro cmacro-with-nasty-key
(&whole form
&key
((nasty-key var
)))
1411 (format nil
"cmacro=~A" (eval var
))
1414 (with-test (:name
(:cmacro-with-nasty-key
:no-key
))
1415 (checked-compile-and-assert ()
1416 `(lambda () (cmacro-with-nasty-key))
1419 (with-test (:name
(:cmacro-with-nasty-key
:constant-key
))
1420 ;; This bogosity is thanks to cmacro lambda lists being /macro/ lambda
1422 (checked-compile-and-assert ()
1423 `(lambda () (cmacro-with-nasty-key 'nasty-key
42))
1426 (with-test (:name
(:cmacro-with-nasty-key
:variable-key
))
1427 (checked-compile-and-assert ()
1428 `(lambda (nasty-key) (cmacro-with-nasty-key nasty-key
42))
1429 (('nasty-key
) "fun=42")))
1431 (defconstant tricky-key
'tricky-key
)
1432 (defun cmacro-with-tricky-key (&key
((tricky-key var
)))
1433 (format nil
"fun=~A" var
))
1434 (define-compiler-macro cmacro-with-tricky-key
(&whole form
&key
((tricky-key var
)))
1436 (format nil
"cmacro=~A" (eval var
))
1439 (with-test (:name
(:cmacro-with-tricky-key
:no-key
))
1440 (let ((fun (checked-compile
1441 `(lambda () (cmacro-with-tricky-key)))))
1442 (assert (string= "cmacro=NIL" (funcall fun
)))))
1444 (with-test (:name
(:cmacro-with-tricky-key
:constant-quoted-key
))
1445 ;; This bogosity is thanks to cmacro lambda lists being /macro/ lambda
1447 (let ((fun (checked-compile
1448 `(lambda () (cmacro-with-tricky-key 'tricky-key
42)))))
1449 (assert (string= "fun=42" (funcall fun
)))))
1451 (with-test (:name
(:cmacro-with-tricky-key
:constant-unquoted-key
))
1452 (let ((fun (checked-compile
1453 `(lambda () (cmacro-with-tricky-key tricky-key
42)))))
1454 (assert (string= "cmacro=42" (funcall fun
)))))
1456 (with-test (:name
(:cmacro-with-tricky-key
:variable-key
))
1457 (let ((fun (checked-compile
1458 `(lambda (x) (cmacro-with-tricky-key x
42)))))
1459 (assert (string= "fun=42" (funcall fun
'tricky-key
)))))
1461 (defun test-function-983 (x) x
)
1462 (define-compiler-macro test-function-983
(x) x
)
1464 (with-test (:name
:funcall-compiler-macro
)
1469 (funcall (function test-function-983 junk
) 1)))
1471 (sb-c:compiler-error
() t
))))
1473 (defsetf test-984 %test-984
)
1475 (with-test (:name
:setf-function-with-setf-expander
)
1478 (and (defun (setf test-984
) ())
1480 (style-warning () t
)))
1481 (checked-compile `(lambda () #'(setf test-984
))
1482 :allow-style-warnings t
))
1484 (with-test (:name
:compile-setf-function
)
1485 (defun (setf compile-setf
) ())
1486 (assert (equal (compile '(setf compile-setf
))
1487 '(setf compile-setf
))))
1489 (declaim (inline cut-test
))
1491 (cond ((integerp b
) b
)
1495 (with-test (:name
:cut-to-width-bad-constant
)
1496 (assert (= (funcall (checked-compile
1498 (multiple-value-bind (a b
) (values t t
)
1499 (declare (ignore b
))
1500 (mask-field (byte 10 0) (cut-test a
))))))
1503 ;; META: there's a test in compiler.pure.lisp that also tests
1504 ;; interaction of PROGV with (debug 3). These tests should be together.
1505 (with-test (:name
:progv-debug-3
)
1507 (sb-ext:restrict-compiler-policy
'debug
3)
1508 (assert (funcall (checked-compile
1510 (declare (special *v
*))
1514 (sb-ext:restrict-compiler-policy
'debug
0)))
1516 (with-test (:name
:restrict-compiler-policy-result
)
1517 (let ((sb-c::*policy-min
* sb-c
::*policy-min
*)
1518 (sb-c::*policy-max
* sb-c
::*policy-max
*))
1519 (sb-ext:restrict-compiler-policy
'safety
2)
1520 (checked-compile '(lambda () (declare (optimize (safety 0))))))
1521 (let ((sb-c::*policy-min
* sb-c
::*policy-min
*)
1522 (sb-c::*policy-max
* sb-c
::*policy-max
*))
1523 ;; Passing no arguments returns the current quality/value pairs.
1524 (assert (null (sb-ext:restrict-compiler-policy
)))
1525 (let ((res (sb-ext:restrict-compiler-policy
'safety
2)))
1527 (assert (equal res
'((safety .
2)))))
1528 (let ((res (sb-ext:restrict-compiler-policy
'debug
3)))
1529 ;; returns an alist, indeterminate order
1530 (assert (or (equal res
'((safety .
2) (debug .
3)))
1531 (equal res
'((debug .
3) (safety .
2))))))
1532 ;; remove the SAFETY restriction
1533 (let ((res (sb-ext:restrict-compiler-policy
'safety
0)))
1534 (assert (equal res
'((debug .
3)))))
1535 ;; remove the DEBUG restriction
1536 (let ((res (sb-ext:restrict-compiler-policy
'debug
0)))
1537 (assert (null res
)))))
1539 ;;;; tests not in the problem domain, but of the consistency of the
1540 ;;;; compiler machinery itself
1544 ;;; Hunt for wrong-looking things in fundamental compiler definitions,
1545 ;;; and gripe about them.
1547 ;;; FIXME: It should be possible to (1) repair the things that this
1548 ;;; code gripes about, and then (2) make the code signal errors
1549 ;;; instead of just printing complaints to standard output, in order
1550 ;;; to prevent the code from later falling back into disrepair.
1551 (defun grovel-results (function)
1552 (dolist (template (fun-info-templates (info :function
:info function
)))
1553 (when (template-more-results-type template
)
1554 (format t
"~&Template ~A has :MORE results, and translates ~A.~%"
1555 (template-name template
)
1558 (when (eq (template-result-types template
) :conditional
)
1561 (let ((types (template-result-types template
))
1562 (result-type (fun-type-returns (global-ftype function
))))
1564 ((values-type-p result-type
)
1565 (do ((ltypes (append (args-type-required result-type
)
1566 (args-type-optional result-type
))
1568 (types types
(rest types
)))
1570 (unless (null types
)
1572 (format t
"~&More types than ltypes in ~A, translating ~A.~%"
1573 (template-name template
)
1577 (unless (null ltypes
)
1579 (format t
"~&More ltypes than types in ~A, translating ~A.~%"
1580 (template-name template
)
1583 ((eq result-type
(specifier-type nil
))
1584 (unless (null types
)
1585 (format t
"~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%"
1586 (template-name template
)
1589 ((/= (length types
) 1)
1590 (format t
"~&Template ~A isn't returning 1 value for ~A.~%"
1591 (template-name template
)
1595 (test-util:with-test
(:name
:identify-suspect-vops
)
1596 (sb-int:call-with-each-globaldb-name
1598 ;; LEGAL-FUN-NAME-P test is necessary, since (INFO :FUNCTION :TYPE)
1599 ;; has a defaulting expression that involves calling FDEFINITION.
1600 (when (and (legal-fun-name-p name
) (global-ftype name
))
1601 ;; OK, so we have an entry in the INFO database. Now, if ...
1602 (binding* ((info (info :function
:info name
) :exit-if-null
)
1603 (nil (fun-info-templates info
) :exit-if-null
))
1604 ;; ... it has translators
1605 (grovel-results name
))))))
1607 ;;;; bug 305: INLINE/NOTINLINE causing local ftype to be lost
1609 (test-util:with-test
(:name
(compile inline notinline
))
1610 (labels ((compile-lambda (type sense allow-notes
)
1612 4 (test-util:checked-compile
1615 ,@(when type
'((ftype (function () (integer 0 10)) bug-305
)))
1619 :allow-style-warnings t
:allow-notes allow-notes
))))
1620 (assert (compile-lambda nil
'inline t
))
1621 (assert (compile-lambda nil
'notinline t
))
1622 (compile-lambda t
'inline nil
)
1623 (compile-lambda t
'notinline nil
)))
1625 ;;; bug 211e: bogus style warning from duplicated keyword argument to
1626 ;;; a local function.
1627 (test-util:with-test
(:name
(compile flet
:duplicate
&key
:bug-211e
))
1628 (let ((f (test-util:checked-compile
1630 (flet ((foo (&key y
) (list y
)))
1631 (list (foo :y
1 :y
2)))))))
1632 (assert (equal '((1)) (funcall f
)))))
1634 ;;; check that EQL is optimized when other argument is (OR SYMBOL FIXNUM).
1635 (test-util:with-test
(:name
(compile :optimize eql
))
1636 (let ((f1 (test-util:checked-compile
1638 (declare (type (or symbol fixnum
) x1
)
1642 (f2 (test-util:checked-compile
1644 (declare (type (or symbol fixnum
) y2
)
1648 (let ((fix (random most-positive-fixnum
))
1651 (assert (funcall f1 fix fix
))
1652 (assert (funcall f2 fix fix
))
1653 (assert (funcall f1 sym sym
))
1654 (assert (funcall f2 sym sym
))
1655 (handler-bind ((type-error (lambda (c)
1658 (flet ((test (f x y
)
1659 (with-simple-restart (continue "continue with next test")
1661 (error "fell through with (~S ~S ~S)" f x y
))))
1663 (test f1
(1+ most-positive-fixnum
) 42)
1665 (test f2
42 (1+ most-positive-fixnum
))))
1666 (assert (= e-count
4)))))
1668 ;;; bug #389 (Rick Taube sbcl-devel)
1669 (declaim (ftype function bes-j0 bes-j1
))
1670 (defun bes-jn (unn ux
)
1671 (let ((nn unn
) (x ux
))
1672 (let* ((n (floor (abs nn
)))
1685 (do ((tox (/ 2.0 (abs x
)))
1686 (bjm (bes-j0 (abs x
)))
1687 (bj (bes-j1 (abs x
)))
1690 ((= j n
) (setf ans bj
))
1691 (setf bjp
(- (* j tox bj
) bjm
))
1694 (let ((tox (/ 2.0 (abs x
)))
1698 (/ (+ n
(sqrt (* iacc n
)))
1707 (setf bjm
(- (* j tox bj
) bjp
))
1710 (when (> (abs bj
) bigno
)
1711 (setf bj
(* bj bigni
))
1712 (setf bjp
(* bjp bigni
))
1713 (setf ans
(* ans bigni
))
1714 (setf sum
(* sum bigni
)))
1715 (if (not (= 0 jsum
)) (incf sum bj
))
1716 (setf jsum
(- 1 jsum
))
1717 (if (= j n
) (setf ans bjp
)))
1718 (setf sum
(- (* 2.0 sum
) bj
))
1719 (setf ans
(/ ans sum
))))
1720 (if (and (minusp x
) (oddp n
))
1723 (if (and (minusp nn
) (oddp nn
)) (- besn
) besn
))))
1726 ;;; bug 233b: lvar lambda-var equality in constraint propagation
1728 ;; Put this in a separate function.
1729 (defun test-constraint-propagation/ref
()
1731 (if (multiple-value-prog1 x
(setq x t
))
1735 (test-util:with-test
(:name
(:compiler
:constraint-propagation
:ref
))
1736 (assert (eq t
(test-constraint-propagation/ref
))))
1738 ;; Put this in a separate function.
1739 (defun test-constraint-propagation/typep
(x y
)
1740 (if (typep (multiple-value-prog1 x
(setq x y
))
1745 (test-util:with-test
(:name
(:compiler
:constraint-propagation
:typep
))
1746 (assert (= 6.0d0
(test-constraint-propagation/typep
1d0
5))))
1748 (test-util:with-test
(:name
(:compiler
:constraint-propagation
:eq
/eql
))
1749 (assert (eq :right
(let ((c :wrong
))
1750 (if (eq (let ((x c
))
1757 ;;; Put this in a separate function.
1758 (defun test-constraint-propagation/cast
(x)
1759 (when (the double-float
(multiple-value-prog1
1764 (test-util:with-test
(:name
(:compiler
:constraint-propagation
:cast
))
1765 (assertoid:assert-error
1766 (test-constraint-propagation/cast
1) type-error
))
1769 (let ((result (make-array 50000 :fill-pointer
0 :adjustable t
)))
1770 (defun string->html
(string &optional
(max-length nil
))
1771 (when (and (numberp max-length
)
1772 (> max-length
(array-dimension result
0)))
1773 (setf result
(make-array max-length
:fill-pointer
0 :adjustable t
)))
1776 (labels ((add-char (it)
1777 (setf (aref result index
) it
)
1780 (loop for ch across it do
1782 (loop for char across string do
1783 (cond ((char= char
#\
<)
1784 (add-string "<"))
1786 (add-string ">"))
1788 (add-string "&"))
1790 (add-string "'"))
1791 ((char= char
#\newline
)
1792 (add-string "<br>"))
1794 (if left-quote?
(add-string "“") (add-string "”"))
1795 (setf left-quote?
(not left-quote?
)))
1798 (setf (fill-pointer result
) index
)
1799 (coerce result
'string
)))))
1801 ;;; Calling thru constant symbols
1803 (declaim (inline target-fun
))
1804 (defun target-fun (arg0 arg1
)
1806 (declaim (notinline target-fun
))
1808 ;; That issue aside, neither sb-introspect nor ctu:find-named-callees
1809 ;; can examine an interpreted function for its callees,
1810 ;; so we can't actually use this function.
1811 (defun test-target-fun-called (fun res
)
1812 (assert (member #'target-fun
1813 (ctu:find-named-callees
#'caller-fun-1
)))
1814 (assert (equal (funcall fun
) res
)))
1816 (defun caller-fun-1 ()
1817 (funcall 'target-fun
1 2))
1818 #-interpreter
(test-target-fun-called #'caller-fun-1
3)
1820 (defun caller-fun-2 ()
1821 (declare (inline target-fun
))
1822 (apply 'target-fun
1 '(3)))
1823 #-interpreter
(test-target-fun-called #'caller-fun-2
4)
1825 (defun caller-fun-3 ()
1826 (flet ((target-fun (a b
)
1828 (list (funcall #'target-fun
1 4) (funcall 'target-fun
1 4))))
1829 #-interpreter
(test-target-fun-called #'caller-fun-3
(list -
3 5))
1831 ;;; Reported by NIIMI Satoshi
1832 ;;; Subject: [Sbcl-devel] compilation error with optimization
1833 ;;; Date: Sun, 09 Apr 2006 17:36:05 +0900
1834 (defun test-minimal-debug-info-for-unstored-but-used-parameter (n a
)
1835 (declare (optimize (speed 3)
1839 (test-minimal-debug-info-for-unstored-but-used-parameter (1- n
) a
)))
1841 ;;; &KEY arguments with non-constant defaults.
1842 (defstruct tricky-defaults
1843 (fun #'identity
:type function
)
1844 (num (test-util:opaque-identity
3) :type fixnum
))
1846 (test-util:with-test
(:name
:defstruct-tricky-defaults
)
1847 (macrolet ((frob (form expected-expected-type
)
1848 `(handler-case ,form
1849 (type-error (c) (assert (eq (type-error-expected-type c
)
1850 ',expected-expected-type
)))
1851 (:no-error
(&rest vals
) (error "~S returned values: ~S" ',form vals
)))))
1852 (frob (make-tricky-defaults :fun
3) function
)
1853 (frob (make-tricky-defaults :num
#'identity
) fixnum
)))
1855 (test-util:with-test
(:name
(compile &key
:non-constant
:default
))
1856 (let ((fun (test-util:checked-compile
1857 '(lambda (&key
(key (test-util:opaque-identity
3)))
1858 (declare (optimize safety
) (type integer key
))
1860 (assert (= (funcall fun
) 3))
1861 (assert (= (funcall fun
:key
17) 17))
1862 (handler-case (funcall fun
:key t
)
1863 (type-error (c) (assert (eq (type-error-expected-type c
) 'integer
)))
1864 (:no-error
(&rest vals
) (declare (ignore vals
)) (error "no error")))))
1866 ;;; Basic compiler-macro expansion
1867 (define-compiler-macro test-cmacro-0
() ''expanded
)
1869 ;; The interpreter is not required to expand compiler-macros.
1870 ;; (Actually neither is the compiler!)
1871 #-interpreter
(assert (eq 'expanded
(funcall (lambda () (test-cmacro-0)))))
1873 ;;; FUNCALL forms in compiler macros, lambda-list parsing
1874 (define-compiler-macro test-cmacro-1
1875 (&whole whole a
(a2) &optional b
&rest c
&key d
)
1876 (list whole a a2 b c d
))
1878 (macrolet ((test (form a a2 b c d
)
1879 `(let ((form ',form
))
1880 (destructuring-bind (whole a a2 b c d
)
1881 (funcall (compiler-macro-function 'test-cmacro-1
) form nil
)
1882 (assert (equal whole form
))
1884 (assert (eql a2
,a2
))
1886 (assert (equal c
,c
))
1887 (assert (eql d
,d
))))) )
1888 (test (funcall 'test-cmacro-1
1 (x) 2 :d
3) 1 'x
2 '(:d
3) 3)
1889 (test (test-cmacro-1 11 (y) 12 :d
13) 11 'y
12 '(:d
13) 13))
1891 ;;; FUNCALL forms in compiler macros, expansions
1892 (define-compiler-macro test-cmacro-2
() ''ok
)
1894 #-interpreter
(assert (eq 'ok
(funcall (lambda () (funcall 'test-cmacro-2
)))))
1895 #-interpreter
(assert (eq 'ok
(funcall (lambda () (funcall #'test-cmacro-2
)))))
1897 ;;; Shadowing of compiler-macros by local functions
1898 (define-compiler-macro test-cmacro-3
() ''global
)
1900 (defmacro find-cmacro-3
(&environment env
)
1901 (compiler-macro-function 'test-cmacro-3 env
))
1903 (assert (funcall (lambda () (find-cmacro-3))))
1904 (assert (not (funcall (lambda () (flet ((test-cmacro-3 ()))
1905 (find-cmacro-3))))))
1906 (assert (eq 'local
(funcall (lambda () (flet ((test-cmacro-3 () 'local
))
1907 (test-cmacro-3))))))
1908 (assert (eq 'local
(funcall (lambda () (flet ((test-cmacro-3 () 'local
))
1909 (funcall #'test-cmacro-3
))))))
1911 (assert (eq 'global
(funcall (lambda () (flet ((test-cmacro-3 () 'local
))
1912 (funcall 'test-cmacro-3
))))))
1914 ;;; Local NOTINLINE & INLINE
1915 (defun test-cmacro-4 () 'fun
)
1916 (define-compiler-macro test-cmacro-4
() ''macro
)
1918 (assert (eq 'fun
(funcall (lambda ()
1919 (declare (notinline test-cmacro-4
))
1923 (assert (eq 'macro
(funcall (lambda ()
1924 (declare (inline test-cmacro-4
))
1927 ;;; SETF function compiler macros
1928 (define-compiler-macro (setf test-cmacro-4
) (&whole form value
) ''ok
)
1931 (assert (eq 'ok
(funcall (lambda () (setf (test-cmacro-4) 'zot
)))))
1933 (assert (eq 'ok
(funcall (lambda () (funcall #'(setf test-cmacro-4
) 'zot
)))))
1935 ;;; Step instrumentation breaking type-inference
1936 (test-util:with-test
(:name
(compile :insert-step-conditions
:type-inference
))
1937 (assert (= 42 (funcall (test-util:checked-compile
1939 (declare (optimize sb-c
:insert-step-conditions
))
1940 (if (typep (the function x
) 'fixnum
)
1941 (svref v
(the function x
))
1943 nil
(constantly 42)))))
1945 ;;; bug 368: array type intersections in the compiler
1949 (i368s (make-array 0 :fill-pointer t
) :type
(or (vector i368
) null
)))
1951 (g368 (error "missing :G368") :type g368
:read-only t
))
1952 (declaim (ftype (function (fixnum (vector i368
) e368
) t
) r368
))
1953 (declaim (ftype (function (fixnum (vector e368
)) t
) h368
))
1954 (defparameter *h368-was-called-p
* nil
)
1955 (defun nsu (vertices e368
)
1956 (let ((i368s (g368-i368s (make-g368))))
1957 (let ((fuis (r368 0 i368s e368
)))
1958 (format t
"~&FUIS=~S~%" fuis
)
1959 (or fuis
(h368 0 i368s
)))))
1961 (declare (ignore w x y
))
1964 (declare (ignore w x
))
1965 (setf *h368-was-called-p
* t
)
1966 (make-s368 :g368
(make-g368)))
1967 (let ((nsu (nsu #() (make-e368))))
1968 (format t
"~&NSU returned ~S~%" nsu
)
1969 (format t
"~&*H368-WAS-CALLED-P*=~S~%" *h368-was-called-p
*)
1970 (assert (s368-p nsu
))
1971 (assert *h368-was-called-p
*))
1973 ;;; bug 367: array type intersections in the compiler
1977 (i367s (make-array 0 :fill-pointer t
) :type
(or (vector i367
) null
)))
1979 (g367 (error "missing :G367") :type g367
:read-only t
))
1980 (declaim (ftype (function ((vector i367
) e367
) (or s367 null
)) r367
))
1981 (declaim (ftype (function ((vector e367
)) (values)) h367
))
1982 (defun frob-367 (v w
)
1983 (let ((x (g367-i367s (make-g367))))
1984 (let* ((y (or (r367 x w
)
1987 (format t
"~&Y=~S Z=~S~%" y z
)
1989 (defun r367 (x y
) (declare (ignore x y
)) nil
)
1990 (defun h367 (x) (declare (ignore x
)) (values))
1991 (assertoid:assert-error
(frob-367 0 (make-e367)) type-error
)
1994 (delete-file (compile-file "circ-tree-test.lisp"
1995 :output-file
(test-util:scratch-file-name
)))
1996 (storage-condition (e)
1999 ;;; warnings due to step-instrumentation
2000 (defclass debug-test-class
() ())
2001 (test-util:checked-compile
2003 (declare (optimize (debug 3)))
2004 (defmethod print-object ((x debug-test-class
) s
)
2005 (call-next-method))))
2007 ;;; program-error from bad lambda-list keyword
2008 (test-util:with-test
(:name
(compile :bad lambda-list keyword program-error
))
2009 (multiple-value-bind (fun failure-p
)
2010 (test-util:checked-compile
'(lambda (&whole x
)
2014 (assertoid:assert-error
(funcall fun
) program-error
)))
2016 (test-util:with-test
(:name
(eval :bad lambda-list keyword program-error
)
2017 :skipped-on
(not :sb-eval
))
2018 (assertoid:assert-error
(let ((*evaluator-mode
* :interpret
))
2019 (funcall (eval '(lambda (&whole x
)
2023 ;;; ignore &environment
2024 (test-util:with-test
(:name
(defmacro ignore
&environment
))
2025 (test-util:checked-compile
2027 (defmacro macro-ignore-env
(&environment env
)
2028 (declare (ignore env
))
2031 (test-util:with-test
(:name
(defmacro :no
&environment
))
2032 (test-util:checked-compile
2034 (defmacro macro-no-env
()
2037 (test-util:with-test
(:name
(disassemble :source-form
))
2038 (dolist (*evaluator-mode
* '(#+sb-eval
:interpret
:compile
))
2039 (disassemble (eval '(defun disassemble-source-form-bug (x y z
)
2040 (declare (optimize debug
))
2042 :stream
(make-broadcast-stream))))
2044 ;;; long-standing bug in defaulting unknown values on the x86-64,
2045 ;;; since changing the calling convention (test case by Christopher
2046 ;;; Laux sbcl-help 30-06-2007)
2048 (defun default-values-bug-demo-sub ()
2051 (compile 'default-values-bug-demo-sub
)
2053 (defun default-values-bug-demo-main ()
2054 (multiple-value-bind (a b c d e f g h
)
2055 (default-values-bug-demo-sub)
2056 (if a
(+ a b c d e f g h
) t
)))
2057 (compile 'default-values-bug-demo-main
)
2059 (test-util:with-test
(:name
(multiple-value-bind :default-values
))
2060 (assert (default-values-bug-demo-main)))
2062 ;;; copy propagation bug reported by Paul Khuong
2064 (defun local-copy-prop-bug-with-move-arg (x)
2069 (multiple-value-bind (a b
)
2073 (test-util:with-test
(:name
(labels multiple-value-bind
:copy-propagation
))
2074 (assert (equal '(0 1) (multiple-value-list
2075 (local-copy-prop-bug-with-move-arg nil
))))
2076 (assert (equal '(1 0) (multiple-value-list
2077 (local-copy-prop-bug-with-move-arg t
)))))
2079 ;;;; with-pinned-objects & unwind-protect, using all non-tail conventions
2081 (defun wpo-quux () (list 1 2 3))
2082 (defvar *wpo-quux
* #'wpo-quux
)
2086 (sb-sys:with-pinned-objects
(*wpo-quux
*)
2087 (values (funcall *wpo-quux
*)))))
2088 (assert (equal '(1 2 3) (wpo-call)))
2090 (defun wpo-multiple-call ()
2092 (sb-sys:with-pinned-objects
(*wpo-quux
*)
2093 (funcall *wpo-quux
*))))
2094 (assert (equal '(1 2 3) (wpo-multiple-call)))
2096 (defun wpo-call-named ()
2098 (sb-sys:with-pinned-objects
(*wpo-quux
*)
2099 (values (wpo-quux)))))
2100 (assert (equal '(1 2 3) (wpo-call-named)))
2102 (defun wpo-multiple-call-named ()
2104 (sb-sys:with-pinned-objects
(*wpo-quux
*)
2106 (assert (equal '(1 2 3) (wpo-multiple-call-named)))
2108 (defun wpo-call-variable (&rest args
)
2110 (sb-sys:with-pinned-objects
(*wpo-quux
*)
2111 (values (apply *wpo-quux
* args
)))))
2112 (assert (equal '(1 2 3) (wpo-call-variable)))
2114 (defun wpo-multiple-call-variable (&rest args
)
2116 (sb-sys:with-pinned-objects
(*wpo-quux
*)
2117 (apply #'wpo-quux args
))))
2118 (assert (equal '(1 2 3) (wpo-multiple-call-named)))
2120 (defun wpo-multiple-call-local ()
2124 (sb-sys:with-pinned-objects
(*wpo-quux
*)
2126 (assert (equal '(1 2 3) (wpo-multiple-call-local)))
2128 ;;; bug 417: toplevel NIL confusing source path logic
2129 (test-util:with-test
(:name
:bug-417
)
2131 (delete-file (let ((*error-output
* (make-broadcast-stream)))
2132 (compile-file "bug-417.lisp"
2133 :output-file
(test-util:scratch-file-name
)
2134 :verbose nil
:print nil
)))
2135 (sb-ext:code-deletion-note
(e)
2138 ;;; unknown values return convention getting disproportionate
2139 ;;; amounts of values.
2140 (declaim (notinline one-value two-values
))
2141 (defun one-value (x)
2143 (defun two-values (x y
)
2145 (defun wants-many-values (x y
)
2146 (multiple-value-bind (a b c d e f
)
2148 (assert (and (eql (not y
) a
)
2149 (not (or b c d e f
)))))
2150 (multiple-value-bind (a b c d e f
)
2152 (assert (and (eql a x
) (eql b y
)
2153 (not (or c d e f
)))))
2154 (multiple-value-bind (a b c d e f g h i
)
2156 (assert (and (eql (not y
) a
)
2157 (not (or b c d e f g h i
)))))
2158 (multiple-value-bind (a b c d e f g h i
)
2160 (assert (and (eql a x
) (eql b y
)
2161 (not (or c d e f g h i
)))))
2162 (multiple-value-bind (a b c d e f g h i j k l m n o p q r s
)
2164 (assert (and (eql (not y
) a
)
2165 (not (or b c d e f g h i j k l m n o p q r s
)))))
2166 (multiple-value-bind (a b c d e f g h i j k l m n o p q r s
)
2168 (assert (and (eql a x
) (eql b y
)
2169 (not (or c d e f g h i j k l m n o p q r s
))))))
2170 (test-util:with-test
(:name
(multiple-value-bind :unknown values
))
2171 (wants-many-values 1 42))
2173 ;;; constant coalescing
2175 (defun count-code-constants (x f
)
2176 (let ((code (sb-kernel:fun-code-header f
))
2178 (loop for i from sb-vm
:code-constants-offset below
(sb-kernel:code-header-words code
)
2179 do
(when (equal x
(sb-kernel:code-header-ref code i
))
2185 (defun compile2 (lambda)
2186 (let* ((lisp (test-util:scratch-file-name
"lisp"))
2187 (fasl (test-util:scratch-file-name
"fasl")))
2190 (with-open-file (f lisp
:direction
:output
)
2191 (prin1 `(setf *lambda
* ,lambda
) f
))
2192 (multiple-value-bind (fasl warn fail
)
2193 (compile-file lisp
:output-file fasl
:verbose nil
:print nil
)
2194 (declare (ignore warn
))
2196 (error "File-compiling ~S failed." lambda
))
2197 (let ((*lambda
* nil
))
2199 (values *lambda
* (test-util:checked-compile lambda
)))))
2200 (ignore-errors (delete-file lisp
))
2201 (ignore-errors (delete-file fasl
)))))
2203 ;; some things must retain identity under COMPILE, but we want to coalesce them under COMPILE-FILE
2204 (defun assert-coalescing (constant)
2205 (let ((value (copy-seq constant
)))
2206 (multiple-value-bind (file-fun core-fun
)
2207 (compile2 `(lambda ()
2208 (let ((x (cons ',constant nil
))
2209 (y (cons ',value nil
)))
2211 (assert (= 1 (count-code-constants value file-fun
)))
2212 (assert (= 2 (count-code-constants value core-fun
)))
2213 (let* ((l (funcall file-fun
))
2215 (b (car (second l
))))
2216 (assert (and (equal value a
)
2219 (let* ((l (funcall core-fun
))
2221 (b (car (second l
))))
2222 (assert (and (equal value a
)
2224 (not (eq a b
))))))))
2226 (test-util:with-test
(:name
(compile compile-file
:coalescing string
))
2227 (assert-coalescing "maybe coalesce me!"))
2229 (test-util:with-test
(:name
(compile compile-file
:coalescing bit-vector
))
2230 (assert-coalescing #*01101001011101110100011))
2232 (test-util:with-test
(:name
(compile compile-file
:coalescing
:mixed
))
2233 (assert-coalescing '(foo bar
"zot" 123 (nested "quux") #*0101110010)))
2235 (defclass some-constant-thing
() ())
2237 ;;; correct handling of nested things loaded via SYMBOL-VALUE
2238 (defvar *sneaky-nested-thing
* (list (make-instance 'some-constant-thing
)))
2239 (defconstant +sneaky-nested-thing
+ *sneaky-nested-thing
*)
2240 (multiple-value-bind (file-fun core-fun
) (compile2 '(lambda () +sneaky-nested-thing
+))
2241 (assert (equal *sneaky-nested-thing
* (funcall file-fun
)))
2242 (assert (equal *sneaky-nested-thing
* (funcall core-fun
))))
2244 ;;; catch constant modifications thru undefined variables
2245 (defun sneak-set-dont-set-me (x)
2246 (ignore-errors (setq dont-set-me x
)))
2247 (defconstant dont-set-me
42)
2248 (assert (not (sneak-set-dont-set-me 13)))
2249 (assert (= 42 dont-set-me
))
2250 (defun sneak-set-dont-set-me2 (x)
2251 (ignore-errors (setq dont-set-me2 x
)))
2252 (defconstant dont-set-me2
(make-instance 'some-constant-thing
))
2253 (assert (not (sneak-set-dont-set-me2 13)))
2254 (assert (typep dont-set-me2
'some-constant-thing
))
2256 ;;; Check that non-trivial constants are EQL across different files, as required by the spec:
2257 ;;; From the CLHS glossary (note that `same' without any qualifiers
2259 ;;; named constant n. a variable that is defined by Common Lisp, by
2260 ;;; the implementation, or by user code (see the macro defconstant) to
2261 ;;; always yield the same value when evaluated. ``The value of a named
2262 ;;; constant may not be changed by assignment or by binding.''
2263 (defconstant +share-me-1
+ 123.456d0
)
2264 (defconstant +share-me-2
+ "a string to share")
2265 (defconstant +share-me-3
+ (vector 1 2 3))
2266 (defconstant +share-me-4
+ (* 2 most-positive-fixnum
))
2267 (multiple-value-bind (f1 c1
) (compile2 `(lambda () (values +share-me-1
+
2272 (multiple-value-bind (f2 c2
) (compile2 `(lambda () (values +share-me-1
+
2277 (flet ((test (fa fb
)
2280 (multiple-value-list (funcall fa
))
2281 (multiple-value-list (funcall fb
)))))
2286 ;;;; backq const folding tests
2287 (test-util:with-test
(:name
:backq-const-named-reference-folding
)
2289 `((defconstant +izero
+ 0)
2290 (defconstant +fzero
+ 0f0
)
2291 (defconstant +dzero
+ 0d0
)
2292 (defparameter *dzero
* 0d0
)
2293 (defun test-1 () `(,+izero
+ ,+fzero
+ ,+dzero
+))
2294 (defun test-2 () `(,+izero
+ ,+fzero
+ ,+dzero
+ ,*dzero
*))
2295 (defun test-3 () (list +izero
+ +fzero
+ +dzero
+)))
2297 (assert (equal (test-1) '(0 0.0 0.0d0
)))
2298 (assert (equal (test-2) '(0 0.0 0.0d0
0.0d0
)))
2299 (assert (equal (test-3) '(0 0.0 0.0d0
))))
2301 ;;; user-defined satisfies-types cannot be folded
2302 (deftype mystery
() '(satisfies mysteryp
))
2303 (defvar *mystery
* nil
)
2304 (defun mysteryp (x) (eq x
*mystery
*))
2305 (defstruct thing
(slot (error "missing") :type mystery
))
2306 (defun test-mystery (m) (when (eq :mystery
(thing-slot m
)) :ok
))
2307 (setf *mystery
* :mystery
)
2308 (assert (eq :ok
(test-mystery (make-thing :slot
:mystery
))))
2310 ;;; Singleton types can also be constant.
2311 (test-util:with-test
(:name
:propagate-singleton-types-to-eql
)
2312 (macrolet ((test (type value
&aux
(fun (gensym "FUN")))
2314 (declaim (ftype (function () (values ,type
&optional
)) ,fun
))
2322 (test (eql foo
) foo
)
2323 (test (integer 0 0) 0)
2324 (test (double-float 0d0
0d0
) 0d0
)
2325 (test (eql #\c
) #\c
))))
2327 (declaim (ftype (function () (integer 42 42)) bug-655581
))
2328 (defun bug-655581 ()
2330 (declaim (notinline bug-655581
))
2331 (test-util:with-test
(:name
:bug-655581
)
2332 (test-util:checked-compile-and-assert
()
2334 (ctu:compiler-derived-type
(bug-655581)))
2335 (() (values '(integer 42 42) t
))))
2337 (test-util:with-test
(:name
:clear-derived-types-on-set-fdefn
)
2338 (let ((*evaluator-mode
* :compile
)
2339 (*derive-function-types
* t
))
2341 (defun clear-derived-types-on-set-fdefn-1 ()
2343 (setf (symbol-function 'clear-derived-types-on-set-fdefn-1
)
2344 (constantly "foobar"))
2345 (defun clear-derived-types-on-set-fdefn-2 ()
2346 (length (clear-derived-types-on-set-fdefn-1)))))
2347 (assert (= 6 (clear-derived-types-on-set-fdefn-2)))))
2349 (test-util:with-test
(:name
(:bug-655126
:derive-function-types t
))
2350 (let ((*evaluator-mode
* :compile
)
2351 (*derive-function-types
* t
))
2352 (eval `(defun bug-655126 (x) x
))
2353 ;; Full warnings are ok due to *derive-function-types* = T.
2354 (assert (eq :full-warning
2356 (eval `(defun bug-655126-2 ()
2358 ((and warning
(not style-warning
)) ()
2360 (assert (eq 'bug-655126
2362 (eval `(defun bug-655126 (x y
)
2364 ((and warning
(not sb-kernel
:redefinition-warning
)) ()
2366 (assert (eq :full-warning
2368 (eval `(defun bug-655126 (x)
2372 (not sb-kernel
:redefinition-warning
)) ()
2375 (test-util:with-test
(:name
(:bug-655126
:derive-function-types nil
))
2376 (let ((*evaluator-mode
* :compile
))
2377 (eval `(defun bug-655126/b
(x) x
))
2378 ;; Just style-warning here.
2379 (assert (eq :style-warning
2381 (eval `(defun bug-655126-2/b
()
2385 (assert (eq 'bug-655126
/b
2387 (eval `(defun bug-655126/b
(x y
)
2389 ((and warning
(not sb-kernel
:redefinition-warning
)) ()
2391 ;; Bogus self-call is always worth a full one.
2392 (assert (eq :full-warning
2394 (eval `(defun bug-655126/b
(x)
2395 (bug-655126/b x y
)))
2398 (not sb-kernel
:redefinition-warning
)) ()
2401 (test-util:with-test
(:name
:bug-657499
)
2402 ;; Don't trust derived types within the compilation unit.
2404 `((declaim (optimize safety
))
2405 (defun bug-657499-foo ()
2407 (defun bug-657499-bar ()
2408 (let ((cons (bug-657499-foo)))
2412 (locally (declare (optimize safety
))
2413 (setf (symbol-function 'bug-657499-foo
) (constantly "foobar"))
2414 (assert (eq :type-error
2416 (funcall 'bug-657499-bar
)
2418 (assert (eq 'cons
(type-error-expected-type e
)))
2419 (assert (equal "foobar" (type-error-datum e
)))
2422 (declaim (unsigned-byte *symbol-value-test-var
*))
2423 (defvar *symbol-value-test-var
*)
2425 (declaim (unsigned-byte **global-symbol-value-test-var
**))
2426 (defglobal **global-symbol-value-test-var
** 0)
2428 (test-util:with-test
(:name
:symbol-value-type-derivation
)
2429 (let ((fun (compile nil
`(lambda () *symbol-value-test-var
*))))
2430 (assert (equal '(function () (values unsigned-byte
&optional
))
2431 (%simple-fun-type fun
))))
2432 (let ((fun (compile nil
`(lambda () **global-symbol-value-test-var
**))))
2433 (assert (equal '(function () (values unsigned-byte
&optional
))
2434 (%simple-fun-type fun
))))
2435 (let ((ufix (type-specifier (specifier-type `(and unsigned-byte fixnum
)))))
2436 ;; Test a free type decl
2437 (let ((fun (compile nil
`(lambda ()
2438 (declare (fixnum *symbol-value-test-var
*))
2439 (symbol-value '*symbol-value-test-var
*)))))
2440 (assert (equal `(function () (values ,ufix
&optional
))
2441 (%simple-fun-type fun
))))
2442 ;; Test a bound type decl
2443 (let ((fun (compile nil
`(lambda (*symbol-value-test-var
*)
2444 (declare (fixnum *symbol-value-test-var
*))
2445 (symbol-value '*symbol-value-test-var
*)))))
2446 (assert (equal `(function (,ufix
) (values ,ufix
&optional
))
2447 (%simple-fun-type fun
)))))
2451 (declare (fixnum **global-symbol-value-test-var
**))
2452 (symbol-global-value '**global-symbol-value-test-var
**))))
2453 (ufix (type-specifier (specifier-type `(and unsigned-byte fixnum
)))))
2454 (assert (equal `(function () (values ,ufix
&optional
))
2455 (%simple-fun-type fun
)))))
2457 (test-util:with-test
(:name
:mv-bind-to-let-type-propagation
)
2458 (let ((f (test-util:checked-compile
2460 (declare (optimize speed
)
2461 (type (integer 20 50) x
))
2462 (< (truncate x
10) 1))))
2463 (g (test-util:checked-compile
2465 (declare (optimize speed
)
2466 (type (integer 20 50) x
))
2467 (< (nth-value 1 (truncate x
10)) 10))))
2468 (h (test-util:checked-compile
2470 (declare (optimize speed
)
2471 (type (integer 20 50) x
))
2472 (multiple-value-bind (q r
)
2474 (declare (ignore r
))
2476 (type0 '(function ((integer 20 50)) (values null
&optional
)))
2477 (type1 '(function ((integer 20 50)) (values (member t
) &optional
))))
2478 (assert (equal type0
(sb-kernel:%simple-fun-type f
)))
2479 (assert (equal type1
(sb-kernel:%simple-fun-type g
)))
2480 (assert (equal type0
(sb-kernel:%simple-fun-type h
)))))
2482 (test-util:with-test
(:name
:bug-308921
)
2483 (let ((*check-consistency
* t
))
2485 `((let ((exported-symbols-alist
2486 (loop for symbol being the external-symbols of
:cl
2487 collect
(cons symbol
2488 (concatenate 'string
2490 (string-downcase symbol
))))))
2491 (defun hyperdoc-lookup (symbol)
2492 (cdr (assoc symbol exported-symbols-alist
)))))
2495 (test-util:with-test
(:name
:bug-308941
)
2496 (multiple-value-bind (warn fail
)
2498 "(eval-when (:compile-toplevel :load-toplevel :execute)
2501 (foo #.(make-foo3)))"
2503 ;; ...but the compiler should not break.
2504 (assert (and warn fail
))))
2506 (test-util:with-test
(:name
:bug-903821
)
2509 (ctu:ir1-named-calls
2511 (declare (sb-ext:word x
)
2512 (type (integer 0 #.
(1- sb-vm
:n-machine-word-bits
)) n
)
2514 (logandc2 x
(ash -
1 n
)))))
2516 (intern (format nil
"ASH-LEFT-MOD~D" sb-vm
:n-machine-word-bits
) "SB-VM")))
2517 (assert (not (member thing-not-to-call calls
)))
2518 (assert (= 7 (funcall fun
15 3)))))
2520 (test-util:with-test
(:name
:bug-997528
)
2521 (let ((fun (test-util:checked-compile
2523 (declare (optimize (speed 0) (space 0))
2524 (type (integer -
228645653448155482 -
228645653447928749) x
))
2525 (floor 1.0 (the (integer -
228645653448151677 -
228645653448150900) x
))))))
2526 (multiple-value-bind (quo rem
)
2527 (funcall fun -
228645653448151381)
2529 (assert (= rem
(float -
228645653448151381))))))
2531 (defmacro def-many-code-constants
()
2532 `(defun many-code-constants ()
2533 ,@(loop for i from
0 below
1000
2534 collect
`(print ,(format nil
"hi-~d" i
)))))
2536 (test-util:with-test
(:name
:many-code-constants
)
2537 (def-many-code-constants)
2538 (assert (search "hi-999"
2539 (with-output-to-string (*standard-output
*)
2540 (many-code-constants)))))
2542 (test-util:with-test
(:name
:bug-943953
)
2543 ;; we sometimes splice compiler structures like clambda in
2544 ;; source, and our error reporting would happily use that
2546 (let* ((src "bug-943953.lisp")
2547 (obj (test-util:scratch-file-name
"fasl")))
2548 (unwind-protect (let ((*error-output
* (make-broadcast-stream)))
2551 :verbose nil
:print nil
))
2552 (ignore-errors (delete-file obj
)))))
2554 (declaim (inline vec-1177703
))
2555 (defstruct (vec-1177703 (:constructor vec-1177703
(&optional x
)))
2556 (x 0.0d0
:type double-float
))
2558 (declaim (inline norm-1177703
))
2559 (defun norm-1177703 (v)
2560 (vec-1177703 (sqrt (vec-1177703-x v
))))
2562 (test-util:with-test
(:name
:bug-1177703
)
2563 (test-util:checked-compile
`(lambda (x)
2564 (norm-1177703 (vec-1177703 x
)))))
2566 (declaim (inline call-1035721
))
2567 (defun call-1035721 (function)
2569 (funcall function x
)))
2571 (declaim (inline identity-1035721
))
2572 (defun identity-1035721 (x)
2575 (test-util:with-test
(:name
:bug-1035721
)
2576 (test-util:checked-compile
2579 (call-1035721 #'identity-1035721
)
2581 (identity-1035721 x
))))))
2583 (test-util:with-test
(:name
:expt-type-derivation-and-method-redefinition
)
2584 (defmethod expt-type-derivation ((x list
) &optional
(y 0.0))
2585 (declare (type float y
))
2587 ;; the redefinition triggers a type lookup of the old
2588 ;; fast-method-function's type, which had a bogus type specifier of
2589 ;; the form (double-float 0) from EXPT type derivation
2590 (defmethod expt-type-derivation ((x list
) &optional
(y 0.0))
2591 (declare (type float y
))
2594 ;; Lp# 1066451 - declarations were either misplaced or dropped
2595 ;; depending on whether the :policy argument was used in DEFTRANSFORM.
2596 ;; That was a bit random. :policy doesn't affect whether decls
2597 ;; are accepted now.
2599 (declare (special randomness-factor
))
2600 (if (constant-lvar-p randomness-factor
)
2601 (format nil
"Weird transform answer is ~D"
2602 (+ (lvar-value randomness-factor
) blah
))))
2603 (defknown weird-fn
(integer symbol
&key
(:magic real
)) t
)
2604 (deftransform weird-fn
((x s
&key
((:magic randomness-factor
)))
2605 (fixnum t
&key
(:magic fixnum
)))
2606 ;; I can't see much use for declarations other than SPECIAL here,
2607 ;; but we shouldn't supposedly allow them and then not handle them right.
2608 (declare (special fred
) (special randomness-factor
) (lvar x s
))
2610 (test-util:with-test
(:name
:deftransform-bug-1066451
)
2611 (let ((f (let ((fred 3))
2612 (declare (special fred
))
2613 (test-util:checked-compile
2614 '(lambda () (weird-fn 2 'foo
:magic
11))))))
2615 (assert (string= (funcall f
)
2616 "Weird transform answer is 14"))))
2618 (test-util:with-test
(:name
:macro-policy
)
2619 (flet ((count-notes ()
2621 (handler-bind ((compiler-note
2626 (multiple-value-bind (fasl warnings errors
)
2627 (compile-file "macro-policy-test.lisp"
2628 :output-file
(test-util:scratch-file-name
)
2629 :print nil
:verbose nil
)
2630 (ignore-errors (delete-file fasl
))
2631 (assert (and (not warnings
) (not errors
)))
2633 (let* ((baseline (count-notes))
2634 (test (progv '(*frob-macro-policy
*) '(t) (count-notes)))
2635 (baseline-again (count-notes)))
2636 (assert (/= 0 baseline
))
2638 ;; macro-policy is rebound inside compile-file
2639 (assert (= baseline-again baseline
)))))
2641 (in-package :cl-user
)
2643 (with-test (:name
:merge-lambdas-dead-return
)
2644 (let ((fasl (let ((*error-output
* (make-broadcast-stream)))
2645 (compile-file "merge-lambdas.lisp"
2646 :output-file
(scratch-file-name)
2647 :print nil
:verbose nil
))))
2648 (ignore-errors (delete-file fasl
))))
2650 (declaim (inline ensure-a-fun
))
2651 (defun ensure-a-fun (f) (coerce f
'function
))
2652 (defmacro compose2
(f g
)
2653 `(let ((f (ensure-a-fun ,f
))
2654 (g (ensure-a-fun ,g
)))
2655 (lambda (arg) (funcall f
(funcall g arg
)))))
2657 (with-test (:name
:coerce-to-function-smarter
)
2658 (let ((calls (ctu:ir1-named-calls
2660 (funcall (compose2 #'integerp
#'car
) x
)))))
2661 ;; should be completely inlined
2662 (assert (null calls
))))
2664 (with-test (:name
:derived-function-type-casts
)
2665 (let ((fasl (compile-file "derived-function-type-casts.lisp"
2666 :output-file
(scratch-file-name)
2667 :print nil
:verbose nil
)))
2669 (ignore-errors (delete-file fasl
))
2670 (assert (null (funcall 'derived-function-type-casts
)))))
2672 (with-test (:name
(compile function
:invalid-function-name
))
2673 (flet ((test-case (nameoid)
2675 1 (checked-compile `(lambda () (function ,nameoid
))
2676 :allow-failure t
)))))
2679 (test-case '(foo bar
))))
2681 (defun catch-compiled-program-error (form &rest args
)
2682 (multiple-value-bind (function failure-p
)
2683 (checked-compile form
:allow-failure t
:allow-warnings t
)
2685 (assert-error (apply function args
))))
2687 (with-test (:name
:duplicate-
&key-no-error
)
2688 (catch-compiled-program-error
2689 '(lambda () (defun duplicate-&key-no-error
(&key a a
) a
))))
2691 (with-test (:name
:bad-type-specifiers
)
2692 (catch-compiled-program-error
2693 '(lambda (x) (typep x
'(values 10)))
2695 (assert (nth-value 1
2697 '(lambda () (declare (sb-ext:muffle-conditions
10)))
2698 :allow-warnings t
))))
2700 (with-test (:name
:coverage-and-errors
)
2702 '((locally (declare (optimize sb-c
:store-coverage-data
))
2705 (symbol-macrolet ((x 30))
2706 (macrolet ((foo (y) (+ x y
)))
2707 (declaim (inline environment-around-inline
))
2708 (defun environment-around-inline (z)
2711 (with-test (:name
:environment-around-inline
)
2712 (defun environment-around-inline.2 (z)
2713 (environment-around-inline z
))
2714 (assert (= (environment-around-inline.2 10) 340)))
2716 (with-test (:name
:defun-setf-return-value
)
2717 (let ((name `(setf ,(gensym))))
2718 (assert (equal (eval `(defun ,name
()))
2721 (with-test (:name
(make-sequence :unknown type
))
2722 (let ((fun (checked-compile
2724 (let ((vector (make-sequence '(simple-array make-sequence-unknown
(*)) 10)))
2725 (setf (aref vector
0) x
)
2727 :allow-style-warnings t
)))
2728 (deftype make-sequence-unknown
() 'fixnum
)
2729 (assert-error (funcall fun
'abc
) type-error
)))
2731 (with-test (:name
(:compiler-messages function
:type-specifier
))
2732 ;; Previously, function types were often printed confusingly, e.g.:
2734 ;; (function ()) => #'NIL
2735 ;; (function *) => #'*
2736 ;; (function (function a)) => #'#'A
2738 (flet ((test-case (spec)
2739 (destructuring-bind (type expected
) spec
2742 (proclaim '(ftype (function () boolean
) my-function
))
2743 (handler-bind ((warning
2745 (setf report
(princ-to-string condition
))
2747 (proclaim `(ftype ,type my-function
)))
2748 (assert (search expected report
)))
2749 (fmakunbound 'my-function
)))))
2752 `(((function ()) "(FUNCTION NIL)")
2753 ((function *) "(FUNCTION *)")
2754 ((function (function t
)) "(FUNCTION (FUNCTION T))")
2755 ((function (function (eql 1))) "(FUNCTION (FUNCTION (EQL 1))")))))
2757 (with-test (:name
(:compiler-messages function
:lambda-list
))
2758 ;; Previously, function lambda lists were sometimes printed
2759 ;; confusingly, e.g.:
2761 ;; (function collection) => #'COLLECTION
2762 ;; ((function t)) => (#'T)
2765 (sb-c::parse-lambda-list
'((function t
) . a
) :context
'defmethod
)
2767 (assert (search "illegal dotted lambda list: ((FUNCTION T) . A)"
2768 (princ-to-string condition
))))))
2770 (with-test (:name
:boxed-ref-setf-special
2771 :skipped-on
:interpreter
)
2772 (let* ((var (gensym))
2773 (fun (checked-compile `(lambda ()
2774 (declare (special ,var
))
2775 (setf ,var
10d0
)))))
2776 (ctu:assert-no-consing
(funcall fun
))))
2778 (with-test (:name
:boxed-ref-bind-special
2779 :skipped-on
:interpreter
)
2780 (let* ((var (gensym))
2781 (fun (checked-compile `(lambda ()
2783 (declare (special ,var
)))))))
2784 (ctu:assert-no-consing
(funcall fun
))))
2786 (with-test (:name
:boxed-ref-svref
2787 :skipped-on
:interpreter
)
2788 (let ((fun (checked-compile `(lambda (x)
2789 (setf (svref x
0) 10d0
))))
2790 (vector (vector nil
)))
2791 (ctu:assert-no-consing
(funcall fun vector
))))
2793 (with-test (:name
:boxed-ref-instance-set
2794 :skipped-on
:interpreter
)
2795 (let* ((name (gensym "STRUCT"))
2797 (eval `(defstruct ,name x
))
2798 (checked-compile `(lambda (x)
2799 (setf (,(sb-int:symbolicate name
'-x
) x
)
2801 (instance (funcall (sb-int:symbolicate
'make- name
))))
2802 (ctu:assert-no-consing
(funcall fun instance
))))
2804 (with-test (:name
:boxed-ref-car
2805 :skipped-on
:interpreter
)
2806 (let ((fun (checked-compile `(lambda (x)
2808 (setf (cdr x
) 10d0
))))
2810 (ctu:assert-no-consing
(funcall fun list
))))
2813 (with-test (:name
:ftype-return-type-conflict
2814 ;; Not having UNWIND-TO-FRAME-AND-CALL-VOP changes
2815 ;; the condition type here?
2816 :fails-on
(not :unwind-to-frame-and-call-vop
))
2817 (proclaim '(ftype (function () fixnum
) ftype-return-type-conflict
))
2818 (checked-compile-and-assert (:optimize
:safe
:allow-warnings t
)
2819 `(sb-int:named-lambda ftype-return-type-conflict
() nil
)
2820 (() (condition 'type-error
))))
2823 (declaim (inline bug-1728074-to-boolean bug-1728074-foo
))
2824 (defun bug-1728074-to-boolean (x) (/= x
0))
2825 (defun bug-1728074-foo (storage key converter
)
2826 (labels ((value (entry)
2827 (funcall converter
(ash entry -
17)))
2828 (insert (start key new
)
2830 (return-from insert
(value (aref storage start
))))
2831 (let ((entry (aref storage start
)))
2832 (let* ((okey (logand entry
#xf00
))
2833 (ostart (logand okey
#xf
)))
2834 (unless (= ostart start
)
2835 (insert ostart okey entry
)))))
2837 (let ((entry (aref storage index
)))
2838 (when (= key
(logand #xf00 entry
))
2840 (declare (inline value
))
2841 (probe (logand key
#xf
))))
2843 (with-test (:name
:defined-fun-in-a-deleted-home-lambda
)
2844 (checked-compile `(lambda (cache key
) (bug-1728074-foo cache key
#'bug-1728074-to-boolean
))))
2846 (defstruct (lambda-var-ref-lvar-null (:type list
))
2850 (with-test (:name
:lambda-var-ref-lvar-null
)
2851 (assert (nth-value 1
2854 (setf (lambda-var-ref-lvar-null-x :b
) nil
2855 (lambda-var-ref-lvar-null-y a
) 0))
2856 :allow-warnings t
))))
2858 (sb-c:defknown blah
* * (sb-c:foldable
))
2859 (defun blah (x) (- x
))
2860 (with-test (:name
:foldable-wild-args-fun
)
2861 (assert (eql (funcall (checked-compile '(lambda () (blah (+ 1 2))))) -
3)))
2864 (declaim (ftype (function * (values cons
&optional
)) safety-zero-return-checking
)
2865 (inline safety-zero-return-checking
))
2866 (defun safety-zero-return-checking (x)
2869 (with-test (:name
:safety-zero-return-checking
)
2870 (assert (nth-value 1 (checked-compile `(lambda ()
2871 (declare (optimize (safety 0)))
2872 (safety-zero-return-checking 1))
2873 :allow-warnings t
))))
2875 (with-test (:name
:inline-macrolet-debug-0
)
2876 (let* ((fun (gensym "FUN"))
2878 `(locally (declare (optimize (debug 0)))
2879 (macrolet ((macro () 10))
2880 (proclaim '(inline ,fun
))
2881 (defun ,fun
() (macro)))
2882 (lambda () (,fun
))))))
2883 (assert (= (funcall fun
) 10))))
2885 (with-test (:name
:substitute-lvar-updating-lvar-dependenceis
)
2886 (let ((name (gensym)))
2887 (proclaim `(ftype (function * (values number
&optional
))
2889 (checked-compile-and-assert
2891 `(sb-int:named-lambda
,name
(x fun
)
2897 (declare (inline snoop
))
2903 ((10 (constantly 131)) 131))))
2905 (defvar *symbol-value-bound-here-escaping
* 10)
2907 (with-test (:name
:symbol-value-bound-here-escaping
)
2908 (assert (eql (funcall
2912 (let (*symbol-value-bound-here-escaping
*)
2914 (let (*symbol-value-bound-here-escaping
*))
2915 *symbol-value-bound-here-escaping
*))))))
2918 (with-test (:name
:+constant-boundp
+)
2919 (let* ((package-name (gensym "CONSTANT-BOUNDP-TEST"))
2920 (*package
* (make-package package-name
:use
'(cl))))
2922 "(defconstant +constant-boundp+
2923 (if (boundp '+constant-boundp+)
2924 (symbol-value '+constant-boundp+)
2925 (let (*) (make-hash-table))))"
2927 :before-load
(lambda ()
2928 (delete-package *package
*)
2929 (setf *package
* (make-package package-name
:use
'(cl)))))))
2931 (with-test (:name
:bug-1804796
)
2935 (flet ((%f9
(f9-1 &optional
(f9-2 0) (f9-3 (complex a
0)))
2936 (declare (ignore f9-1 f9-3
))
2939 (flet ((%f14
(&optional
(f14-1 0) (f14-2 (complex f9-2
0)))
2940 (declare (ignore f14-1 f14-2
))
2942 (multiple-value-call #'%f14
(values f9-2
)))
2948 (multiple-value-call #'%f9
(values a
))
2951 (assert (eql (funcall f337
17) 0))))
2954 (defmethod make-load-form ((self dump-me
) &optional e
)
2955 (declare (notinline typep
) (ignore e
))
2956 ;; This error in bad usage of TYPEP would cause SB-C::COMPUTE-ENTRY-INFO
2957 ;; to encounter another error:
2959 ;; #<SB-FORMAT::FMT-CONTROL "bad thing to be a type specifier: ~/SB-IMPL:PRINT-TYPE-SPECIFIER/">
2960 ;; is not of type SEQUENCE
2962 (if (typep 'foo
(cons 1 2))
2963 (make-load-form-saving-slots self
)
2966 (with-test (:name
:failed-dump-fun-source
)
2967 (with-scratch-file (fasl "fasl")
2968 (let ((error-stream (make-string-output-stream)))
2969 (multiple-value-bind (fasl warnings errors
)
2970 (let ((*error-output
* error-stream
))
2971 (compile-file "bad-mlf-test.lisp" :output-file fasl
))
2972 (assert (and fasl warnings
(not errors
)))
2973 (assert (search "bad thing to be" (get-output-stream-string error-stream
)))
2975 (assert (eq (zook) 'hi
))))))
2977 (with-test (:name
:block-compile
)
2978 (with-scratch-file (fasl "fasl")
2979 (compile-file "block-compile-test.lisp" :output-file fasl
:block-compile t
)
2981 ;; Make sure the defuns all get compiled into the same code
2983 (assert (and (eq (sb-kernel::fun-code-header
#'baz2
)
2984 (sb-kernel::fun-code-header
#'bar2
))
2985 (eq (sb-kernel::fun-code-header
#'baz2
)
2986 (sb-kernel::fun-code-header
#'foo2
))))))
2988 (with-test (:name
(:block-compile
:entry-point
))
2989 (with-scratch-file (fasl "fasl")
2990 (compile-file "block-compile-test-2.lisp" :output-file fasl
:block-compile t
:entry-points
'(foo1))
2992 ;; Ensure bar1 gets let-converted into FOO1 and disappears.
2993 (assert (not (fboundp 'bar1
)))
2994 (assert (eql (foo1 10 1) 3628800))
2995 (let ((code (sb-kernel::fun-code-header
#'foo1
)))
2996 (assert (= (sb-kernel::code-n-entries code
) 1))
2997 (assert (eq (sb-kernel:%code-entry-point code
0)
3000 (with-test (:name
(:block-compile
:inline
))
3001 (with-scratch-file (fasl "fasl")
3002 (compile-file "block-compile-test-3.lisp" :output-file fasl
:block-compile t
)
3004 ;; Ensure all functions get inlined properly, so that there are no
3005 ;; local calls between them. The result will be that NONE of the
3006 ;; functions will share a code component.
3007 (let ((components '()))
3009 (pushnew (sb-kernel::fun-code-header fun
) components
)))
3014 (assert (= (length components
) 4)))))
3016 (with-test (:name
(:block-compile
:start-block
/end-block
))
3017 (with-scratch-file (fasl "fasl")
3018 (compile-file "block-compile-test-4.lisp" :output-file fasl
:block-compile
:specified
)
3020 (assert (eq (sb-kernel::fun-code-header
#'fun1
)
3021 (sb-kernel::fun-code-header
#'fun3
)))
3022 (assert (not (eq (sb-kernel::fun-code-header
#'fun1
)
3023 (sb-kernel::fun-code-header
#'fun4
))))
3024 (assert (not (fboundp 'fun2
)))))
3026 (with-test (:name
(:block-compile
:inlined-functions-local-call
))
3027 (with-scratch-file (fasl "fasl")
3028 (compile-file "block-compile-test-5.lisp" :output-file fasl
:block-compile
:specified
)
3030 (assert (not (fboundp 'zeta1
)))
3031 (assert (not (fboundp 'zeta2
)))
3032 (assert (= (gamma1 4) 10))))
3034 (with-test (:name
:symbol-value-constant
)
3035 (let* ((package-name (gensym "SYMBOL-VALUE-CONSTANT-TEST"))
3036 (*package
* (make-package package-name
:use
'(cl))))
3038 "(defconstant +constant+
3040 (if (boundp '+constant+)
3041 (symbol-value '+constant+)
3042 (complex 0.0 0.0))))"
3044 :before-load
(lambda ()
3045 (delete-package *package
*)
3046 (setf *package
* (make-package package-name
:use
'(cl)))))))
3048 (with-test (:name
:block-compile-merge-lambdas
)
3050 "(let (f) (when f (funcall f)))
3055 (with-test (:name
:fopcompile-specials
)
3057 "(locally (declare (special foo)) (print foo))"))
3059 (with-test (:name
:local-call-context
)
3061 "(lambda (&optional b) (declare (type integer b)) b)"
3064 (defstruct entry-info-type-struct
)
3066 (defvar *entry-info-type-struct
* (make-entry-info-type-struct))
3068 (defmethod make-load-form ((struct entry-info-type-struct
) &optional env
)
3069 (declare (ignore env
))
3070 '*entry-info-type-struct
*)
3072 (declaim (ftype (function () (member #.
*entry-info-type-struct
*)) entry-info-type-func
))
3074 (with-test (:name
:dump-entry-info-type
)
3076 "(lambda () (entry-info-type-func))"
3079 (deftype member-abc
() '(member #\a #\b #\c
))
3080 (with-test (:name
(make-array :initial-element style-warning
))
3081 (multiple-value-bind (warnp failp
)
3083 "(defun make-... (len) (make-array len :element-type '(or member-abc condition) :initial-element #\\e))")
3085 (assert (not failp
))))
3089 (defun is-probability?
(inp)
3090 (and (characterp inp
) (char<= false inp true
)))
3091 (deftype probability
() '(satisfies is-probability?
)))
3092 (with-test (:name
(make-array :initial-element satisfies
))
3093 (multiple-value-bind (warnp failp
)
3095 "(defun make-... (len) (make-array len :element-type '(or probability condition) :initial-element #\\e))")
3096 (assert (not warnp
))
3097 (assert (not failp
))))
3098 (with-test (:name
(make-sequence :initial-element satisfies
))
3099 (multiple-value-bind (warnp failp
)
3101 "(defun make-... (len) (make-sequence '(simple-array (or probability condition) (*)) len :initial-element #\\e))")
3102 (assert (not warnp
))
3103 (assert (not failp
))))
3105 ;;; Test from git rev 0b39d68b05ef669f812a6bf570126505d931bf96
3106 ;;; I do not understand why, if placed in a '.pure' file, it causes:
3107 ;;; There is no applicable method for the generic function
3108 ;;; #<STANDARD-GENERIC-FUNCTION SB-MOP:REMOVE-DIRECT-SUBCLASS (1)>
3109 ;;; when called with arguments
3110 ;;; (#<STRUCTURE-CLASS COMMON-LISP:STRUCTURE-OBJECT> NIL).
3111 ;;; when the test runner attempts to purge the classoid namespace
3112 ;;; of test artifacts.
3113 ;;; (It does define structures, but that's supposed to be allowed now)
3114 (with-test (:name
:bug-255
)
3115 (with-scratch-file (fasl "fasl")
3116 (compile-file "bug-255" :output-file fasl
))
3117 (delete-package :bug255
))
3119 (with-test (:name
:non-top-level-type-derive
)
3121 "(defun non-top-level-type-derive () 0)"
3125 "(when nil (defun non-top-level-type-derive () 1))"
3127 (assert (equal (sb-kernel:type-specifier
3128 (sb-int:info
:function
:type
'non-top-level-type-derive
))
3129 '(function () (values (integer 0 0) &optional
))))))
3132 (assert (eql (funcall 'non-top-level-type-derive
) 0)))
3134 "(when t (defun non-top-level-type-derive () 1))"
3136 (assert (equal (sb-kernel:type-specifier
3137 (sb-int:info
:function
:type
'non-top-level-type-derive
))
3138 '(function () (values (integer 1 1) &optional
))))
3139 (assert (eql (funcall 'non-top-level-type-derive
) 1)))
3141 (with-test (:name
:delete-optional-dispatch-xep
)
3143 "(defun delete-optional-dispatch-xep (&optional x)
3146 (multiple-value-call #'delete-optional-dispatch-xep (1- x))))"
3147 :block-compile t
; so the self call is recognized
3149 (assert (= (funcall 'delete-optional-dispatch-xep
3) 10)))
3152 (with-test (:name
:dx-dont-propagate
)
3154 `((defmacro generalized-delete
(item list test
)
3155 `(let ((the-list ,list
))
3156 (flet ((fun (y) (funcall ,test
,item y
)))
3157 (let ((input the-list
))
3158 (%%delete-impl
#'fun input
)))))
3160 (defmacro %%delete-impl
(predicate list
)
3161 `(let ((dummy (cons nil
,list
)))
3162 (declare (dynamic-extent dummy
))
3164 (cur (cdr prev
) (cdr prev
)))
3165 ((null cur
) (cdr dummy
))
3166 (if (funcall ,predicate
(car cur
))
3167 (rplacd prev
(cdr cur
))
3170 (defun foo-assert (test expect actual
)
3171 (unless (funcall test expect actual
)
3172 (format t
"stack-allocated-p=~S~%" (sb-ext:stack-allocated-p actual
))
3173 (error "assertion failed")))
3175 ;; The dummy cons made by the DELETE-IMPL algorithm (using
3176 ;; essentially the same technique as many list traversal macros in
3177 ;; SBCL such as COLLECT). But The list made by (LIST 1) in this assertion
3178 ;; does not want to be dynamic-extent.
3179 (foo-assert #'equal
(list 1) (generalized-delete 0 (list 1) #'=)))
3182 (with-test (:name
:new-inline-functional-type-conflict
)
3184 `((declaim (inline inline-fun
))
3185 (defun inline-fun (x)
3188 (defun new-inline-functional-type-conflict (m)
3189 (declare (optimize space
)
3193 (funcall (if t
#'inline-fun
) 'a
)))
3195 (assert (null (ctu:find-named-callees
(symbol-function 'new-inline-functional-type-conflict
))))
3196 ;; We want to share the functional on space > speed, so we should
3197 ;; have 3 code segments: one for
3198 ;; NEW-INLINE-FUNCTIONAL-TYPE-CONFLICT's XEP, one for
3199 ;; NEW-INLINE-FUNCTIONAL-TYPE-CONFLICT, and one for INLINE-FUN.
3200 (assert (= 3 (length (sb-disassem::get-code-segments
(sb-kernel::fun-code-header
#'new-inline-functional-type-conflict
)))))
3201 (let ((type (sb-kernel:%simple-fun-type
3202 (symbol-function 'new-inline-functional-type-conflict
))))
3203 ;; Either of these types should be OK.
3204 (assert (or (ctype= type
3205 '(function (integer) (values (member a
) &optional
)))
3207 '(function (integer) (values (or integer
(member a
)) &optional
)))))))
3209 (with-test (:name
:new-inline-functional-type-conflict
.2)
3211 `((declaim (inline inline-fun
))
3212 (defun inline-fun (x)
3215 (defun new-inline-functional-type-conflict.2 (m)
3216 (declare (optimize space
))
3217 (print (list (inline-fun m
)
3219 (funcall (if t
#'inline-fun
) 'a
)))
3221 (assert (equal (ctu:find-named-callees
(symbol-function 'new-inline-functional-type-conflict
.2))
3223 ;; We want to share the functional on space > speed, so we should
3224 ;; have 3 code segments: one for
3225 ;; NEW-INLINE-FUNCTIONAL-TYPE-CONFLICT.2's XEP, one for
3226 ;; NEW-INLINE-FUNCTIONAL-TYPE-CONFLICT.2, and one for INLINE-FUN.
3227 (assert (= 3 (length (sb-disassem::get-code-segments
(sb-kernel::fun-code-header
#'new-inline-functional-type-conflict
.2)))))
3228 ;; We should have no type information from the arguments, because
3229 ;; the functional is shared.
3230 (let ((type (sb-kernel:%simple-fun-type
3231 (symbol-function 'new-inline-functional-type-conflict
.2))))
3232 (assert (ctype= type
'(function (t) (values t
&optional
))))))
3234 (with-test (:name
:new-inline-functional-type-conflict
.3)
3236 `((declaim (inline inline-fun
))
3237 (defun inline-fun (x)
3240 (defun new-inline-functional-type-conflict.3 (m)
3241 (declare (optimize space
))
3245 (funcall (if (integerp m
) #'inline-fun
) 1)))
3246 (assert (= (new-inline-functional-type-conflict.3 1) 1)))
3250 (with-test (:name
:new-inline-functional-type-conflict
.4)
3252 `((declaim (inline inline-fun
))
3253 (defun inline-fun (x)
3258 (declare (optimize space
))
3262 (funcall (if (integerp m
) #'inline-fun
) 2)))
3263 (assert (eq (test 1 2) t
)))