X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=f410d4db31a50d88e51b0fbe2af8b2d53c63a5cb;hb=1f03c7f326823245708a84af86b31ac72bdb1742;hp=06f52a51603237c96f5e634285a47e24aaa4a617;hpb=b402bbba90ce3b8b90683a09f36568d9dc8d7ba9;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 06f52a5..f410d4d 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -19,6 +19,7 @@
   (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")
@@ -618,7 +619,7 @@
 (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))
 
 
@@ -1084,6 +1085,87 @@
   (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)))))
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
@@ -1803,7 +1885,7 @@
 ;;; 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))
@@ -1811,12 +1893,12 @@
                                                            +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)))