Remove duplicate implementations of (setf aref/sbit/bit).

[sbcl.git] / tests / compiler.impure-cload.lisp

diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp
index 44f7396..ade8555 100644 (file)
--- a/tests/compiler.impure-cload.lisp
+++ b/tests/compiler.impure-cload.lisp
@@ -1,5 +1,7 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (load "assertoid.lisp")
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (load "assertoid.lisp")

+  (load "compiler-test-util.lisp")
+  (load "test-util.lisp")

   (use-package "ASSERTOID"))
 
 ;;; bug 254: compiler falure
   (use-package "ASSERTOID"))
 
 ;;; bug 254: compiler falure

@@ -449,7 +451,7 @@
   (setq *hannu-trap* t))
 (assert (not *hannu-trap*))
 
   (setq *hannu-trap* t))
 (assert (not *hannu-trap*))
 

-;;; bug reported on sbcl-help by vrotaru
+;;; bug reported on sbcl-help by Vasile Rotaru

 (let* ((initial-size (expt 2 16))
        (prime-table (make-array initial-size
                                 :element-type 'integer))
 (let* ((initial-size (expt 2 16))
        (prime-table (make-array initial-size
                                 :element-type 'integer))

@@ -460,7 +462,7 @@
                       227 229 233 239 241 251 257 263 269 271 277 281))
        (count 0)
        (increment 2))
                       227 229 233 239 241 251 257 263 269 271 277 281))
        (count 0)
        (increment 2))

-  
+

   (defun largest-prime-so-far ()
     (aref prime-table (1- count)))
   (defun add-prime (prime)
   (defun largest-prime-so-far ()
     (aref prime-table (1- count)))
   (defun add-prime (prime)

@@ -490,3 +492,69 @@
         (add-prime candidate))))
   ;;
   (init-table))
         (add-prime candidate))))
   ;;
   (init-table))

+
+;;; Bug in the fopcompiler's handling of LOCALLY pre-0.9.14.8
+
+(defvar *a* 1)
+
+(setf *a*
+      (locally
+          (declare)
+        2))
+
+;;; Bug in the interaction of BIND-SENTINEL and UNBIND-TO-HERE, as
+;;; used by PROGV.
+
+(defvar *foo-1* nil)
+(defvar *foo-2* nil)
+
+(defun foo ()
+  (declare (optimize (debug 2)))
+  (let ((*foo-1* nil))
+    (progv
+        (list '*foo-2*)
+        (list nil)
+      (write-line "foo-2"))
+    (write-line "foo-1"))
+  (write-line "foo-0"))
+
+(foo)
+
+;;; LOAD-TIME-VALUE smartness
+(defun load-time-value-type-derivation-test-1 ()
+  (ctu:compiler-derived-type (load-time-value (cons 'foo 0))))
+(defun load-time-value-type-derivation-test-2 ()
+  (ctu:compiler-derived-type (load-time-value (+ (or *print-length* 0) 10))))
+(defun load-time-value-auto-read-only-p ()
+  (load-time-value (random most-positive-fixnum)))
+(defun load-time-value-boring ()
+  (load-time-value (cons t t)))
+(test-util:with-test (:name (load-time-value :type-smartness/cload))
+  (assert (eq 'cons (load-time-value-type-derivation-test-1)))
+  (assert (equal '(integer 10) (load-time-value-type-derivation-test-2)))
+  (assert (not (ctu:find-value-cell-values #'load-time-value-auto-read-only-p)))
+  (assert (ctu:find-value-cell-values #'load-time-value-boring)))
+
+(defun regression-1.0.29.54 ()
+  (logior (1+ most-positive-fixnum)
+          (load-time-value (the fixnum (eval 1)) t)))
+
+(test-util:with-test (:name :regression-1.0.29.54)
+  (assert (= (+ most-positive-fixnum 2) (regression-1.0.29.54)))
+  (assert (eq 42
+              (funcall (compile nil
+                                `(lambda ()
+                                   (load-time-value (values 42))))))))
+
+(defun mv-call-regression-1.0.43.57-foo (a c d x y)
+  (values a c d x y))
+(defun mv-call-regression-1.0.43.57-bar (a b c d)
+  (declare (number a b c d))
+  (values a b c d))
+(defun mv-call-regression-1.0.43.57-quux (a sxx sxy syy)
+  (multiple-value-call #'mv-call-regression-1.0.43.57-foo
+    (mv-call-regression-1.0.43.57-bar sxx sxy sxy syy)
+    a))
+(test-util:with-test (:name :mv-call-regression-1.0.43.57)
+  ;; This used to signal a bogus argument-count error.
+  (mv-call-regression-1.0.43.57-quux 1s0 10s0 1s0 10s0))