0.9.12.10:

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

diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp
index 7d5e99d..a673601 100644 (file)
--- a/tests/compiler.impure-cload.lisp
+++ b/tests/compiler.impure-cload.lisp
@@ -442,5 +442,51 @@
        (compiled-res (funcall (compile nil form)))
        (real-res (- 1 (aref (funcall (eval #'bit-not) v) 0))))
   (assert (equal compiled-res real-res)))
-\f
-(sb-ext:quit :unix-status 104)
+
+;; bug reported on sbcl-devel by Hannu Koivisto on 2005-08-10
+(defvar *hannu-trap* nil)
+(progv '(*hannu-trap*) '()
+  (setq *hannu-trap* t))
+(assert (not *hannu-trap*))
+
+;;; bug reported on sbcl-help by Vasile Rotaru
+(let* ((initial-size (expt 2 16))
+       (prime-table (make-array initial-size
+                                :element-type 'integer))
+       (first-primes #(5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71
+       73
+                      79 83 89 97 101 103 107 109 113 127 131 137 139 149
+                      151 157 163 167 173 179 181 191 193 197 199 211 223
+                      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)
+    (setf (aref prime-table count) prime) (incf count))
+  (defun init-table ()
+    (map 'nil #'add-prime first-primes))
+  (defun next-candidate (candidate)
+    (prog1 (+ candidate increment)
+      (ecase increment
+        (2 (setf increment 4))
+        (4 (setf increment 2)))))
+  (defun prime-p (n)
+    (let ((sqrt-n (truncate (sqrt n))))
+      (dotimes (i count)
+        (let ((prime (aref prime-table i)))
+          (when (> prime sqrt-n)
+            (return-from prime-p t))
+          (when (zerop (mod n prime))
+            (return-from prime-p nil))))
+      (error "~&prime-table too small: ~A ~A~%" n
+      (largest-prime-so-far))))
+  (defun generate-primes (required)
+    (do ((candidate (next-candidate (largest-prime-so-far))
+                    (next-candidate candidate)))
+        ((> candidate required))
+      (when (prime-p candidate)
+        (add-prime candidate))))
+  ;;
+  (init-table))