X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fcompiler.pure.lisp;h=4325bd26d1869bde571173f27df9e04bd24a7566;hb=b41f8c974ccfba8a59ec2a6af843e8869e14be5f;hp=e9ca625975b28dd8fe9280bfdb9ed472d5c2ff12;hpb=47042c85e19c07dbaa0ade4f6f8afd5c1eee129b;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index e9ca625..4325bd2 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1605,3 +1605,177 @@ '(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. +(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)))))))))