X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=d1c86564c3bdcc6002d2ffbd0ed0cf73fb878248;hb=f713c0f609e53771394439dc6b418efcd7c7fb2f;hp=68b37d13ade20e8bb516c1e81118568293bfb4d5;hpb=c50747a96774ec8164ead5e51d74a6d8bcf6e822;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 68b37d1..d1c8656 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3717,7 +3717,11 @@ (flet ((time-it (lambda want) (gc :full t) ; let's keep GCs coming from other code out... (let* ((start (get-internal-run-time)) - (fun (compile nil lambda)) + (fun (dotimes (internal-time-resolution-too-low-workaround + #+win32 10 + #-win32 0 + (compile nil lambda)) + (compile nil lambda))) (end (get-internal-run-time)) (got (funcall fun))) (unless (eql want got) @@ -3827,7 +3831,8 @@ (with-test (:name :multiple-args-to-function) (let ((form `(flet ((foo (&optional (x 13)) x)) (funcall (function foo 42)))) - (*evaluator-mode* :interpret)) + #+sb-eval (*evaluator-mode* :interpret)) + #+sb-eval (assert (eq :error (handler-case (eval form) (error () :error)))) @@ -4254,3 +4259,203 @@ ,@(loop for i from 27 to 32 collect (expt 2 i))))))) (assert (every #'plusp (funcall f #'list))))) + +(with-test (:name (:malformed-ignore :lp-1000239)) + (raises-error? + (eval '(lambda () (declare (ignore (function . a))))) + sb-int:compiled-program-error) + (raises-error? + (eval '(lambda () (declare (ignore (function a b))))) + sb-int:compiled-program-error) + (raises-error? + (eval '(lambda () (declare (ignore (function))))) + sb-int:compiled-program-error) + (raises-error? + (eval '(lambda () (declare (ignore (a))))) + sb-int:compiled-program-error) + (raises-error? + (eval '(lambda () (declare (ignorable (a b))))) + sb-int:compiled-program-error)) + +(with-test (:name :malformed-type-declaraions) + (compile nil '(lambda (a) (declare (type (integer 1 2 . 3) a))))) + +(with-test (:name :compiled-program-error-escaped-source) + (assert + (handler-case + (funcall (compile nil `(lambda () (lambda ("foo"))))) + (sb-int:compiled-program-error (e) + (let ((source (read-from-string (sb-kernel::program-error-source e)))) + (equal source '#'(lambda ("foo")))))))) + +(with-test (:name :escape-analysis-for-nlxs) + (flet ((test (check lambda &rest args) + (let* ((cell-note nil) + (fun (handler-bind ((compiler-note + (lambda (note) + (when (search + "Allocating a value-cell at runtime for" + (princ-to-string note)) + (setf cell-note t))))) + (compile nil lambda)))) + (assert (eql check cell-note)) + (if check + (assert + (eq :ok + (handler-case + (dolist (arg args nil) + (setf fun (funcall fun arg))) + (sb-int:simple-control-error (e) + (when (equal + (simple-condition-format-control e) + "attempt to RETURN-FROM a block or GO to a tag that no longer exists") + :ok))))) + (ctu:assert-no-consing (apply fun args)))))) + (test nil `(lambda (x) + (declare (optimize speed)) + (block out + (flet ((ex () (return-from out 'out!))) + (typecase x + (cons (or (car x) (ex))) + (t (ex)))))) :foo) + (test t `(lambda (x) + (declare (optimize speed)) + (funcall + (block nasty + (flet ((oops () (return-from nasty t))) + #'oops)))) t) + (test t `(lambda (r) + (declare (optimize speed)) + (block out + (flet ((ex () (return-from out r))) + (lambda (x) + (typecase x + (cons (or (car x) (ex))) + (t (ex))))))) t t) + (test t `(lambda (x) + (declare (optimize speed)) + (flet ((eh (x) + (flet ((meh () (return-from eh 'meh))) + (lambda () + (typecase x + (cons (or (car x) (meh))) + (t (meh))))))) + (funcall (eh x)))) t t))) + +(with-test (:name (:bug-1050768 :symptom)) + ;; Used to signal an error. + (compile nil + `(lambda (string position) + (char string position) + (array-in-bounds-p string (1+ position))))) + +(with-test (:name (:bug-1050768 :cause)) + (let ((types `((string string) + ((or (simple-array character 24) (vector t 24)) + (or (simple-array character 24) (vector t)))))) + (dolist (pair types) + (destructuring-bind (orig conservative) pair + (assert sb-c::(type= (specifier-type cl-user::conservative) + (conservative-type (specifier-type cl-user::orig)))))))) + +(with-test (:name (:smodular64 :wrong-width)) + (let ((fun (compile nil + '(lambda (x) + (declare (type (signed-byte 64) x)) + (sb-c::mask-signed-field 64 (- x 7033717698976965573)))))) + (assert (= (funcall fun 10038) -7033717698976955535)))) + +(with-test (:name (:smodular32 :wrong-width)) + (let ((fun (compile nil '(lambda (x) + (declare (type (signed-byte 31) x)) + (sb-c::mask-signed-field 31 (- x 1055131947)))))) + (assert (= (funcall fun 10038) -1055121909)))) + +(with-test (:name :first-open-coded) + (let ((fun (compile nil `(lambda (x) (first x))))) + (assert (not (ctu:find-named-callees fun))))) + +(with-test (:name :second-open-coded) + (let ((fun (compile nil `(lambda (x) (second x))))) + (assert (not (ctu:find-named-callees fun))))) + +(with-test (:name :svref-of-symbol-macro) + (compile nil `(lambda (x) + (symbol-macrolet ((sv x)) + (values (svref sv 0) (setf (svref sv 0) 99)))))) + +;; The compiler used to update the receiving LVAR's type too +;; aggressively when converting a large constant to a smaller +;; (potentially signed) one, causing other branches to be +;; inferred as dead. +(with-test (:name :modular-cut-constant-to-width) + (let ((test (compile nil + `(lambda (x) + (logand 254 + (case x + ((3) x) + ((2 2 0 -2 -1 2) 9223372036854775803) + (t 358458651))))))) + (assert (= (funcall test -10470605025) 26)))) + +(with-test (:name :append-type-derivation) + (let ((test-cases + '((lambda () (append 10)) (integer 10 10) + (lambda () (append nil 10)) (integer 10 10) + (lambda (x) (append x 10)) t + (lambda (x) (append x (cons 1 2))) cons + (lambda (x y) (append x (cons 1 2) y)) cons + (lambda (x y) (nconc x (the list y) x)) t + (lambda (x y) (print (length y)) (append x y)) sequence))) + (loop for (function result-type) on test-cases by #'cddr + do (assert (equal (car (cdaddr (sb-kernel:%simple-fun-type + (compile nil function)))) + result-type))))) + +(with-test (:name :bug-504121) + (compile nil `(lambda (s) + (let ((p1 #'upper-case-p)) + (funcall + (lambda (g) + (funcall p1 g)))) + (let ((p2 #'(lambda (char) (upper-case-p char)))) + (funcall p2 s))))) + +(with-test (:name (:bug-504121 :optional-missing)) + (compile nil `(lambda (s) + (let ((p1 #'upper-case-p)) + (funcall + (lambda (g &optional x) + (funcall p1 g)))) + (let ((p2 #'(lambda (char) (upper-case-p char)))) + (funcall p2 s))))) + +(with-test (:name (:bug-504121 :optional-superfluous)) + (compile nil `(lambda (s) + (let ((p1 #'upper-case-p)) + (funcall + (lambda (g &optional x) + (funcall p1 g)) + #\1 2 3)) + (let ((p2 #'(lambda (char) (upper-case-p char)))) + (funcall p2 s))))) + +(with-test (:name (:bug-504121 :key-odd)) + (compile nil `(lambda (s) + (let ((p1 #'upper-case-p)) + (funcall + (lambda (g &key x) + (funcall p1 g)) + #\1 :x)) + (let ((p2 #'(lambda (char) (upper-case-p char)))) + (funcall p2 s))))) + +(with-test (:name (:bug-504121 :key-unknown)) + (compile nil `(lambda (s) + (let ((p1 #'upper-case-p)) + (funcall + (lambda (g &key x) + (funcall p1 g)) + #\1 :y 2)) + (let ((p2 #'(lambda (char) (upper-case-p char)))) + (funcall p2 s)))))