(sb-ext:quit :unix-status 104))
(load "test-util.lisp")
+(load "compiler-test-util.lisp")
(load "assertoid.lisp")
(use-package "TEST-UTIL")
(use-package "ASSERTOID")
(assert (equal "GOOD!"
(progv '(*hairy-progv-var*) (list (eval "GOOD!"))
*hairy-progv-var*))))
+
+(with-test (:name :fill-complex-single-float)
+ (assert (every (lambda (x) (eql x #c(-1.0 -2.0)))
+ (funcall
+ (lambda ()
+ (make-array 2
+ :element-type '(complex single-float)
+ :initial-element #c(-1.0 -2.0)))))))
+
+(with-test (:name :make-array-symbol-as-initial-element)
+ (assert (every (lambda (x) (eq x 'a))
+ (funcall
+ (compile nil
+ `(lambda ()
+ (make-array 12 :initial-element 'a)))))))
+
+;;; This non-minimal test-case catches a nasty error when loading
+;;; inline constants.
+(deftype matrix ()
+ `(simple-array single-float (16)))
+(declaim (ftype (sb-int:sfunction (single-float single-float single-float single-float
+ single-float single-float single-float single-float
+ single-float single-float single-float single-float
+ single-float single-float single-float single-float)
+ matrix)
+ matrix)
+ (inline matrix))
+(defun matrix (m11 m12 m13 m14
+ m21 m22 m23 m24
+ m31 m32 m33 m34
+ m41 m42 m43 m44)
+ (make-array 16
+ :element-type 'single-float
+ :initial-contents (list m11 m21 m31 m41
+ m12 m22 m32 m42
+ m13 m23 m33 m43
+ m14 m24 m34 m44)))
+(declaim (ftype (sb-int:sfunction ((simple-array single-float (3)) single-float) matrix)
+ rotate-around))
+(defun rotate-around (a radians)
+ (let ((c (cos radians))
+ (s (sin radians))
+ ;; The 1.0 here was misloaded on x86-64.
+ (g (- 1.0 (cos radians))))
+ (let* ((x (aref a 0))
+ (y (aref a 1))
+ (z (aref a 2))
+ (gxx (* g x x)) (gxy (* g x y)) (gxz (* g x z))
+ (gyy (* g y y)) (gyz (* g y z)) (gzz (* g z z)))
+ (matrix
+ (+ gxx c) (- gxy (* s z)) (+ gxz (* s y)) 0.0
+ (+ gxy (* s z)) (+ gyy c) (- gyz (* s x)) 0.0
+ (- gxz (* s y)) (+ gyz (* s x)) (+ gzz c) 0.0
+ 0.0 0.0 0.0 1.0))))
+(with-test (:name :regression-1.0.29.54)
+ (assert (every #'=
+ '(-1.0 0.0 0.0 0.0 0.0 -1.0 0.0 0.0 0.0 0.0 -1.0 0.0 0.0 0.0 0.0 1.0)
+ (rotate-around
+ (make-array 3 :element-type 'single-float) (coerce pi 'single-float))))
+ ;; Same bug manifests in COMPLEX-ATANH as well.
+ (assert (= (atanh #C(-0.7d0 1.1d0)) #C(-0.28715567731069275d0 0.9394245539093365d0))))
+
+(with-test (:name :slot-value-on-structure)
+ (let ((f (compile nil `(lambda (x a b)
+ (declare (something-known-to-be-a-struct x))
+ (setf (slot-value x 'x) a
+ (slot-value x 'y) b)
+ (list (slot-value x 'x)
+ (slot-value x 'y))))))
+ (assert (equal '(#\x #\y)
+ (funcall f
+ (make-something-known-to-be-a-struct :x "X" :y "Y")
+ #\x #\y)))
+ (assert (not (ctu:find-named-callees f)))))
+
+(defclass some-slot-thing ()
+ ((slot :initarg :slot)))
+(with-test (:name :with-slots-the)
+ (let ((x (make-instance 'some-slot-thing :slot "foo")))
+ (with-slots (slot) (the some-slot-thing x)
+ (assert (equal "foo" slot)))))
+
+;;; Missing &REST type in proclamation causing a miscompile.
+(declaim (ftype
+ (function
+ (sequence unsigned-byte
+ &key (:initial-element t) (:initial-contents sequence))
+ (values sequence &optional))
+ bug-458354))
+(defun bug-458354
+ (sequence length
+ &rest keys
+ &key (initial-element nil iep) (initial-contents nil icp))
+ (declare (sb-ext:unmuffle-conditions style-warning))
+ (declare (ignorable keys initial-element iep initial-contents icp))
+ (apply #'sb-sequence:make-sequence-like sequence length keys))
+(with-test (:name :bug-458354)
+ (assert (equalp #((a b) (a b)) (bug-458354 #(1 2) 2 :initial-element '(a b)))))
+
+(with-test (:name :bug-542807)
+ (handler-bind ((style-warning #'error))
+ (eval '(defstruct bug-542807 slot)))
+ (let (conds)
+ (handler-bind ((style-warning (lambda (c)
+ (push c conds))))
+ (eval '(defstruct bug-542807 slot)))
+ (assert (= 1 (length conds)))
+ (assert (typep (car conds) 'sb-kernel::redefinition-with-defun))))
+
+(with-test (:name :defmacro-not-list-lambda-list)
+ (assert (raises-error? (eval `(defmacro ,(gensym) "foo"))
+ type-error)))
+
+(with-test (:name :bug-308951)
+ (let ((x 1))
+ (dotimes (y 10)
+ (let ((y y))
+ (when (funcall (eval #'(lambda (x) (eql x 2))) y)
+ (defun bug-308951-foo (z)
+ (incf x (incf y z))))))
+ (defun bug-308951-bar (z)
+ (bug-308951-foo z)
+ (values x)))
+ (assert (= 4 (bug-308951-bar 1))))
+
+(declaim (inline bug-308914-storage))
+(defun bug-308914-storage (x)
+ (the (simple-array flt (*)) (bug-308914-unknown x)))
+
+(with-test (:name :bug-308914-workaround)
+ ;; This used to hang in ORDER-UVL-SETS.
+ (handler-case
+ (with-timeout 10
+ (compile nil
+ `(lambda (lumps &key cg)
+ (let ((nodes (map 'list (lambda (lump)
+ (bug-308914-storage lump))
+ lumps)))
+ (setf (aref nodes 0) 2)
+ (assert (every #'~= (apply #'concatenate 'list nodes) '(2 3 6 9)))))))
+ (sb-ext:timeout ()
+ (error "Hang in ORDER-UVL-SETS?"))))
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
;;; check that non-trivial constants are EQ across different files: this is
;;; not something ANSI either guarantees or requires, but we want to do it
;;; anyways.
-(defconstant +share-me-1+ 123.456d0)
+(defconstant +share-me-1+ #-inline-constants 123.456d0 #+inline-constants nil)
(defconstant +share-me-2+ "a string to share")
(defconstant +share-me-3+ (vector 1 2 3))
(defconstant +share-me-4+ (* 2 most-positive-fixnum))
+share-me-2+
+share-me-3+
+share-me-4+
- pi)))
+ #-inline-constants pi)))
(multiple-value-bind (f2 c2) (compile2 '(lambda () (values +share-me-1+
+share-me-2+
+share-me-3+
+share-me-4+
- pi)))
+ #-inline-constants pi)))
(flet ((test (fa fb)
(mapc (lambda (a b)
(assert (eq a b)))
(setf *mystery* :mystery)
(assert (eq :ok (test-mystery (make-thing :slot :mystery))))
+;;; Singleton types can also be constant.
+(test-util:with-test (:name :propagate-singleton-types-to-eql)
+ (macrolet ((test (type value &aux (fun (gensym "FUN")))
+ `(progn
+ (declaim (ftype (function () (values ,type &optional)) ,fun))
+ (defun ,fun ()
+ ',value)
+ (lambda (x)
+ (if (eql x (,fun))
+ nil
+ (eql x (,fun)))))))
+ (values
+ (test (eql foo) foo)
+ (test (integer 0 0) 0)
+ (test (double-float 0d0 0d0) 0d0)
+ (test (eql #\c) #\c))))
+
+(declaim (ftype (function () (integer 42 42)) bug-655581))
+(defun bug-655581 ()
+ 42)
+(declaim (notinline bug-655581))
+(test-util:with-test (:name :bug-655581)
+ (multiple-value-bind (type derived)
+ (funcall (compile nil `(lambda ()
+ (ctu:compiler-derived-type (bug-655581)))))
+ (assert derived)
+ (assert (equal '(integer 42 42) type))))
+
;;; success
projects / sbcl.git / blobdiff