X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=d2e81c86dd40c44b0dd662c71a0362debb33665a;hb=6a8fb906ba96395f2a60f821b2ec7649a2a3ae46;hp=d9d88e370f0f3355833278167ec6a6b9d4cb775b;hpb=a95d2711a647fef8cc670c74909a93d306735075;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index d9d88e3..d2e81c8 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -75,16 +75,16 @@ ;;; another LET-related bug fixed by Alexey Dejneka at the same ;;; time as bug 112 -(multiple-value-bind (value error) - (ignore-errors - ;; should complain about duplicate variable names in LET binding - (compile nil - '(lambda () - (let (x - (x 1)) - (list x))))) - (assert (null value)) - (assert (typep error 'error))) +(multiple-value-bind (fun warnings-p failure-p) + ;; should complain about duplicate variable names in LET binding + (compile nil + '(lambda () + (let (x + (x 1)) + (list x)))) + (declare (ignore warnings-p)) + (assert (functionp fun)) + (assert failure-p)) ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David ;;; Lichteblau 2002-05-21) @@ -232,7 +232,7 @@ (ignore-errors (ecase 1 (t 0) (1 2))) (assert (eql result 2)) (assert (null error))) - + ;;; FTYPE should accept any functional type specifier (compile nil '(lambda (x) (declare (ftype function f)) (f x))) @@ -326,8 +326,8 @@ (loop for (fun warns-p) in '(((lambda (&optional *x*) *x*) t) ((lambda (&optional *x* &rest y) (values *x* y)) t) - ((lambda (&optional *print-base*) (values *print-base*)) nil) - ((lambda (&optional *print-base* &rest y) (values *print-base* y)) nil) + ((lambda (&optional *print-length*) (values *print-length*)) nil) + ((lambda (&optional *print-length* &rest y) (values *print-length* y)) nil) ((lambda (&optional *x*) (declare (special *x*)) (values *x*)) nil) ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil)) for real-warns-p = (nth-value 1 (compile nil fun)) @@ -342,6 +342,16 @@ ;;; Moellmann: CONVERT-MORE-CALL failed on the following call (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u)) +(raises-error? (multiple-value-bind (a b c) + (eval '(truncate 3 4)) + (declare (integer c)) + (list a b c)) + type-error) + +(assert (equal (multiple-value-list (the (values &rest integer) + (eval '(values 3)))) + '(3))) + ;;; Bug relating to confused representation for the wild function ;;; type: (assert (null (funcall (eval '(lambda () (multiple-value-list (values))))))) @@ -377,3 +387,96 @@ (bar)))) (error (c) (values nil t t)))))) + +(assert (typep (eval `(the arithmetic-error + ',(make-condition 'arithmetic-error))) + 'arithmetic-error)) + +(assert (not (nth-value + 2 (compile nil '(lambda () + (make-array nil :initial-element 11)))))) + +(assert (raises-error? (funcall (eval #'open) "assertoid.lisp" + :external-format '#:nonsense))) +(assert (raises-error? (funcall (eval #'load) "assertoid.lisp" + :external-format '#:nonsense))) + +(assert (= (the (values integer symbol) (values 1 'foo 13)) 1)) + +(let ((f (compile nil + '(lambda (v) + (declare (optimize (safety 3))) + (list (the fixnum (the (real 0) (eval v)))))))) + (assert (raises-error? (funcall f 0.1) type-error)) + (assert (raises-error? (funcall f -1) type-error))) + +;;; the implicit block does not enclose lambda list +(let ((forms '((defmacro #1=#:foo (&optional (x (return-from #1#)))) + #+nil(macrolet ((#2=#:foo (&optional (x (return-from #2#)))))) + (define-compiler-macro #3=#:foo (&optional (x (return-from #3#)))) + (deftype #4=#:foo (&optional (x (return-from #4#)))) + (define-setf-expander #5=#:foo (&optional (x (return-from #5#)))) + (defsetf #6=#:foo (&optional (x (return-from #6#))) ())))) + (dolist (form forms) + (assert (nth-value 2 (compile nil `(lambda () ,form)))))) + +(assert (nth-value 2 (compile nil + '(lambda () + (svref (make-array '(8 9) :adjustable t) 1))))) + +;;; CHAR= did not check types of its arguments (reported by Adam Warner) +(raises-error? (funcall (compile nil '(lambda (x y z) (char= x y z))) + #\a #\b nil) + type-error) +(raises-error? (funcall (compile nil + '(lambda (x y z) + (declare (optimize (speed 3) (safety 3))) + (char/= x y z))) + nil #\a #\a) + type-error) + +;;; Compiler lost return type of MAPCAR and friends +(dolist (fun '(mapcar mapc maplist mapl)) + (assert (nth-value 2 (compile nil + `(lambda (x) + (1+ (,fun #'print x))))))) + +(assert (nth-value 2 (compile nil + '(lambda () + (declare (notinline mapcar)) + (1+ (mapcar #'print '(1 2 3))))))) + +;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant +;; index was effectless +(let ((f (compile nil '(lambda (a v) + (declare (type simple-bit-vector a) (type bit v)) + (declare (optimize (speed 3) (safety 0))) + (setf (aref a 0) v) + a)))) + (let ((y (make-array 2 :element-type 'bit :initial-element 0))) + (assert (equal y #*00)) + (funcall f y 1) + (assert (equal y #*10)))) + +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x) + (declare (type (simple-array (simple-string 3) (5)) x)) + (aref (aref x 0) 0)))) + +;; compiler failure +(let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0))))))) + (assert (funcall f 1d0))) + +(compile nil '(lambda (x) + (declare (double-float x)) + (let ((y (* x pi))) + (atan y y)))) + +;; bogus optimization of BIT-NOT +(multiple-value-bind (result x) + (eval '(let ((x (eval #*1001))) + (declare (optimize (speed 2) (space 3)) + (type (bit-vector) x)) + (values (bit-not x nil) x))) + (assert (equal x #*1001)) + (assert (equal result #*0110)))