(declare (type (alien (* (unsigned 8))) a)
(type (unsigned-byte 32) i))
(deref a i))))
- (compiler-note () (error "The code is not optimized.")))
+ (compiler-note (c)
+ (unless (search "%ASH/RIGHT" (first (simple-condition-format-arguments c)))
+ (error "The code is not optimized."))))
(handler-case
(compile nil '(lambda (x)
(declare (type fixnum y z))
(catch (if x y z) (funcall f)))))
(error "Where's my style-warning?")))
+
+;; Smoke test for rightward shifts
+(with-test (:name (:ash/right-signed))
+ (let* ((f (compile nil `(lambda (x y)
+ (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+ (type sb-vm:signed-word x)
+ (optimize speed))
+ (ash x (- y)))))
+ (max (ash most-positive-word -1))
+ (min (- -1 max)))
+ (flet ((test (x y)
+ (assert (= (ash x (- y))
+ (funcall f x y)))))
+ (dotimes (x 32)
+ (dotimes (y (* 2 sb-vm:n-word-bits))
+ (test x y)
+ (test (- x) y)
+ (test (- max x) y)
+ (test (+ min x) y))))))
+
+(with-test (:name (:ash/right-unsigned))
+ (let ((f (compile nil `(lambda (x y)
+ (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+ (type word x)
+ (optimize speed))
+ (ash x (- y)))))
+ (max most-positive-word))
+ (flet ((test (x y)
+ (assert (= (ash x (- y))
+ (funcall f x y)))))
+ (dotimes (x 32)
+ (dotimes (y (* 2 sb-vm:n-word-bits))
+ (test x y)
+ (test (- max x) y))))))
+
+(with-test (:name (:ash/right-fixnum))
+ (let ((f (compile nil `(lambda (x y)
+ (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+ (type fixnum x)
+ (optimize speed))
+ (ash x (- y))))))
+ (flet ((test (x y)
+ (assert (= (ash x (- y))
+ (funcall f x y)))))
+ (dotimes (x 32)
+ (dotimes (y (* 2 sb-vm:n-word-bits))
+ (test x y)
+ (test (- x) y)
+ (test (- most-positive-fixnum x) y)
+ (test (+ most-negative-fixnum x) y))))))