From: Christophe Rhodes Date: Wed, 27 Nov 2002 16:17:09 +0000 (+0000) Subject: 0.7.10.1: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=763c7b3ba0358ae9f92a06f17815b44422d53308;p=sbcl.git 0.7.10.1: Fix yet another LOOP bug ... disallow aggregate booleans with anonymous collectors ... and the converse :-) --- diff --git a/NEWS b/NEWS index 5a97db5..19c6806 100644 --- a/NEWS +++ b/NEWS @@ -1431,6 +1431,12 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9: * incremented fasl file version number, because of the SXHASH-related changes in the layout of CLOS data structures +changes in sbcl-0.7.11 relative to sbcl-0.7.10: + * fixed some bugs shown by Paul Dietz' test suite: + ** As required by ANSI, LOOP now disallows anonymous collection + clauses such as COLLECT I in conjunction with aggregate boolean + clauses such as THEREIS (= I 1); + planned incompatible changes in 0.7.x: * (not done yet, but planned:) When the profiling interface settles down, maybe in 0.7.x, maybe later, it might impact TRACE. They both diff --git a/src/code/loop.lisp b/src/code/loop.lisp index a1cec36..18f08ac 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -901,17 +901,26 @@ code to be loaded. (setq *loop-emitted-body* t) (loop-pseudo-body form)) -(defun loop-emit-final-value (form) - (push (loop-construct-return form) *loop-after-epilogue*) +(defun loop-emit-final-value (&optional (form nil form-supplied-p)) + (when form-supplied-p + (push (loop-construct-return form) *loop-after-epilogue*)) (when *loop-final-value-culprit* - (loop-warn "The LOOP clause is providing a value for the iteration,~@ - however one was already established by a ~S clause." + (loop-warn "The LOOP clause is providing a value for the iteration;~@ + however, one was already established by a ~S clause." *loop-final-value-culprit*)) (setq *loop-final-value-culprit* (car *loop-source-context*))) (defun loop-disallow-conditional (&optional kwd) (when *loop-inside-conditional* (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) + +(defun loop-disallow-anonymous-collectors () + (when (find-if-not 'loop-collector-name *loop-collection-cruft*) + (loop-error "This LOOP clause is not permitted with anonymous collectors."))) + +(defun loop-disallow-aggregate-booleans () + (when (loop-tmember *loop-final-value-culprit* '(always never thereis)) + (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans."))) ;;;; loop types @@ -1153,6 +1162,8 @@ code to be loaded. (loop-pop-source)))) (when (not (symbolp name)) (loop-error "The value accumulation recipient name, ~S, is not a symbol." name)) + (unless name + (loop-disallow-aggregate-booleans)) (unless dtype (setq dtype (or (loop-optional-type) default-type))) (let ((cruft (find (the symbol name) *loop-collection-cruft* @@ -1249,6 +1260,7 @@ code to be loaded. (defun loop-do-always (restrictive negate) (let ((form (loop-get-form))) (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) (loop-emit-body `(,(if negate 'when 'unless) ,form ,(loop-construct-return nil))) (loop-emit-final-value t))) @@ -1258,8 +1270,10 @@ code to be loaded. ;;; Under ANSI this is not permitted to appear under conditionalization. (defun loop-do-thereis (restrictive) (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) + (loop-emit-final-value) (loop-emit-body `(when (setq ,(loop-when-it-var) ,(loop-get-form)) - ,(loop-construct-return *loop-when-it-var*)))) + ,(loop-construct-return *loop-when-it-var*)))) (defun loop-do-while (negate kwd &aux (form (loop-get-form))) (loop-disallow-conditional kwd) diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp index 067f7ef..7e6d4ce 100644 --- a/tests/loop.pure.lisp +++ b/tests/loop.pure.lisp @@ -115,3 +115,35 @@ (assert (= (loop with (nil a) = '(1 2) return a) 2)) (assert (= (loop with (a . nil) = '(1 2) return a) 1)) (assert (equal (loop with (nil . a) = '(1 2) return a) '(2))) + +(multiple-value-bind (result error) + (ignore-errors + (loop for i in '(1 2 3) collect i always (< i 4))) + (assert (null result)) + (assert (typep error 'program-error))) +(assert (equal + (loop for i in '(1 2 3) collect i into foo always (< i 4) + finally (return foo)) + '(1 2 3))) +(assert (equal + (loop for i in '(1 2 3) collect i into foo always (= i 4) + finally (return foo)) + nil)) +(multiple-value-bind (result error) + (ignore-errors + (loop for i in '(1 2 3) always (< i 4) collect i)) + (assert (null result)) + (assert (typep error 'program-error))) +(assert (equal + (loop for i in '(1 2 3) always (< i 4) collect i into foo + finally (return foo)) + '(1 2 3))) +(assert (equal + (loop for i in '(1 2 3) always (= i 4) collect i into foo + finally (return foo)) + nil)) +(multiple-value-bind (result error) + (ignore-errors + (loop for i in '(1 2 3) thereis (= i 3) collect i)) + (assert (null result)) + (assert (typep error 'program-error))) \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index 773ac9d..6f57564 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.10" +"0.7.10.1"