X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=4c3eb78ac45f85931ee834aa83cfc2ca3d15d9f7;hb=672b2f6cb751566526c7f3bb3de6b7d8424760e2;hp=d4608173a4348dc9fd8edb6464217da3858a4340;hpb=d4624e03c64b15a86594b12020da88d7e5167e4f;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index d460817..4c3eb78 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -528,11 +528,19 @@ (funcall f y 1) (assert (equal y #*10)))) +;;; use of declared array types (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda (x) - (declare (type (simple-array (simple-string 3) (5)) x)) + (declare (type (simple-array (simple-string 3) (5)) x) + (optimize speed)) (aref (aref x 0) 0)))) +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x) + (declare (type (simple-array (simple-array bit (10)) (10)) x) + (optimize speed)) + (1+ (aref (aref x 0) 0))))) + ;;; compiler failure (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0))))))) (assert (funcall f 1d0))) @@ -774,6 +782,35 @@ (declare (type (integer 4303063 101130078) a)) (mask-field (byte 18 2) (ash a 77)))) 57132532))) +;;; rewrite the test case to get the unsigned-byte 32/64 +;;; implementation even after implementing some modular arithmetic +;;; with signed-byte 30: +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (mask-field (byte 30 2) (ash a 77)))) + 57132532))) +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (mask-field (byte 64 2) (ash a 77)))) + 57132532))) +;;; and a similar test case for the signed masking extension (not the +;;; final interface, so change the call when necessary): +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (sb-c::mask-signed-field 30 (ash a 77)))) + 57132532))) +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (sb-c::mask-signed-field 61 (ash a 77)))) + 57132532))) ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for ;;; type check regeneration @@ -1947,7 +1984,7 @@ (bit #*1001101001001 (min 12 (max 0 lv3)))))))))))) -;;; MISC.624: erronous AVER in x86's %LOGBITP VOPs +;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs (assert (eql 0 (funcall (compile @@ -2287,3 +2324,213 @@ t) t (error "~a" y))))) + +;;; Compiling W-P-O when the pinned objects are known to be fixnums +;;; or characters. +(compile nil '(lambda (x y) + (declare (fixnum y) (character x)) + (sb-sys:with-pinned-objects (x y) + (some-random-function)))) + +;;; *CHECK-CONSISTENCY* and TRULY-THE + +(with-test (:name :bug-423) + (let ((sb-c::*check-consistency* t)) + (handler-bind ((warning #'error)) + (flet ((make-lambda (type) + `(lambda (x) + ((lambda (z) + (if (listp z) + (let ((q (truly-the list z))) + (length q)) + (if (arrayp z) + (let ((q (truly-the vector z))) + (length q)) + (error "oops")))) + (the ,type x))))) + (compile nil (make-lambda 'list)) + (compile nil (make-lambda 'vector)))))) + +;;; this caused a momentary regression when an ill-adviced fix to +;;; bug 427 made ANY-REG suitable for primitive-type T: +;;; +;;; no :MOVE-ARG VOP defined to move # (SC SB-VM::SINGLE-REG) to # (SC SB-VM::ANY-REG) +;;; [Condition of type SIMPLE-ERROR] +(compile nil + '(lambda (frob) + (labels + ((%zig (frob) + (typecase frob + (double-float + (setf (sb-alien:deref (sb-alien:cast (sb-alien:sap-alien (unknown1) (* unsigned-char)) + (* double-float))) frob)) + (hash-table + (%zig (the (values (single-float (0.0) 1.0) &optional) (unknown2))) + nil)))) + (%zig)))) + +;;; non-required arguments in HANDLER-BIND +(assert (eq :oops (car (funcall (compile nil + '(lambda (x) + (block nil + (handler-bind ((error (lambda (&rest args) (return (cons :oops args))))) + (/ 2 x))))) + 0)))) + +;;; NIL is a legal function name +(assert (eq 'a (flet ((nil () 'a)) (nil)))) + +;;; misc.528 +(assert (null (let* ((x 296.3066f0) + (y 22717067) + (form `(lambda (r p2) + (declare (optimize speed (safety 1)) + (type (simple-array single-float nil) r) + (type (integer -9369756340 22717335) p2)) + (setf (aref r) (* ,x (the (eql 22717067) p2))) + (values))) + (r (make-array nil :element-type 'single-float)) + (expected (* x y))) + (funcall (compile nil form) r y) + (let ((actual (aref r))) + (unless (eql expected actual) + (list expected actual)))))) +;;; misc.529 +(assert (null (let* ((x -2367.3296f0) + (y 46790178) + (form `(lambda (r p2) + (declare (optimize speed (safety 1)) + (type (simple-array single-float nil) r) + (type (eql 46790178) p2)) + (setf (aref r) (+ ,x (the (integer 45893897) p2))) + (values))) + (r (make-array nil :element-type 'single-float)) + (expected (+ x y))) + (funcall (compile nil form) r y) + (let ((actual (aref r))) + (unless (eql expected actual) + (list expected actual)))))) + +;;; misc.556 +(assert (eql -1 + (funcall + (compile nil '(lambda (p1 p2) + (declare + (optimize (speed 1) (safety 0) + (debug 0) (space 0)) + (type (member 8174.8604) p1) + (type (member -95195347) p2)) + (floor p1 p2))) + 8174.8604 -95195347))) + +;;; misc.557 +(assert (eql -1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 3) (safety 0) (debug 3) (space 1)) + (type (member -94430.086f0) p1)) + (floor (the single-float p1) 19311235))) + -94430.086f0))) + +;;; misc.558 +(assert (eql -1.0f0 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 2) + (debug 2) (space 3)) + (type (eql -39466.56f0) p1)) + (ffloor p1 305598613))) + -39466.56f0))) + +;;; misc.559 +(assert (eql 1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 1) (debug 1) (space 2)) + (type (eql -83232.09f0) p1)) + (ceiling p1 -83381228))) + -83232.09f0))) + +;;; misc.560 +(assert (eql 1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 1) + (debug 1) (space 0)) + (type (member -66414.414f0) p1)) + (ceiling p1 -63019173f0))) + -66414.414f0))) + +;;; misc.561 +(assert (eql 1.0f0 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 0) (safety 1) + (debug 0) (space 1)) + (type (eql 20851.398f0) p1)) + (fceiling p1 80839863))) + 20851.398f0))) + +;;; misc.581 +(assert (floatp + (funcall + (compile nil '(lambda (x) + (declare (type (eql -5067.2056) x)) + (+ 213734822 x))) + -5067.2056))) + +;;; misc.581a +(assert (typep + (funcall + (compile nil '(lambda (x) (declare (type (eql -1.0) x)) + (+ #x1000001 x))) + -1.0f0) + 'single-float)) + +;;; misc.582 +(assert (plusp (funcall + (compile + nil + ' (lambda (p1) + (declare (optimize (speed 0) (safety 1) (debug 1) (space 1)) + (type (eql -39887.645) p1)) + (mod p1 382352925))) + -39887.645))) + +;;; misc.587 +(assert (let ((result (funcall + (compile + nil + '(lambda (p2) + (declare (optimize (speed 0) (safety 3) (debug 1) (space 0)) + (type (eql 33558541) p2)) + (- 92215.266 p2))) + 33558541))) + (typep result 'single-float))) + +;;; misc.635 +(assert (eql 1 + (let* ((form '(lambda (p2) + (declare (optimize (speed 0) (safety 1) + (debug 2) (space 2)) + (type (member -19261719) p2)) + (ceiling -46022.094 p2)))) + (values (funcall (compile nil form) -19261719))))) + +;;; misc.636 +(assert (let* ((x 26899.875) + (form `(lambda (p2) + (declare (optimize (speed 3) (safety 1) (debug 3) (space 1)) + (type (member ,x #:g5437 char-code #:g5438) p2)) + (* 104102267 p2)))) + (floatp (funcall (compile nil form) x))))