X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=1a4a58c3be57e2017a2569a3d3fcc5cd6d9d7346;hb=02a50d510572990c2b836e37ec1c0b23dac41b1a;hp=3bfaf656dc6844e19367732048be4403fd81bcba;hpb=f49bfb22b950ee41bdfd23de705fa023b3a9848c;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 3bfaf65..1a4a58c 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -21,67 +21,67 @@ ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by ;;; Martin Atzmueller (2000-09-13 on sbcl-devel). (funcall (compile nil - '(lambda () - (labels ((fun1 () - (fun2)) - (fun2 () - (when nil - (tagbody - tag - (fun2) - (go tag))) - (when nil - (tagbody - tag - (fun1) - (go tag))))) - - (fun1) - nil)))) + '(lambda () + (labels ((fun1 () + (fun2)) + (fun2 () + (when nil + (tagbody + tag + (fun2) + (go tag))) + (when nil + (tagbody + tag + (fun1) + (go tag))))) + + (fun1) + nil)))) ;;; Exercise a compiler bug (by crashing the compiler). ;;; -;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on +;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL. (funcall (compile nil - '(lambda (x) - (or (integerp x) - (block used-by-some-y? - (flet ((frob (stk) - (dolist (y stk) - (unless (rejected? y) - (return-from used-by-some-y? t))))) - (declare (inline frob)) - (frob (rstk x)) - (frob (mrstk x))) - nil)))) - 13) + '(lambda (x) + (or (integerp x) + (block used-by-some-y? + (flet ((frob (stk) + (dolist (y stk) + (unless (rejected? y) + (return-from used-by-some-y? t))))) + (declare (inline frob)) + (frob (rstk x)) + (frob (mrstk x))) + nil)))) + 13) ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally ;;; from Bruno Haible in CMU CL bugs collection), fixed by ;;; Alexey Dejneka 2002-01-27 (assert (= 1 ; (used to give 0 under bug 112) - (let ((x 0)) - (declare (special x)) - (let ((x 1)) - (let ((y x)) - (declare (special x)) y))))) + (let ((x 0)) + (declare (special x)) + (let ((x 1)) + (let ((y x)) + (declare (special x)) y))))) (assert (= 1 ; (used to give 1 even under bug 112, still works after fix) - (let ((x 0)) - (declare (special x)) - (let ((x 1)) - (let ((y x) (x 5)) - (declare (special x)) y))))) + (let ((x 0)) + (declare (special x)) + (let ((x 1)) + (let ((y x) (x 5)) + (declare (special x)) y))))) ;;; another LET-related bug fixed by Alexey Dejneka at the same ;;; time as bug 112 (multiple-value-bind (fun warnings-p failure-p) ;; should complain about duplicate variable names in LET binding (compile nil - '(lambda () - (let (x - (x 1)) - (list x)))) + '(lambda () + (let (x + (x 1)) + (list x)))) (declare (ignore warnings-p)) (assert (functionp fun)) (assert failure-p)) @@ -91,26 +91,26 @@ (progn (multiple-value-bind (fun warnings-p failure-p) (compile nil - ;; Compiling this code should cause a STYLE-WARNING - ;; about *X* looking like a special variable but not - ;; being one. - '(lambda (n) - (let ((*x* n)) - (funcall (symbol-function 'x-getter)) - (print *x*)))) + ;; Compiling this code should cause a STYLE-WARNING + ;; about *X* looking like a special variable but not + ;; being one. + '(lambda (n) + (let ((*x* n)) + (funcall (symbol-function 'x-getter)) + (print *x*)))) (assert (functionp fun)) (assert warnings-p) (assert (not failure-p))) (multiple-value-bind (fun warnings-p failure-p) (compile nil - ;; Compiling this code should not cause a warning - ;; (because the DECLARE turns *X* into a special - ;; variable as its name suggests it should be). - '(lambda (n) - (let ((*x* n)) - (declare (special *x*)) - (funcall (symbol-function 'x-getter)) - (print *x*)))) + ;; Compiling this code should not cause a warning + ;; (because the DECLARE turns *X* into a special + ;; variable as its name suggests it should be). + '(lambda (n) + (let ((*x* n)) + (declare (special *x*)) + (funcall (symbol-function 'x-getter)) + (print *x*)))) (assert (functionp fun)) (assert (not warnings-p)) (assert (not failure-p)))) @@ -167,7 +167,7 @@ ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)") (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14) - 17)) + 17)) ;;; bug 181: bad type specifier dropped compiler into debugger (assert (list (compile nil '(lambda (x) @@ -194,6 +194,71 @@ (assert (not (eval `(locally (declare (optimize (safety 3))) (ignore-errors (progn ,form t))))))) +;;; feature: we shall complain if functions which are only useful for +;;; their result are called and their result ignored. +(loop for (form expected-des) in + '(((progn (nreverse (list 1 2)) t) + "The return value of NREVERSE should not be discarded.") + ((progn (nreconc (list 1 2) (list 3 4)) t) + "The return value of NRECONC should not be discarded.") + ((locally + (declare (inline sort)) + (sort (list 1 2) #'<) t) + ;; FIXME: it would be nice if this warned on non-inlined sort + ;; but the current simple boolean function attribute + ;; can't express the condition that would be required. + "The return value of STABLE-SORT-LIST should not be discarded.") + ((progn (sort (vector 1 2) #'<) t) + ;; Apparently, SBCL (but not CL) guarantees in-place vector + ;; sort, so no warning. + nil) + ((progn (delete 2 (list 1 2)) t) + "The return value of DELETE should not be discarded.") + ((progn (delete-if #'evenp (list 1 2)) t) + ("The return value of DELETE-IF should not be discarded.")) + ((progn (delete-if #'evenp (vector 1 2)) t) + ("The return value of DELETE-IF should not be discarded.")) + ((progn (delete-if-not #'evenp (list 1 2)) t) + "The return value of DELETE-IF-NOT should not be discarded.") + ((progn (delete-duplicates (list 1 2)) t) + "The return value of DELETE-DUPLICATES should not be discarded.") + ((progn (merge 'list (list 1 3) (list 2 4) #'<) t) + "The return value of MERGE should not be discarded.") + ((progn (nreconc (list 1 3) (list 2 4)) t) + "The return value of NRECONC should not be discarded.") + ((progn (nunion (list 1 3) (list 2 4)) t) + "The return value of NUNION should not be discarded.") + ((progn (nintersection (list 1 3) (list 2 4)) t) + "The return value of NINTERSECTION should not be discarded.") + ((progn (nset-difference (list 1 3) (list 2 4)) t) + "The return value of NSET-DIFFERENCE should not be discarded.") + ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t) + "The return value of NSET-EXCLUSIVE-OR should not be discarded.")) + for expected = (if (listp expected-des) + expected-des + (list expected-des)) + do + (multiple-value-bind (fun warnings-p failure-p) + (handler-bind ((style-warning (lambda (c) + (if expected + (let ((expect-one (pop expected))) + (assert (search expect-one + (with-standard-io-syntax + (let ((*print-right-margin* nil)) + (princ-to-string c)))) + () + "~S should have warned ~S, but instead warned: ~A" + form expect-one c)) + (error "~S shouldn't give a(nother) warning, but did: ~A" form c))))) + (compile nil `(lambda () ,form))) + (declare (ignore warnings-p)) + (assert (functionp fun)) + (assert (null expected) + () + "~S should have warned ~S, but didn't." + form expected) + (assert (not failure-p)))) + ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers ;;; to cause errors in the compiler. Fixed by CSR in 0.7.8.10 (assert (list (compile nil '(lambda (x) (map 'simple-array 'identity x))))) @@ -252,37 +317,37 @@ ;;; PSETQ should behave when given complex symbol-macro arguments (multiple-value-bind (sequence index) (symbol-macrolet ((x (aref a (incf i))) - (y (aref a (incf i)))) - (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) - (i 0)) - (psetq x (aref a (incf i)) - y (aref a (incf i))) - (values a i))) + (y (aref a (incf i)))) + (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) + (i 0)) + (psetq x (aref a (incf i)) + y (aref a (incf i))) + (values a i))) (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9))) (assert (= index 4))) (multiple-value-bind (result error) (ignore-errors (let ((x (list 1 2))) - (psetq (car x) 3) - x)) + (psetq (car x) 3) + x)) (assert (null result)) (assert (typep error 'program-error))) ;;; COPY-SEQ should work on known-complex vectors: (assert (equalp #(1) - (let ((v (make-array 0 :fill-pointer 0))) - (vector-push-extend 1 v) - (copy-seq v)))) + (let ((v (make-array 0 :fill-pointer 0))) + (vector-push-extend 1 v) + (copy-seq v)))) ;;; to support INLINE functions inside MACROLET, it is necessary for ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in ;;; certain circumstances, one of which is when compile is called from ;;; top-level. (assert (equal - (function-lambda-expression - (compile nil '(lambda (x) (block nil (print x))))) - '(lambda (x) (block nil (print x))))) + (function-lambda-expression + (compile nil '(lambda (x) (block nil (print x))))) + '(lambda (x) (block nil (print x))))) ;;; bug 62: too cautious type inference in a loop (assert (nth-value @@ -389,8 +454,8 @@ (values nil t t)))))) (assert (typep (eval `(the arithmetic-error - ',(make-condition 'arithmetic-error))) - 'arithmetic-error)) + ',(make-condition 'arithmetic-error))) + 'arithmetic-error)) (assert (not (nth-value 2 (compile nil '(lambda () @@ -460,17 +525,17 @@ (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda (x) - (declare (type (simple-array (simple-string 3) (5)) x)) - (aref (aref x 0) 0)))) + (declare (type (simple-array (simple-string 3) (5)) x)) + (aref (aref x 0) 0)))) ;;; compiler failure (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0))))))) (assert (funcall f 1d0))) (compile nil '(lambda (x) - (declare (double-float x)) - (let ((y (* x pi))) - (atan y y)))) + (declare (double-float x)) + (let ((y (* x pi))) + (atan y y)))) ;;; bogus optimization of BIT-NOT (multiple-value-bind (result x) @@ -484,13 +549,13 @@ ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T). (handler-bind ((sb-ext:compiler-note #'error)) (assert (equalp (funcall - (compile - nil - '(lambda () - (let ((x (make-sequence 'vector 10 :initial-element 'a))) - (setf (aref x 4) 'b) - x)))) - #(a a a a b a a a a a)))) + (compile + nil + '(lambda () + (let ((x (make-sequence 'vector 10 :initial-element 'a))) + (setf (aref x 4) 'b) + x)))) + #(a a a a b a a a a a)))) ;;; this is not a check for a bug, but rather a test of compiler ;;; quality @@ -566,8 +631,8 @@ ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ] ;;; wasn't recognized as a good type specifier. (let ((fun (lambda (x y) - (declare (type (integer -1 0) x y) (optimize speed)) - (logxor x y)))) + (declare (type (integer -1 0) x y) (optimize speed)) + (logxor x y)))) (assert (= (funcall fun 0 0) 0)) (assert (= (funcall fun 0 -1) -1)) (assert (= (funcall fun -1 -1) 0))) @@ -637,12 +702,12 @@ ;;; bug in Alpha backend: not enough sanity checking of arguments to ;;; instructions -(assert (= (funcall (compile nil - '(lambda (x) - (declare (fixnum x)) - (ash x -257))) - 1024) - 0)) +(assert (= (funcall (compile nil + '(lambda (x) + (declare (fixnum x)) + (ash x -257))) + 1024) + 0)) ;;; bug found by WHN and pfdietz: compiler failure while referencing ;;; an entry point inside a deleted lambda @@ -682,19 +747,19 @@ ;;; reasonable multiplication never returned, causing chaos. Fixed by ;;; explicitly doing modular arithmetic, and relying on the backends ;;; being smart. -(assert (= (funcall - (compile nil - '(lambda (x) - (declare (type (integer 178956970 178956970) x) - (optimize speed)) - (* x 24))) - 178956970) - 4294967280)) +(assert (= (funcall + (compile nil + '(lambda (x) + (declare (type (integer 178956970 178956970) x) + (optimize speed)) + (* x 24))) + 178956970) + 4294967280)) ;;; bug in modular arithmetic and type specifiers (assert (= (funcall (compile nil (lambda (x) (logand x x 0))) - -1) - 0)) + -1) + 0)) ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP ;;; produced wrong result for shift >=32 on X86 @@ -881,19 +946,19 @@ (labels ((%f12 (f12-1 f12-2) (labels ((%f2 (f2-1 f2-2) (flet ((%f6 () - (flet ((%f18 + (flet ((%f18 (f18-1 &optional (f18-2 a) (f18-3 -207465075) (f18-4 a)) (return-from %f12 b))) - (%f18 -3489553 - -7 - (%f18 (%f18 150 -64 f12-1) - (%f18 (%f18 -8531) - 11410) - b) - 56362666)))) + (%f18 -3489553 + -7 + (%f18 (%f18 150 -64 f12-1) + (%f18 (%f18 -8531) + 11410) + b) + 56362666)))) (labels ((%f7 (f7-1 f7-2 &optional (f7-3 (%f6))) @@ -1189,18 +1254,18 @@ '(lambda (a b c) (declare (notinline boole values denominator list)) (declare - (optimize (speed 2) - (space 0) - (safety 1) - (debug 0) - (compilation-speed 2))) + (optimize (speed 2) + (space 0) + (safety 1) + (debug 0) + (compilation-speed 2))) (catch 'ct6 - (progv - '(*s8*) - (list 0) - (let ((v9 (ignore-errors (throw 'ct6 0)))) - (denominator - (progv nil nil (values (boole boole-and 0 v9))))))))) + (progv + '(*s8*) + (list 0) + (let ((v9 (ignore-errors (throw 'ct6 0)))) + (denominator + (progv nil nil (values (boole boole-and 0 v9))))))))) 1 2 3))) ;;; non-continuous dead UVL blocks @@ -1241,21 +1306,21 @@ nil '(lambda (b g h) (declare (optimize (speed 3) (space 3) (safety 2) - (debug 2) (compilation-speed 3))) + (debug 2) (compilation-speed 3))) (catch 'ct5 - (unwind-protect - (labels ((%f15 (f15-1 f15-2 f15-3) + (unwind-protect + (labels ((%f15 (f15-1 f15-2 f15-3) (rational (throw 'ct5 0)))) - (%f15 0 - (apply #'%f15 - 0 - h - (progn - (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b) - 0) - nil) - 0)) - (common-lisp:handler-case 0))))) + (%f15 0 + (apply #'%f15 + 0 + h + (progn + (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b) + 0) + nil) + 0)) + (common-lisp:handler-case 0))))) 1 2 3)) '(0))) @@ -1332,10 +1397,10 @@ (handler-case (compile nil '(lambda (x) - (declare (type (integer -100 100) x)) - (declare (optimize speed)) - (declare (notinline identity)) - (1+ (identity x)))) + (declare (type (integer -100 100) x)) + (declare (optimize speed)) + (declare (notinline identity)) + (1+ (identity x)))) (compiler-note () (error "IDENTITY derive-type not applied."))) (assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil))) @@ -1375,17 +1440,17 @@ ;;; efficiency notes for ordinary code (macrolet ((frob (arglist &body body) - `(progn - (handler-case - (compile nil '(lambda ,arglist ,@body)) - (sb-ext:compiler-note (e) - (error "bad compiler note for ~S:~% ~A" ',body e))) - (catch :got-note - (handler-case - (compile nil '(lambda ,arglist (declare (optimize speed)) - ,@body)) - (sb-ext:compiler-note (e) (throw :got-note nil))) - (error "missing compiler note for ~S" ',body))))) + `(progn + (handler-case + (compile nil '(lambda ,arglist ,@body)) + (sb-ext:compiler-note (e) + (error "bad compiler note for ~S:~% ~A" ',body e))) + (catch :got-note + (handler-case + (compile nil '(lambda ,arglist (declare (optimize speed)) + ,@body)) + (sb-ext:compiler-note (e) (throw :got-note nil))) + (error "missing compiler note for ~S" ',body))))) (frob (x) (funcall x)) (frob (x y) (find x y)) (frob (x y) (find-if x y)) @@ -1396,16 +1461,16 @@ (frob (x) (aref x 0))) (macrolet ((frob (style-warn-p form) - (if style-warn-p - `(catch :got-style-warning - (handler-case - (eval ',form) - (style-warning (e) (throw :got-style-warning nil))) - (error "missing style-warning for ~S" ',form)) - `(handler-case - (eval ',form) - (style-warning (e) - (error "bad style-warning for ~S: ~A" ',form e)))))) + (if style-warn-p + `(catch :got-style-warning + (handler-case + (eval ',form) + (style-warning (e) (throw :got-style-warning nil))) + (error "missing style-warning for ~S" ',form)) + `(handler-case + (eval ',form) + (style-warning (e) + (error "bad style-warning for ~S: ~A" ',form e)))))) (frob t (lambda (x &optional y &key z) (list x y z))) (frob nil (lambda (x &optional y z) (list x y z))) (frob nil (lambda (x &key y z) (list x y z))) @@ -1419,27 +1484,27 @@ ;;; from LOGXOR was small and negative, though the bottom one worked. (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda () - (declare (optimize speed (safety 0))) - (lambda (x y) - (declare (type (integer 3 6) x) - (type (integer -6 -3) y)) - (+ (logxor x y) most-positive-fixnum))))) + (declare (optimize speed (safety 0))) + (lambda (x y) + (declare (type (integer 3 6) x) + (type (integer -6 -3) y)) + (+ (logxor x y) most-positive-fixnum))))) (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda () - (declare (optimize speed (safety 0))) - (lambda (x y) - (declare (type (integer 3 6) y) - (type (integer -6 -3) x)) - (+ (logxor x y) most-positive-fixnum))))) + (declare (optimize speed (safety 0))) + (lambda (x y) + (declare (type (integer 3 6) y) + (type (integer -6 -3) x)) + (+ (logxor x y) most-positive-fixnum))))) ;;; check that modular ash gives the right answer, to protect against ;;; possible misunderstandings about the hardware shift instruction. (assert (zerop (funcall - (compile nil '(lambda (x y) - (declare (optimize speed) - (type (unsigned-byte 32) x y)) - (logand #xffffffff (ash x y)))) - 1 257))) + (compile nil '(lambda (x y) + (declare (optimize speed) + (type (unsigned-byte 32) x y)) + (logand #xffffffff (ash x y)))) + 1 257))) ;;; code instrumenting problems (compile nil @@ -1505,22 +1570,22 @@ (declare (type (integer -4085 0) b)) (declare (ignorable a b)) (declare - (optimize (space 2) - (compilation-speed 0) - #+sbcl (sb-c:insert-step-conditions 0) - (debug 2) - (safety 0) - (speed 3))) + (optimize (space 2) + (compilation-speed 0) + #+sbcl (sb-c:insert-step-conditions 0) + (debug 2) + (safety 0) + (speed 3))) (let ((*s5* 0)) - (dotimes (iv1 2 0) - (let ((*s5* - (elt '(1954479092053) - (min 0 - (max 0 - (if (< iv1 iv1) - (lognand iv1 (ash iv1 (min 53 iv1))) - iv1)))))) - 0))))) + (dotimes (iv1 2 0) + (let ((*s5* + (elt '(1954479092053) + (min 0 + (max 0 + (if (< iv1 iv1) + (lognand iv1 (ash iv1 (min 53 iv1))) + iv1)))))) + 0))))) -7639589303599 -1368))) (compile @@ -1544,15 +1609,15 @@ '(lambda (a b c d) (declare (notinline aref logandc2 gcd make-array)) (declare - (optimize (space 0) (safety 0) (compilation-speed 3) - (speed 3) (debug 1))) + (optimize (space 0) (safety 0) (compilation-speed 3) + (speed 3) (debug 1))) (progn - (tagbody - (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2))))) - (declare (dynamic-extent v2)) - (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2)))) - tag2) - 0))) + (tagbody + (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2))))) + (declare (dynamic-extent v2)) + (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2)))) + tag2) + 0))) 3021871717588 -866608 -2 -17194))) ;;; MISC.436, 438: lost reoptimization @@ -1564,39 +1629,39 @@ (declare (type (integer 0 160159) b)) (declare (ignorable a b)) (declare - (optimize (compilation-speed 1) - (speed 3) - (safety 3) - (space 0) - ; #+sbcl (sb-c:insert-step-conditions 0) - (debug 0))) + (optimize (compilation-speed 1) + (speed 3) + (safety 3) + (space 0) + ; #+sbcl (sb-c:insert-step-conditions 0) + (debug 0))) (if - (oddp - (loop for - lv1 - below - 2 - count - (logbitp 0 - (1- - (ash b - (min 8 - (count 0 - '(-10197561 486 430631291 - 9674068)))))))) - b - 0))) + (oddp + (loop for + lv1 + below + 2 + count + (logbitp 0 + (1- + (ash b + (min 8 + (count 0 + '(-10197561 486 430631291 + 9674068)))))))) + b + 0))) 1265797 110757))) (assert (zerop (funcall (compile nil ' (lambda (a) - (declare (type (integer 0 1696) a)) - ; (declare (ignorable a)) - (declare (optimize (space 2) (debug 0) (safety 1) - (compilation-speed 0) (speed 1))) - (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) + (declare (type (integer 0 1696) a)) + ; (declare (ignorable a)) + (declare (optimize (space 2) (debug 0) (safety 1) + (compilation-speed 0) (speed 1))) + (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) 805))) ;;; bug #302 @@ -1656,3 +1721,261 @@ (dotimes (i 100) (when (> (funcall fun t) 9) (error "bad RANDOM event")))) + +;;; 0.8.17.28-sma.1 lost derived type information. +(with-test (:name "0.8.17.28-sma.1" :fails-on :sparc) + (handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c)))) + (compile nil + '(lambda (x y v) + (declare (optimize (speed 3) (safety 0))) + (declare (type (integer 0 80) x) + (type (integer 0 11) y) + (type (simple-array (unsigned-byte 32) (*)) v)) + (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y)) + nil)))) + +;;; Bug reported by Robert J. Macomber: instrumenting of more-entry +;;; prevented open coding of %LISTIFY-REST-ARGS. +(let ((f (compile nil '(lambda () + (declare (optimize (debug 3))) + (with-simple-restart (blah "blah") (error "blah")))))) + (handler-bind ((error (lambda (c) (invoke-restart 'blah)))) + (assert (equal (multiple-value-list (funcall f)) '(nil t))))) + +;;; Bug reported by Timmy Douglas: overflow in bit vector setter with +;;; constant index and value. +(loop for n-bits = 1 then (* n-bits 2) + for type = `(unsigned-byte ,n-bits) + and v-max = (1- (ash 1 n-bits)) + while (<= n-bits sb-vm:n-word-bits) + do + (let* ((n (* 2 (1+ (- sb-vm::n-word-bits n-bits)))) + (array1 (make-array n :element-type type)) + (array2 (make-array n :element-type type))) + (dotimes (i n) + (dolist (v (list 0 v-max)) + (let ((f (compile nil `(lambda (a) + (declare (type (simple-array ,type (,n)) a)) + (setf (aref a ,i) ,v))))) + (fill array1 (- v-max v)) + (fill array2 (- v-max v)) + (funcall f array1) + (setf (aref array2 i) v) + (assert (every #'= array1 array2))))))) + +(let ((fn (compile nil '(lambda (x) + (declare (type bit x)) + (declare (optimize speed)) + (let ((b (make-array 64 :element-type 'bit + :initial-element 0))) + (count x b)))))) + (assert (= (funcall fn 0) 64)) + (assert (= (funcall fn 1) 0))) + +(let ((fn (compile nil '(lambda (x y) + (declare (type simple-bit-vector x y)) + (declare (optimize speed)) + (equal x y))))) + (assert (funcall + fn + (make-array 64 :element-type 'bit :initial-element 0) + (make-array 64 :element-type 'bit :initial-element 0))) + (assert (not + (funcall + fn + (make-array 64 :element-type 'bit :initial-element 0) + (let ((b (make-array 64 :element-type 'bit :initial-element 0))) + (setf (sbit b 63) 1) + b))))) + +;;; MISC.535: compiler failure +(let ((c0 #c(4196.088977268509d0 -15943.3603515625d0))) + (assert (not (funcall + (compile + nil + `(lambda (p1 p2) + (declare (optimize speed (safety 1)) + (type (eql ,c0) p1) + (type number p2)) + (eql (the (complex double-float) p1) p2))) + c0 #c(12 612/979))))) + +;;; reported by Lutz Euler: we shouldn't signal a compiler note for +;;; simple-bit-vector functions. +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x) + (declare (type simple-bit-vector x)) + (count 1 x)))) +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x y) + (declare (type simple-bit-vector x y)) + (equal x y)))) + +;;; MISC.550: CAST merging in IR1 finalization caused unexpected +;;; code transformations. +(assert (eql (funcall + (compile + nil + '(lambda (p1 p2) + (declare (optimize (speed 3) (safety 2) (debug 3) (space 3)) + (type atom p1) + (type symbol p2)) + (or p1 (the (eql t) p2)))) + nil t) + t)) + +;;; MISC.548: type check weakening converts required type into +;;; optional +(assert (eql t + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 2) (safety 1) (debug 3) (space 2))) + (atom (the (member f assoc-if write-line t w) p1)))) + t))) + +;;; Free special bindings only apply to the body of the binding form, not +;;; the initialization forms. +(assert (eq :good + (funcall (compile 'nil + (lambda () + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + ((lambda (&optional (y x)) + (declare (special x)) y))))))))) + +;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of +;;; a rational was zero, but didn't do the substitution, leading to a +;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the +;;; machine's ASH instruction's immediate field) that the compiler +;;; thought was legitimate. +;;; +;;; FIXME: this has been recorded as bug 383. The attempted fix (sbcl +;;; 0.9.2.6) led to lots of spurious optimization notes. So the bug stil +;;; exist and this test case serves as a reminder of the problem. +;;; --njf, 2005-07-05 +#+nil +(compile 'nil + (LAMBDA (B) + (DECLARE (TYPE (INTEGER -2 14) B)) + (DECLARE (IGNORABLE B)) + (ASH (IMAGPART B) 57))) + +;;; bug reported by Eduardo Mu\~noz +(multiple-value-bind (fun warnings failure) + (compile nil '(lambda (struct first) + (declare (optimize speed)) + (let* ((nodes (nodes struct)) + (bars (bars struct)) + (length (length nodes)) + (new (make-array length :fill-pointer 0))) + (vector-push first new) + (loop with i fixnum = 0 + for newl fixnum = (length new) + while (< newl length) do + (let ((oldl (length new))) + (loop for j fixnum from i below newl do + (dolist (n (node-neighbours (aref new j) bars)) + (unless (find n new) + (vector-push n new)))) + (setq i oldl))) + new))) + (declare (ignore fun warnings failure)) + (assert (not failure))) + +;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe +;;; sbcl-devel) +(compile nil '(lambda (x y a b c) + (- y (* (signum x) (sqrt (abs (- (* b x) c))))))) + +;;; Type inference from CHECK-TYPE +(let ((count0 0) (count1 0)) + (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count0)))) + (compile nil '(lambda (x) + (declare (optimize (speed 3))) + (1+ x)))) + ;; forced-to-do GENERIC-+, etc + (assert (> count0 0)) + (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1)))) + (compile nil '(lambda (x) + (declare (optimize (speed 3))) + (check-type x fixnum) + (1+ x)))) + (assert (= count1 0))) + +;;; Up to 0.9.8.22 x86-64 had broken return value handling in the +;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs. +(with-test (:name :sap-ref-float) + (compile nil '(lambda (sap) + (let ((x (setf (sb-vm::sap-ref-double sap 0) 1d0))) + (1+ x)))) + (compile nil '(lambda (sap) + (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0))) + (1+ x))))) + +;;; bug #399 +(with-test (:name :string-union-types) + (compile nil '(lambda (x) + (declare (type (or (simple-array character (6)) + (simple-array character (5))) x)) + (aref x 0)))) + +;;; MISC.623: missing functions for constant-folding +(assert (eql 0 + (funcall + (compile + nil + '(lambda () + (declare (optimize (space 2) (speed 0) (debug 2) + (compilation-speed 3) (safety 0))) + (loop for lv3 below 1 + count (minusp + (loop for lv2 below 2 + count (logbitp 0 + (bit #*1001101001001 + (min 12 (max 0 lv3)))))))))))) + +;;; MISC.624: erronous AVER in x86's %LOGBITP VOPs +(assert (eql 0 + (funcall + (compile + nil + '(lambda (a) + (declare (type (integer 21 28) a)) + (declare (optimize (compilation-speed 1) (safety 2) + (speed 0) (debug 0) (space 1))) + (let* ((v7 (flet ((%f3 (f3-1 f3-2) + (loop for lv2 below 1 + count + (logbitp 29 + (sbit #*10101111 + (min 7 (max 0 (eval '0)))))))) + (%f3 0 a)))) + 0))) + 22))) + +;;; MISC.626: bandaged AVER was still wrong +(assert (eql -829253 + (funcall + (compile + nil + '(lambda (a) + (declare (type (integer -902970 2) a)) + (declare (optimize (space 2) (debug 0) (compilation-speed 1) + (speed 0) (safety 3))) + (prog2 (if (logbitp 30 a) 0 (block b3 0)) a))) + -829253))) + +;; MISC.628: constant-folding %LOGBITP was buggy +(assert (eql t + (funcall + (compile + nil + '(lambda () + (declare (optimize (safety 3) (space 3) (compilation-speed 3) + (speed 0) (debug 1))) + (not (not (logbitp 0 (floor 2147483651 (min -23 0)))))))))) + +