Fix bug in unsigned modular arithmetic using a signed implementation

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

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 81c72bd..b3970e6 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1227,6 +1227,77 @@
     (assert (search "INLINED-FUNCTION-IN-SOURCE-PATH" output))
     ;; ...not the leaf.
     (assert (not (search "DEFINED-FUN" output)))))
+
+(defmacro bug-795705 ()
+  t)
+
+(with-test (:name :bug-795705)
+  (assert (macro-function 'bug-795705))
+  (fmakunbound 'bug-795705)
+  (assert (not (macro-function 'bug-795705))))
+
+(with-test (:name (load-time-value :type-derivation))
+  (let ((name 'load-time-value-type-derivation-test))
+    (labels ((funtype (fun)
+               (sb-kernel:type-specifier
+                (sb-kernel:single-value-type
+                 (sb-kernel:fun-type-returns
+                  (sb-kernel:specifier-type
+                   (sb-kernel:%simple-fun-type fun))))))
+             (test (type1 type2 form value-cell-p)
+             (let* ((lambda-form `(lambda ()
+                                    (load-time-value ,form)))
+                    (core-fun (compile nil lambda-form))
+                    (core-type (funtype core-fun))
+                    (core-cell (ctu:find-value-cell-values core-fun))
+                    (defun-form `(defun ,name ()
+                                   (load-time-value ,form)))
+                    (file-fun (progn
+                                (ctu:file-compile (list defun-form) :load t)
+                                (symbol-function name)))
+                    (file-type (funtype file-fun))
+                    (file-cell (ctu:find-value-cell-values file-fun)))
+               (if value-cell-p
+                   (assert (and core-cell file-cell))
+                   (assert (not (or core-cell file-cell))))
+               (unless (subtypep core-type type1)
+                 (error "core: wanted ~S, got ~S" type1 core-type))
+               (unless (subtypep file-type type2)
+                 (error "file: wanted ~S, got ~S" type2 file-type)))))
+      (let ((* 10))
+        (test '(integer 11 11) 'number
+              '(+ * 1) nil))
+      (let ((* "fooo"))
+        (test '(integer 4 4) 'unsigned-byte
+              '(length *) nil))
+      (test '(integer 10 10) '(integer 10 10) 10 nil)
+      (test 'cons 'cons '(cons t t) t))))
+
+(with-test (:name (load-time-value :errors))
+  (multiple-value-bind (warn fail)
+      (ctu:file-compile
+       `((defvar *load-time-value-error-value* 10)
+         (declaim (fixnum *load-time-value-error-value*))
+         (defun load-time-value-error-test-1 ()
+           (the list (load-time-value *load-time-value-error-value*))))
+       :load t)
+    (assert warn)
+    (assert fail))
+  (handler-case (load-time-value-error-test-1)
+    (type-error (e)
+      (and (eql 10 (type-error-datum e))
+           (eql 'list (type-error-expected-type e)))))
+  (multiple-value-bind (warn2 fail2)
+      (ctu:file-compile
+       `((defun load-time-value-error-test-2 ()
+           (the list (load-time-value 10))))
+       :load t)
+    (assert warn2)
+    (assert fail2))
+  (handler-case (load-time-value-error-test-2)
+    (type-error (e)
+      (and (eql 10 (type-error-datum e))
+           (eql 'list (type-error-expected-type e))))))
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
@@ -2128,4 +2199,63 @@
     (assert (equal `(function () (values ,ufix &optional))
                    (%simple-fun-type fun)))))
 
+(test-util:with-test (:name :mv-bind-to-let-type-propagation)
+  (let ((f (compile nil `(lambda (x)
+                           (declare (optimize speed)
+                                    (type (integer 20 50) x))
+                           (< (truncate x 10) 1))))
+        (g (compile nil `(lambda (x)
+                           (declare (optimize speed)
+                                    (type (integer 20 50) x))
+                           (< (nth-value 1 (truncate x 10)) 10))))
+        (h (compile nil `(lambda (x)
+                           (declare (optimize speed)
+                                    (type (integer 20 50) x))
+                           (multiple-value-bind (q r)
+                               (truncate x 10)
+                             (declare (ignore r))
+                             (< q 1)))))
+        (type0 '(function ((integer 20 50)) (values null &optional)))
+        (type1 '(function ((integer 20 50)) (values (member t) &optional))))
+    (assert (equal type0 (sb-kernel:%simple-fun-type f)))
+    (assert (equal type1 (sb-kernel:%simple-fun-type g)))
+    (assert (equal type0 (sb-kernel:%simple-fun-type h)))))
+
+(test-util:with-test (:name :bug-308921)
+  (let ((*check-consistency* t))
+    (ctu:file-compile
+     `((let ((exported-symbols-alist
+               (loop for symbol being the external-symbols of :cl
+                     collect (cons symbol
+                                   (concatenate 'string
+                                                "#"
+                                                (string-downcase symbol))))))
+         (defun hyperdoc-lookup (symbol)
+           (cdr (assoc symbol exported-symbols-alist)))))
+     :load nil)))
+
+(test-util:with-test (:name :bug-308941)
+  (multiple-value-bind (warn fail)
+      (let ((*check-consistency* t))
+        (ctu:file-compile
+         "(eval-when (:compile-toplevel :load-toplevel :execute)
+            (defstruct foo3))
+          (defstruct bar
+            (foo #.(make-foo3)))"
+         :load nil))
+    ;; ...but the compiler should not break.
+    (assert (and warn fail))))
+
+(test-util:with-test (:name :bug-903821)
+  (let* ((fun (compile nil '(lambda (x n)
+                             (declare (sb-ext:word x)
+                              (type (integer 0 #.(1- sb-vm:n-word-bits)) n)
+                              (optimize speed))
+                             (logandc2 x (ash -1 n)))))
+         (trace-output
+          (with-output-to-string (*trace-output*)
+            (eval `(trace ,(intern (format nil "ASH-LEFT-MOD~D" sb-vm::n-word-bits) "SB-VM")))
+            (assert (= 7 (funcall fun 15 3))))))
+    (assert (string= "" trace-output))))
+
 ;;; success