(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)))))))))
+
+;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
+;;; a rational was zero, but didn't do the substitution, leading to a
+;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
+;;; machine's ASH instruction's immediate field) that the compiler
+;;; thought was legitimate.
+(compile 'nil
+ (LAMBDA (B)
+ (DECLARE (TYPE (INTEGER -2 14) B))
+ (DECLARE (IGNORABLE B))
+ (ASH (IMAGPART B) 57)))
+
+;;; bug reported by Eduardo Mu\~noz
+(multiple-value-bind (fun warnings failure)
+ (compile nil '(lambda (struct first)
+ (declare (optimize speed))
+ (let* ((nodes (nodes struct))
+ (bars (bars struct))
+ (length (length nodes))
+ (new (make-array length :fill-pointer 0)))
+ (vector-push first new)
+ (loop with i fixnum = 0
+ for newl fixnum = (length new)
+ while (< newl length) do
+ (let ((oldl (length new)))
+ (loop for j fixnum from i below newl do
+ (dolist (n (node-neighbours (aref new j) bars))
+ (unless (find n new)
+ (vector-push n new))))
+ (setq i oldl)))
+ new)))
+ (declare (ignore fun warnings failure))
+ (assert (not failure)))
projects / sbcl.git / blobdiff