X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=7dcc183567ab236799eb9e0a76fdfc621714807e;hb=59f4a9f62d1ab9656b02eef240d7aac65669262d;hp=b2612549e5575c934e716956bdf6c134512419e4;hpb=04f74c8cbe98704aa761e187741984bc8fe3983f;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index b261254..7dcc183 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -11,6 +11,16 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
+(cl:in-package :sb-c)
+
+(defknown compiler-derived-type (t) (values t t) (movable flushable unsafe))
+
+(deftransform compiler-derived-type ((x))
+ `(values ',(type-specifier (lvar-type x)) t))
+
+(defun compiler-derived-type (x)
+  (values t nil))
+
 (cl:in-package :cl-user)
 
 ;; The tests in this file assume that EVAL will use the compiler
@@ -2546,3 +2556,137 @@
               (+ 81535869 (the (member 17549.955 #:g35917) p2))))
            17549.955)
           (+ 81535869 17549.955)))
+
+;;; misc.654
+(assert (eql 2
+             (let ((form '(lambda (p2)
+                           (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
+                            (type (member integer eql) p2))
+                           (coerce 2 p2))))
+               (funcall (compile nil form) 'integer))))
+
+;;; misc.656
+(assert (eql 2
+             (let ((form '(lambda (p2)
+                           (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
+                            (type (member integer mod) p2))
+                           (coerce 2 p2))))
+               (funcall (compile nil form) 'integer))))
+
+;;; misc.657
+(assert (eql 2
+         (let ((form '(lambda (p2)
+                       (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
+                        (type (member integer values) p2))
+                       (coerce 2 p2))))
+           (funcall (compile nil form) 'integer))))
+
+(with-test (:name :string-aref-type)
+ (assert (eq 'character
+             (funcall (compile nil
+                               '(lambda (s)
+                                 (sb-c::compiler-derived-type (aref (the string s) 0))))
+                      "foo"))))
+
+(with-test (:name :base-string-aref-type)
+ (assert (eq #+sb-unicode 'base-char
+             #-sb-unicode 'character
+             (funcall (compile nil
+                               '(lambda (s)
+                                 (sb-c::compiler-derived-type (aref (the base-string s) 0))))
+                      (coerce "foo" 'base-string)))))
+
+(with-test (:name :dolist-constant-type-derivation)
+  (assert (equal '(integer 1 3)
+                 (funcall (compile nil
+                                   '(lambda (x)
+                                     (dolist (y '(1 2 3))
+                                       (when x
+                                         (return (sb-c::compiler-derived-type y))))))
+                          t))))
+
+(with-test (:name :dolist-simple-list-type-derivation)
+  (assert (equal '(integer 1 3)
+                 (funcall (compile nil
+                                   '(lambda (x)
+                                     (dolist (y (list 1 2 3))
+                                       (when x
+                                         (return (sb-c::compiler-derived-type y))))))
+                          t))))
+
+(with-test (:name :dolist-dotted-constant-list-type-derivation)
+  (let* ((warned nil)
+         (fun (handler-bind ((style-warning (lambda (c) (push c warned))))
+                (compile nil
+                         '(lambda (x)
+                           (dolist (y '(1 2 3 . 4) :foo)
+                             (when x
+                               (return (sb-c::compiler-derived-type y)))))))))
+    (assert (equal '(integer 1 3) (funcall fun t)))
+    (assert (= 1 (length warned)))
+    (multiple-value-bind (res err) (ignore-errors (funcall fun nil))
+      (assert (not res))
+      (assert (typep err 'type-error)))))
+
+(with-test (:name :constant-list-destructuring)
+  (handler-bind ((sb-ext:compiler-note #'error))
+    (progn
+      (assert (= 10
+                 (funcall
+                  (compile nil
+                           '(lambda ()
+                             (destructuring-bind (a (b c) d) '(1 (2 3) 4)
+                               (+ a b c d)))))))
+      (assert (eq :feh
+                  (funcall
+                   (compile nil
+                            '(lambda (x)
+                              (or x
+                               (destructuring-bind (a (b c) d) '(1 "foo" 4)
+                                 (+ a b c d)))))
+                   :feh))))))
+
+;;; Functions with non-required arguments used to end up with
+;;; (&OPTIONAL-DISPATCH ...) as their names.
+(with-test (:name :hairy-function-name)
+  (assert (eq 'read-line (nth-value 2 (function-lambda-expression #'read-line))))
+  (assert (equal "#<FUNCTION READ-LINE>" (princ-to-string #'read-line))))
+
+;;; PROGV + RESTRICT-COMPILER-POLICY
+(with-test (:name :progv-and-restrict-compiler-policy)
+  (let ((sb-c::*policy-restrictions* sb-c::*policy-restrictions*))
+    (restrict-compiler-policy 'debug 3)
+    (let ((fun (compile nil '(lambda (x)
+                              (let ((i x))
+                                (declare (special i))
+                                (list i
+                                      (progv '(i) (list (+ i 1))
+                                        i)
+                                      i))))))
+      (assert (equal '(1 2 1) (funcall fun 1))))))
+
+;;; It used to be possible to confuse the compiler into
+;;; IR2-converting such a call to CONS
+(with-test (:name :late-bound-primitive)
+  (compile nil `(lambda ()
+                  (funcall 'cons 1))))
+
+(with-test (:name :hairy-array-element-type-derivation)
+  (compile nil '(lambda (x)
+                 (declare (type (and simple-string (satisfies array-has-fill-pointer-p)) x))
+                 (array-element-type x))))
+
+(with-test (:name :rest-list-type-derivation)
+  (multiple-value-bind (type derivedp)
+      (funcall (compile nil `(lambda (&rest args)
+                               (sb-c::compiler-derived-type args)))
+               nil)
+    (assert (eq 'list type))
+    (assert derivedp)))
+
+(with-test (:name :base-char-typep-elimination)
+  (assert (eq (funcall (lambda (ch)
+                         (declare (type base-char ch) (optimize (speed 3) (safety 0)))
+                         (typep ch 'base-char))
+                       t)
+              t)))