Commit 4864426a authored by Steve Losh's avatar Steve Losh
Browse files

Fix control flow when the loop contains NIL blocks

Control flow clauses that return from an iterate form without executing
the epilogue code (e.g. `never` and `leave`) currently do so by
expanding into `(return-from ,*block-name*)`.  For iterate forms without
a user-provided name, the block will be named `nil`.  This causes
problems when used with other Common Lisp looping constructs such as
`dolist`:

    (iterate
      (for i :from 0 :below 10)
      (dolist (x '(5 10 15))
        (never (= i x))))
    ; => T, but should be NIL

This patch adds a separate `*loop-name*` variable that will be bound to
a gensym for `NIL`-named blocks and makes the various epilogue-skipping
code refer to that instead of `*block-name*`.  Iterate forms *without*
an explicit user-provided name will still have a separate `(block nil
...)` wrapping so users can still `(return ...)` as before.

Before (simplified):

    (iterate (leave))
    ; ==> (block nil (return-from nil))

    (iterate foo (leave))
    ; ==> (block foo (return-from nil))

After:

    (iterate (leave))
    ; ==> (block nil (block #:ITERATE123 (return-from #:ITERATE123)))

    (iterate foo (leave))
    ; ==> (block foo (return-from foo))
parent a1c47b2b
...@@ -1336,6 +1336,14 @@ ...@@ -1336,6 +1336,14 @@
(finally (error "not found"))) (finally (error "not found")))
2) 2)
(deftest nil.block.names
(iter (for x in '(1 2 3))
(dolist (y '(5 3 4))
(when (= x y)
(leave x)))
(finally (error "not found")))
3)
(deftest lambda (deftest lambda
(iter (for i index-of-sequence "ab") (iter (for i index-of-sequence "ab")
(collecting ((lambda(n) (cons 1 n)) i))) (collecting ((lambda(n) (cons 1 n)) i)))
......
...@@ -254,6 +254,7 @@ ...@@ -254,6 +254,7 @@
;;; return statements. ;;; return statements.
(defvar *block-name*) (defvar *block-name*)
(defvar *loop-name*)
;;; The index of standard clauses (a discrimination tree). This is a ;;; The index of standard clauses (a discrimination tree). This is a
;;; defvar so that reloading doesn't clobber existing defs (though it ;;; defvar so that reloading doesn't clobber existing defs (though it
...@@ -560,12 +561,15 @@ Evaluate (iterate:display-iterate-clauses) for an overview of clauses" ...@@ -560,12 +561,15 @@ Evaluate (iterate:display-iterate-clauses) for an overview of clauses"
(*declarations* nil) (*declarations* nil)
(*loop-body-wrappers* nil) (*loop-body-wrappers* nil)
(*accum-var-alist* nil) (*accum-var-alist* nil)
(*shared-bindings-alist* nil) (*shared-bindings-alist* nil)
(*top-level?* t) (*top-level?* t)
(*binding-context?* nil) (*binding-context?* nil)
(*temps* nil) (*temps* nil)
(*temps-in-use* nil) (*temps-in-use* nil)
(*driver-info-alist* nil) (*driver-info-alist* nil)
(*loop-name* (if (symbolp (car body))
(car body)
(gensym "ITERATE")))
(*block-name* (if (symbolp (car body)) (*block-name* (if (symbolp (car body))
(pop body) (pop body)
nil)) nil))
...@@ -582,19 +586,22 @@ Evaluate (iterate:display-iterate-clauses) for an overview of clauses" ...@@ -582,19 +586,22 @@ Evaluate (iterate:display-iterate-clauses) for an overview of clauses"
(augment init-code init) (augment init-code init)
(augment steppers step)) (augment steppers step))
(prepend (default-driver-code) body) (prepend (default-driver-code) body)
(let ((it-bod `(block ,*block-name* (let* ((it-bod `(block ,*loop-name*
(tagbody (tagbody
(progn ,.init-code) (progn ,.init-code)
,*loop-top* ,*loop-top*
(progn ,.body) (progn ,.body)
,.(if *loop-step-used?* (list *loop-step*)) ,.(if *loop-step-used?* (list *loop-step*))
(progn ,.steppers) (progn ,.steppers)
(go ,*loop-top*) (go ,*loop-top*)
,.(if *loop-end-used?* (list *loop-end*)) ,.(if *loop-end-used?* (list *loop-end*))
(progn ,.final-code)) (progn ,.final-code))
,(if (member *result-var* *bindings* :key #'car) ,(if (member *result-var* *bindings* :key #'car)
*result-var* *result-var*
nil)))) nil)))
(it-bod (if (eql *block-name* nil)
`(block nil ,it-bod)
it-bod)))
(wrap-form *loop-body-wrappers* (wrap-form *loop-body-wrappers*
`(let* ,(nreverse *bindings*) `(let* ,(nreverse *bindings*)
,.(if *declarations* ,.(if *declarations*
...@@ -2978,7 +2985,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)" ...@@ -2978,7 +2985,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)"
;;; (LEAVE &optional) ;;; (LEAVE &optional)
(defmacro leave (&optional value) (defmacro leave (&optional value)
"Exit the loop without running the epilogue code" "Exit the loop without running the epilogue code"
`(return-from ,*block-name* ,value)) `(return-from ,*loop-name* ,value))
;;; (WHILE) ;;; (WHILE)
(defclause (while expr) (defclause (while expr)
...@@ -3007,7 +3014,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)" ...@@ -3007,7 +3014,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)"
(let ((var *result-var*)) (let ((var *result-var*))
(make-accum-var-binding var t :if-exists) (make-accum-var-binding var t :if-exists)
(return-code :body `((or (setq ,var ,expr) (return-code :body `((or (setq ,var ,expr)
(return-from ,*block-name* nil)))))) (return-from ,*loop-name* nil))))))
;;; (NEVER) ;;; (NEVER)
(defclause (never expr) (defclause (never expr)
...@@ -3017,7 +3024,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)" ...@@ -3017,7 +3024,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)"
(let ((var *result-var*)) (let ((var *result-var*))
;; Do not use :type 'symbol so as be compatible with ALWAYS ;; Do not use :type 'symbol so as be compatible with ALWAYS
(make-accum-var-binding var t :if-exists) (make-accum-var-binding var t :if-exists)
(return-code :body `((if ,expr (return-from ,*block-name* nil)))))) (return-code :body `((if ,expr (return-from ,*loop-name* nil))))))
;;; (THEREIS) ;;; (THEREIS)
...@@ -3028,7 +3035,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)" ...@@ -3028,7 +3035,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)"
(let ((var *result-var*)) (let ((var *result-var*))
(make-accum-var-default-binding var :if-exists) (make-accum-var-default-binding var :if-exists)
(return-code :body `((if (setq ,var ,expr) (return-code :body `((if (setq ,var ,expr)
(return-from ,*block-name* ,var)))))) (return-from ,*loop-name* ,var))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Finders. ;;; Finders.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment