Commit e0cc021a authored by Steve Losh's avatar Steve Losh Committed by Robert Goldman
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

      (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))


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

    (iterate foo (leave))
    ; ==> (block foo (return-from foo))
parent 0914f44e
......@@ -1355,6 +1355,14 @@
(finally (error "not found")))
(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")))
(deftest lambda
(iter (for i index-of-sequence "ab")
(collecting ((lambda(n) (cons 1 n)) i)))
......@@ -254,6 +254,7 @@
;;; return statements.
(defvar *block-name*)
(defvar *loop-name*)
;;; The index of standard clauses (a discrimination tree). This is a
;;; defvar so that reloading doesn't clobber existing defs (though it
......@@ -564,12 +565,15 @@ Evaluate (iterate:display-iterate-clauses) for an overview of clauses"
(*declarations* nil)
(*loop-body-wrappers* nil)
(*accum-var-alist* nil)
(*shared-bindings-alist* nil)
(*shared-bindings-alist* nil)
(*top-level?* t)
(*binding-context?* nil)
(*temps* nil)
(*temps-in-use* nil)
(*driver-info-alist* nil)
(*loop-name* (if (symbolp (car body))
(car body)
(gensym "ITERATE")))
(*block-name* (if (symbolp (car body))
(pop body)
......@@ -586,19 +590,22 @@ Evaluate (iterate:display-iterate-clauses) for an overview of clauses"
(augment init-code init)
(augment steppers step))
(prepend (default-driver-code) body)
(let ((it-bod `(block ,*block-name*
(progn ,.init-code)
(progn ,.body)
,.(if *loop-step-used?* (list *loop-step*))
(progn ,.steppers)
(go ,*loop-top*)
,.(if *loop-end-used?* (list *loop-end*))
(progn ,.final-code))
,(if (member *result-var* *bindings* :key #'car)
(let* ((it-bod `(block ,*loop-name*
(progn ,.init-code)
(progn ,.body)
,.(if *loop-step-used?* (list *loop-step*))
(progn ,.steppers)
(go ,*loop-top*)
,.(if *loop-end-used?* (list *loop-end*))
(progn ,.final-code))
,(if (member *result-var* *bindings* :key #'car)
(it-bod (if (eql *block-name* nil)
`(block nil ,it-bod)
(wrap-form *loop-body-wrappers*
`(let* ,(nreverse *bindings*)
,.(if *declarations*
......@@ -2986,7 +2993,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)"
;;; (LEAVE &optional)
(defmacro leave (&optional value)
"Exit the loop without running the epilogue code"
`(return-from ,*block-name* ,value))
`(return-from ,*loop-name* ,value))
;;; (WHILE)
(defclause (while expr)
......@@ -3015,7 +3022,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)"
(let ((var *result-var*))
(make-accum-var-binding var t :if-exists)
(return-code :body `((or (setq ,var ,expr)
(return-from ,*block-name* nil))))))
(return-from ,*loop-name* nil))))))
;;; (NEVER)
(defclause (never expr)
......@@ -3025,7 +3032,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)"
(let ((var *result-var*))
;; Do not use :type 'symbol so as be compatible with ALWAYS
(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))))))
......@@ -3036,7 +3043,7 @@ e.g. (DSETQ (VALUES (a . b) nil c) form)"
(let ((var *result-var*))
(make-accum-var-default-binding var :if-exists)
(return-code :body `((if (setq ,var ,expr)
(return-from ,*block-name* ,var))))))
(return-from ,*loop-name* ,var))))))
;;; Finders.
Supports Markdown
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