X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=72013e8fdae6cf76eb0eb9683d82f3772cb3dda9;hb=d007a04970c7daa85d522a1816e3ffc7a3bf1913;hp=db08b0d305f11f57ff37dc56ea5f5aedc6db10bc;hpb=bff8455d98c50672cdc29abcf1809b8823f5f117;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index db08b0d..72013e8 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -159,6 +159,183 @@ (logand a0 a10) ;; a call to prevent the other arguments from being optimized away (logand a1 a2 a3 a4 a5 a6 a7 a8 a9))) + +;;; bug 192, reported by Einar Floystad Dorum sbcl-devel 2002-08-14, +;;; fixed in sbcl-0.7.6.26: Compiling this function in 0.7.6 caused +;;; the compiler to try to constant-fold DATA-VECTOR-REF, which is OK, +;;; except that there was no non-VOP definition of DATA-VECTOR-REF, so +;;; it would fail. +(defun bug192 () + (funcall + (LAMBDA (TEXT I L ) + (LABELS ((G908 (I) + (LET ((INDEX + (OR + (IF (= I L) + NIL + (LET ((S TEXT) + (E (ELT TEXT I))) + (DECLARE (IGNORABLE S E)) + (WHEN (EQL #\a E) + (G909 (1+ I)))))))) + INDEX)) + (G909 (I) + (OR + (IF (= I L) + NIL + (LET ((S TEXT) + (E (ELT TEXT I))) + (DECLARE (IGNORABLE S E)) + (WHEN (EQL #\b E) (G910 (1+ I))))))) + (G910 (I) + (LET ((INDEX + (OR + (IF NIL + NIL + (LET ((S TEXT)) + (DECLARE (IGNORABLE S)) + (WHEN T I)))))) + INDEX))) + (G908 I))) "abcdefg" 0 (length "abcdefg"))) + +;;; bugs #65, #70, and #109, closed by APD's patch sbcl-devel 2002-08-17 +;;; +;;; This was "YA code deletion bug" whose symptom was the failure of +;;; the assertion +;;; (EQ (C::LAMBDA-TAIL-SET C::CALLER) +;;; (C::LAMBDA-TAIL-SET (C::LAMBDA-HOME C::CALLEE))) +;;; at compile time. +(defun bug65-1 (termx termy) ; from Carl Witty on submit bugs list, debian.org + (labels + ((alpha-equal-bound-term-lists (listx listy) + (or (and (null listx) (null listy)) + (and listx listy + (let ((bindings-x (bindings-of-bound-term (car listx))) + (bindings-y (bindings-of-bound-term (car listy)))) + (if (and (null bindings-x) (null bindings-y)) + (alpha-equal-terms (term-of-bound-term (car listx)) + (term-of-bound-term (car listy))) + (and (= (length bindings-x) (length bindings-y)) + (prog2 + (enter-binding-pairs (bindings-of-bound-term (car listx)) + (bindings-of-bound-term (car listy))) + (alpha-equal-terms (term-of-bound-term (car listx)) + (term-of-bound-term (car listy))) + (exit-binding-pairs (bindings-of-bound-term (car listx)) + (bindings-of-bound-term (car listy))))))) + (alpha-equal-bound-term-lists (cdr listx) (cdr listy))))) + + (alpha-equal-terms (termx termy) + (if (and (variable-p termx) + (variable-p termy)) + (equal-bindings (id-of-variable-term termx) + (id-of-variable-term termy)) + (and (equal-operators-p (operator-of-term termx) (operator-of-term termy)) + (alpha-equal-bound-term-lists (bound-terms-of-term termx) + (bound-terms-of-term termy)))))) + + (or (eq termx termy) + (and termx termy + (with-variable-invocation (alpha-equal-terms termx termy)))))) +(defun bug65-2 () ; from Bob Rogers cmucl-imp 1999-07-28 + ;; Given an FSSP alignment file named by the argument . . . + (labels ((get-fssp-char () + (get-fssp-char)) + (read-fssp-char () + (get-fssp-char))) + ;; Stub body, enough to tickle the bug. + (list (read-fssp-char) + (read-fssp-char)))) +(defun bug70 ; from David Young cmucl-help 30 Nov 2000 + (item sequence &key (test #'eql)) + (labels ((find-item (obj seq test &optional (val nil)) + (let ((item (first seq))) + (cond ((null seq) + (values nil nil)) + ((funcall test obj item) + (values val seq)) + (t + (find-item obj + (rest seq) + test + (nconc val `(,item)))))))) + (find-item item sequence test))) +(defun bug109 () ; originally from CMU CL bugs collection, reported as + ; SBCL bug by MNA 2001-06-25 + (labels + ((eff (&key trouble) + (eff) + ;; nil + ;; Uncomment and it works + )) + (eff))) + +;;; bug 192a, fixed by APD "more strict type checking" patch +;;; (sbcl-devel 2002-08-07) +(defun bug192a (x) + (declare (optimize (speed 0) (safety 3))) + ;; Even with bug 192a, this declaration was checked as an assertion. + (declare (real x)) + (+ x + (locally + ;; Because of bug 192a, this declaration was trusted without checking. + (declare (single-float x)) + (sin x)))) +(assert (null (ignore-errors (bug192a nil)))) +(multiple-value-bind (result error) (ignore-errors (bug192a 100)) + (assert (null result)) + (assert (equal (type-error-expected-type error) 'single-float))) + +;;; bug 194, fixed in part by APD "more strict type checking" patch +;;; (sbcl-devel 2002-08-07) +(progn + #+nil ; FIXME: still broken in 0.7.7.19 (after patch) + (multiple-value-bind (result error) + (ignore-errors (multiple-value-prog1 (progn (the real '(1 2 3))))) + (assert (null result)) + (assert (typep error 'type-error))) + #+nil ; FIXME: still broken in 0.7.7.19 (after patch) + (multiple-value-bind (result error) + (ignore-errors (the real '(1 2 3))) + (assert (null result)) + (assert (typep error 'type-error)))) + +;;; 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))) + (assert failure-p) + (assert (raises-error? (funcall function) program-error))) +(multiple-value-bind (function warnings-p failure-p) + (compile nil + '(lambda () + (symbol-macrolet ((*standard-input* nil)) + *standard-input*))) + (assert failure-p) + (assert (raises-error? (funcall function) program-error))) +#|| +BUG 48c, not yet fixed: +(multiple-value-bind (function warnings-p failure-p) + (compile nil '(lambda () (symbol-macrolet ((s nil)) (declare (special s)) s))) + (assert failure-p) + (assert (raises-error? (funcall function) program-error))) +||# + +;;; bug 120a: Turned out to be constraining code looking like (if foo +;;; ) where was optimized by the compiler to be the exact +;;; same block in both cases, but not turned into (PROGN FOO ). +;;; Fixed by APD in sbcl-0.7.7.2, who provided this test: +(declaim (inline dont-constrain-if-too-much)) +(defun dont-constrain-if-too-much (frame up-frame) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (if (or (not frame) t) + frame + "bar")) +(defun dont-constrain-if-too-much-aux (x y) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (if x t (if y t (dont-constrain-if-too-much x y)))) + +(assert (null (dont-constrain-if-too-much-aux nil nil))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself