X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure-cload.lisp;h=b0514a8781daef47b70fabba849755f2f2724461;hb=fb9c34275389e23f32d80954ab4848fac48936d9;hp=05a11457311991814c3f249aceb16244fecb217c;hpb=17794352c2ef078a1fc3cdd306f17f7328edf40b;p=sbcl.git diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index 05a1145..b0514a8 100644 --- a/tests/compiler.impure-cload.lisp +++ b/tests/compiler.impure-cload.lisp @@ -28,6 +28,7 @@ (stub avecname)) (paip avecname))))) :eexpr (lambda (south east)))) +(in-package :cl-user) (delete-package :bug254) ;;; bug 255 @@ -54,6 +55,7 @@ (multiple-value-prog1 (progn (%pu avecname)) (frob))))))) +(in-package :cl-user) (delete-package :bug255) ;;; bug 148 @@ -120,6 +122,7 @@ (assert (equal (eval '(bug148-4 '(1 2 3))) '((1 2 3) (7 14 21) (21 14 7)))) +(in-package :cl-user) (delete-package :bug148) ;;; bug 258 @@ -141,9 +144,8 @@ (assert (equal (u-b-sra '(4 9 7)) '((4 9 7) (3 8 6) (6 8 3)))) -(delete-package :bug258) - (in-package :cl-user) +(delete-package :bug258) ;;; (defun bug233a (x) @@ -156,5 +158,214 @@ (funcall (eval ''list) y (+ y 2d0) (* y 3d0))))) (assert (raises-error? (bug233a 4) type-error)) +;;; compiler failure +(defun bug145b (x) + (declare (type (double-float -0d0) x)) + (declare (optimize speed)) + (+ x (sqrt (log (random 1d0))))) + +;;; compiler failures reported by Paul Dietz: inaccurate dealing with +;;; BLOCK-LAST in CONSTANT-FOLD-CALL and DO-NODES +(defun #:foo (a b c d) + (declare (type (integer -1 1000655) b) + (optimize (speed 3) (safety 1) (debug 1))) + (- (logior + (abs (- (+ b (logandc1 -473949 (max 5165 (abs (logandc1 a 250775))))))) + (logcount (logeqv (max (logxor (abs c) -1) 0) -4))) + d)) + +(defun #:foo (a d) + (declare (type (integer -8507 26755) a) + (type (integer -393314538 2084485) d) + (optimize (speed 3) (safety 1) (debug 1))) + (gcd + (if (= 0 a) 10 (abs -1)) + (logxor -1 + (min -7580 + (max (logand a 31365125) d))))) + +;;; compiler failure "NIL is not of type LVAR" +(defun #:foo (x) + (progn (truly-the integer x) + (1+ x))) + +(defun #:foo (a b c) + (declare (type (integer -5498929 389890) a) + (type (integer -5029571274946 48793670) b) + (type (integer 9221496 260169518304) c) + (ignorable a b c) + (optimize (speed 3) (safety 1) (debug 1))) + (- (mod 1020122 (min -49 -420)) + (logandc1 + (block b2 (mod c (min -49 (if t (return-from b2 1582) b)))) + (labels ((%f14 () + (mod a (max 76 8)))) + b)))) + +;;; bug 291 reported by Nikodemus Siivola (modified version) +(defstruct line + (%chars "")) +(defun update-window-imag (line) + (tagbody + TOP + (if (null line) + (go DONE) + (go TOP)) + DONE + (unless (eq current the-sentinel) + (let* ((cc (car current)) + (old-line (dis-line-line cc))) + (if (eq old-line line) + (do ((chars (line-%chars line) nil)) + (()) + (let* () + (multiple-value-call + #'(lambda (&optional g2740 g2741 &rest g2742) + (declare (ignore g2742)) + (catch 'foo + (values (setq string g2740) (setq underhang g2741)))) + (foo))) + (setf (dis-line-old-chars cc) chars))))))) + +;;; and similar cases found by Paul Dietz +(defun #:foo (a b c) + (declare (optimize (speed 0) (safety 3) (debug 3))) + (FLET ((%F11 () + (BLOCK B6 + (LET ((V2 B)) + (IF (LDB-TEST (BYTE 27 14) V2) + (LET ((V6 + (FLET ((%F7 () + B)) + -1))) + (RETURN-FROM B6 V2)) + C))))) + A)) +(defun #:foo (a b c) + (declare (optimize (speed 0) (safety 3) (debug 3))) + (FLET ((%F15 () + (BLOCK B8 + (LET ((V5 B)) + (MIN A (RETURN-FROM B8 C)))))) + C)) + +;;; bug 292, reported by Paul Dietz +(defun #:foo (C) + (DECLARE (TYPE (INTEGER -5945502333 12668542) C) + (OPTIMIZE (SPEED 3))) + (LET ((V2 (* C 12))) + (- (MAX (IF (/= 109335113 V2) -26479 V2) + (DEPOSIT-FIELD 311 + (BYTE 14 28) + (MIN (MAX 521326 C) -51)))))) + +;;; zombie variables, arising from constraints +(defun #:foo (A B) + (DECLARE (TYPE (INTEGER -40945116 24028306) B) + (OPTIMIZE (SPEED 3))) + (LET ((V5 (MIN 31883 (LOGCOUNT A)))) + (IF (/= B V5) (IF (EQL 122911784 V5) -43765 1487) B))) + +;;; let-conversion of a function into deleted one +(defun #:foo (a c) + (declare (type (integer -883 1566) a) + (type (integer -1 0) c) + (optimize (speed 3) (safety 1) (debug 1))) + (flet ((%f8 () c)) + (flet ((%f5 () + (if (< c a) + (return-from %f5 (if (= -4857 a) (%f8) (%f8))) + c))) + (if (<= 11 c) (%f5) c)))) + +;;; two bugs: "aggressive" deletion of optional entries and problems +;;; of FIND-RESULT-TYPE in dealing with deleted code; reported by +;;; Nikodemus Siivola (simplified version) +(defun lisp-error-error-handler (condition) + (invoke-debugger condition) + (handler-bind () + (unwind-protect + (with-simple-restart + (continue "return to hemlock's debug loop.") + (invoke-debugger condition)) + (device)))) + +;;; +(defun #:foo () + (labels ((foo (x) + (return-from foo x) + (block u + (labels ((bar (x &optional (y (return-from u))) + (list x y (apply #'bar (fee))))) + (list (bar 1) (bar 1 2)))) + (1+ x))) + #'foo)) + +(defun #:foo (b c) + (declare (type (integer 0 1) b) (optimize (speed 3))) + (flet ((%f2 () (lognor (block b5 138) c))) + (if (not (or (= -67399 b) b)) + (deposit-field (%f2) (byte 11 8) -3) + c))) + +;;; bug 214: compiler failure +(defun bug214a1 () + (declare (optimize (sb-ext:inhibit-warnings 0) (compilation-speed 2))) + (flet ((foo (&key (x :vx x-p)) (list x x-p))) + (foo :x 2))) + +(defun bug214a2 () + (declare (optimize (sb-ext:inhibit-warnings 0) (compilation-speed 2))) + (lambda (x) (declare (fixnum x)) (if (< x 0) 0 (1- x)))) + +;;; this one was reported by rydis on #lisp +(defun 214b (n) + (declare (fixnum n)) + (declare (optimize (speed 2) (space 3))) + (dotimes (k n) + (princ k))) + +;;; bug reported by Brian Downing: incorrect detection of MV-LET +(DEFUN #:failure-testcase (SESSION) + (LABELS ((CONTINUATION-1 () + (PROGN + (IF (foobar-1 SESSION) + (CONTINUATION-2)) + (LET ((CONTINUATION-3 + #'(LAMBDA () + (MULTIPLE-VALUE-CALL #'CONTINUATION-2 + (CONTINUATION-1))))) + (foobar-2 CONTINUATION-3)))) + (CONTINUATION-2 (&REST OTHER-1) + (DECLARE (IGNORE OTHER-1)))) + (continuation-1))) + +;;; reported by antifuchs/bdowning/etc on #lisp: ITERATE failure on +;;; (iter (for i in '(1 2 3)) (+ i 50)) +(defun values-producer () (values 1 2 3 4 5 6 7)) + +(defun values-consumer (fn) + (let (a b c d e f g h) + (multiple-value-bind (aa bb cc dd ee ff gg hh) (funcall fn) + (setq a aa) + (setq b bb) + (setq c cc) + (setq d dd) + (setq e ee) + (setq f ff) + (setq g gg) + (setq h hh) + (values a b c d e f g h)))) + +(let ((list (multiple-value-list (values-consumer #'values-producer)))) + (assert (= (length list) 8)) + (assert (null (nth 7 list)))) + +;;; bug 313: source transforms were "lisp-1" +(defun srctran-lisp1-1 (cadr) (if (functionp cadr) (funcall cadr 1) nil)) +(assert (eql (funcall (eval #'srctran-lisp1-1) #'identity) 1)) +(defvar caar) +(defun srctran-lisp1-2 (caar) (funcall (sb-ext:truly-the function caar) 1)) +(assert (eql (funcall (eval #'srctran-lisp1-2) #'identity) 1)) (sb-ext:quit :unix-status 104)