(compile nil '(lambda (s x)
(pprint-logical-block (s x :suffix ">")
(print x s)))))
+
+;;; MISC.427: loop analysis requires complete DFO structure
+(assert (eql 17 (funcall
+ (compile
+ nil
+ '(lambda (a)
+ (declare (notinline list reduce logior))
+ (declare (optimize (safety 2) (compilation-speed 1)
+ (speed 3) (space 2) (debug 2)))
+ (logior
+ (let* ((v5 (reduce #'+ (list 0 a))))
+ (declare (dynamic-extent v5))
+ v5))))
+ 17)))
+
+;;; MISC.434
+(assert (zerop (funcall
+ (compile
+ nil
+ '(lambda (a b)
+ (declare (type (integer -8431780939320 1571817471932) a))
+ (declare (type (integer -4085 0) b))
+ (declare (ignorable a b))
+ (declare
+ (optimize (space 2)
+ (compilation-speed 0)
+ #+sbcl (sb-c:insert-step-conditions 0)
+ (debug 2)
+ (safety 0)
+ (speed 3)))
+ (let ((*s5* 0))
+ (dotimes (iv1 2 0)
+ (let ((*s5*
+ (elt '(1954479092053)
+ (min 0
+ (max 0
+ (if (< iv1 iv1)
+ (lognand iv1 (ash iv1 (min 53 iv1)))
+ iv1))))))
+ 0)))))
+ -7639589303599 -1368)))
+
+(compile
+ nil
+ '(lambda (a b)
+ (declare (type (integer) a))
+ (declare (type (integer) b))
+ (declare (ignorable a b))
+ (declare (optimize (space 2) (compilation-speed 0)
+ (debug 0) (safety 0) (speed 3)))
+ (dotimes (iv1 2 0)
+ (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass
+ (print (if (< iv1 iv1)
+ (logand (ash iv1 iv1) 1)
+ iv1)))))
+
+;;; MISC.435: lambda var substitution in a deleted code.
+(assert (zerop (funcall
+ (compile
+ nil
+ '(lambda (a b c d)
+ (declare (notinline aref logandc2 gcd make-array))
+ (declare
+ (optimize (space 0) (safety 0) (compilation-speed 3)
+ (speed 3) (debug 1)))
+ (progn
+ (tagbody
+ (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2)))))
+ (declare (dynamic-extent v2))
+ (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2))))
+ tag2)
+ 0)))
+ 3021871717588 -866608 -2 -17194)))
+
+;;; MISC.436, 438: lost reoptimization
+(assert (zerop (funcall
+ (compile
+ nil
+ '(lambda (a b)
+ (declare (type (integer -2917822 2783884) a))
+ (declare (type (integer 0 160159) b))
+ (declare (ignorable a b))
+ (declare
+ (optimize (compilation-speed 1)
+ (speed 3)
+ (safety 3)
+ (space 0)
+ ; #+sbcl (sb-c:insert-step-conditions 0)
+ (debug 0)))
+ (if
+ (oddp
+ (loop for
+ lv1
+ below
+ 2
+ count
+ (logbitp 0
+ (1-
+ (ash b
+ (min 8
+ (count 0
+ '(-10197561 486 430631291
+ 9674068))))))))
+ b
+ 0)))
+ 1265797 110757)))
+
+(assert (zerop (funcall
+ (compile
+ nil
+ ' (lambda (a)
+ (declare (type (integer 0 1696) a))
+ ; (declare (ignorable a))
+ (declare (optimize (space 2) (debug 0) (safety 1)
+ (compilation-speed 0) (speed 1)))
+ (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0)))
+ 805)))
+
+;;; bug #302
+(assert (compile
+ nil
+ '(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)))))))))
+
+;;; 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