(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")
*hairy-progv-var*))))
(with-test (:name :fill-complex-single-float)
- (assert (eql #c(-1.0 2.0)
- (aref (funcall
- (lambda ()
- (make-array 2
- :element-type '(complex single-float)
- :initial-element #c(-1.0 2.0))))
- 0))))
+ (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)))))
\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))))
-;;; optimizing make-array
-(defun count-code-callees (f)
- (let ((code (sb-kernel:fun-code-header f))
- (n 0))
- (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
- for c = (sb-kernel:code-header-ref code i)
- do (when (typep c 'fdefn)
- (print c)
- (incf n)))
- n))
-(assert (zerop (count-code-callees
- (compile nil
- `(lambda (x y z)
- (make-array '(3) :initial-contents (list x y z)))))))
-(assert (zerop (count-code-callees
- (compile nil
- `(lambda (x y z)
- (make-array '3 :initial-contents (vector x y z)))))))
-(assert (zerop (count-code-callees
- (compile nil
- `(lambda (x y z)
- (make-array '3 :initial-contents `(,x ,y ,z)))))))
-
;;; success
projects / sbcl.git / blobdiff