X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=fb5d3e4b44c0924f9db0f7014f889b22c4bc0eb3;hb=a1007bcf38130a9a08e32f04a69e6836f76329d2;hp=c54e61e270f05a98a0980b7d2bd6caeb43ea8bd4;hpb=dea9bd5c1afe23d9e061c60db654b88187ba9a5e;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index c54e61e..fb5d3e4 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -177,3 +177,167 @@ (let ((f (compile nil '(lambda (x) (make-array 1 :element-type '(0)))))) (assert (null (ignore-errors (funcall f))))) + +;;; the following functions must not be flushable +(dolist (form '((make-sequence 'fixnum 10) + (concatenate 'fixnum nil) + (map 'fixnum #'identity nil) + (merge 'fixnum nil nil #'<))) + (assert (not (eval `(locally (declare (optimize (safety 0))) + (ignore-errors (progn ,form t))))))) + +(dolist (form '((values-list (car (list '(1 . 2)))) + (fboundp '(set bet)) + (atan #c(1 1) (car (list #c(2 2)))) + (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5)) + (nthcdr (car (list 5)) '(1 2 . 3)))) + (assert (not (eval `(locally (declare (optimize (safety 3))) + (ignore-errors (progn ,form t))))))) + +;;; a bug in the MAP deftransform caused non-VECTOR array specifiers +;;; to cause errors in the compiler. Fixed by CSR in 0.7.8.10 +(assert (list (compile nil '(lambda (x) (map 'simple-array 'identity x))))) + +;;; bug 129: insufficient syntax checking in MACROLET +(multiple-value-bind (result error) + (ignore-errors (eval '(macrolet ((foo x `',x)) (foo 1 2 3)))) + (assert (null result)) + (assert (typep error 'error))) + +;;; bug 124: environment of MACROLET-introduced macro expanders +(assert (equal + (macrolet ((mext (x) `(cons :mext ,x))) + (macrolet ((mint (y) `'(:mint ,(mext y)))) + (list (mext '(1 2)) + (mint (1 2))))) + '((:MEXT 1 2) (:MINT (:MEXT 1 2))))) + +;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced +;;; symbol is declared to be SPECIAL +(multiple-value-bind (result error) + (ignore-errors (funcall (lambda () + (symbol-macrolet ((s '(1 2))) + (declare (special s)) + s)))) + (assert (null result)) + (assert (typep error 'program-error))) + +;;; ECASE should treat a bare T as a literal key +(multiple-value-bind (result error) + (ignore-errors (ecase 1 (t 0))) + (assert (null result)) + (assert (typep error 'type-error))) + +(multiple-value-bind (result error) + (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))) + +;;; FUNCALL of special operators and macros should signal an +;;; UNDEFINED-FUNCTION error +(multiple-value-bind (result error) + (ignore-errors (funcall 'quote 1)) + (assert (null result)) + (assert (typep error 'undefined-function)) + (assert (eq (cell-error-name error) 'quote))) +(multiple-value-bind (result error) + (ignore-errors (funcall 'and 1)) + (assert (null result)) + (assert (typep error 'undefined-function)) + (assert (eq (cell-error-name error) 'and))) + +;;; PSETQ should behave when given complex symbol-macro arguments +(multiple-value-bind (sequence index) + (symbol-macrolet ((x (aref a (incf i))) + (y (aref a (incf i)))) + (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) + (i 0)) + (psetq x (aref a (incf i)) + y (aref a (incf i))) + (values a i))) + (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9))) + (assert (= index 4))) + +(multiple-value-bind (result error) + (ignore-errors + (let ((x (list 1 2))) + (psetq (car x) 3) + x)) + (assert (null result)) + (assert (typep error 'program-error))) + +;;; COPY-SEQ should work on known-complex vectors: +(assert (equalp #(1) + (let ((v (make-array 0 :fill-pointer 0))) + (vector-push-extend 1 v) + (copy-seq v)))) + +;;; to support INLINE functions inside MACROLET, it is necessary for +;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in +;;; certain circumstances, one of which is when compile is called from +;;; top-level. +(assert (equal + (function-lambda-expression + (compile nil '(lambda (x) (block nil (print x))))) + '(lambda (x) (block nil (print x))))) + +;;; bug 62: too cautious type inference in a loop +(assert (nth-value + 2 + (compile nil + '(lambda (a) + (declare (optimize speed (safety 0))) + (typecase a + (array (loop (print (car a))))))))) + +;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler +;;; failure +(compile nil + '(lambda (key tree collect-path-p) + (let ((lessp (key-lessp tree)) + (equalp (key-equalp tree))) + (declare (type (function (t t) boolean) lessp equalp)) + (let ((path '(nil))) + (loop for node = (root-node tree) + then (if (funcall lessp key (node-key node)) + (left-child node) + (right-child node)) + when (null node) + do (return (values nil nil nil)) + do (when collect-path-p + (push node path)) + (when (funcall equalp key (node-key node)) + (return (values node path t)))))))) + +;;; CONSTANTLY should return a side-effect-free function (bug caught +;;; by Paul Dietz' test suite) +(let ((i 0)) + (let ((fn (constantly (progn (incf i) 1)))) + (assert (= i 1)) + (assert (= (funcall fn) 1)) + (assert (= i 1)) + (assert (= (funcall fn) 1)) + (assert (= i 1)))) + +;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version) +(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 *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)) + do (assert (eq warns-p real-warns-p))) + +;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26 +(assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y))) + '(1 2)) + '((2) 1))) + +;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd +;;; Moellmann: CONVERT-MORE-CALL failed on the following call +(assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))