X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure-cload.lisp;h=ade85555fec839e9178398846f63a11888b711e8;hb=1cba0af01f5107ab384d0d8b94b1f6330b3d0ef4;hp=661c1845317538c5cea86883609afeedbb130335;hpb=5af8c2ae56df139842270bd9c9605c5d4b2d5148;p=sbcl.git diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index 661c184..ade8555 100644 --- a/tests/compiler.impure-cload.lisp +++ b/tests/compiler.impure-cload.lisp @@ -1,5 +1,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (load "assertoid.lisp") + (load "compiler-test-util.lisp") + (load "test-util.lisp") (use-package "ASSERTOID")) ;;; bug 254: compiler falure @@ -28,6 +30,7 @@ (stub avecname)) (paip avecname))))) :eexpr (lambda (south east)))) +(in-package :cl-user) (delete-package :bug254) ;;; bug 255 @@ -54,6 +57,7 @@ (multiple-value-prog1 (progn (%pu avecname)) (frob))))))) +(in-package :cl-user) (delete-package :bug255) ;;; bug 148 @@ -120,6 +124,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 +146,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) @@ -187,6 +191,19 @@ (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 "")) @@ -276,7 +293,7 @@ (device)))) ;;; -(defun foo () +(defun #:foo () (labels ((foo (x) (return-from foo x) (block u @@ -286,5 +303,258 @@ (1+ x))) #'foo)) - -(sb-ext:quit :unix-status 104) +(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)))) + +;;; failed on Alpha prior to sbcl-0.8.10.30 +(defun lotso-values () + (values 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9)) + +;;; 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)) +(without-package-locks + ;; this be a nasal demon, but test anyways + (defvar caar)) +(defun srctran-lisp1-2 (caar) (funcall (sb-ext:truly-the function caar) 1)) +(assert (eql (funcall (eval #'srctran-lisp1-2) #'identity) 1)) + +;;; partial bug 262: reference of deleted CTRAN (in RETURN-FROM) +;;; during inline expansion. Bug report by Peter Denno, simplified +;;; test case by David Wragg. +(defun bug262-return-from (x &aux (y nil)) + (labels ((foo-a (z) (return-from bug262-return-from z)) + (foo-b (z) (foo-a z))) + (declare (inline foo-a)) + (foo-a x))) + +;;; broken inference of an upper bound of an iteration variable, +;;; reported by Rajat Datta. +(defun isieve (num) + (let ((vec (make-array num :initial-element 0)) + (acc 0)) + (do ((i 2 (+ i 1))) + ((>= i num) 'done) + (when (= (svref vec i) 0) + (do ((j (* i i) (+ j i))) + ((>= j num) 'done) + (setf (svref vec j) 1)) + (incf acc))) + acc)) + +(assert (= (isieve 46349) 4792)) + +;;; COERCE should not be constant-folded (reported by Nikodemus +;;; Siivola) +(let ((f (gensym))) + (setf (fdefinition f) (lambda (x) x)) + (let ((g (compile nil `(lambda () (coerce ',f 'function))))) + (setf (fdefinition f) (lambda (x) (1+ x))) + (assert (eq (funcall g) (fdefinition f))))) + +(let ((x (coerce '(1 11) 'vector))) + (incf (aref x 0)) + (assert (equalp x #(2 11)))) + +;;; and BIT-* too (reported by Paul F. Dietz) +(loop with v1 = #*0011 + and v2 = #*0101 + for f in '(bit-and bit-andc1 bit-andc2 bit-eqv + bit-ior bit-nand bit-nor bit-not + bit-orc1 bit-orc2 bit-xor + ) + for form = `(lambda () + (let ((v (,f ,v1 ,v2))) + (setf (aref v 0) (- 1 (aref v 0))) + (aref v 0))) + for compiled-res = (funcall (compile nil form)) + for real-res = (- 1 (aref (funcall f v1 v2) 0)) + do (assert (equal compiled-res real-res))) +(let* ((v #*0011) + (form `(lambda () + (let ((v (bit-not ,v))) + (setf (aref v 0) (- 1 (aref v 0))) + (aref v 0)))) + (compiled-res (funcall (compile nil form))) + (real-res (- 1 (aref (funcall (eval #'bit-not) v) 0)))) + (assert (equal compiled-res real-res))) + +;; bug reported on sbcl-devel by Hannu Koivisto on 2005-08-10 +(defvar *hannu-trap* nil) +(progv '(*hannu-trap*) '() + (setq *hannu-trap* t)) +(assert (not *hannu-trap*)) + +;;; bug reported on sbcl-help by Vasile Rotaru +(let* ((initial-size (expt 2 16)) + (prime-table (make-array initial-size + :element-type 'integer)) + (first-primes #(5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 + 73 + 79 83 89 97 101 103 107 109 113 127 131 137 139 149 + 151 157 163 167 173 179 181 191 193 197 199 211 223 + 227 229 233 239 241 251 257 263 269 271 277 281)) + (count 0) + (increment 2)) + + (defun largest-prime-so-far () + (aref prime-table (1- count))) + (defun add-prime (prime) + (setf (aref prime-table count) prime) (incf count)) + (defun init-table () + (map 'nil #'add-prime first-primes)) + (defun next-candidate (candidate) + (prog1 (+ candidate increment) + (ecase increment + (2 (setf increment 4)) + (4 (setf increment 2))))) + (defun prime-p (n) + (let ((sqrt-n (truncate (sqrt n)))) + (dotimes (i count) + (let ((prime (aref prime-table i))) + (when (> prime sqrt-n) + (return-from prime-p t)) + (when (zerop (mod n prime)) + (return-from prime-p nil)))) + (error "~&prime-table too small: ~A ~A~%" n + (largest-prime-so-far)))) + (defun generate-primes (required) + (do ((candidate (next-candidate (largest-prime-so-far)) + (next-candidate candidate))) + ((> candidate required)) + (when (prime-p candidate) + (add-prime candidate)))) + ;; + (init-table)) + +;;; Bug in the fopcompiler's handling of LOCALLY pre-0.9.14.8 + +(defvar *a* 1) + +(setf *a* + (locally + (declare) + 2)) + +;;; Bug in the interaction of BIND-SENTINEL and UNBIND-TO-HERE, as +;;; used by PROGV. + +(defvar *foo-1* nil) +(defvar *foo-2* nil) + +(defun foo () + (declare (optimize (debug 2))) + (let ((*foo-1* nil)) + (progv + (list '*foo-2*) + (list nil) + (write-line "foo-2")) + (write-line "foo-1")) + (write-line "foo-0")) + +(foo) + +;;; LOAD-TIME-VALUE smartness +(defun load-time-value-type-derivation-test-1 () + (ctu:compiler-derived-type (load-time-value (cons 'foo 0)))) +(defun load-time-value-type-derivation-test-2 () + (ctu:compiler-derived-type (load-time-value (+ (or *print-length* 0) 10)))) +(defun load-time-value-auto-read-only-p () + (load-time-value (random most-positive-fixnum))) +(defun load-time-value-boring () + (load-time-value (cons t t))) +(test-util:with-test (:name (load-time-value :type-smartness/cload)) + (assert (eq 'cons (load-time-value-type-derivation-test-1))) + (assert (equal '(integer 10) (load-time-value-type-derivation-test-2))) + (assert (not (ctu:find-value-cell-values #'load-time-value-auto-read-only-p))) + (assert (ctu:find-value-cell-values #'load-time-value-boring))) + +(defun regression-1.0.29.54 () + (logior (1+ most-positive-fixnum) + (load-time-value (the fixnum (eval 1)) t))) + +(test-util:with-test (:name :regression-1.0.29.54) + (assert (= (+ most-positive-fixnum 2) (regression-1.0.29.54))) + (assert (eq 42 + (funcall (compile nil + `(lambda () + (load-time-value (values 42)))))))) + +(defun mv-call-regression-1.0.43.57-foo (a c d x y) + (values a c d x y)) +(defun mv-call-regression-1.0.43.57-bar (a b c d) + (declare (number a b c d)) + (values a b c d)) +(defun mv-call-regression-1.0.43.57-quux (a sxx sxy syy) + (multiple-value-call #'mv-call-regression-1.0.43.57-foo + (mv-call-regression-1.0.43.57-bar sxx sxy sxy syy) + a)) +(test-util:with-test (:name :mv-call-regression-1.0.43.57) + ;; This used to signal a bogus argument-count error. + (mv-call-regression-1.0.43.57-quux 1s0 10s0 1s0 10s0))