branch: elpa/loopy
commit 873ec3d2771d83de222832ef41d50f5b6ca6d756
Author: okamsn <28612288+oka...@users.noreply.github.com>
Commit: GitHub <nore...@github.com>
General code cleanup (#241)
- Stop using `loopy--valid-external-at-targets`.
- Instead of having a list of approved targets, use all targets that
aren't
`loopy--main-body` or `loopy--latter-body` as external and valid.
- Remove variable `loopy--valid-external-at-targets`
and function `loopy--valid-external-at-target-p`.
- Update `loopy--process-instruction` to no longer call
`loopy--valid-external-at-target-p`.
- Add test `loopy-at-set` to check that `loopy--other-vars` are handled
correctly, as they were not listed in
`loopy--valid-external-at-targets`.
- Update changelog to mention bug.
- Remove unused function `loopy--flags`.
- Remove obsolete alias `loopy--accumulation-final-updates` for
`loopy--vars-final-updates`. This has been obsolete since 2022-11.
- Fix typo in documentation string of `loopy--accumulation-places`.
- Add `loopy--other-vars` to `loopy--command-bound-p` check.
- Remove unused function `loopy--special-macro-argument-p`.
- Move body of `loopy--known-loop-name-p` into
`loopy--check-target-loop-name`.
That latter function is the only user of the first function.
Remove function `loopy--known-loop-name-p`.
- Use `loopy--normalize-position-name` in accumulation commands.
- Replace use of `loopy--normalize-symbol` in accumulation commands
and explicit accumulation constructors.
- Check validity in `loopy--normalize-symbol` instead of explicitly in
each
constructor.
- Add use for explicit version of `concat` and `union`.
- Remove commented-out lines applying default flags from Loopy and
Iter Flag processor.
- Remove unused function `loopy--ensure-valid-bindings`.
- Use `loopy--with-protected-stack` in `loopy`.
- Remove unused declarations.
- Make sure `accum-opt` SMA normalizes the position symbols of optimized
sequences.
- Fix typo in documentation string of `loopy--defiteration`.
- Fix reasoning error in `loopy-seq--make-pcase-pattern`.
- Remove unused function `loopy--car-equal-car` and alias
`loopy--car-equals-car`.
- Remove unused functions `loopy--count-while` and `loopy--count-until`.
- Move body of `loopy--convert-iteration-vars-to-other-vars`
into `loopy--destructure-for-other-command`. This was the only use of
`loopy--convert-iteration-vars-to-other-vars`. Delete
`loopy--convert-iteration-vars-to-other-vars`.
- Remove unused functions `loopy--substitute-using` and
`loopy--substitute-using-if`. They were only used by
`loopy--convert-iteration-vars-to-other-vars`, which we've now deleted.
- Replaceable uses of `loopy--extract-main-body` with
`loopy--bind-main-body`.
- Move the content of `loopy--extract-main-body` into
`loopy--bind-main-body`.
- Remove `loopy--extract-main-body`.
- Remove some old TODOs.
- Fix some typos in doc strings.
---
CHANGELOG.md | 3 +-
lisp/loopy-commands.el | 180 +++++++++++++++++-----------------------------
lisp/loopy-destructure.el | 10 ++-
lisp/loopy-instrs.el | 53 +++++---------
lisp/loopy-iter.el | 2 +-
lisp/loopy-misc.el | 58 ---------------
lisp/loopy-seq.el | 2 +-
lisp/loopy-vars.el | 80 ++++++++-------------
lisp/loopy.el | 73 +++++++++----------
tests/misc-tests.el | 2 -
tests/tests.el | 27 ++++++-
11 files changed, 175 insertions(+), 315 deletions(-)
diff --git a/CHANGELOG.md b/CHANGELOG.md
index a2dc5e85a8..927a1671e8 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -9,6 +9,7 @@ For Loopy Dash, see <https://github.com/okamsn/loopy-dash>.
### Bug Fixes
- `when` and `unless` now correctly work when aliased ([#234], [#240]).
+- Fix variable scoping when using `set` with `at` ([#241]).
### Breaking Changes
@@ -44,7 +45,7 @@ For Loopy Dash, see <https://github.com/okamsn/loopy-dash>.
[#234]: https://github.com/okamsn/loopy/issues/234
[#237]: https://github.com/okamsn/loopy/PR/237
[#240]: https://github.com/okamsn/loopy/PR/240
-
+[#241]: https://github.com/okamsn/loopy/PR/241
## 0.14.0
diff --git a/lisp/loopy-commands.el b/lisp/loopy-commands.el
index e117da3be3..1cc585b393 100644
--- a/lisp/loopy-commands.el
+++ b/lisp/loopy-commands.el
@@ -85,9 +85,7 @@
(require 'subr-x)
(require 'stream)
-(declare-function loopy--bound-p "loopy")
(declare-function loopy--process-instructions "loopy")
-(declare-function loopy--process-instruction "loopy")
(defvar loopy--in-sub-level)
;;;; Helpful Functions
@@ -275,8 +273,8 @@ BODY is one or more commands to be grouped by a `progn'
form.
This command is suitable for using as the first sub-command in an
`if' command."
(let ((loopy--in-sub-level t))
- (cl-destructuring-bind (progn-body rest)
- (loopy--extract-main-body (loopy--parse-loop-commands body))
+ (loopy--bind-main-body (progn-body rest)
+ (loopy--parse-loop-commands body)
;; Return the instructions.
(cons `(loopy--main-body (progn ,@progn-body))
rest))))
@@ -300,19 +298,16 @@ the loop literally (not even in a `progn')."
- IF-TRUE is the first sub-command of the `if' command.
- IF-FALSE are all the other sub-commands."
(let ((loopy--in-sub-level t))
- (pcase-let ((`(,if-true-main-body ,true-rest)
- (loopy--extract-main-body (loopy--parse-loop-command
if-true)))
- (`(,if-false-main-body ,false-rest)
- (loopy--extract-main-body (loopy--parse-loop-commands
if-false))))
-
- ;; Handle if we need to wrap multiple main-body expressions.
- (setq if-true-main-body (macroexp-progn if-true-main-body))
-
- ;; Return the full instruction list.
- `((loopy--main-body
- (if ,condition ,if-true-main-body ,@if-false-main-body))
- ,@true-rest
- ,@false-rest))))
+ (loopy--bind-main-body (if-true-main-body true-rest)
+ (loopy--parse-loop-command if-true)
+ (loopy--bind-main-body (if-false-main-body false-rest)
+ (loopy--parse-loop-commands if-false)
+ ;; Return the full instruction list.
+ `((loopy--main-body (if ,condition
+ ,(macroexp-progn if-true-main-body)
+ ,@if-false-main-body))
+ ,@true-rest
+ ,@false-rest)))))
;;;;;; Cond
(cl-defun loopy--parse-cond-command ((_ &rest clauses))
@@ -326,13 +321,12 @@ command are inserted into a `cond' special form."
(let ((loopy--in-sub-level t)
(cond-body nil)
(rest-instructions nil))
- (cl-loop for clause in clauses
- for (main-body rest) = (loopy--extract-main-body
- (loopy--parse-loop-commands
- (cl-rest clause)))
- do
- (push (cons (cl-first clause) main-body) cond-body)
- (push rest rest-instructions))
+ (dolist (clause clauses)
+ (loopy--bind-main-body (main-body rest)
+ (loopy--parse-loop-commands
+ (cl-rest clause))
+ (push (cons (cl-first clause) main-body) cond-body)
+ (push rest rest-instructions)))
(cons `(loopy--main-body (cond ,@(nreverse cond-body)))
(apply #'append (nreverse rest-instructions)))))
@@ -357,7 +351,7 @@ command are inserted into a `cond' special form."
;;;;; Iteration
(cl-defmacro loopy--defiteration
(name doc-string &key keywords (required-vals 1) other-vals instructions)
- "Define an interation command parser for NAME.
+ "Define an iteration command parser for NAME.
An iteration command made with this macro has the layout of
\(command-name variable-name value [values] [keys]). That is,
@@ -1781,8 +1775,8 @@ second pass of macro expansion."
plist
(if (null fn)
(signal 'loopy-accum-constructor-missing (list name plist))
- (cl-destructuring-bind (main-body other-instrs)
- (loopy--extract-main-body (funcall fn plist))
+ (loopy--bind-main-body (main-body other-instrs)
+ (funcall fn plist)
(loopy--process-instructions
`((loopy--at-instructions (,loop ,@(remq nil other-instrs)))))
(macroexp-progn main-body))))))
@@ -1794,13 +1788,11 @@ LOOP is the current loop. VAR is the accumulation
variable.
PLACE is one of `start' or `end'. VALUE is the integer by which
to increment the count (default 1)."
(loopy--check-target-loop-name loop)
+ (loopy--check-position-name place)
(cl-symbol-macrolet ((loop-map (map-elt loopy--accumulation-places loop)))
(unless (map-elt loop-map var)
(setf (map-elt loop-map var)
(list (cons 'start 0) (cons 'end 0))))
- (setq place (loopy--normalize-symbol place))
- (when (eq place 'beginning) (setq place 'start))
- (loopy--check-position-name place)
(cl-incf (map-elt (map-elt loop-map var) place) value)))
;;;;;; Commands
@@ -2036,11 +2028,7 @@ you can use in the instructions:
:explicit
(loopy--plist-bind ( :test (test (quote #'equal)) :key key :at (pos 'end))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
-
+ (setq pos (loopy--normalize-position-name pos))
(if (memq var loopy--optimized-accum-vars)
(progn
(loopy--update-accum-place-count loopy--loop-name var pos)
@@ -2049,31 +2037,27 @@ you can use in the instructions:
:var ,var :val ,val
:test ,test :key ,key :at ,pos
:opt-accum-fn
loopy--construct-accum-adjoin)))))
-
(loopy--check-accumulation-compatibility loopy--loop-name var 'list cmd)
`((loopy--accumulation-vars (,var nil))
- ,@(cond
- ((member pos '(start beginning 'start 'beginning))
- (loopy--instr-let-const* ((test-val test)
- (key-val key))
- loopy--accumulation-vars
- `((loopy--main-body
- ,(cl-once-only ((adjoin-value val))
- `(unless (loopy--member-p ,var ,adjoin-value
- :test ,test-val :key ,key-val)
- (cl-callf2 cons ,adjoin-value ,var)))))))
- ((member pos '(end nil 'end))
- (loopy--produce-adjoin-end-tracking var val :test test :key key))
- (t
- (signal 'loopy-bad-position-command-argument (list pos cmd))))
+ ,@(pcase pos
+ ('start
+ (loopy--instr-let-const* ((test-val test)
+ (key-val key))
+ loopy--accumulation-vars
+ `((loopy--main-body
+ ,(cl-once-only ((adjoin-value val))
+ `(unless (loopy--member-p ,var ,adjoin-value
+ :test ,test-val :key ,key-val)
+ (cl-callf2 cons ,adjoin-value ,var)))))))
+ ((or 'end 'nil)
+ (loopy--produce-adjoin-end-tracking var val :test test :key key))
+ (_
+ (signal 'loopy-bad-position-command-argument (list pos cmd))))
(loopy--vars-final-updates (,var . nil)))))
:implicit
(loopy--plist-bind ( :test (test (quote #'equal)) :key key :at (pos 'end))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(loopy--update-accum-place-count loopy--loop-name var pos)
`((loopy--main-body
(loopy--optimized-accum '( :cmd ,cmd :name ,name
@@ -2089,7 +2073,6 @@ you can use in the instructions:
:var var :val val
:at (pos 'end))
plist
- (setq pos (loopy--get-quoted-symbol pos))
(map-let (('start start)
('end end))
(loopy--get-accum-counts loop var 'append)
@@ -2119,10 +2102,7 @@ you can use in the instructions:
:explicit
(loopy--plist-bind (:at (pos 'end))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(if (memq var loopy--optimized-accum-vars)
(progn
(loopy--update-accum-place-count loopy--loop-name var pos)
@@ -2134,24 +2114,18 @@ you can use in the instructions:
:opt-accum-fn
loopy--construct-accum-append)))))
(loopy--check-accumulation-compatibility loopy--loop-name var 'list cmd)
`((loopy--accumulation-vars (,var nil))
- ,@(cond
- ;; TODO: Is there a better way of appending to the beginning
- ;; of a list?
- ((member pos '(start beginning 'start 'beginning))
+ ,@(pcase pos
+ ;; TODO: Is there a better way of appending to the beginning
+ ;; of a list?
;; `append' doesn't copy the last argument.
- `((loopy--main-body (setq ,var (append ,val ,var)))))
- ((member pos '(end 'end))
- (loopy--produce-multi-item-end-tracking var val))
- (t
- (signal 'loopy-bad-position-command-argument (list pos cmd))))
+ ('start `((loopy--main-body (setq ,var (append ,val ,var)))))
+ ('end (loopy--produce-multi-item-end-tracking var val))
+ (_ (signal 'loopy-bad-position-command-argument (list pos cmd))))
(loopy--vars-final-updates (,var . nil)))))
:implicit
(loopy--plist-bind (:at (pos 'end))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(loopy--update-accum-place-count loopy--loop-name var pos)
`((loopy--accumulation-vars (,var nil))
(loopy--main-body
@@ -2165,7 +2139,6 @@ you can use in the instructions:
"Construct an optimized `collect' accumulation from PLIST."
(loopy--plist-bind ( :cmd cmd :loop loop :var var :val val :at (pos 'end))
plist
- (setq pos (loopy--get-quoted-symbol pos))
`((loopy--accumulation-vars (,var nil))
,@(map-let (('start start)
('end end))
@@ -2192,10 +2165,7 @@ you can use in the instructions:
:keywords (at)
:explicit (loopy--plist-bind ( :at (pos (quote 'end)))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(if (memq var loopy--optimized-accum-vars)
(progn
(loopy--update-accum-place-count loopy--loop-name var pos)
@@ -2218,10 +2188,7 @@ you can use in the instructions:
:implicit (loopy--plist-bind ( :at (pos 'end))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(loopy--update-accum-place-count loopy--loop-name var pos)
`((loopy--main-body
(loopy--optimized-accum
@@ -2263,6 +2230,7 @@ This function is called by
`loopy--expand-optimized-accum'."
:keywords (at)
:explicit (loopy--plist-bind (:at (pos 'end))
opts
+ (setq pos (loopy--normalize-position-name pos))
(if (memq var loopy--optimized-accum-vars)
(progn
(loopy--update-accum-place-count loopy--loop-name var pos)
@@ -2288,10 +2256,7 @@ This function is called by
`loopy--expand-optimized-accum'."
(loopy--vars-final-updates (,var . nil)))))
:implicit (loopy--plist-bind (:at (pos 'end))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(loopy--update-accum-place-count loopy--loop-name var pos)
`((loopy--accumulation-vars (,var nil))
(loopy--main-body
@@ -2465,10 +2430,7 @@ EXPR is the value to bind to VAR."
:keywords (at)
:explicit (loopy--plist-bind (:at (pos 'end))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(if (memq var loopy--optimized-accum-vars)
(progn
(loopy--update-accum-place-count loopy--loop-name var pos)
@@ -2490,10 +2452,7 @@ EXPR is the value to bind to VAR."
(loopy--vars-final-updates (,var . nil)))))
:implicit (loopy--plist-bind (:at (pos 'end))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(loopy--update-accum-place-count loopy--loop-name var pos)
`((loopy--accumulation-vars (,var nil))
(loopy--main-body (loopy--optimized-accum
@@ -2559,10 +2518,7 @@ This function is used by
`loopy--expand-optimized-accum'."
:explicit
(loopy--plist-bind (:at (pos 'end) :key key :test (test (quote #'equal)))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(if (memq var loopy--optimized-accum-vars)
(progn
(loopy--update-accum-place-count loopy--loop-name var pos)
@@ -2597,10 +2553,7 @@ This function is used by
`loopy--expand-optimized-accum'."
:implicit
(loopy--plist-bind (:at (pos 'end) :key key :test (test (quote #'equal)))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(loopy--update-accum-place-count loopy--loop-name var pos)
`((loopy--accumulation-vars (,var nil))
(loopy--implicit-return ,var)
@@ -2753,6 +2706,7 @@ This function is used by `loopy--expand-optimized-accum'."
:explicit
(loopy--plist-bind (:at (pos 'end) :key key :test (test (quote #'equal)))
opts
+ (setq pos (loopy--normalize-position-name pos))
(if (memq var loopy--optimized-accum-vars)
(progn
(loopy--update-accum-place-count loopy--loop-name var pos)
@@ -2787,10 +2741,7 @@ This function is used by
`loopy--expand-optimized-accum'."
:implicit
(loopy--plist-bind (:at (pos 'end) :key key :test (test (quote #'equal)))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(loopy--update-accum-place-count loopy--loop-name var pos)
`((loopy--accumulation-vars (,var nil))
(loopy--implicit-return ,var)
@@ -2833,10 +2784,7 @@ This function is called by
`loopy--expand-optimized-accum'."
:keywords (at)
:explicit (loopy--plist-bind (:at (pos 'end))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(if (memq var loopy--optimized-accum-vars)
(progn
(loopy--update-accum-place-count loopy--loop-name var pos)
@@ -2861,10 +2809,7 @@ This function is called by
`loopy--expand-optimized-accum'."
(loopy--vars-final-updates (,var . nil)))))
:implicit (loopy--plist-bind (:at (pos 'end))
opts
- (setq pos (loopy--normalize-symbol pos))
- (when (eq pos 'beginning) (setq pos 'start))
- (unless (memq pos '(start beginning end))
- (signal 'loopy-bad-position-command-argument (list pos cmd)))
+ (setq pos (loopy--normalize-position-name pos))
(loopy--update-accum-place-count loopy--loop-name var pos)
`((loopy--accumulation-vars (,var nil))
(loopy--main-body
@@ -3067,8 +3012,13 @@ Return a list of instructions for initializing the
variables and
destructuring into them in the loop body.
A wrapper around `loopy--destructure-for-iteration-command'."
- (loopy--convert-iteration-vars-to-other-vars
- (loopy--destructure-for-iteration-command var value-expression)))
+ (cl-loop
+ for binding in (loopy--destructure-for-iteration-command var
value-expression)
+ if (eq (car binding) 'loopy--iteration-vars)
+ collect (cons 'loopy--other-vars (cdr binding))
+ else
+ collect binding
+ end))
(cl-defun loopy--parse-destructuring-accumulation-command-default
((name var val &rest args))
diff --git a/lisp/loopy-destructure.el b/lisp/loopy-destructure.el
index 1ec1b1e585..a14e175143 100644
--- a/lisp/loopy-destructure.el
+++ b/lisp/loopy-destructure.el
@@ -260,7 +260,6 @@ Type is one of `list' or `array'."
(puthash var-seq val loopy--get-var-groups-cache)
val))))
-;; TODO: Turn these into records?
(defun loopy--get-&optional-spec (form)
"Get the spec of the `&optional' variable FORM as (VAR DEFAULT SUPPLIED
LEN)."
(let ((var)
@@ -390,7 +389,7 @@ Type is one of `list' or `array'."
"Wrapper macro for compatibility with obsoletion of `pcase--flip'.
FN is the function. ARG2 is the argument to move to the second
-postion of the call to FN in the pattern."
+position of the call to FN in the pattern."
(static-if (>= emacs-major-version 30)
`(,fn _ ,arg2)
`(pcase--flip ,fn ,arg2)))
@@ -1033,10 +1032,9 @@ an error should be signaled if the pattern doesn't
match."
#'cdr
#'cadr))
v)))
- (seq-let (main-body other-instructions)
- (loopy--extract-main-body
- (loopy--parse-loop-command
- `(,name ,destr-var ,destr-val
,@args)))
+ (loopy--bind-main-body (main-body
other-instructions)
+ (loopy--parse-loop-command
+ `(,name ,destr-var ,destr-val
,@args))
;; Just push the other instructions, but
;; gather the main body expressions.
(dolist (instr other-instructions)
diff --git a/lisp/loopy-instrs.el b/lisp/loopy-instrs.el
index 3896e021c6..4631bba192 100644
--- a/lisp/loopy-instrs.el
+++ b/lisp/loopy-instrs.el
@@ -115,45 +115,24 @@ binding exists."
(reverse bindings)
:initial-value (macroexp-progn body)))
+(cl-defmacro loopy--bind-main-body ((main-exprs other-instrs) value &rest body)
+ "Bind MAIN-EXPRS and OTHER-INSTRS for those items in VALUE for BODY.
-(defun loopy--extract-main-body (instructions)
- "Extract main-body expressions from INSTRUCTIONS.
-
-This returns a list of two sub-lists:
-
-1. A list of expressions (not instructions) that are meant to be
- use in the main body of the loop.
-
-2. A list of instructions for places other than the main body.
-
-The lists will be in the order parsed (correct for insertion)."
- (let ((wrapped-main-body)
- (other-instructions))
- (dolist (instruction instructions)
- (if (eq (cl-first instruction) 'loopy--main-body)
- (push (cl-second instruction) wrapped-main-body)
- (push instruction other-instructions)))
-
- ;; Return the sub-lists.
- (list (nreverse wrapped-main-body) (nreverse other-instructions))))
-
-;; We find ourselves doing this pattern a lot.
-(cl-defmacro loopy--bind-main-body ((main-expr other-instrs) value &rest body)
- "Bind MAIN-EXPR and OTHER-INSTRS for those items in VALUE for BODY."
+MAIN-EXPR is a list of main-body expressions (not instructions).
+OTHER-INSTRS is a list of the remaining instructions."
(declare (indent 2))
- `(cl-destructuring-bind (,main-expr ,other-instrs)
- (loopy--extract-main-body ,value)
- ,@body))
-
-(defun loopy--convert-iteration-vars-to-other-vars (instructions)
- "Convert instructions for `loopy--iteration-vars' to `loopy--other-vars'.
-
-INSTRUCTIONS is a list of instructions, which don't all have to be
-for `loopy--iteration-vars'."
- (loopy--substitute-using-if
- (cl-function (lambda ((_ init)) (list 'loopy--other-vars init)))
- (lambda (x) (eq (car x) 'loopy--iteration-vars))
- instructions))
+ (let ((main-temp (gensym "main-temp"))
+ (other-temp (gensym "other-temp"))
+ (instruction (gensym "instr")))
+ `(let ((,main-temp nil)
+ (,other-temp nil))
+ (dolist (,instruction ,value)
+ (if (eq (cl-first ,instruction) 'loopy--main-body)
+ (push (cl-second ,instruction) ,main-temp)
+ (push ,instruction ,other-temp)))
+ (let ((,main-exprs (nreverse ,main-temp))
+ (,other-instrs (nreverse ,other-temp)))
+ ,@body))))
(provide 'loopy-instrs)
;;; loopy-instrs.el ends here
diff --git a/lisp/loopy-iter.el b/lisp/loopy-iter.el
index 10b941dc82..da806bcbe2 100644
--- a/lisp/loopy-iter.el
+++ b/lisp/loopy-iter.el
@@ -383,7 +383,6 @@ Returns BODY without the `%s' argument."
;;
;; 1. Flags in `loopy-default-flags'.
;; 2. Flags in the `flag' macro argument, which can undo the first group.
- ;; (mapc #'loopy--apply-flag loopy-default-flags)
(mapc #'loopy--apply-flag arg-value))
(loopy-iter--def-special-processor without
@@ -393,6 +392,7 @@ Returns BODY without the `%s' argument."
(pcase-dolist ((or `(,var ,pos) var) arg-value)
(push var loopy--optimized-accum-vars)
(when pos
+ (setq pos (loopy--normalize-position-name pos))
(loopy--update-accum-place-count loopy--loop-name var pos 1.0e+INF))))
(loopy-iter--def-special-processor wrap
diff --git a/lisp/loopy-misc.el b/lisp/loopy-misc.el
index 7a907c52e6..6dac28f8de 100644
--- a/lisp/loopy-misc.el
+++ b/lisp/loopy-misc.el
@@ -256,39 +256,6 @@
;;;; List Processing
-(defalias 'loopy--car-equals-car #'loopy--car-equal-car)
-(defun loopy--car-equal-car (a b)
- "Check whether the `car' of A equals the `car' of B."
- (equal (car a) (car b)))
-
-;; Similar to `seq--count-successive'.
-(defun loopy--count-while (pred list)
- "Count the number of items while PRED is true in LIST.
-
-This function returns 0 if PRED is immediately false.
-PRED is a function taking one argument: the item.
-
-For example, applying `cl-evenp' on (2 4 6 7) returns 3."
- ;; Could be done with `cl-position-if-not', except that
- ;; we want to return the length of the lists if
- ;; no counterexample found.
- (cl-loop for i in list
- while (funcall pred i)
- sum 1))
-
-(defun loopy--count-until (pred list)
- "Count the number of items until PRED is true in LIST.
-
-This function returns 0 if PRED is immediately true.
-PRED is a function taking one argument: the item.
-
-For example, applying `cl-oddp' on (2 4 6 7) returns 3."
- ;; Could be done with `cl-position-if', except that
- ;; we want to return the length of the lists if
- ;; no counterexample found.
- (cl-loop for i in list
- until (funcall pred i)
- sum 1))
(defmacro loopy--plist-bind (bindings plist &rest body)
"Bind values in PLIST to variables in BINDINGS, surrounding BODY.
@@ -313,31 +280,6 @@ keywords and variables are separate."
,plist
,@body))
-(cl-defun loopy--substitute-using (new seq &key test)
- "Copy SEQ, substituting elements using output of function NEW.
-
-NEW receives the element as its only argument.
-
-If given predicate function TEST, replace only elements
-satisfying TEST. This testing could also be done in NEW."
- ;; In testing, `cl-map' seems the fastest way to do this.
- (cl-map (if (listp seq) 'list 'array)
- (if test
- (lambda (x)
- (if (funcall test x)
- (funcall new x)
- x))
- (lambda (x) (funcall new x)))
- seq))
-
-(cl-defun loopy--substitute-using-if (new test seq)
- "Copy SEQ, substituting elements satisfying TEST using output of NEW.
-
-NEW receives the element as its only argument.
-
-Unlike `loopy--substitute-using', the test is required."
- (loopy--substitute-using new seq :test test))
-
;;;; Loop Tag Names
(defun loopy--produce-non-returning-exit-tag-name (&optional loop-name)
diff --git a/lisp/loopy-seq.el b/lisp/loopy-seq.el
index 7fed5fa2e1..28bc99cf56 100644
--- a/lisp/loopy-seq.el
+++ b/lisp/loopy-seq.el
@@ -77,7 +77,7 @@
(cons 'seq
(seq-map (lambda (elt)
(if (seqp elt)
- (seq--make-pcase-patterns elt)
+ (loopy-seq--make-pcase-pattern elt)
elt))
args)))
diff --git a/lisp/loopy-vars.el b/lisp/loopy-vars.el
index 1dfacc3201..891a192e56 100644
--- a/lisp/loopy-vars.el
+++ b/lisp/loopy-vars.el
@@ -456,11 +456,6 @@ Each item is of the form (FLAG . FLAG-ENABLING-FUNCTION).")
This is used to check for errors with the `at' command.")
-(defvar loopy--flags nil
- "Symbols/flags whose presence changes the behavior of `loopy'.
-
-NOTE: This functionality might change in the future.")
-
(defvar loopy--with-vars nil
"With Forms are variables explicitly created using the `with' keyword.
@@ -514,21 +509,6 @@ are `(loopy--at-instructions (LOOP-NAME INSTRUCTION
INSTRUCTION ...))'.
These instructions are removed when that loop expansion is complete.")
-(defvar loopy--valid-external-at-targets
- ;; Iteration vars currently needed for `expr'.
- ;;
- ;; TODO: We should probably change what the variables are named
- '( loopy--iteration-vars
- loopy--accumulation-vars
- loopy--vars-final-updates
- loopy--skip-used
- loopy--non-returning-exit-used
- loopy--implicit-return)
- "Valid targets for instructions pushed upwards by the `at' command.
-
-Instructions not in this list are interpreted by the current
-loop.")
-
;;;;; Loop Body Settings
(defvar loopy--pre-conditions nil
"The list of expressions that determine whether the `while' loop
starts/loops.
@@ -673,8 +653,6 @@ list much easier. When using multiple accumulation
commands, it
is important that such commands use the same variable to keep
track of the end of the list.")
-(define-obsolete-variable-alias 'loopy--accumulation-final-updates
- 'loopy--vars-final-updates "2022-11")
(defvar loopy--vars-final-updates nil
"Alist of actions to perform on variables after the loop ends.
@@ -712,7 +690,7 @@ command) create for themselves a new, local top level.")
"Where some accumulation commands are placing values.
This variable keeps track some of the accumulation variables in a
-loop and how there being used. This allows for optimizing some
+loop and how they are being used. This allows for optimizing some
kinds accumulations.
Generally, this is used with commands that produce lists, such as
@@ -792,8 +770,9 @@ This list is mainly fed to the macro
`loopy--wrap-variables-around-body'."))
(defun loopy--with-bound-p (var-name)
"Whether VAR-NAME is bound in `loopy--with-vars' or `loopy--without-vars'.
-Some iteration commands can produce more efficient code if there
-is no request for a specific initialization value."
+Some iteration commands (e.g., `reduce') will change their behavior
+depending on whether the accumulation variable is given an initial
+value."
(or (cl-loop for (var val) in loopy--with-vars
when (eq var var-name)
return (cons 'with val))
@@ -805,7 +784,10 @@ is no request for a specific initialization value."
"Whether VAR-NAME was bound by a command (and not a special macro argument).
The variable can exist in `loopy--iteration-vars',
-`loopy--accumulation-vars', or `loopy--generalized-vars'."
+`loopy--accumulation-vars', `loopy--other-vars' (for commands like
+`set'), or `loopy--generalized-vars'.
+
+Re-initializing an iteration variable is an error."
(or (cl-loop for (var val) in loopy--iteration-vars
when (eq var var-name)
return (cons 'iteration val))
@@ -814,7 +796,10 @@ The variable can exist in `loopy--iteration-vars',
return (cons 'accumulation val))
(cl-loop for (var val) in loopy--generalized-vars
when (eq var var-name)
- return (cons 'generalized val))))
+ return (cons 'generalized val))
+ (cl-loop for (var val) in loopy--other-vars
+ when (eq var var-name)
+ return (cons 'other val))))
(defun loopy--bound-p (var-name)
"Check if VAR-NAME (a symbol) is already bound for the macro.
@@ -833,35 +818,33 @@ Accumulation commands can operate on the same variable,
and we
don't want that variable to appear more than once as an implied return."
(member expression loopy--implicit-return))
-(defun loopy--special-macro-argument-p (symbol arguments-list)
- "Whether SYMBOL is a special macro argument (including aliases).
-
-Special macro arguments are listed in ARGUMENTS-LIST
-or `loopy-aliases'."
- (memq symbol (append arguments-list
- (let ((results))
- (dolist (alias loopy-aliases)
- (when (memq (cdr alias) arguments-list)
- (push (car alias) results)))
- results))))
-
-(defun loopy--known-loop-name-p (target)
- "Whether TARGET is a known loop name."
- (memq target loopy--known-loop-names))
-
(defun loopy--check-target-loop-name (target)
"Signal an error whether TARGET is not a valid loop name."
- (unless (loopy--known-loop-name-p target)
+ (unless (memq target loopy--known-loop-names)
(signal 'loopy-unknown-loop-target (list target))))
(defun loopy--check-position-name (pos)
"Error if POS is not an accepted symbol describing how to add to a sequence.
+Accepted places are the quoted symbols `start' or `end'. The place
+`beginning' is assumed to have been transformed by the function
+`loopy--normalize-position-name' into `start' before calling
+`loopy--check-position-name'.
+
For example, the `collect' command can add items at the beginning or end
of a sequence."
- (unless (member pos '(start end beginning))
+ (unless (member pos '(start end))
(signal 'loopy-bad-position-command-argument (list pos))))
+(defun loopy--normalize-position-name (pos)
+ (pcase pos
+ ((or 'beginning '(quote beginning) 'start '(quote start))
+ 'start)
+ ((or 'end '(quote end))
+ 'end)
+ (_
+ (signal 'loopy-bad-position-command-argument (list pos)))))
+
(defmacro loopy--wrap-variables-around-body (&rest body)
"Wrap variables in `loopy--variables' in `let*' bindings around BODY."
(macroexp-let* (mapcar (lambda (x) (list x nil))
@@ -874,12 +857,5 @@ of a sequence."
(funcall func)
(error "Loopy: Flag not defined: %s" flag)))
-(defun loopy--valid-external-at-target-p (target)
- "Check if variable TARGET is valid for an `at' command.
-
-This predicate checks for presence in the list
-`loopy--valid-external-at-targets'."
- (memq target loopy--valid-external-at-targets))
-
(provide 'loopy-vars)
;;; loopy-vars.el ends here
diff --git a/lisp/loopy.el b/lisp/loopy.el
index a96882c310..e6dbcd2d5e 100644
--- a/lisp/loopy.el
+++ b/lisp/loopy.el
@@ -155,10 +155,6 @@ this means that an explicit \"nil\" is always required."
(= 2 (length binding)))
(error "Invalid binding in `loopy' expansion: %s" binding)))
-(defun loopy--ensure-valid-bindings (bindings)
- "Ensure BINDINGS valid according to `loopy--validate-binding'."
- (mapc #'loopy--validate-binding bindings))
-
(defun loopy--destructure-for-with-vars (bindings)
"Destructure BINDINGS into bindings suitable for something like `let*'.
@@ -495,7 +491,6 @@ Returns BODY without the `%s' argument."
;;
;; 1. Flags in `loopy-default-flags'.
;; 2. Flags in the `flag' macro argument, which can undo the first group.
- ;; (mapc #'loopy--apply-flag loopy-default-flags)
(mapc #'loopy--apply-flag arg-value)
(seq-remove (lambda (x) (eq (car x) arg-name)) body))
@@ -519,6 +514,7 @@ Returns BODY without the `%s' argument."
(pcase-dolist ((or `(,var ,pos) var) arg-value)
(push var loopy--optimized-accum-vars)
(when pos
+ (setq pos (loopy--normalize-position-name pos))
(loopy--update-accum-place-count loopy--loop-name var pos 1.0e+INF)))
(seq-remove (lambda (x) (eq (car x) arg-name)) body))
@@ -672,9 +668,10 @@ macro `loopy' itself."
(map-let ((t external)
(nil internal))
(seq-group-by (lambda (x)
- (if (loopy--valid-external-at-target-p (cl-first
x))
- t
- nil))
+ (if (memq (cl-first x)
+ '(loopy--main-body loopy--latter-body))
+ nil
+ t))
at-instructions)
(setf (alist-get target-loop loopy--at-instructions)
(append (alist-get target-loop
@@ -923,37 +920,35 @@ see the Info node `(loopy)' distributed with this
package."
;; Body forms have the most variety.
;; An instruction is (PLACE-TO-ADD . THING-TO-ADD).
;; Things added are expanded in place.
- (unwind-protect
- (progn
- (loopy--process-instructions (loopy--parse-loop-commands body))
-
- ;; (cl-callf2 mapcar #'loopy--accum-code-expansion loopy--main-body)
- ;; Expand any uses of `loopy--optimized-accum' as if it were a macro,
- ;; using the function `loopy--expand-optimized-accum'.
- ;;
- ;; Prevent the expansion of, at the very least, `cl-block',
- ;; `cl-return-from', and `cl-return' shouldn't be expanded.
- ;;
- ;; TODO: Is there a way to more precisely only expand
- ;; `loopy--optimized-accum'?
- ;; Another option is this, but it massively slows down expansion:
- ;; (cl-loop for i being the symbols
- ;; when (eq (car-safe (symbol-function i)) 'macro)
- ;; collect (cons i nil))
- (setq loopy--main-body
- (cl-loop
- with macro-funcs = `(,@(cl-loop for i in
loopy--suppressed-macros
- collect (cons i nil))
- (loopy--optimized-accum
- . loopy--expand-optimized-accum)
- ,@macroexpand-all-environment)
- for i in loopy--main-body
- collect (macroexpand-all i macro-funcs)))
-
- ;; Process any `at' instructions from loops lower in the call list.
- (loopy--process-instructions (map-elt loopy--at-instructions
- loopy--loop-name)))
- (loopy--clean-up-stack-vars))
+ (loopy--with-protected-stack
+ (loopy--process-instructions (loopy--parse-loop-commands body))
+
+ ;; (cl-callf2 mapcar #'loopy--accum-code-expansion loopy--main-body)
+ ;; Expand any uses of `loopy--optimized-accum' as if it were a macro,
+ ;; using the function `loopy--expand-optimized-accum'.
+ ;;
+ ;; Prevent the expansion of, at the very least, `cl-block',
+ ;; `cl-return-from', and `cl-return' shouldn't be expanded.
+ ;;
+ ;; TODO: Is there a way to more precisely only expand
+ ;; `loopy--optimized-accum'?
+ ;; Another option is this, but it massively slows down expansion:
+ ;; (cl-loop for i being the symbols
+ ;; when (eq (car-safe (symbol-function i)) 'macro)
+ ;; collect (cons i nil))
+ (setq loopy--main-body
+ (cl-loop
+ with macro-funcs = `(,@(cl-loop for i in loopy--suppressed-macros
+ collect (cons i nil))
+ (loopy--optimized-accum
+ . loopy--expand-optimized-accum)
+ ,@macroexpand-all-environment)
+ for i in loopy--main-body
+ collect (macroexpand-all i macro-funcs)))
+
+ ;; Process any `at' instructions from loops lower in the call list.
+ (loopy--process-instructions (map-elt loopy--at-instructions
+ loopy--loop-name)))
;; Now that instructions processed, make sure the order-dependent lists are
;; in the correct order.
diff --git a/tests/misc-tests.el b/tests/misc-tests.el
index 8f28b998b7..c37c759996 100644
--- a/tests/misc-tests.el
+++ b/tests/misc-tests.el
@@ -1915,8 +1915,6 @@ The valid keys are:
:list nil
:convert nil)
-;; TODO: HERE!!!!!!!!!!!!! start with `pcase-tests-loopy-&map-full-form'
-
(loopy-def-pcase-test pcase-tests-loopy-&map-full-form-1
:result (list 1 2)
:val (list 'a 1 'b 2)
diff --git a/tests/tests.el b/tests/tests.el
index 77b057954a..1c0336a9e5 100644
--- a/tests/tests.el
+++ b/tests/tests.el
@@ -738,6 +738,30 @@ writing a `seq-do' method for the custom seq."
;; "for loopy"" should work, but is redundant and unneeded.
:iter-keyword (array loopy))
+(loopy-deftest loopy-at-set
+ :doc "Ensure `loopy--other-vars' are handled by `at' correctly."
+ :result 25
+ :multi-body t
+ :body [((named outer)
+ (cycle 1)
+ ;; Don't turn this into (for cycle 1) inside `loopy',
+ ;; which would break.
+ (loopy (loopy-test-escape (cycle 1))
+ (loopy-test-escape (at outer (set cat 25))))
+ (finally-return cat))
+ (outer
+ (cycle 1)
+ ;; Don't turn this into (for cycle 1) inside `loopy',
+ ;; which would break.
+ (loopy (loopy-test-escape (cycle 1))
+ (loopy-test-escape (at outer (set cat 25))))
+ (finally-return cat))]
+ :loopy t
+ ;; `loopy' should work barely.
+ :iter-bare ((cycle . cycling))
+ ;; "for loopy"" should work, but is redundant and unneeded.
+ :iter-keyword (cycle loopy))
+
(loopy-deftest loopy-at-leave
:result '(1 2 3)
:multi-body t
@@ -2057,8 +2081,6 @@ Using numbers directly will use less variables and more
efficient code."
(do . ignore)))
;;;;; Nums
-;; TODO: Names `num' and `number' aren't listed in the Org doc.
-;; They should be removed.
(loopy-deftest numbers
:result '(1 2 3 4 5)
:repeat _cmd
@@ -5313,7 +5335,6 @@ Using `start' and `end' in either order should give the
same result."
:iter-bare ((array . arraying)
(nunion . nunioning)))
-;; TODO: Fail. Fix in optimized constructor, same as others.
(loopy-deftest nunion-end-tracking-accum-opt-end-:at-start
:result '(10 8 9 7 5 6 4 1 2 3)
:body ((accum-opt (coll end))
