(flet ((time-it (lambda want)
(gc :full t) ; let's keep GCs coming from other code out...
(let* ((start (get-internal-run-time))
- (fun (compile nil lambda))
+ (fun (dotimes (internal-time-resolution-too-low-workaround
+ #+win32 10
+ #-win32 0
+ (compile nil lambda))
+ (compile nil lambda)))
(end (get-internal-run-time))
(got (funcall fun)))
(unless (eql want got)
(with-test (:name :multiple-args-to-function)
(let ((form `(flet ((foo (&optional (x 13)) x))
(funcall (function foo 42))))
- (*evaluator-mode* :interpret))
+ #+sb-eval (*evaluator-mode* :interpret))
+ #+sb-eval
(assert (eq :error
(handler-case (eval form)
(error () :error))))
(with-test (:name :escape-analysis-for-nlxs)
(flet ((test (check lambda &rest args)
- (let ((fun (compile nil lambda)))
+ (let* ((cell-note nil)
+ (fun (handler-bind ((compiler-note
+ (lambda (note)
+ (when (search
+ "Allocating a value-cell at runtime for"
+ (princ-to-string note))
+ (setf cell-note t)))))
+ (compile nil lambda))))
+ (assert (eql check cell-note))
(if check
(assert
(eq :ok
:ok)))))
(ctu:assert-no-consing (apply fun args))))))
(test nil `(lambda (x)
+ (declare (optimize speed))
(block out
(flet ((ex () (return-from out 'out!)))
(typecase x
(cons (or (car x) (ex)))
(t (ex)))))) :foo)
(test t `(lambda (x)
+ (declare (optimize speed))
(funcall
(block nasty
(flet ((oops () (return-from nasty t)))
#'oops)))) t)
(test t `(lambda (r)
+ (declare (optimize speed))
(block out
(flet ((ex () (return-from out r)))
(lambda (x)
(cons (or (car x) (ex)))
(t (ex))))))) t t)
(test t `(lambda (x)
+ (declare (optimize speed))
(flet ((eh (x)
(flet ((meh () (return-from eh 'meh)))
(lambda ()
(cons (or (car x) (meh)))
(t (meh)))))))
(funcall (eh x)))) t t)))
+
+(with-test (:name (:bug-1050768 :symptom))
+ ;; Used to signal an error.
+ (compile nil
+ `(lambda (string position)
+ (char string position)
+ (array-in-bounds-p string (1+ position)))))
+
+(with-test (:name (:bug-1050768 :cause))
+ (let ((types `((string string)
+ ((or (simple-array character 24) (vector t 24))
+ (or (simple-array character 24) (vector t))))))
+ (dolist (pair types)
+ (destructuring-bind (orig conservative) pair
+ (assert sb-c::(type= (specifier-type cl-user::conservative)
+ (conservative-type (specifier-type cl-user::orig))))))))
+
+(with-test (:name (:smodular64 :wrong-width))
+ (let ((fun (compile nil
+ '(lambda (x)
+ (declare (type (signed-byte 64) x))
+ (sb-c::mask-signed-field 64 (- x 7033717698976965573))))))
+ (assert (= (funcall fun 10038) -7033717698976955535))))
+
+(with-test (:name (:smodular32 :wrong-width))
+ (let ((fun (compile nil '(lambda (x)
+ (declare (type (signed-byte 31) x))
+ (sb-c::mask-signed-field 31 (- x 1055131947))))))
+ (assert (= (funcall fun 10038) -1055121909))))