+;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 58-63 for an
+;;; explanation of LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND.
+;;; Credit also goes to Raymond Toy for writing (and debugging!) similar
+;;; versions in CMUCL, from which these functions copy liberally.
+
+(defun logand-derive-unsigned-low-bound (x y)
+ (let ((a (numeric-type-low x))
+ (b (numeric-type-high x))
+ (c (numeric-type-low y))
+ (d (numeric-type-high y)))
+ (loop for m = (ash 1 (integer-length (lognor a c))) then (ash m -1)
+ until (zerop m) do
+ (unless (zerop (logand m (lognot a) (lognot c)))
+ (let ((temp (logandc2 (logior a m) (1- m))))
+ (when (<= temp b)
+ (setf a temp)
+ (loop-finish))
+ (setf temp (logandc2 (logior c m) (1- m)))
+ (when (<= temp d)
+ (setf c temp)
+ (loop-finish))))
+ finally (return (logand a c)))))
+
+(defun logand-derive-unsigned-high-bound (x y)
+ (let ((a (numeric-type-low x))
+ (b (numeric-type-high x))
+ (c (numeric-type-low y))
+ (d (numeric-type-high y)))
+ (loop for m = (ash 1 (integer-length (logxor b d))) then (ash m -1)
+ until (zerop m) do
+ (cond
+ ((not (zerop (logand b (lognot d) m)))
+ (let ((temp (logior (logandc2 b m) (1- m))))
+ (when (>= temp a)
+ (setf b temp)
+ (loop-finish))))
+ ((not (zerop (logand (lognot b) d m)))
+ (let ((temp (logior (logandc2 d m) (1- m))))
+ (when (>= temp c)
+ (setf d temp)
+ (loop-finish)))))
+ finally (return (logand b d)))))
+