X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=33810870b7712977d3e829e28384ed5a2d47b58f;hb=079ef9dad558ca07cb8178ef428bf738112174fa;hp=36741f4c826a20a89f47bc437ac21d9d55866633;hpb=2546d61e3e230629978781602f82cee66f579d07;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 36741f4..3381087 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1536,3 +1536,183 @@ (print (if (< iv1 iv1) (logand (ash iv1 iv1) 1) iv1))))) + +;;; MISC.435: lambda var substitution in a deleted code. +(assert (zerop (funcall + (compile + nil + '(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))) + (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))) + 3021871717588 -866608 -2 -17194))) + +;;; MISC.436, 438: lost reoptimization +(assert (zerop (funcall + (compile + nil + '(lambda (a b) + (declare (type (integer -2917822 2783884) a)) + (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))) + (if + (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))) + 805))) + +;;; bug #302 +(assert (compile + nil + '(lambda (s ei x y) + (declare (type (simple-array function (2)) s) (type ei ei)) + (funcall (aref s ei) x y)))) + +;;; MISC.320: ir1-transform can create an intercomponent reference to +;;; a DEFINED-FUN. +(assert (eql 102 (funcall + (compile + nil + '(lambda () + (declare (optimize (speed 3) (space 0) (safety 2) + (debug 2) (compilation-speed 0))) + (catch 'ct2 + (elt '(102) + (flet ((%f12 () (rem 0 -43))) + (multiple-value-call #'%f12 (values)))))))))) + +;;; MISC.437: lost reoptimization after FLUSH-DEST +(assert (zerop (funcall + (compile + nil + '(lambda (a b c d e) + (declare (notinline values complex eql)) + (declare + (optimize (compilation-speed 3) + (speed 3) + (debug 1) + (safety 1) + (space 0))) + (flet ((%f10 + (f10-1 f10-2 f10-3 + &optional (f10-4 (ignore-errors 0)) (f10-5 0) + &key &allow-other-keys) + (if (or (eql 0 0) t) 0 (if f10-1 0 0)))) + (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0)))) + 80043 74953652306 33658947 -63099937105 -27842393))) + +;;; bug #351 -- program-error for malformed LET and LET*, including those +;;; resulting from SETF of LET. +(dolist (fun (list (compile nil '(lambda () (let :bogus-let :oops))) + (compile nil '(lambda () (let* :bogus-let* :oops))) + (compile nil '(lambda (x) (push x (let ((y 0)) y)))))) + (assert (functionp fun)) + (multiple-value-bind (res err) (ignore-errors (funcall fun)) + (assert (not res)) + (assert (typep err 'program-error)))) + +(let ((fun (compile nil '(lambda (x) (random (if x 10 20)))))) + (dotimes (i 100 (error "bad RANDOM distribution")) + (when (> (funcall fun nil) 9) + (return t))) + (dotimes (i 100) + (when (> (funcall fun t) 9) + (error "bad RANDOM event")))) + +;;; 0.8.17.28-sma.1 lost derived type information. +(handler-bind ((sb-ext:compiler-note #'error)) + (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. +(let* ((n (* 2 sb-vm::n-word-bits)) + (array1 (make-array n :element-type 'bit)) + (array2 (make-array n :element-type 'bit))) + (dotimes (i n) + (dotimes (v 2) + (let ((f (compile nil `(lambda (a) + (declare (type (simple-array bit (,n)) a)) + (setf (bit a ,i) ,v))))) + (fill array1 (- 1 v)) + (fill array2 (- 1 v)) + (funcall f array1) + (setf (aref array2 i) v) + (assert (equal 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)))))