X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=57e96361961725860ed11dd9f0d17ed3805bb0a3;hb=d04b59670ab69405c4115ea3caac99fd62a4b7ab;hp=9435118af91daa348b5e1cff3a50e80c39b5b899;hpb=9489abab7f981b8eea2aec8a883f2eb48d4cb138;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 9435118..57e9636 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -308,12 +308,17 @@ ;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden ;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18. (multiple-value-bind (function warnings-p failure-p) - (compile nil '(lambda () (symbol-macrolet ((t nil)) t))) + (compile nil '(lambda () + ;; not interested in the package lock violation here + (declare (sb-ext:disable-package-locks t)) + (symbol-macrolet ((t nil)) t))) (assert failure-p) (assert (raises-error? (funcall function) program-error))) (multiple-value-bind (function warnings-p failure-p) (compile nil '(lambda () + ;; not interested in the package lock violation here + (declare (sb-ext:disable-package-locks *standard-input*)) (symbol-macrolet ((*standard-input* nil)) *standard-input*))) (assert failure-p) @@ -839,6 +844,85 @@ (list (bar x) (bar x) (bar x)))) (assert (raises-error? (bug249 1.0) type-error)) + +;;; bug reported by ohler on #lisp 2003-07-10 +(defun bug-ohler-2003-07-10 (a b) + (declare (optimize (speed 0) (safety 3) (space 0) + (debug 1) (compilation-speed 0))) + (adjoin a b)) + +;;; bug reported by Doug McNaught on sbcl-devel 2003-09-14: +;;; COMPILE-FILE did not bind *READTABLE* +(let* ((source "bug-doug-mcnaught-20030914.lisp") + (fasl (compile-file-pathname source))) + (labels ((check () + (assert (null (get-macro-character #\])))) + (full-check () + (check) + (assert (typep *bug-doug-mcnaught-20030914* + '(simple-array (unsigned-byte 4) (*)))) + (assert (equalp *bug-doug-mcnaught-20030914* #(1 2 3))) + (makunbound '*bug-doug-mcnaught-20030914*))) + (compile-file source) + (check) + (load fasl) + (full-check) + (load source) + (full-check) + (delete-file fasl))) + +(defun expt-derive-type-bug (a b) + (unless (< a b) + (truncate (expt a b)))) +(assert (equal (multiple-value-list (expt-derive-type-bug 1 1)) + '(1 0))) + +;;; Problems with type checking in functions with EXPLICIT-CHECK +;;; attribute (reported by Peter Graves) +(loop for (fun . args) in '((= a) (/= a) + (< a) (<= a) (> a) (>= a)) + do (assert (raises-error? (apply fun args) type-error))) + +(defclass broken-input-stream (sb-gray:fundamental-input-stream) ()) +(defmethod sb-gray:stream-read-char ((stream broken-input-stream)) + (throw 'break :broken)) +(assert (eql (block return + (handler-case + (catch 'break + (funcall (eval ''peek-char) + 1 (make-instance 'broken-input-stream)) + :test-broken) + (type-error (c) + (return-from return :good)))) + :good)) + +;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual) +(defvar *compiler-note-count* 0) +#-(or alpha x86-64) ; FIXME: make a better test! +(handler-bind ((sb-ext:compiler-note (lambda (c) + (declare (ignore c)) + (incf *compiler-note-count*)))) + (let ((fun + (compile nil + '(lambda (x) + (declare (optimize speed) (fixnum x)) + (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (values (* x 5) ; no compiler note from this + (locally + (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) + ;; this one gives a compiler note + (* x -5))))))) + (assert (= *compiler-note-count* 1)) + (assert (equal (multiple-value-list (funcall fun 1)) '(5 -5))))) + +(handler-case + (eval '(flet ((%f (&key) nil)) (%f nil nil))) + (error (c) :good) + (:no-error (val) (error "no error: ~S" val))) +(handler-case + (eval '(labels ((%f (&key x) x)) (%f nil nil))) + (error (c) :good) + (:no-error (val) (error "no error: ~S" val))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself @@ -906,5 +990,82 @@ (grovel-results name)))))) (identify-suspect-vops) +;;;; tests for compiler output +(let* ((*error-output* (make-broadcast-stream)) + (output (with-output-to-string (*standard-output*) + (compile-file "compiler-output-test.lisp" + :print nil :verbose nil)))) + (print output) + (assert (zerop (length output)))) + +;;;; bug 305: INLINE/NOTINLINE causing local ftype to be lost + +(define-condition optimization-error (error) ()) + +(labels ((compile-lambda (type sense) + (handler-bind ((compiler-note (lambda (_) + (declare (ignore _)) + (error 'optimization-error)))) + (values + (compile + nil + `(lambda () + (declare + ,@(when type '((ftype (function () (integer 0 10)) bug-305))) + (,sense bug-305) + (optimize speed)) + (1+ (bug-305)))) + nil))) + (expect-error (sense) + (multiple-value-bind (f e) (ignore-errors (compile-lambda nil sense)) + (assert (not f)) + (assert (typep e 'optimization-error)))) + (expect-pass (sense) + (multiple-value-bind (f e) (ignore-errors (compile-lambda t sense)) + (assert f) + (assert (not e))))) + (expect-error 'inline) + (expect-error 'notinline) + (expect-pass 'inline) + (expect-pass 'notinline)) + +;;; bug 211e: bogus style warning from duplicated keyword argument to +;;; a local function. +(handler-bind ((style-warning #'error)) + (let ((f (compile nil '(lambda () + (flet ((foo (&key y) (list y))) + (list (foo :y 1 :y 2))))))) + (assert (equal '((1)) (funcall f))))) + +;;; check that EQL is optimized when other argument is (OR SYMBOL FIXNUM). +(handler-bind ((compiler-note #'error)) + (let ((f1 (compile nil '(lambda (x1 y1) + (declare (type (or symbol fixnum) x1) + (optimize speed)) + (eql x1 y1)))) + (f2 (compile nil '(lambda (x2 y2) + (declare (type (or symbol fixnum) y2) + (optimize speed)) + (eql x2 y2))))) + (let ((fix (random most-positive-fixnum)) + (sym (gensym)) + (e-count 0)) + (assert (funcall f1 fix fix)) + (assert (funcall f2 fix fix)) + (assert (funcall f1 sym sym)) + (assert (funcall f2 sym sym)) + (handler-bind ((type-error (lambda (c) + (incf e-count) + (continue c)))) + (flet ((test (f x y) + (with-simple-restart (continue "continue with next test") + (funcall f x y) + (error "fell through with (~S ~S ~S)" f x y)))) + (test f1 "oops" 42) + (test f1 (1+ most-positive-fixnum) 42) + (test f2 42 "oops") + (test f2 42 (1+ most-positive-fixnum)))) + (assert (= e-count 4))))) + ;;; success (quit :unix-status 104)