Skip to content
Snippets Groups Projects
Commit 897548b5 authored by toy's avatar toy
Browse files

From Gerd Moellmann:

o Add ABOVE keyword for loops
o Handle nil in destructuring bindings.
o Put proper blocks for named loops (and unnamed loops)
o Signal program-error for loop expansion errors
o Handle bogus INTO vars
parent bc97b10c
No related branches found
No related tags found
No related merge requests found
...@@ -49,7 +49,7 @@ ...@@ -49,7 +49,7 @@
#+cmu #+cmu
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/loop.lisp,v 1.13 2002/11/14 04:12:37 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/loop.lisp,v 1.14 2002/11/22 16:28:28 toy Exp $")
;;;; LOOP Iteration Macro ;;;; LOOP Iteration Macro
...@@ -953,7 +953,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ...@@ -953,7 +953,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
(defun loop-error (format-string &rest format-args) (defun loop-error (format-string &rest format-args)
#+(or Genera CLOE) (declare (dbg:error-reporter)) #+(or Genera CLOE) (declare (dbg:error-reporter))
#+Genera (setq format-args (copy-list format-args)) ;Don't ask. #+Genera (setq format-args (copy-list format-args)) ;Don't ask.
(error "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))) (kernel:simple-program-error "~?~%Current LOOP context:~{ ~S~}."
format-string format-args (loop-context)))
(defun loop-warn (format-string &rest format-args) (defun loop-warn (format-string &rest format-args)
...@@ -1023,9 +1024,6 @@ collected result will be returned as the value of the LOOP." ...@@ -1023,9 +1024,6 @@ collected result will be returned as the value of the LOOP."
,(nreverse *loop-body*) ,(nreverse *loop-body*)
,(nreverse *loop-after-body*) ,(nreverse *loop-after-body*)
,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*))))) ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*)))))
(do () (nil)
(setq answer `(block ,(pop *loop-names*) ,answer))
(unless *loop-names* (return nil)))
(dolist (entry *loop-bind-stack*) (dolist (entry *loop-bind-stack*)
(let ((vars (first entry)) (let ((vars (first entry))
(dcls (second entry)) (dcls (second entry))
...@@ -1042,7 +1040,10 @@ collected result will be returned as the value of the LOOP." ...@@ -1042,7 +1040,10 @@ collected result will be returned as the value of the LOOP."
(t 'let)) (t 'let))
,vars ,vars
,@(loop-build-destructuring-bindings crocks forms))))))) ,@(loop-build-destructuring-bindings crocks forms)))))))
answer))) (if *loop-names*
(do () ((null (car *loop-names*)) answer)
(setq answer `(block ,(pop *loop-names*) ,answer)))
`(block nil ,answer)))))
(defun loop-iteration-driver () (defun loop-iteration-driver ()
...@@ -1194,6 +1195,12 @@ collected result will be returned as the value of the LOOP." ...@@ -1194,6 +1195,12 @@ collected result will be returned as the value of the LOOP."
*loop-desetq-crocks* nil *loop-desetq-crocks* nil
*loop-wrappers* nil))) *loop-wrappers* nil)))
(defun loop-variable-p (name)
(do ((entry *loop-bind-stack* (cdr entry))) (nil)
(cond ((null entry)
(return nil))
((assoc name (caar entry) :test #'eq)
(return t)))))
(defun loop-make-variable (name initialization dtype &optional iteration-variable-p) (defun loop-make-variable (name initialization dtype &optional iteration-variable-p)
(cond ((null name) (cond ((null name)
...@@ -1359,6 +1366,8 @@ collected result will be returned as the value of the LOOP." ...@@ -1359,6 +1366,8 @@ collected result will be returned as the value of the LOOP."
(let ((cruft (find (the symbol name) *loop-collection-cruft* (let ((cruft (find (the symbol name) *loop-collection-cruft*
:key #'loop-collector-name))) :key #'loop-collector-name)))
(cond ((not cruft) (cond ((not cruft)
(when (and name (loop-variable-p name))
(loop-error "Variable ~S cannot be used in INTO clause" name))
(push (setq cruft (make-loop-collector (push (setq cruft (make-loop-collector
:name name :class class :name name :class class
:history (list collector) :dtype dtype)) :history (list collector) :dtype dtype))
...@@ -2098,6 +2107,7 @@ collected result will be returned as the value of the LOOP." ...@@ -2098,6 +2107,7 @@ collected result will be returned as the value of the LOOP."
(downfrom (loop-for-arithmetic :downfrom)) (downfrom (loop-for-arithmetic :downfrom))
(upfrom (loop-for-arithmetic :upfrom)) (upfrom (loop-for-arithmetic :upfrom))
(below (loop-for-arithmetic :below)) (below (loop-for-arithmetic :below))
(above (loop-for-arithmetic :above))
(to (loop-for-arithmetic :to)) (to (loop-for-arithmetic :to))
(upto (loop-for-arithmetic :upto)) (upto (loop-for-arithmetic :upto))
(by (loop-for-arithmetic :by)) (by (loop-for-arithmetic :by))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment