(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 (check-embedded-thes 3 0 2 :a) '(2 :a)))
(assert (typep (check-embedded-thes 3 0 4 2.5f0) 'type-error))
-(assert (equal (check-embedded-thes 1 0 4 :b) '(4 :b)))
+(assert (equal (check-embedded-thes 1 0 3 :b) '(3 :b)))
(assert (typep (check-embedded-thes 1 0 1.0 2.5f0) 'type-error))
(let ((usage-after (sb-kernel::dynamic-usage)))
(when (< (+ usage-before 2000000) usage-after)
(error "Leak")))))
+
+;;; PROGV compilation and type checking when the declared type
+;;; includes a FUNCTION subtype.
+(declaim (type (or (function (t) (values boolean &optional)) string)
+ *hairy-progv-var*))
+(defvar *hairy-progv-var* #'null)
+(with-test (:name :hairy-progv-type-checking)
+ (assert (eq :error
+ (handler-case
+ (progv '(*hairy-progv-var*) (list (eval 42))
+ *hairy-progv-var*)
+ (type-error () :error))))
+ (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)))))
\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))))
-;;; PROGV compilation and type checking when the declared type
-;;; includes a FUNCTION subtype.
-(declaim (type (or (function (t) (values boolean &optional)) string)
- *hairy-progv-var*))
-(defvar *hairy-progv-var* #'null)
-(with-test (:name :hairy-progv-type-checking)
- (assert (eq :error
- (handler-case
- (progv '(*hairy-progv-var*) (list (eval 42))
- *hairy-progv-var*)
- (type-error () :error))))
- (assert (equal "GOOD!"
- (progv '(*hairy-progv-var*) (list (eval "GOOD!"))
- *hairy-progv-var*))))
;;; success
projects / sbcl.git / blobdiff