* bug#57907: 29.0.50; Using keywords with cl-loop
@ 2022-09-18 12:03 Philip Kaludercic
2022-09-18 12:20 ` Lars Ingebrigtsen
` (2 more replies)
0 siblings, 3 replies; 13+ messages in thread
From: Philip Kaludercic @ 2022-09-18 12:03 UTC (permalink / raw)
To: 57907
In Common Lisp the following to are equivalent
(loop :repeat 5 :collect t)
and
(loop repeat 5 collect t)
as keywords are shared among all packages. In cl-lib, the former
variant is now allowed, since :repeat is not recognised as a cl-loop
keywords.
It seems to me that it would be nice to support these too, as keywords
have the superficial advantage of being a bit more readable due to their
additional highlighting, and for some people it makes the macro a bit
more comfortable to use since it doesn't have to feel like you are using
a whole new language, but instead these are just keyword arguments to an
unusual function call.
In GNU Emacs 29.0.50 (build 3, x86_64-pc-linux-gnu, GTK+ Version
3.24.34, cairo version 1.17.6) of 2022-09-17 built on rhea
Repository revision: bd77f60f949eab3453de76f130aa4a21ef9b1cc6
Repository branch: local
System Description: Fedora Linux 36 (Workstation Edition)
Configured using:
'configure --with-native-compilation --with-pgtk --with-imagemagick'
Configured features:
CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GSETTINGS HARFBUZZ IMAGEMAGICK
JPEG JSON LIBSELINUX LIBSYSTEMD LIBXML2 MODULES NATIVE_COMP NOTIFY
INOTIFY PDUMPER PGTK PNG RSVG SECCOMP SOUND SQLITE3 THREADS TIFF
TOOLKIT_SCROLL_BARS XIM GTK3 ZLIB
Important settings:
value of $LANG: en_US.UTF-8
value of $XMODIFIERS: @im=ibus
locale-coding-system: utf-8-unix
Major mode: ELisp/l
Minor modes in effect:
rcirc-track-minor-mode: t
global-git-commit-mode: t
magit-auto-revert-mode: t
auto-revert-mode: t
shell-dirtrack-mode: t
TeX-PDF-mode: t
bug-reference-prog-mode: t
outline-minor-mode: t
flymake-mode: t
yas-minor-mode: t
flyspell-mode: t
repeat-mode: t
display-battery-mode: t
display-time-mode: t
diff-hl-flydiff-mode: t
diff-hl-mode: t
winner-mode: t
windmove-mode: t
corfu-history-mode: t
corfu-mode: t
vertico-multiform-mode: t
vertico-mode: t
electric-pair-mode: t
recentf-mode: t
save-place-mode: t
savehist-mode: t
pixel-scroll-precision-mode: t
pixel-scroll-mode: t
xterm-mouse-mode: t
tooltip-mode: t
global-eldoc-mode: t
eldoc-mode: t
show-paren-mode: t
electric-indent-mode: t
mouse-wheel-mode: t
tab-bar-mode: t
file-name-shadow-mode: t
context-menu-mode: t
global-font-lock-mode: t
font-lock-mode: t
line-number-mode: t
transient-mark-mode: t
auto-composition-mode: t
auto-encryption-mode: t
auto-compression-mode: t
Load-path shadows:
/home/philip/.config/emacs/site-lisp/ef-themes/ef-winter-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-winter-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-themes hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-themes
/home/philip/.config/emacs/site-lisp/ef-themes/ef-summer-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-summer-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-spring-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-spring-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-night-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-night-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-light-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-light-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-duo-light-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-duo-light-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-duo-dark-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-duo-dark-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-deuteranopia-light-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-deuteranopia-light-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-deuteranopia-dark-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-deuteranopia-dark-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-day-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-day-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-dark-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-dark-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-autumn-theme hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-autumn-theme
/home/philip/.config/emacs/site-lisp/ef-themes/ef-themes-autoloads hides /home/philip/.config/emacs/elpa/ef-themes-0.5.0/ef-themes-autoloads
/home/philip/.config/emacs/elpa/transient-0.3.7/transient hides /home/philip/Source/emacs/lisp/transient
/home/philip/.config/emacs/elpa/xref-1.5.1/xref hides /home/philip/Source/emacs/lisp/progmodes/xref
Features:
(shadow emacsbug man gnus-dup sp-tutor waffel doc-view image-mode exif
ps-print ps-print-loaddefs lpr ox-odt rng-loc rng-uri rng-parse
rng-match rng-pttrn nxml-parse nxml-ns nxml-enc xmltok nxml-util
ox-latex ox-icalendar org-agenda org-refile ox-html table ox-ascii
ox-publish ox org-element avl-tree hl-line rcirc nnagent nnml jka-compr
tramp-sh display-line-numbers two-column eudc-capf eudc eudc-vars delsel
rect flymake-cc help-at-pt mhtml-mode css-mode js cc-mode cc-fonts
cc-guess cc-menus cc-cmds cc-styles cc-align cc-engine cc-vars cc-defs
sgml-mode facemenu flow-fill nnselect gnus-search eieio-opt speedbar
ezimage dframe make-mode embark tar-mode goto-addr timezone toolbar-x
reporter desktop frameset context plain-tex latex latex-flymake
tex-ispell tex-style compat-macs consult-icomplete icomplete forms
forms-mode diff-hl-show-hunk diff-hl-inline-popup diff-hl-dired
ef-winter-theme ef-summer-theme ef-spring-theme ef-night-theme
ef-light-theme ef-duo-light-theme ef-duo-dark-theme
ef-deuteranopia-light-theme ef-deuteranopia-dark-theme ef-day-theme
ef-dark-theme ef-autumn-theme ef-themes python eglot array jsonrpc
geiser-mode geiser-xref geiser-compile geiser-debug geiser-guile
geiser-chibi info-look geiser geiser-repl geiser-image geiser-capf
geiser-doc geiser-menu geiser-edit geiser-completion geiser-autodoc
geiser-eval geiser-connection tq geiser-syntax scheme geiser-log
geiser-popup view go-mode find-file ido git-rebase let-alist benchmark
eww url-queue mm-url markdown-mode slime-repl-tests slime-tests
inferior-slime slime-indentation slime-cl-indent cl-indent
slime-trace-dialog slime-fontifying-fu slime-package-fu slime-references
slime-compiler-notes-tree slime-scratch slime-presentations bridge
slime-macrostep macrostep slime-mdot-fu slime-enclosing-context
slime-fuzzy slime-fancy-trace slime-fancy-inspector slime-c-p-c
slime-autodoc slime-editing-commands slime-repl elp slime-parse grep
slime gud apropos etags fileloop arc-mode archive-mode hyperspec
which-key term ehelp eshell esh-cmd generator esh-ext esh-opt esh-proc
esh-io esh-arg esh-module esh-groups esh-util cl org ob ob-tangle ob-ref
ob-lob ob-table ob-exp org-macro org-footnote org-src ob-comint
org-pcomplete org-list org-faces org-entities org-version ob-emacs-lisp
ob-core ob-eval org-table oc-basic bibtex ol org-keys oc org-compat
org-macs org-loaddefs cal-menu calendar cal-loaddefs ert-x ert advice
magit-patch magit-subtree magit-gitignore magit-ediff ediff ediff-merg
ediff-mult ediff-wind ediff-diff ediff-help ediff-init ediff-util
magit-extras face-remap magit-bookmark magit-submodule magit-obsolete
magit-blame magit-stash magit-reflog magit-bisect magit-push magit-pull
magit-fetch magit-clone magit-remote magit-commit magit-sequence
magit-notes magit-worktree magit-tag magit-merge magit-branch
magit-reset magit-files magit-refs magit-status magit magit-repos
magit-apply magit-wip magit-log which-func imenu magit-diff git-commit
magit-core magit-autorevert autorevert filenotify magit-margin
magit-transient magit-process with-editor server magit-mode transient
edmacro magit-git magit-section magit-utils dash tabify debbugs-gnu
debbugs-compat debbugs soap-client rng-xsd rng-dt rng-util xsd-regexp
nndoc mm-archive url-http url-gw url-cache url-auth sh-script smie
executable tramp-archive tramp-gvfs tramp-cache zeroconf tramp
tramp-loaddefs trampver tramp-integration files-x tramp-compat ls-lisp
dictionary dictionary-connection ffap gnus-fun shell pcomplete shortdoc
cus-edit cus-start cus-dep vertico-buffer finder avy log-edit
consult-vertico consult compat-28 kmacro bookmark pp add-log vc-annotate
mailalias smtpmail autocrypt-message ecomplete ietf-drums-date sort
smiley gnus-cite mail-extr textsec uni-scripts idna-mapping
ucs-normalize uni-confusable textsec-check qp gnus-async gnus-bcklg
gnus-ml disp-table autocrypt-gnus autocrypt nndraft nnmh utf-7 nnfolder
epa-file network-stream nsm gnus-agent gnus-srvr gnus-score score-mode
nnvirtual gnus-msg gnus-art mm-uu mml2015 mm-view mml-smime smime gnutls
dig nntp gnus-cache gnus-sum shr pixel-fill kinsoku url-file svg dom
gnus-group gnus-undo gnus-start gnus-dbus gnus-cloud nnimap nnmail
mail-source utf7 nnoo parse-time iso8601 gnus-spec gnus-int gnus-range
message yank-media puny rfc822 mml mml-sec epa derived epg rfc6068
epg-config mm-decode mm-bodies mm-encode mail-parse rfc2231 mailabbrev
gmm-utils mailheader gnus-win char-fold misearch multi-isearch
flymake-proselint xdg tex-info tex crm texmathp texinfo texinfo-loaddefs
mule-util wombat-theme whiteboard-theme wheatgrass-theme
tsdh-light-theme tango-theme tango-dark-theme modus-vivendi-theme
misterioso-theme manoj-dark-theme light-blue-theme leuven-theme
leuven-dark-theme dichromacy-theme deeper-blue-theme smerge-mode
dired-aux gnus-dired copyright time-stamp pulse color xref cl-print
edebug debug backtrace vc-backup vc-fossil vc-hg vc-bzr vc-src vc-sccs
vc-svn vc-cvs vc-rcs whitespace buffer-env compat bug-reference vc-git
find-func tsdh-dark-theme vertico-directory orderless vertico-flat
noutline outline checkdoc flymake-proc flymake yasnippet-snippets
yasnippet flyspell ispell comp comp-cstr warnings icons cl-extra
auth-source-pass repeat project format-spec battery dbus xml
shell-command+ thingatpt dired-x dired dired-loaddefs rx time sendmail
rfc2047 rfc2045 ietf-drums gnus nnheader gnus-util time-date mail-utils
range mm-util mail-prsvr finder-inf diff-hl-flydiff diff diff-hl
log-view pcvs-util vc-dir ewoc vc vc-dispatcher diff-mode easy-mmode
hippie-exp winner windmove corfu-history corfu vertico-multiform vertico
elec-pair recentf tree-widget wid-edit saveplace savehist pixel-scroll
cua-base xt-mouse modus-operandi-theme modus-themes pcase cus-load setup
site-lisp auto-site compile text-property-search comint ansi-color
autoload loaddefs-gen lisp-mnt auctex-autoloads tex-site
buffer-env-autoloads consult-autoloads compat-autoloads corfu-autoloads
crdt-autoloads debbugs-autoloads diff-hl-autoloads ef-themes-autoloads
embark-autoloads focus-autoloads geiser-chibi-autoloads
geiser-guile-autoloads geiser-impl help-fns radix-tree help-mode
geiser-custom geiser-base ring geiser-autoloads magit-autoloads
slime-autoloads transient-autoloads vc-fossil-autoloads
vertico-autoloads which-key-autoloads info xref-autoloads package
browse-url url url-proxy url-privacy url-expand url-methods url-history
url-cookie generate-lisp-file url-domsuf url-util mailcap url-handlers
url-parse auth-source cl-seq eieio eieio-core cl-macs password-cache
json subr-x map byte-opt gv bytecomp byte-compile cconv url-vars
cl-loaddefs cl-lib rmc iso-transl tooltip eldoc paren electric uniquify
ediff-hook vc-hooks lisp-float-type elisp-mode mwheel term/pgtk-win
pgtk-win term/common-win pgtk-dnd tool-bar dnd fontset image regexp-opt
fringe tabulated-list replace newcomment text-mode lisp-mode prog-mode
register page tab-bar menu-bar rfn-eshadow isearch easymenu timer select
scroll-bar mouse jit-lock font-lock syntax font-core term/tty-colors
frame minibuffer nadvice seq simple cl-generic indonesian philippine
cham georgian utf-8-lang misc-lang vietnamese tibetan thai tai-viet lao
korean japanese eucjp-ms cp51932 hebrew greek romanian slovak czech
european ethiopic indian cyrillic chinese composite emoji-zwj charscript
charprop case-table epa-hook jka-cmpr-hook help abbrev obarray oclosure
cl-preloaded button loaddefs faces cus-face macroexp files window
text-properties overlay sha1 md5 base64 format env code-pages mule
custom widget keymap hashtable-print-readable backquote threads dbusbind
inotify dynamic-setting system-font-setting font-render-setting cairo
gtk pgtk multi-tty make-network-process native-compile emacs)
Memory information:
((conses 16 2923673 345540)
(symbols 48 78147 110)
(strings 32 419441 127926)
(string-bytes 1 13928223)
(vectors 16 217707)
(vector-slots 8 4076811 237970)
(floats 8 4366 992)
(intervals 56 179610 6264)
(buffers 1000 189))
^ permalink raw reply [flat|nested] 13+ messages in thread* bug#57907: 29.0.50; Using keywords with cl-loop 2022-09-18 12:03 bug#57907: 29.0.50; Using keywords with cl-loop Philip Kaludercic @ 2022-09-18 12:20 ` Lars Ingebrigtsen 2022-09-18 12:28 ` Philip Kaludercic [not found] ` <handler.57907.B.166350264228653.ack@debbugs.gnu.org> 2022-09-18 12:38 ` bug#57907: 29.0.50; Using keywords with cl-loop Gerd Möllmann 2 siblings, 1 reply; 13+ messages in thread From: Lars Ingebrigtsen @ 2022-09-18 12:20 UTC (permalink / raw) To: Philip Kaludercic; +Cc: 57907 Philip Kaludercic <philipk@posteo.net> writes: > It seems to me that it would be nice to support these too, as keywords > have the superficial advantage of being a bit more readable due to their > additional highlighting, and for some people it makes the macro a bit > more comfortable to use since it doesn't have to feel like you are using > a whole new language, but instead these are just keyword arguments to an > unusual function call. I think it'd just lead to even more confusion, since they aren't really keyword arguments. Because then you'd have to say (loop ... :do (progn (foo) (bar))) But you can say (loop ... do (foo) (bar)) ^ permalink raw reply [flat|nested] 13+ messages in thread
* bug#57907: 29.0.50; Using keywords with cl-loop 2022-09-18 12:20 ` Lars Ingebrigtsen @ 2022-09-18 12:28 ` Philip Kaludercic 2022-09-18 12:37 ` Lars Ingebrigtsen 0 siblings, 1 reply; 13+ messages in thread From: Philip Kaludercic @ 2022-09-18 12:28 UTC (permalink / raw) To: Lars Ingebrigtsen; +Cc: 57907 Lars Ingebrigtsen <larsi@gnus.org> writes: > Philip Kaludercic <philipk@posteo.net> writes: > >> It seems to me that it would be nice to support these too, as keywords >> have the superficial advantage of being a bit more readable due to their >> additional highlighting, and for some people it makes the macro a bit >> more comfortable to use since it doesn't have to feel like you are using >> a whole new language, but instead these are just keyword arguments to an >> unusual function call. > > I think it'd just lead to even more confusion, since they aren't really > keyword arguments. Because then you'd have to say > > (loop ... > :do (progn (foo) (bar))) > > But you can say > > (loop ... > do (foo) > (bar)) Why would this be necessary? I am not saying that `cl-loop' should be converted into a proper keyword-macro, just that each `:foo' in a loop-keyword position ought to be interpreted as `foo'. ^ permalink raw reply [flat|nested] 13+ messages in thread
* bug#57907: 29.0.50; Using keywords with cl-loop 2022-09-18 12:28 ` Philip Kaludercic @ 2022-09-18 12:37 ` Lars Ingebrigtsen 2022-09-18 12:46 ` Philip Kaludercic 0 siblings, 1 reply; 13+ messages in thread From: Lars Ingebrigtsen @ 2022-09-18 12:37 UTC (permalink / raw) To: Philip Kaludercic; +Cc: 57907 Philip Kaludercic <philipk@posteo.net> writes: > Why would this be necessary? I am not saying that `cl-loop' should be > converted into a proper keyword-macro, just that each `:foo' in a > loop-keyword position ought to be interpreted as `foo'. You said that cl-loop would be more comfortable if "it doesn't have to feel like you are using a whole new language, but instead these are just keyword arguments to an unusual function call". I'm pointing out that this is wrong -- they are not keyword arguments, and if you think that they are, you're going to be using it wrong. In other words, it is a whole new language, not just keyword arguments. ^ permalink raw reply [flat|nested] 13+ messages in thread
* bug#57907: 29.0.50; Using keywords with cl-loop 2022-09-18 12:37 ` Lars Ingebrigtsen @ 2022-09-18 12:46 ` Philip Kaludercic 2022-09-19 8:06 ` Lars Ingebrigtsen 0 siblings, 1 reply; 13+ messages in thread From: Philip Kaludercic @ 2022-09-18 12:46 UTC (permalink / raw) To: Lars Ingebrigtsen; +Cc: 57907 Lars Ingebrigtsen <larsi@gnus.org> writes: > Philip Kaludercic <philipk@posteo.net> writes: > >> Why would this be necessary? I am not saying that `cl-loop' should be >> converted into a proper keyword-macro, just that each `:foo' in a >> loop-keyword position ought to be interpreted as `foo'. > > You said that cl-loop would be more comfortable if "it doesn't have to > feel like you are using a whole new language, but instead these are > just keyword arguments to an unusual function call". > > I'm pointing out that this is wrong -- they are not keyword arguments, > and if you think that they are, you're going to be using it wrong. > > In other words, it is a whole new language, not just keyword arguments. I phrased that clumsily -- while it is a new language, it doesn't always have to feel like one. E.g. the repeat-collect example I gave before. If you *can* use keywords, you *can* make some cl-loop invocations appear to be a macro or a function call with keyword-arguments. But of course this wouldn't be the case, as the macro should stay backwards compatible. ^ permalink raw reply [flat|nested] 13+ messages in thread
* bug#57907: 29.0.50; Using keywords with cl-loop 2022-09-18 12:46 ` Philip Kaludercic @ 2022-09-19 8:06 ` Lars Ingebrigtsen 2022-09-19 10:16 ` Philip Kaludercic 0 siblings, 1 reply; 13+ messages in thread From: Lars Ingebrigtsen @ 2022-09-19 8:06 UTC (permalink / raw) To: Philip Kaludercic; +Cc: 57907 Philip Kaludercic <philipk@posteo.net> writes: > I phrased that clumsily -- while it is a new language, it doesn't always > have to feel like one. And I'm saying that that feeling is a misleading feeling -- we're leading the users down the garden path. > E.g. the repeat-collect example I gave before. > If you *can* use keywords, you *can* make some cl-loop invocations > appear to be a macro or a function call with keyword-arguments. > > But of course this wouldn't be the case, as the macro should stay > backwards compatible. I understand that. But it means that the stated rationale for this change does the users a disservice. So I'm against extending cl-loop in this way. Gerd has explained why it works this way in Common Lisp (because CL doesn't have any other choice because that's the way the language works), but we should not shoehorn in this accident into Emacs, too. ^ permalink raw reply [flat|nested] 13+ messages in thread
* bug#57907: 29.0.50; Using keywords with cl-loop 2022-09-19 8:06 ` Lars Ingebrigtsen @ 2022-09-19 10:16 ` Philip Kaludercic 2022-09-19 12:52 ` Lars Ingebrigtsen 0 siblings, 1 reply; 13+ messages in thread From: Philip Kaludercic @ 2022-09-19 10:16 UTC (permalink / raw) To: Lars Ingebrigtsen; +Cc: 57907-done Lars Ingebrigtsen <larsi@gnus.org> writes: > Philip Kaludercic <philipk@posteo.net> writes: > >> I phrased that clumsily -- while it is a new language, it doesn't always >> have to feel like one. > > And I'm saying that that feeling is a misleading feeling -- we're > leading the users down the garden path. > >> E.g. the repeat-collect example I gave before. >> If you *can* use keywords, you *can* make some cl-loop invocations >> appear to be a macro or a function call with keyword-arguments. >> >> But of course this wouldn't be the case, as the macro should stay >> backwards compatible. > > I understand that. But it means that the stated rationale for this > change does the users a disservice. > > So I'm against extending cl-loop in this way. Gerd has explained why > it works this way in Common Lisp (because CL doesn't have any other > choice because that's the way the language works), but we should not > shoehorn in this accident into Emacs, too. While it might have had been an accident initially, I don't think it has to be considered such. As I said, there are reasons like syntax highlighting for preferring keyword-symbols. But if you don't think this is a good idea, I'll go ahead and close the issue. ^ permalink raw reply [flat|nested] 13+ messages in thread
* bug#57907: 29.0.50; Using keywords with cl-loop 2022-09-19 10:16 ` Philip Kaludercic @ 2022-09-19 12:52 ` Lars Ingebrigtsen 0 siblings, 0 replies; 13+ messages in thread From: Lars Ingebrigtsen @ 2022-09-19 12:52 UTC (permalink / raw) To: Philip Kaludercic; +Cc: 57907-done Philip Kaludercic <philipk@posteo.net> writes: > While it might have had been an accident initially, I don't think it has > to be considered such. As I said, there are reasons like syntax > highlighting for preferring keyword-symbols. But if you don't think > this is a good idea, I'll go ahead and close the issue. I think we could probably get better syntax highlighting without keywords if somebody took that on. My general lack of enthusiasm for this is that this offers syntactical variation without any practical advantages either way. This means that some people will choose one syntax, and others will choose the other, and we get code churn when people "correct" the code from one to another. ^ permalink raw reply [flat|nested] 13+ messages in thread
[parent not found: <handler.57907.B.166350264228653.ack@debbugs.gnu.org>]
* bug#57907: Acknowledgement (29.0.50; Using keywords with cl-loop) [not found] ` <handler.57907.B.166350264228653.ack@debbugs.gnu.org> @ 2022-09-18 12:26 ` Philip Kaludercic 2022-09-18 20:12 ` Philip Kaludercic 0 siblings, 1 reply; 13+ messages in thread From: Philip Kaludercic @ 2022-09-18 12:26 UTC (permalink / raw) To: 57907 [-- Attachment #1: Type: text/plain, Size: 127 bytes --] It seems it isn't that difficult to do this (though the patch is longer than it ought to be because of indentation changes): [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #2: 0001-Have-cl-loop-handle-keyword-symbols.patch --] [-- Type: text/x-patch, Size: 47393 bytes --] From d98dc3e0905d41305061708a601d63659fa7ce81 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic <philipk@posteo.net> Date: Sun, 18 Sep 2022 14:25:29 +0200 Subject: [PATCH] Have 'cl-loop' handle keyword symbols * lisp/emacs-lisp/cl-macs.el (cl-loop): Add keywords to the edebug spec. (cl--parse-loop-clause): Handle keyword symbols by converting them into regular symbols. --- lisp/emacs-lisp/cl-macs.el | 938 +++++++++++++++++++------------------ 1 file changed, 474 insertions(+), 464 deletions(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index f8fdc50251..2df91701e2 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -926,6 +926,9 @@ cl-loop do EXPRS... [finally] return EXPR +All cl-loop keywords may also be written using keyword +symbols (e.g. `:for' is the same as `for'). + For more details, see Info node `(cl)Loop Facility'. \(fn CLAUSE...)" @@ -933,22 +936,24 @@ cl-loop ;; These are usually followed by a symbol, but it can ;; actually be any destructuring-bind pattern, which ;; would erroneously match `form'. - [[&or "for" "as" "with" "and"] sexp] + [[&or "for" ":for" "as" ":as" "with" ":with" "and" ":and"] sexp] ;; These are followed by expressions which could ;; erroneously match `symbolp'. - [[&or "from" "upfrom" "downfrom" "to" "upto" "downto" - "above" "below" "by" "in" "on" "=" "across" - "repeat" "while" "until" "always" "never" - "thereis" "collect" "append" "nconc" "sum" - "count" "maximize" "minimize" - "if" "when" "unless" - "return"] + [[&or "from" ":from" "upfrom" ":upfrom" "downfrom" ":downfrom" "to" + ":to" "upto" ":upto" "downto" ":downto" "above" ":above" + "below" ":below" "by" ":by" "in" ":in" "on" ":on" "=" ":=" + "across" ":across" "repeat" ":repeat" "while" ":while" "until" + ":until" "always" ":always" "never" ":never" "thereis" + ":thereis" "collect" ":collect" "append" ":append" "nconc" + ":nconc" "sum" ":sum" "count" ":count" "maximize" ":maximize" + "minimize" ":minimize" "if" ":if" "when" ":when" "unless" + ":unless" "return" ":return" ] form] ["using" (symbolp symbolp)] ;; Simple default, which covers 99% of the cases. symbolp form))) (if (not (memq t (mapcar #'symbolp - (delq nil (delq t (cl-copy-list loop-args)))))) + (delq nil (remq t loop-args))))) `(cl-block nil (while t ,@loop-args)) (let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil) (cl--loop-body nil) (cl--loop-steps nil) @@ -1184,465 +1189,470 @@ cl--push-clause-loop-body ;; '(&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) (defun cl--parse-loop-clause () ; uses loop-* - (let ((word (pop cl--loop-args)) - (hash-types '(hash-key hash-keys hash-value hash-values)) - (key-types '(key-code key-codes key-seq key-seqs - key-binding key-bindings))) - (cond + (cl-flet ((next () + (let ((word (pop cl--loop-args))) + (if (keywordp word) + (intern (substring (symbol-name word) 1)) + word)))) + (let ((word (next)) + (hash-types '(hash-key hash-keys hash-value hash-values)) + (key-types '(key-code key-codes key-seq key-seqs + key-binding key-bindings))) + (cond + + ((null cl--loop-args) + (error "Malformed `cl-loop' macro")) + + ((eq word 'named) + (setq cl--loop-name (next))) + + ((eq word 'initially) + (if (memq (car cl--loop-args) '(do doing)) (next)) + (or (consp (car cl--loop-args)) + (error "Syntax error on `initially' clause")) + (while (consp (car cl--loop-args)) + (push (next) cl--loop-initially))) + + ((eq word 'finally) + (if (eq (car cl--loop-args) 'return) + (setq cl--loop-result-explicit + (or (cl--pop2 cl--loop-args) '(quote nil))) + (if (memq (car cl--loop-args) '(do doing)) (next)) + (or (consp (car cl--loop-args)) + (error "Syntax error on `finally' clause")) + (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) + (setq cl--loop-result-explicit + (or (nth 1 (next)) '(quote nil))) + (while (consp (car cl--loop-args)) + (push (next) cl--loop-finally))))) + + ((memq word '(for as)) + (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) + (ands nil)) + (while + ;; Use `cl-gensym' rather than `make-symbol'. It's important that + ;; (not (eq (symbol-name var1) (symbol-name var2))) because + ;; these vars get added to the macro-environment. + (let ((var (or (next) (cl-gensym "--cl-var--")))) + (setq word (next)) + (if (eq word 'being) (setq word (next))) + (if (memq word '(the each)) (setq word (next))) + (if (memq word '(buffer buffers)) + (setq word 'in + cl--loop-args (cons '(buffer-list) cl--loop-args))) + (cond - ((null cl--loop-args) - (error "Malformed `cl-loop' macro")) - - ((eq word 'named) - (setq cl--loop-name (pop cl--loop-args))) - - ((eq word 'initially) - (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) - (or (consp (car cl--loop-args)) - (error "Syntax error on `initially' clause")) - (while (consp (car cl--loop-args)) - (push (pop cl--loop-args) cl--loop-initially))) - - ((eq word 'finally) - (if (eq (car cl--loop-args) 'return) - (setq cl--loop-result-explicit - (or (cl--pop2 cl--loop-args) '(quote nil))) - (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) - (or (consp (car cl--loop-args)) - (error "Syntax error on `finally' clause")) - (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) - (setq cl--loop-result-explicit - (or (nth 1 (pop cl--loop-args)) '(quote nil))) - (while (consp (car cl--loop-args)) - (push (pop cl--loop-args) cl--loop-finally))))) - - ((memq word '(for as)) - (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) - (ands nil)) - (while - ;; Use `cl-gensym' rather than `make-symbol'. It's important that - ;; (not (eq (symbol-name var1) (symbol-name var2))) because - ;; these vars get added to the macro-environment. - (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--")))) - (setq word (pop cl--loop-args)) - (if (eq word 'being) (setq word (pop cl--loop-args))) - (if (memq word '(the each)) (setq word (pop cl--loop-args))) - (if (memq word '(buffer buffers)) - (setq word 'in - cl--loop-args (cons '(buffer-list) cl--loop-args))) - (cond - - ((memq word '(from downfrom upfrom to downto upto - above below by)) - (push word cl--loop-args) - (if (memq (car cl--loop-args) '(downto above)) - (error "Must specify `from' value for downward cl-loop")) - (let* ((down (or (eq (car cl--loop-args) 'downfrom) - (memq (nth 2 cl--loop-args) - '(downto above)))) - (excl (or (memq (car cl--loop-args) '(above below)) - (memq (nth 2 cl--loop-args) - '(above below)))) - (start (and (memq (car cl--loop-args) - '(from upfrom downfrom)) - (cl--pop2 cl--loop-args))) - (end (and (memq (car cl--loop-args) - '(to upto downto above below)) - (cl--pop2 cl--loop-args))) - (step (and (eq (car cl--loop-args) 'by) - (cl--pop2 cl--loop-args))) - (end-var (and (not (macroexp-const-p end)) - (make-symbol "--cl-var--"))) - (step-var (and (not (macroexp-const-p step)) - (make-symbol "--cl-var--")))) - (and step (numberp step) (<= step 0) - (error "Loop `by' value is not positive: %s" step)) - (push (list var (or start 0)) loop-for-bindings) - (if end-var (push (list end-var end) loop-for-bindings)) - (if step-var (push (list step-var step) - loop-for-bindings)) - (when end + ((memq word '(from downfrom upfrom to downto upto + above below by)) + (push word cl--loop-args) + (if (memq (car cl--loop-args) '(downto above)) + (error "Must specify `from' value for downward cl-loop")) + (let* ((down (or (eq (car cl--loop-args) 'downfrom) + (memq (nth 2 cl--loop-args) + '(downto above)))) + (excl (or (memq (car cl--loop-args) '(above below)) + (memq (nth 2 cl--loop-args) + '(above below)))) + (start (and (memq (car cl--loop-args) + '(from upfrom downfrom)) + (cl--pop2 cl--loop-args))) + (end (and (memq (car cl--loop-args) + '(to upto downto above below)) + (cl--pop2 cl--loop-args))) + (step (and (eq (car cl--loop-args) 'by) + (cl--pop2 cl--loop-args))) + (end-var (and (not (macroexp-const-p end)) + (make-symbol "--cl-var--"))) + (step-var (and (not (macroexp-const-p step)) + (make-symbol "--cl-var--")))) + (and step (numberp step) (<= step 0) + (error "Loop `by' value is not positive: %s" step)) + (push (list var (or start 0)) loop-for-bindings) + (if end-var (push (list end-var end) loop-for-bindings)) + (if step-var (push (list step-var step) + loop-for-bindings)) + (when end + (cl--push-clause-loop-body + (list + (if down (if excl '> '>=) (if excl '< '<=)) + var (or end-var end)))) + (push (list var (list (if down '- '+) var + (or step-var step 1))) + loop-for-steps))) + + ((memq word '(in in-ref on)) + (let* ((on (eq word 'on)) + (temp (if (and on (symbolp var)) + var (make-symbol "--cl-var--")))) + (push (list temp (next)) loop-for-bindings) + (cl--push-clause-loop-body `(consp ,temp)) + (if (eq word 'in-ref) + (push (list var `(car ,temp)) cl--loop-symbol-macs) + (or (eq temp var) + (progn + (push (list var nil) loop-for-bindings) + (push (list var (if on temp `(car ,temp))) + loop-for-sets)))) + (push (list temp + (if (eq (car cl--loop-args) 'by) + (let ((step (cl--pop2 cl--loop-args))) + (if (and (memq (car-safe step) + '(quote function + cl-function)) + (symbolp (nth 1 step))) + (list (nth 1 step) temp) + `(funcall ,step ,temp))) + `(cdr ,temp))) + loop-for-steps))) + + ((eq word '=) + (let* ((start (next)) + (then (if (eq (car cl--loop-args) 'then) + (cl--pop2 cl--loop-args) start)) + (first-assign (or cl--loop-first-flag + (setq cl--loop-first-flag + (make-symbol "--cl-var--"))))) + (push (list var nil) loop-for-bindings) + (if (or ands (eq (car cl--loop-args) 'and)) + (progn + (push `(,var (if ,first-assign ,start ,var)) loop-for-sets) + (push `(,var (if ,(car (cl--loop-build-ands + (nreverse cl--loop-conditions))) + ,then ,var)) + loop-for-steps)) + (push (if (eq start then) + `(,var ,then) + `(,var (if ,first-assign ,start ,then))) + loop-for-sets)))) + + ((memq word '(across across-ref)) + (let ((temp-vec (make-symbol "--cl-vec--")) + (temp-idx (make-symbol "--cl-idx--"))) + (push (list temp-vec (next)) loop-for-bindings) + (push (list temp-idx -1) loop-for-bindings) + (push `(setq ,temp-idx (1+ ,temp-idx)) cl--loop-body) (cl--push-clause-loop-body - (list - (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)))) - (push (list var (list (if down '- '+) var - (or step-var step 1))) - loop-for-steps))) - - ((memq word '(in in-ref on)) - (let* ((on (eq word 'on)) - (temp (if (and on (symbolp var)) - var (make-symbol "--cl-var--")))) - (push (list temp (pop cl--loop-args)) loop-for-bindings) - (cl--push-clause-loop-body `(consp ,temp)) - (if (eq word 'in-ref) - (push (list var `(car ,temp)) cl--loop-symbol-macs) - (or (eq temp var) - (progn - (push (list var nil) loop-for-bindings) - (push (list var (if on temp `(car ,temp))) - loop-for-sets)))) - (push (list temp - (if (eq (car cl--loop-args) 'by) - (let ((step (cl--pop2 cl--loop-args))) - (if (and (memq (car-safe step) - '(quote function - cl-function)) - (symbolp (nth 1 step))) - (list (nth 1 step) temp) - `(funcall ,step ,temp))) - `(cdr ,temp))) - loop-for-steps))) - - ((eq word '=) - (let* ((start (pop cl--loop-args)) - (then (if (eq (car cl--loop-args) 'then) - (cl--pop2 cl--loop-args) start)) - (first-assign (or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))))) - (push (list var nil) loop-for-bindings) - (if (or ands (eq (car cl--loop-args) 'and)) - (progn - (push `(,var (if ,first-assign ,start ,var)) loop-for-sets) - (push `(,var (if ,(car (cl--loop-build-ands - (nreverse cl--loop-conditions))) - ,then ,var)) - loop-for-steps)) - (push (if (eq start then) - `(,var ,then) - `(,var (if ,first-assign ,start ,then))) - loop-for-sets)))) - - ((memq word '(across across-ref)) - (let ((temp-vec (make-symbol "--cl-vec--")) - (temp-idx (make-symbol "--cl-idx--"))) - (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) - (push (list temp-idx -1) loop-for-bindings) - (push `(setq ,temp-idx (1+ ,temp-idx)) cl--loop-body) - (cl--push-clause-loop-body - `(< ,temp-idx (length ,temp-vec))) - (if (eq word 'across-ref) - (push (list var `(aref ,temp-vec ,temp-idx)) - cl--loop-symbol-macs) - (push (list var nil) loop-for-bindings) - (push (list var `(aref ,temp-vec ,temp-idx)) - loop-for-sets)))) - - ((memq word '(element elements)) - (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref)) - (and (not (memq (car cl--loop-args) '(in of))) - (error "Expected `of'")))) - (seq (cl--pop2 cl--loop-args)) - (temp-seq (make-symbol "--cl-seq--")) - (temp-idx - (if (eq (car cl--loop-args) 'using) - (if (and (= (length (cadr cl--loop-args)) 2) - (eq (caadr cl--loop-args) 'index)) - (cadr (cl--pop2 cl--loop-args)) - (error "Bad `using' clause")) - (make-symbol "--cl-idx--")))) - (push (list temp-seq seq) loop-for-bindings) - (push (list temp-idx 0) loop-for-bindings) - (if ref - (let ((temp-len (make-symbol "--cl-len--"))) - (push (list temp-len `(length ,temp-seq)) - loop-for-bindings) - (push (list var `(elt ,temp-seq ,temp-idx)) - cl--loop-symbol-macs) - (cl--push-clause-loop-body `(< ,temp-idx ,temp-len))) - (push (list var nil) loop-for-bindings) - (cl--push-clause-loop-body `(and ,temp-seq - (or (consp ,temp-seq) - (< ,temp-idx (length ,temp-seq))))) - (push (list var `(if (consp ,temp-seq) - (pop ,temp-seq) - (aref ,temp-seq ,temp-idx))) - loop-for-sets)) - (push (list temp-idx `(1+ ,temp-idx)) - loop-for-steps))) - - ((memq word hash-types) - (or (memq (car cl--loop-args) '(in of)) - (error "Expected `of'")) - (let* ((table (cl--pop2 cl--loop-args)) - (other - (if (eq (car cl--loop-args) 'using) - (if (and (= (length (cadr cl--loop-args)) 2) - (memq (caadr cl--loop-args) hash-types) - (not (eq (caadr cl--loop-args) word))) - (cadr (cl--pop2 cl--loop-args)) - (error "Bad `using' clause")) - (make-symbol "--cl-var--")))) - (if (memq word '(hash-value hash-values)) - (setq var (prog1 other (setq other var)))) - (cl--loop-set-iterator-function - 'hash-tables (lambda (body) - `(maphash (lambda (,var ,other) . ,body) - ,table))))) - - ((memq word '(symbol present-symbol external-symbol - symbols present-symbols external-symbols)) - (let ((ob (and (memq (car cl--loop-args) '(in of)) - (cl--pop2 cl--loop-args)))) - (cl--loop-set-iterator-function - 'symbols (lambda (body) - `(mapatoms (lambda (,var) . ,body) ,ob))))) - - ((memq word '(overlay overlays extent extents)) - (let ((buf nil) (from nil) (to nil)) - (while (memq (car cl--loop-args) '(in of from to)) - (cond ((eq (car cl--loop-args) 'from) - (setq from (cl--pop2 cl--loop-args))) - ((eq (car cl--loop-args) 'to) - (setq to (cl--pop2 cl--loop-args))) - (t (setq buf (cl--pop2 cl--loop-args))))) - (cl--loop-set-iterator-function - 'overlays (lambda (body) - `(cl--map-overlays - (lambda (,var ,(make-symbol "--cl-var--")) - (progn . ,body) nil) - ,buf ,from ,to))))) - - ((memq word '(interval intervals)) - (let ((buf nil) (prop nil) (from nil) (to nil) - (var1 (make-symbol "--cl-var1--")) - (var2 (make-symbol "--cl-var2--"))) - (while (memq (car cl--loop-args) '(in of property from to)) - (cond ((eq (car cl--loop-args) 'from) - (setq from (cl--pop2 cl--loop-args))) - ((eq (car cl--loop-args) 'to) - (setq to (cl--pop2 cl--loop-args))) - ((eq (car cl--loop-args) 'property) - (setq prop (cl--pop2 cl--loop-args))) - (t (setq buf (cl--pop2 cl--loop-args))))) - (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) - (setq var1 (car var) var2 (cdr var)) - (push (list var `(cons ,var1 ,var2)) loop-for-sets)) - (cl--loop-set-iterator-function - 'intervals (lambda (body) - `(cl--map-intervals - (lambda (,var1 ,var2) . ,body) - ,buf ,prop ,from ,to))))) - - ((memq word key-types) - (or (memq (car cl--loop-args) '(in of)) - (error "Expected `of'")) - (let ((cl-map (cl--pop2 cl--loop-args)) - (other - (if (eq (car cl--loop-args) 'using) - (if (and (= (length (cadr cl--loop-args)) 2) - (memq (caadr cl--loop-args) key-types) - (not (eq (caadr cl--loop-args) word))) - (cadr (cl--pop2 cl--loop-args)) - (error "Bad `using' clause")) - (make-symbol "--cl-var--")))) - (if (memq word '(key-binding key-bindings)) - (setq var (prog1 other (setq other var)))) - (cl--loop-set-iterator-function - 'keys (lambda (body) - `(,(if (memq word '(key-seq key-seqs)) - 'cl--map-keymap-recursively 'map-keymap) - (lambda (,var ,other) . ,body) ,cl-map))))) - - ((memq word '(frame frames screen screens)) - (let ((temp (make-symbol "--cl-var--"))) - (push (list var '(selected-frame)) - loop-for-bindings) - (push (list temp nil) loop-for-bindings) - (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var)))) - (push (list var `(next-frame ,var)) - loop-for-steps))) - - ((memq word '(window windows)) - (let ((scr (and (memq (car cl--loop-args) '(in of)) - (cl--pop2 cl--loop-args))) - (temp (make-symbol "--cl-var--")) - (minip (make-symbol "--cl-minip--"))) - (push (list var (if scr - `(frame-selected-window ,scr) - '(selected-window))) - loop-for-bindings) - ;; If we started in the minibuffer, we need to - ;; ensure that next-window will bring us back there - ;; at some point. (Bug#7492). - ;; (Consider using walk-windows instead of cl-loop if - ;; you care about such things.) - (push (list minip `(minibufferp (window-buffer ,var))) - loop-for-bindings) - (push (list temp nil) loop-for-bindings) - (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var)))) - (push (list var `(next-window ,var ,minip)) - loop-for-steps))) - - (t - ;; This is an advertised interface: (info "(cl)Other Clauses"). - (let ((handler (and (symbolp word) - (get word 'cl-loop-for-handler)))) - (if handler - (funcall handler var) - (error "Expected a `for' preposition, found %s" word))))) - (eq (car cl--loop-args) 'and)) - (setq ands t) - (pop cl--loop-args)) - (if (and ands loop-for-bindings) - (push (nreverse loop-for-bindings) cl--loop-bindings) - (setq cl--loop-bindings (nconc (mapcar #'list loop-for-bindings) - cl--loop-bindings))) - (if loop-for-sets - (push `(progn - ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) + `(< ,temp-idx (length ,temp-vec))) + (if (eq word 'across-ref) + (push (list var `(aref ,temp-vec ,temp-idx)) + cl--loop-symbol-macs) + (push (list var nil) loop-for-bindings) + (push (list var `(aref ,temp-vec ,temp-idx)) + loop-for-sets)))) + + ((memq word '(element elements)) + (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref)) + (and (not (memq (car cl--loop-args) '(in of))) + (error "Expected `of'")))) + (seq (cl--pop2 cl--loop-args)) + (temp-seq (make-symbol "--cl-seq--")) + (temp-idx + (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (eq (caadr cl--loop-args) 'index)) + (cadr (cl--pop2 cl--loop-args)) + (error "Bad `using' clause")) + (make-symbol "--cl-idx--")))) + (push (list temp-seq seq) loop-for-bindings) + (push (list temp-idx 0) loop-for-bindings) + (if ref + (let ((temp-len (make-symbol "--cl-len--"))) + (push (list temp-len `(length ,temp-seq)) + loop-for-bindings) + (push (list var `(elt ,temp-seq ,temp-idx)) + cl--loop-symbol-macs) + (cl--push-clause-loop-body `(< ,temp-idx ,temp-len))) + (push (list var nil) loop-for-bindings) + (cl--push-clause-loop-body `(and ,temp-seq + (or (consp ,temp-seq) + (< ,temp-idx (length ,temp-seq))))) + (push (list var `(if (consp ,temp-seq) + (pop ,temp-seq) + (aref ,temp-seq ,temp-idx))) + loop-for-sets)) + (push (list temp-idx `(1+ ,temp-idx)) + loop-for-steps))) + + ((memq word hash-types) + (or (memq (car cl--loop-args) '(in of)) + (error "Expected `of'")) + (let* ((table (cl--pop2 cl--loop-args)) + (other + (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (caadr cl--loop-args) hash-types) + (not (eq (caadr cl--loop-args) word))) + (cadr (cl--pop2 cl--loop-args)) + (error "Bad `using' clause")) + (make-symbol "--cl-var--")))) + (if (memq word '(hash-value hash-values)) + (setq var (prog1 other (setq other var)))) + (cl--loop-set-iterator-function + 'hash-tables (lambda (body) + `(maphash (lambda (,var ,other) . ,body) + ,table))))) + + ((memq word '(symbol present-symbol external-symbol + symbols present-symbols external-symbols)) + (let ((ob (and (memq (car cl--loop-args) '(in of)) + (cl--pop2 cl--loop-args)))) + (cl--loop-set-iterator-function + 'symbols (lambda (body) + `(mapatoms (lambda (,var) . ,body) ,ob))))) + + ((memq word '(overlay overlays extent extents)) + (let ((buf nil) (from nil) (to nil)) + (while (memq (car cl--loop-args) '(in of from to)) + (cond ((eq (car cl--loop-args) 'from) + (setq from (cl--pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) + (setq to (cl--pop2 cl--loop-args))) + (t (setq buf (cl--pop2 cl--loop-args))))) + (cl--loop-set-iterator-function + 'overlays (lambda (body) + `(cl--map-overlays + (lambda (,var ,(make-symbol "--cl-var--")) + (progn . ,body) nil) + ,buf ,from ,to))))) + + ((memq word '(interval intervals)) + (let ((buf nil) (prop nil) (from nil) (to nil) + (var1 (make-symbol "--cl-var1--")) + (var2 (make-symbol "--cl-var2--"))) + (while (memq (car cl--loop-args) '(in of property from to)) + (cond ((eq (car cl--loop-args) 'from) + (setq from (cl--pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) + (setq to (cl--pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'property) + (setq prop (cl--pop2 cl--loop-args))) + (t (setq buf (cl--pop2 cl--loop-args))))) + (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) + (setq var1 (car var) var2 (cdr var)) + (push (list var `(cons ,var1 ,var2)) loop-for-sets)) + (cl--loop-set-iterator-function + 'intervals (lambda (body) + `(cl--map-intervals + (lambda (,var1 ,var2) . ,body) + ,buf ,prop ,from ,to))))) + + ((memq word key-types) + (or (memq (car cl--loop-args) '(in of)) + (error "Expected `of'")) + (let ((cl-map (cl--pop2 cl--loop-args)) + (other + (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (caadr cl--loop-args) key-types) + (not (eq (caadr cl--loop-args) word))) + (cadr (cl--pop2 cl--loop-args)) + (error "Bad `using' clause")) + (make-symbol "--cl-var--")))) + (if (memq word '(key-binding key-bindings)) + (setq var (prog1 other (setq other var)))) + (cl--loop-set-iterator-function + 'keys (lambda (body) + `(,(if (memq word '(key-seq key-seqs)) + 'cl--map-keymap-recursively 'map-keymap) + (lambda (,var ,other) . ,body) ,cl-map))))) + + ((memq word '(frame frames screen screens)) + (let ((temp (make-symbol "--cl-var--"))) + (push (list var '(selected-frame)) + loop-for-bindings) + (push (list temp nil) loop-for-bindings) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) + (push (list var `(next-frame ,var)) + loop-for-steps))) + + ((memq word '(window windows)) + (let ((scr (and (memq (car cl--loop-args) '(in of)) + (cl--pop2 cl--loop-args))) + (temp (make-symbol "--cl-var--")) + (minip (make-symbol "--cl-minip--"))) + (push (list var (if scr + `(frame-selected-window ,scr) + '(selected-window))) + loop-for-bindings) + ;; If we started in the minibuffer, we need to + ;; ensure that next-window will bring us back there + ;; at some point. (Bug#7492). + ;; (Consider using walk-windows instead of cl-loop if + ;; you care about such things.) + (push (list minip `(minibufferp (window-buffer ,var))) + loop-for-bindings) + (push (list temp nil) loop-for-bindings) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) + (push (list var `(next-window ,var ,minip)) + loop-for-steps))) + + (t + ;; This is an advertised interface: (info "(cl)Other Clauses"). + (let ((handler (and (symbolp word) + (get word 'cl-loop-for-handler)))) + (if handler + (funcall handler var) + (error "Expected a `for' preposition, found %s" word))))) + (eq (car cl--loop-args) 'and)) + (setq ands t) + (next)) + (if (and ands loop-for-bindings) + (push (nreverse loop-for-bindings) cl--loop-bindings) + (setq cl--loop-bindings (nconc (mapcar #'list loop-for-bindings) + cl--loop-bindings))) + (if loop-for-sets + (push `(progn + ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) + t) + cl--loop-body)) + (when loop-for-steps + (push (cons (if ands 'cl-psetq 'setq) + (apply #'append (nreverse loop-for-steps))) + cl--loop-steps)))) + + ((eq word 'repeat) + (let ((temp (make-symbol "--cl-var--"))) + (push (list (list temp (next))) cl--loop-bindings) + (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body))) + + ((memq word '(collect collecting)) + (let ((what (next)) + (var (cl--loop-handle-accum nil 'nreverse))) + (if (eq var cl--loop-accum-var) + (push `(progn (push ,what ,var) t) cl--loop-body) + (push `(progn + (setq ,var (nconc ,var (list ,what))) t) - cl--loop-body)) - (when loop-for-steps - (push (cons (if ands 'cl-psetq 'setq) - (apply #'append (nreverse loop-for-steps))) - cl--loop-steps)))) - - ((eq word 'repeat) - (let ((temp (make-symbol "--cl-var--"))) - (push (list (list temp (pop cl--loop-args))) cl--loop-bindings) - (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body))) - - ((memq word '(collect collecting)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum nil 'nreverse))) - (if (eq var cl--loop-accum-var) - (push `(progn (push ,what ,var) t) cl--loop-body) - (push `(progn - (setq ,var (nconc ,var (list ,what))) + cl--loop-body)))) + + ((memq word '(nconc nconcing append appending)) + (let ((what (next)) + (var (cl--loop-handle-accum nil 'nreverse))) + (push `(progn + (setq ,var + ,(if (eq var cl--loop-accum-var) + `(nconc + (,(if (memq word '(nconc nconcing)) + #'nreverse #'reverse) + ,what) + ,var) + `(,(if (memq word '(nconc nconcing)) + #'nconc #'append) + ,var ,what))) t) - cl--loop-body)))) - - ((memq word '(nconc nconcing append appending)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum nil 'nreverse))) - (push `(progn - (setq ,var - ,(if (eq var cl--loop-accum-var) - `(nconc - (,(if (memq word '(nconc nconcing)) - #'nreverse #'reverse) - ,what) - ,var) - `(,(if (memq word '(nconc nconcing)) - #'nconc #'append) - ,var ,what))) - t) - cl--loop-body))) - - ((memq word '(concat concating)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum ""))) - (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body))) - - ((memq word '(vconcat vconcating)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum []))) - (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body))) - - ((memq word '(sum summing)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum 0))) - (push `(progn (cl-incf ,var ,what) t) cl--loop-body))) - - ((memq word '(count counting)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum 0))) - (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) - - ((memq word '(minimize minimizing maximize maximizing)) - (push `(progn ,(macroexp-let2 macroexp-copyable-p temp - (pop cl--loop-args) - (let* ((var (cl--loop-handle-accum nil)) - (func (intern (substring (symbol-name word) - 0 3)))) - `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) - t) - cl--loop-body)) - - ((eq word 'with) - (let ((bindings nil)) - (while (progn (push (list (pop cl--loop-args) - (and (eq (car cl--loop-args) '=) - (cl--pop2 cl--loop-args))) - bindings) - (eq (car cl--loop-args) 'and)) - (pop cl--loop-args)) - (push (nreverse bindings) cl--loop-bindings))) - - ((eq word 'while) - (push (pop cl--loop-args) cl--loop-body)) - - ((eq word 'until) - (push `(not ,(pop cl--loop-args)) cl--loop-body)) - - ((eq word 'always) - (or cl--loop-finish-flag - (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) - (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body) - (setq cl--loop-result t)) - - ((eq word 'never) - (or cl--loop-finish-flag - (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) - (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args))) - cl--loop-body) - (setq cl--loop-result t)) - - ((eq word 'thereis) - (or cl--loop-finish-flag - (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) - (or cl--loop-result-var - (setq cl--loop-result-var (make-symbol "--cl-var--"))) - (push `(setq ,cl--loop-finish-flag - (not (setq ,cl--loop-result-var ,(pop cl--loop-args)))) - cl--loop-body)) - - ((memq word '(if when unless)) - (let* ((cond (pop cl--loop-args)) - (then (let ((cl--loop-body nil)) - (cl--parse-loop-clause) - (cl--loop-build-ands (nreverse cl--loop-body)))) - (else (let ((cl--loop-body nil)) - (if (eq (car cl--loop-args) 'else) - (progn (pop cl--loop-args) (cl--parse-loop-clause))) - (cl--loop-build-ands (nreverse cl--loop-body)))) - (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car cl--loop-args) 'end) (pop cl--loop-args)) - (if (eq word 'unless) (setq then (prog1 else (setq else then)))) - (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) - (if simple (nth 1 else) (list (nth 2 else)))))) - (setq form (if (cl--expr-contains form 'it) - `(let ((it ,cond)) (if it ,@form)) - `(if ,cond ,@form))) - (push (if simple `(progn ,form t) form) cl--loop-body)))) - - ((memq word '(do doing)) - (let ((body nil)) - (or (consp (car cl--loop-args)) (error "Syntax error on `do' clause")) - (while (consp (car cl--loop-args)) (push (pop cl--loop-args) body)) - (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) - - ((eq word 'return) - (or cl--loop-finish-flag - (setq cl--loop-finish-flag (make-symbol "--cl-var--"))) - (or cl--loop-result-var - (setq cl--loop-result-var (make-symbol "--cl-var--"))) - (push `(setq ,cl--loop-result-var ,(pop cl--loop-args) - ,cl--loop-finish-flag nil) - cl--loop-body)) - - (t - ;; This is an advertised interface: (info "(cl)Other Clauses"). - (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) - (or handler (error "Expected a cl-loop keyword, found %s" word)) - (funcall handler)))) - (if (eq (car cl--loop-args) 'and) - (progn (pop cl--loop-args) (cl--parse-loop-clause))))) + cl--loop-body))) + + ((memq word '(concat concating)) + (let ((what (next)) + (var (cl--loop-handle-accum ""))) + (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body))) + + ((memq word '(vconcat vconcating)) + (let ((what (next)) + (var (cl--loop-handle-accum []))) + (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body))) + + ((memq word '(sum summing)) + (let ((what (next)) + (var (cl--loop-handle-accum 0))) + (push `(progn (cl-incf ,var ,what) t) cl--loop-body))) + + ((memq word '(count counting)) + (let ((what (next)) + (var (cl--loop-handle-accum 0))) + (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) + + ((memq word '(minimize minimizing maximize maximizing)) + (push `(progn ,(macroexp-let2 macroexp-copyable-p temp + (next) + (let* ((var (cl--loop-handle-accum nil)) + (func (intern (substring (symbol-name word) + 0 3)))) + `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) + t) + cl--loop-body)) + + ((eq word 'with) + (let ((bindings nil)) + (while (progn (push (list (next) + (and (eq (car cl--loop-args) '=) + (cl--pop2 cl--loop-args))) + bindings) + (eq (car cl--loop-args) 'and)) + (next)) + (push (nreverse bindings) cl--loop-bindings))) + + ((eq word 'while) + (push (next) cl--loop-body)) + + ((eq word 'until) + (push `(not ,(next)) cl--loop-body)) + + ((eq word 'always) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag ,(next)) cl--loop-body) + (setq cl--loop-result t)) + + ((eq word 'never) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag (not ,(next))) + cl--loop-body) + (setq cl--loop-result t)) + + ((eq word 'thereis) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (or cl--loop-result-var + (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-finish-flag + (not (setq ,cl--loop-result-var ,(next)))) + cl--loop-body)) + + ((memq word '(if when unless)) + (let* ((cond (next)) + (then (let ((cl--loop-body nil)) + (cl--parse-loop-clause) + (cl--loop-build-ands (nreverse cl--loop-body)))) + (else (let ((cl--loop-body nil)) + (if (eq (car cl--loop-args) 'else) + (progn (next) (cl--parse-loop-clause))) + (cl--loop-build-ands (nreverse cl--loop-body)))) + (simple (and (eq (car then) t) (eq (car else) t)))) + (if (eq (car cl--loop-args) 'end) (next)) + (if (eq word 'unless) (setq then (prog1 else (setq else then)))) + (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) + (if simple (nth 1 else) (list (nth 2 else)))))) + (setq form (if (cl--expr-contains form 'it) + `(let ((it ,cond)) (if it ,@form)) + `(if ,cond ,@form))) + (push (if simple `(progn ,form t) form) cl--loop-body)))) + + ((memq word '(do doing)) + (let ((body nil)) + (or (consp (car cl--loop-args)) (error "Syntax error on `do' clause")) + (while (consp (car cl--loop-args)) (push (next) body)) + (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) + + ((eq word 'return) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-var--"))) + (or cl--loop-result-var + (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-result-var ,(next) + ,cl--loop-finish-flag nil) + cl--loop-body)) + + (t + ;; This is an advertised interface: (info "(cl)Other Clauses"). + (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) + (or handler (error "Expected a cl-loop keyword, found %s" word)) + (funcall handler)))) + (if (eq (car cl--loop-args) 'and) + (progn (next) (cl--parse-loop-clause)))))) (defun cl--unused-var-p (sym) (or (null sym) (eq ?_ (aref (symbol-name sym) 0)))) -- 2.37.3 [-- Attachment #3: Type: text/plain, Size: 92 bytes --] Perhaps I could pull the cl-flet out and replace each (next) with a (cl--loop-parse-next)? ^ permalink raw reply related [flat|nested] 13+ messages in thread
* bug#57907: Acknowledgement (29.0.50; Using keywords with cl-loop) 2022-09-18 12:26 ` bug#57907: Acknowledgement (29.0.50; Using keywords with cl-loop) Philip Kaludercic @ 2022-09-18 20:12 ` Philip Kaludercic 0 siblings, 0 replies; 13+ messages in thread From: Philip Kaludercic @ 2022-09-18 20:12 UTC (permalink / raw) To: 57907 [-- Attachment #1: Type: text/plain, Size: 306 bytes --] Philip Kaludercic <philipk@posteo.net> writes: > It seems it isn't that difficult to do this (though the patch is longer > than it ought to be because of indentation changes) It turned out to be a bit more difficult than I had assumed at first, but this patch should address the remaining issues I had: [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #2: 0001-Have-cl-loop-handle-keyword-symbols.patch --] [-- Type: text/x-patch, Size: 49879 bytes --] From a15a3d33b3ae4e2e8608da04978ed91b7c01187f Mon Sep 17 00:00:00 2001 From: Philip Kaludercic <philipk@posteo.net> Date: Sun, 18 Sep 2022 14:25:29 +0200 Subject: [PATCH] Have 'cl-loop' handle keyword symbols * lisp/emacs-lisp/cl-macs.el (cl-loop): Add keywords to the edebug spec. (cl--parse-loop-clause): Handle keyword symbols by converting them into regular symbols. * doc/misc/cl.texi (Loop Basics): Mention that keywords are handled. * etc/NEWS: Mention it. (Bug#57907) --- doc/misc/cl.texi | 13 +- etc/NEWS | 3 + lisp/emacs-lisp/cl-macs.el | 964 +++++++++++++++++++------------------ 3 files changed, 510 insertions(+), 470 deletions(-) diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index a6747b1096..2f64aa3f1e 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -1700,12 +1700,13 @@ Loop Basics @defmac cl-loop clauses@dots{} A loop construct consists of a series of @var{clause}s, each -introduced by a symbol like @code{for} or @code{do}. Clauses -are simply strung together in the argument list of @code{cl-loop}, -with minimal extra parentheses. The various types of clauses -specify initializations, such as the binding of temporary -variables, actions to be taken in the loop, stepping actions, -and final cleanup. +introduced by a symbol like @code{for} or @code{do}. Clauses are +simply strung together in the argument list of @code{cl-loop}, with +minimal extra parentheses. The various types of clauses specify +initializations, such as the binding of temporary variables, actions +to be taken in the loop, stepping actions, and final cleanup. +@code{cl-loop} can also handle keyword symbols, such as @code{:for} or +@code{:do}, in the same way as it would handle non-keyword symbols. Common Lisp specifies a certain general order of clauses in a loop: diff --git a/etc/NEWS b/etc/NEWS index e5d9b1ca23..b6862276f1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3801,6 +3801,9 @@ the same but works by modifying LIST destructively. --- ** 'string-split' is now an alias for 'split-string'. ++++ +** 'cl-loop' now handles keyword symbols. + \f * Changes in Emacs 29.1 on Non-Free Operating Systems diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5d330f32d6..74d0878689 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -946,6 +946,9 @@ cl-loop do EXPRS... [finally] return EXPR +All cl-loop keywords may also be written using keyword +symbols (e.g. `:for' is the same as `for'). + For more details, see Info node `(cl)Loop Facility'. \(fn CLAUSE...)" @@ -953,22 +956,24 @@ cl-loop ;; These are usually followed by a symbol, but it can ;; actually be any destructuring-bind pattern, which ;; would erroneously match `form'. - [[&or "for" "as" "with" "and"] sexp] + [[&or "for" ":for" "as" ":as" "with" ":with" "and" ":and"] sexp] ;; These are followed by expressions which could ;; erroneously match `symbolp'. - [[&or "from" "upfrom" "downfrom" "to" "upto" "downto" - "above" "below" "by" "in" "on" "=" "across" - "repeat" "while" "until" "always" "never" - "thereis" "collect" "append" "nconc" "sum" - "count" "maximize" "minimize" - "if" "when" "unless" - "return"] + [[&or "from" ":from" "upfrom" ":upfrom" "downfrom" ":downfrom" "to" + ":to" "upto" ":upto" "downto" ":downto" "above" ":above" + "below" ":below" "by" ":by" "in" ":in" "on" ":on" "=" ":=" + "across" ":across" "repeat" ":repeat" "while" ":while" "until" + ":until" "always" ":always" "never" ":never" "thereis" + ":thereis" "collect" ":collect" "append" ":append" "nconc" + ":nconc" "sum" ":sum" "count" ":count" "maximize" ":maximize" + "minimize" ":minimize" "if" ":if" "when" ":when" "unless" + ":unless" "return" ":return" ] form] ["using" (symbolp symbolp)] ;; Simple default, which covers 99% of the cases. symbolp form))) (if (not (memq t (mapcar #'symbolp - (delq nil (delq t (cl-copy-list loop-args)))))) + (delq nil (remq t loop-args))))) `(cl-block nil (while t ,@loop-args)) (let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil) (cl--loop-body nil) (cl--loop-steps nil) @@ -1204,465 +1209,496 @@ cl--push-clause-loop-body ;; '(&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) (defun cl--parse-loop-clause () ; uses loop-* - (let ((word (pop cl--loop-args)) - (hash-types '(hash-key hash-keys hash-value hash-values)) - (key-types '(key-code key-codes key-seq key-seqs - key-binding key-bindings))) - (cond + (cl-flet + ;; The following local functions are added to automatically + ;; convert loop-keywords that use keyword symbols to + ;; non-keyword symbols. E.g. we want + ;; + ;; (cl-loop :repeat foo :collect :bar) + ;; + ;; to do the same as + ;; + ;; (cl-loop repeat foo collect :bar) + ;; + ;; We can't generically replace all keyword symbols with + ;; non-keyword symbols because that could break things when we + ;; actually intend to have a keyword symbol. Instead the local + ;; functions are used whenever we want to query the next + ;; loop-keyword. + ((next () + (let ((word (pop cl--loop-args))) + (if (keywordp word) + (intern (substring (symbol-name word) 1)) + word))) + (next-2 () ;double-step `next' + (let ((word (cl--pop2 cl--loop-args))) + (if (keywordp word) + (intern (substring (symbol-name word) 1)) + word))) + (peek () + (let ((word (car cl--loop-args))) + (if (keywordp word) + (intern (substring (symbol-name word) 1)) + word)))) + (let ((word (next)) + (hash-types '(hash-key hash-keys hash-value hash-values)) + (key-types '(key-code key-codes key-seq key-seqs + key-binding key-bindings))) + (cond + + ((null cl--loop-args) + (error "Malformed `cl-loop' macro")) + + ((eq word 'named) + (setq cl--loop-name (pop cl--loop-args))) + + ((eq word 'initially) + (if (memq (peek) '(do doing)) (next)) + (or (consp (peek)) + (error "Syntax error on `initially' clause")) + (while (consp (peek)) + (push (pop cl--loop-args) cl--loop-initially))) + + ((eq word 'finally) + (if (eq (peek) 'return) + (setq cl--loop-result-explicit + (or (cl--pop2 cl--loop-args) '(quote nil))) + (if (memq (peek) '(do doing)) (next)) + (or (consp (peek)) + (error "Syntax error on `finally' clause")) + (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) + (setq cl--loop-result-explicit + (or (nth 1 (pop cl--loop-args)) '(quote nil))) + (while (consp (peek)) + (push (pop cl--loop-args) cl--loop-finally))))) + + ((memq word '(for as)) + (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) + (ands nil)) + (while + ;; Use `cl-gensym' rather than `make-symbol'. It's important that + ;; (not (eq (symbol-name var1) (symbol-name var2))) because + ;; these vars get added to the macro-environment. + (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--")))) + (setq word (next)) + (if (eq word 'being) (setq word (next))) + (if (memq word '(the each)) (setq word (next))) + (if (memq word '(buffer buffers)) + (setq word 'in + cl--loop-args (cons '(buffer-list) cl--loop-args))) + (cond - ((null cl--loop-args) - (error "Malformed `cl-loop' macro")) - - ((eq word 'named) - (setq cl--loop-name (pop cl--loop-args))) - - ((eq word 'initially) - (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) - (or (consp (car cl--loop-args)) - (error "Syntax error on `initially' clause")) - (while (consp (car cl--loop-args)) - (push (pop cl--loop-args) cl--loop-initially))) - - ((eq word 'finally) - (if (eq (car cl--loop-args) 'return) - (setq cl--loop-result-explicit - (or (cl--pop2 cl--loop-args) '(quote nil))) - (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) - (or (consp (car cl--loop-args)) - (error "Syntax error on `finally' clause")) - (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) - (setq cl--loop-result-explicit - (or (nth 1 (pop cl--loop-args)) '(quote nil))) - (while (consp (car cl--loop-args)) - (push (pop cl--loop-args) cl--loop-finally))))) - - ((memq word '(for as)) - (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) - (ands nil)) - (while - ;; Use `cl-gensym' rather than `make-symbol'. It's important that - ;; (not (eq (symbol-name var1) (symbol-name var2))) because - ;; these vars get added to the macro-environment. - (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--")))) - (setq word (pop cl--loop-args)) - (if (eq word 'being) (setq word (pop cl--loop-args))) - (if (memq word '(the each)) (setq word (pop cl--loop-args))) - (if (memq word '(buffer buffers)) - (setq word 'in - cl--loop-args (cons '(buffer-list) cl--loop-args))) - (cond - - ((memq word '(from downfrom upfrom to downto upto - above below by)) - (push word cl--loop-args) - (if (memq (car cl--loop-args) '(downto above)) - (error "Must specify `from' value for downward cl-loop")) - (let* ((down (or (eq (car cl--loop-args) 'downfrom) - (memq (nth 2 cl--loop-args) - '(downto above)))) - (excl (or (memq (car cl--loop-args) '(above below)) - (memq (nth 2 cl--loop-args) - '(above below)))) - (start (and (memq (car cl--loop-args) - '(from upfrom downfrom)) - (cl--pop2 cl--loop-args))) - (end (and (memq (car cl--loop-args) - '(to upto downto above below)) - (cl--pop2 cl--loop-args))) - (step (and (eq (car cl--loop-args) 'by) - (cl--pop2 cl--loop-args))) - (end-var (and (not (macroexp-const-p end)) - (make-symbol "--cl-var--"))) - (step-var (and (not (macroexp-const-p step)) - (make-symbol "--cl-var--")))) - (and step (numberp step) (<= step 0) - (error "Loop `by' value is not positive: %s" step)) - (push (list var (or start 0)) loop-for-bindings) - (if end-var (push (list end-var end) loop-for-bindings)) - (if step-var (push (list step-var step) - loop-for-bindings)) - (when end + ((memq word '(from downfrom upfrom to downto upto + above below by)) + (push word cl--loop-args) + (if (memq (peek) '(downto above)) + (error "Must specify `from' value for downward cl-loop")) + (let* ((down (or (eq (peek) 'downfrom) + (memq (nth 2 cl--loop-args) + '(downto above)))) + (excl (or (memq (peek) '(above below)) + (memq (nth 2 cl--loop-args) + '(above below)))) + (start (and (memq (peek) + '(from upfrom downfrom)) + (next-2))) + (end (and (memq (peek) + '(to upto downto above below)) + (next-2))) + (step (and (eq (peek) 'by) + (next-2))) + (end-var (and (not (macroexp-const-p end)) + (make-symbol "--cl-var--"))) + (step-var (and (not (macroexp-const-p step)) + (make-symbol "--cl-var--")))) + (and step (numberp step) (<= step 0) + (error "Loop `by' value is not positive: %s" step)) + (push (list var (or start 0)) loop-for-bindings) + (if end-var (push (list end-var end) loop-for-bindings)) + (if step-var (push (list step-var step) + loop-for-bindings)) + (when end + (cl--push-clause-loop-body + (list + (if down (if excl '> '>=) (if excl '< '<=)) + var (or end-var end)))) + (push (list var (list (if down '- '+) var + (or step-var step 1))) + loop-for-steps))) + + ((memq word '(in in-ref on)) + (let* ((on (eq word 'on)) + (temp (if (and on (symbolp var)) + var (make-symbol "--cl-var--")))) + (push (list temp (pop cl--loop-args)) loop-for-bindings) + (cl--push-clause-loop-body `(consp ,temp)) + (if (eq word 'in-ref) + (push (list var `(car ,temp)) cl--loop-symbol-macs) + (or (eq temp var) + (progn + (push (list var nil) loop-for-bindings) + (push (list var (if on temp `(car ,temp))) + loop-for-sets)))) + (push (list temp + (if (eq (peek) 'by) + (let ((step (cl--pop2 cl--loop-args))) + (if (and (memq (car-safe step) + '(quote function + cl-function)) + (symbolp (nth 1 step))) + (list (nth 1 step) temp) + `(funcall ,step ,temp))) + `(cdr ,temp))) + loop-for-steps))) + + ((eq word '=) + (let* ((start (next)) + (then (if (eq (peek) 'then) + (cl--pop2 cl--loop-args) start)) + (first-assign (or cl--loop-first-flag + (setq cl--loop-first-flag + (make-symbol "--cl-var--"))))) + (push (list var nil) loop-for-bindings) + (if (or ands (eq (peek) 'and)) + (progn + (push `(,var (if ,first-assign ,start ,var)) loop-for-sets) + (push `(,var (if ,(car (cl--loop-build-ands + (nreverse cl--loop-conditions))) + ,then ,var)) + loop-for-steps)) + (push (if (eq start then) + `(,var ,then) + `(,var (if ,first-assign ,start ,then))) + loop-for-sets)))) + + ((memq word '(across across-ref)) + (let ((temp-vec (make-symbol "--cl-vec--")) + (temp-idx (make-symbol "--cl-idx--"))) + (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) + (push (list temp-idx -1) loop-for-bindings) + (push `(setq ,temp-idx (1+ ,temp-idx)) cl--loop-body) (cl--push-clause-loop-body - (list - (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)))) - (push (list var (list (if down '- '+) var - (or step-var step 1))) - loop-for-steps))) - - ((memq word '(in in-ref on)) - (let* ((on (eq word 'on)) - (temp (if (and on (symbolp var)) - var (make-symbol "--cl-var--")))) - (push (list temp (pop cl--loop-args)) loop-for-bindings) - (cl--push-clause-loop-body `(consp ,temp)) - (if (eq word 'in-ref) - (push (list var `(car ,temp)) cl--loop-symbol-macs) - (or (eq temp var) - (progn - (push (list var nil) loop-for-bindings) - (push (list var (if on temp `(car ,temp))) - loop-for-sets)))) - (push (list temp - (if (eq (car cl--loop-args) 'by) - (let ((step (cl--pop2 cl--loop-args))) - (if (and (memq (car-safe step) - '(quote function - cl-function)) - (symbolp (nth 1 step))) - (list (nth 1 step) temp) - `(funcall ,step ,temp))) - `(cdr ,temp))) - loop-for-steps))) - - ((eq word '=) - (let* ((start (pop cl--loop-args)) - (then (if (eq (car cl--loop-args) 'then) - (cl--pop2 cl--loop-args) start)) - (first-assign (or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))))) - (push (list var nil) loop-for-bindings) - (if (or ands (eq (car cl--loop-args) 'and)) - (progn - (push `(,var (if ,first-assign ,start ,var)) loop-for-sets) - (push `(,var (if ,(car (cl--loop-build-ands - (nreverse cl--loop-conditions))) - ,then ,var)) - loop-for-steps)) - (push (if (eq start then) - `(,var ,then) - `(,var (if ,first-assign ,start ,then))) - loop-for-sets)))) - - ((memq word '(across across-ref)) - (let ((temp-vec (make-symbol "--cl-vec--")) - (temp-idx (make-symbol "--cl-idx--"))) - (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) - (push (list temp-idx -1) loop-for-bindings) - (push `(setq ,temp-idx (1+ ,temp-idx)) cl--loop-body) - (cl--push-clause-loop-body - `(< ,temp-idx (length ,temp-vec))) - (if (eq word 'across-ref) - (push (list var `(aref ,temp-vec ,temp-idx)) - cl--loop-symbol-macs) - (push (list var nil) loop-for-bindings) - (push (list var `(aref ,temp-vec ,temp-idx)) - loop-for-sets)))) - - ((memq word '(element elements)) - (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref)) - (and (not (memq (car cl--loop-args) '(in of))) - (error "Expected `of'")))) - (seq (cl--pop2 cl--loop-args)) - (temp-seq (make-symbol "--cl-seq--")) - (temp-idx - (if (eq (car cl--loop-args) 'using) - (if (and (= (length (cadr cl--loop-args)) 2) - (eq (caadr cl--loop-args) 'index)) - (cadr (cl--pop2 cl--loop-args)) - (error "Bad `using' clause")) - (make-symbol "--cl-idx--")))) - (push (list temp-seq seq) loop-for-bindings) - (push (list temp-idx 0) loop-for-bindings) - (if ref - (let ((temp-len (make-symbol "--cl-len--"))) - (push (list temp-len `(length ,temp-seq)) - loop-for-bindings) - (push (list var `(elt ,temp-seq ,temp-idx)) - cl--loop-symbol-macs) - (cl--push-clause-loop-body `(< ,temp-idx ,temp-len))) - (push (list var nil) loop-for-bindings) - (cl--push-clause-loop-body `(and ,temp-seq - (or (consp ,temp-seq) - (< ,temp-idx (length ,temp-seq))))) - (push (list var `(if (consp ,temp-seq) - (pop ,temp-seq) - (aref ,temp-seq ,temp-idx))) - loop-for-sets)) - (push (list temp-idx `(1+ ,temp-idx)) - loop-for-steps))) - - ((memq word hash-types) - (or (memq (car cl--loop-args) '(in of)) - (error "Expected `of'")) - (let* ((table (cl--pop2 cl--loop-args)) - (other - (if (eq (car cl--loop-args) 'using) - (if (and (= (length (cadr cl--loop-args)) 2) - (memq (caadr cl--loop-args) hash-types) - (not (eq (caadr cl--loop-args) word))) - (cadr (cl--pop2 cl--loop-args)) - (error "Bad `using' clause")) - (make-symbol "--cl-var--")))) - (if (memq word '(hash-value hash-values)) - (setq var (prog1 other (setq other var)))) - (cl--loop-set-iterator-function - 'hash-tables (lambda (body) - `(maphash (lambda (,var ,other) . ,body) - ,table))))) - - ((memq word '(symbol present-symbol external-symbol - symbols present-symbols external-symbols)) - (let ((ob (and (memq (car cl--loop-args) '(in of)) - (cl--pop2 cl--loop-args)))) - (cl--loop-set-iterator-function - 'symbols (lambda (body) - `(mapatoms (lambda (,var) . ,body) ,ob))))) - - ((memq word '(overlay overlays extent extents)) - (let ((buf nil) (from nil) (to nil)) - (while (memq (car cl--loop-args) '(in of from to)) - (cond ((eq (car cl--loop-args) 'from) - (setq from (cl--pop2 cl--loop-args))) - ((eq (car cl--loop-args) 'to) - (setq to (cl--pop2 cl--loop-args))) - (t (setq buf (cl--pop2 cl--loop-args))))) - (cl--loop-set-iterator-function - 'overlays (lambda (body) - `(cl--map-overlays - (lambda (,var ,(make-symbol "--cl-var--")) - (progn . ,body) nil) - ,buf ,from ,to))))) - - ((memq word '(interval intervals)) - (let ((buf nil) (prop nil) (from nil) (to nil) - (var1 (make-symbol "--cl-var1--")) - (var2 (make-symbol "--cl-var2--"))) - (while (memq (car cl--loop-args) '(in of property from to)) - (cond ((eq (car cl--loop-args) 'from) - (setq from (cl--pop2 cl--loop-args))) - ((eq (car cl--loop-args) 'to) - (setq to (cl--pop2 cl--loop-args))) - ((eq (car cl--loop-args) 'property) - (setq prop (cl--pop2 cl--loop-args))) - (t (setq buf (cl--pop2 cl--loop-args))))) - (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) - (setq var1 (car var) var2 (cdr var)) - (push (list var `(cons ,var1 ,var2)) loop-for-sets)) - (cl--loop-set-iterator-function - 'intervals (lambda (body) - `(cl--map-intervals - (lambda (,var1 ,var2) . ,body) - ,buf ,prop ,from ,to))))) - - ((memq word key-types) - (or (memq (car cl--loop-args) '(in of)) - (error "Expected `of'")) - (let ((cl-map (cl--pop2 cl--loop-args)) - (other - (if (eq (car cl--loop-args) 'using) - (if (and (= (length (cadr cl--loop-args)) 2) - (memq (caadr cl--loop-args) key-types) - (not (eq (caadr cl--loop-args) word))) - (cadr (cl--pop2 cl--loop-args)) - (error "Bad `using' clause")) - (make-symbol "--cl-var--")))) - (if (memq word '(key-binding key-bindings)) - (setq var (prog1 other (setq other var)))) - (cl--loop-set-iterator-function - 'keys (lambda (body) - `(,(if (memq word '(key-seq key-seqs)) - 'cl--map-keymap-recursively 'map-keymap) - (lambda (,var ,other) . ,body) ,cl-map))))) - - ((memq word '(frame frames screen screens)) - (let ((temp (make-symbol "--cl-var--"))) - (push (list var '(selected-frame)) - loop-for-bindings) - (push (list temp nil) loop-for-bindings) - (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var)))) - (push (list var `(next-frame ,var)) - loop-for-steps))) - - ((memq word '(window windows)) - (let ((scr (and (memq (car cl--loop-args) '(in of)) - (cl--pop2 cl--loop-args))) - (temp (make-symbol "--cl-var--")) - (minip (make-symbol "--cl-minip--"))) - (push (list var (if scr - `(frame-selected-window ,scr) - '(selected-window))) - loop-for-bindings) - ;; If we started in the minibuffer, we need to - ;; ensure that next-window will bring us back there - ;; at some point. (Bug#7492). - ;; (Consider using walk-windows instead of cl-loop if - ;; you care about such things.) - (push (list minip `(minibufferp (window-buffer ,var))) - loop-for-bindings) - (push (list temp nil) loop-for-bindings) - (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var)))) - (push (list var `(next-window ,var ,minip)) - loop-for-steps))) - - (t - ;; This is an advertised interface: (info "(cl)Other Clauses"). - (let ((handler (and (symbolp word) - (get word 'cl-loop-for-handler)))) - (if handler - (funcall handler var) - (error "Expected a `for' preposition, found %s" word))))) - (eq (car cl--loop-args) 'and)) - (setq ands t) - (pop cl--loop-args)) - (if (and ands loop-for-bindings) - (push (nreverse loop-for-bindings) cl--loop-bindings) - (setq cl--loop-bindings (nconc (mapcar #'list loop-for-bindings) - cl--loop-bindings))) - (if loop-for-sets - (push `(progn - ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) + `(< ,temp-idx (length ,temp-vec))) + (if (eq word 'across-ref) + (push (list var `(aref ,temp-vec ,temp-idx)) + cl--loop-symbol-macs) + (push (list var nil) loop-for-bindings) + (push (list var `(aref ,temp-vec ,temp-idx)) + loop-for-sets)))) + + ((memq word '(element elements)) + (let ((ref (or (memq (peek) '(in-ref of-ref)) + (and (not (memq (peek) '(in of))) + (error "Expected `of'")))) + (seq (cl--pop2 cl--loop-args)) + (temp-seq (make-symbol "--cl-seq--")) + (temp-idx + (if (eq (peek) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (eq (caadr cl--loop-args) 'index)) + (cadr (cl--pop2 cl--loop-args)) + (error "Bad `using' clause")) + (make-symbol "--cl-idx--")))) + (push (list temp-seq seq) loop-for-bindings) + (push (list temp-idx 0) loop-for-bindings) + (if ref + (let ((temp-len (make-symbol "--cl-len--"))) + (push (list temp-len `(length ,temp-seq)) + loop-for-bindings) + (push (list var `(elt ,temp-seq ,temp-idx)) + cl--loop-symbol-macs) + (cl--push-clause-loop-body `(< ,temp-idx ,temp-len))) + (push (list var nil) loop-for-bindings) + (cl--push-clause-loop-body `(and ,temp-seq + (or (consp ,temp-seq) + (< ,temp-idx (length ,temp-seq))))) + (push (list var `(if (consp ,temp-seq) + (pop ,temp-seq) + (aref ,temp-seq ,temp-idx))) + loop-for-sets)) + (push (list temp-idx `(1+ ,temp-idx)) + loop-for-steps))) + + ((memq word hash-types) + (or (memq (peek) '(in of)) + (error "Expected `of'")) + (let* ((table (cl--pop2 cl--loop-args)) + (other + (if (eq (peek) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (caadr cl--loop-args) hash-types) + (not (eq (caadr cl--loop-args) word))) + (cadr (cl--pop2 cl--loop-args)) + (error "Bad `using' clause")) + (make-symbol "--cl-var--")))) + (if (memq word '(hash-value hash-values)) + (setq var (prog1 other (setq other var)))) + (cl--loop-set-iterator-function + 'hash-tables (lambda (body) + `(maphash (lambda (,var ,other) . ,body) + ,table))))) + + ((memq word '(symbol present-symbol external-symbol + symbols present-symbols external-symbols)) + (let ((ob (and (memq (peek) '(in of)) + (cl--pop2 cl--loop-args)))) + (cl--loop-set-iterator-function + 'symbols (lambda (body) + `(mapatoms (lambda (,var) . ,body) ,ob))))) + + ((memq word '(overlay overlays extent extents)) + (let ((buf nil) (from nil) (to nil)) + (while (memq (peek) '(in of from to)) + (cond ((eq (peek) 'from) + (setq from (cl--pop2 cl--loop-args))) + ((eq (peek) 'to) + (setq to (cl--pop2 cl--loop-args))) + (t (setq buf (cl--pop2 cl--loop-args))))) + (cl--loop-set-iterator-function + 'overlays (lambda (body) + `(cl--map-overlays + (lambda (,var ,(make-symbol "--cl-var--")) + (progn . ,body) nil) + ,buf ,from ,to))))) + + ((memq word '(interval intervals)) + (let ((buf nil) (prop nil) (from nil) (to nil) + (var1 (make-symbol "--cl-var1--")) + (var2 (make-symbol "--cl-var2--"))) + (while (memq (peek) '(in of property from to)) + (cond ((eq (peek) 'from) + (setq from (cl--pop2 cl--loop-args))) + ((eq (peek) 'to) + (setq to (cl--pop2 cl--loop-args))) + ((eq (peek) 'property) + (setq prop (cl--pop2 cl--loop-args))) + (t (setq buf (cl--pop2 cl--loop-args))))) + (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) + (setq var1 (car var) var2 (cdr var)) + (push (list var `(cons ,var1 ,var2)) loop-for-sets)) + (cl--loop-set-iterator-function + 'intervals (lambda (body) + `(cl--map-intervals + (lambda (,var1 ,var2) . ,body) + ,buf ,prop ,from ,to))))) + + ((memq word key-types) + (or (memq (peek) '(in of)) + (error "Expected `of'")) + (let ((cl-map (cl--pop2 cl--loop-args)) + (other + (if (eq (peek) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (caadr cl--loop-args) key-types) + (not (eq (caadr cl--loop-args) word))) + (cadr (cl--pop2 cl--loop-args)) + (error "Bad `using' clause")) + (make-symbol "--cl-var--")))) + (if (memq word '(key-binding key-bindings)) + (setq var (prog1 other (setq other var)))) + (cl--loop-set-iterator-function + 'keys (lambda (body) + `(,(if (memq word '(key-seq key-seqs)) + 'cl--map-keymap-recursively 'map-keymap) + (lambda (,var ,other) . ,body) ,cl-map))))) + + ((memq word '(frame frames screen screens)) + (let ((temp (make-symbol "--cl-var--"))) + (push (list var '(selected-frame)) + loop-for-bindings) + (push (list temp nil) loop-for-bindings) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) + (push (list var `(next-frame ,var)) + loop-for-steps))) + + ((memq word '(window windows)) + (let ((scr (and (memq (peek) '(in of)) + (cl--pop2 cl--loop-args))) + (temp (make-symbol "--cl-var--")) + (minip (make-symbol "--cl-minip--"))) + (push (list var (if scr + `(frame-selected-window ,scr) + '(selected-window))) + loop-for-bindings) + ;; If we started in the minibuffer, we need to + ;; ensure that next-window will bring us back there + ;; at some point. (Bug#7492). + ;; (Consider using walk-windows instead of cl-loop if + ;; you care about such things.) + (push (list minip `(minibufferp (window-buffer ,var))) + loop-for-bindings) + (push (list temp nil) loop-for-bindings) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) + (push (list var `(next-window ,var ,minip)) + loop-for-steps))) + + (t + ;; This is an advertised interface: (info "(cl)Other Clauses"). + (let ((handler (and (symbolp word) + (get word 'cl-loop-for-handler)))) + (if handler + (funcall handler var) + (error "Expected a `for' preposition, found %s" word))))) + (eq (peek) 'and)) + (setq ands t) + (pop cl--loop-args)) + (if (and ands loop-for-bindings) + (push (nreverse loop-for-bindings) cl--loop-bindings) + (setq cl--loop-bindings (nconc (mapcar #'list loop-for-bindings) + cl--loop-bindings))) + (if loop-for-sets + (push `(progn + ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) + t) + cl--loop-body)) + (when loop-for-steps + (push (cons (if ands 'cl-psetq 'setq) + (apply #'append (nreverse loop-for-steps))) + cl--loop-steps)))) + + ((eq word 'repeat) + (let ((temp (make-symbol "--cl-var--"))) + (push (list (list temp (pop cl--loop-args))) cl--loop-bindings) + (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body))) + + ((memq word '(collect collecting)) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum nil 'nreverse))) + (if (eq var cl--loop-accum-var) + (push `(progn (push ,what ,var) t) cl--loop-body) + (push `(progn + (setq ,var (nconc ,var (list ,what))) t) - cl--loop-body)) - (when loop-for-steps - (push (cons (if ands 'cl-psetq 'setq) - (apply #'append (nreverse loop-for-steps))) - cl--loop-steps)))) - - ((eq word 'repeat) - (let ((temp (make-symbol "--cl-var--"))) - (push (list (list temp (pop cl--loop-args))) cl--loop-bindings) - (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body))) - - ((memq word '(collect collecting)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum nil 'nreverse))) - (if (eq var cl--loop-accum-var) - (push `(progn (push ,what ,var) t) cl--loop-body) - (push `(progn - (setq ,var (nconc ,var (list ,what))) + cl--loop-body)))) + + ((memq word '(nconc nconcing append appending)) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum nil 'nreverse))) + (push `(progn + (setq ,var + ,(if (eq var cl--loop-accum-var) + `(nconc + (,(if (memq word '(nconc nconcing)) + #'nreverse #'reverse) + ,what) + ,var) + `(,(if (memq word '(nconc nconcing)) + #'nconc #'append) + ,var ,what))) t) - cl--loop-body)))) - - ((memq word '(nconc nconcing append appending)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum nil 'nreverse))) - (push `(progn - (setq ,var - ,(if (eq var cl--loop-accum-var) - `(nconc - (,(if (memq word '(nconc nconcing)) - #'nreverse #'reverse) - ,what) - ,var) - `(,(if (memq word '(nconc nconcing)) - #'nconc #'append) - ,var ,what))) - t) - cl--loop-body))) - - ((memq word '(concat concating)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum ""))) - (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body))) - - ((memq word '(vconcat vconcating)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum []))) - (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body))) - - ((memq word '(sum summing)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum 0))) - (push `(progn (cl-incf ,var ,what) t) cl--loop-body))) - - ((memq word '(count counting)) - (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum 0))) - (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) - - ((memq word '(minimize minimizing maximize maximizing)) - (push `(progn ,(macroexp-let2 macroexp-copyable-p temp - (pop cl--loop-args) - (let* ((var (cl--loop-handle-accum nil)) - (func (intern (substring (symbol-name word) - 0 3)))) - `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) - t) - cl--loop-body)) - - ((eq word 'with) - (let ((bindings nil)) - (while (progn (push (list (pop cl--loop-args) - (and (eq (car cl--loop-args) '=) - (cl--pop2 cl--loop-args))) - bindings) - (eq (car cl--loop-args) 'and)) - (pop cl--loop-args)) - (push (nreverse bindings) cl--loop-bindings))) - - ((eq word 'while) - (push (pop cl--loop-args) cl--loop-body)) - - ((eq word 'until) - (push `(not ,(pop cl--loop-args)) cl--loop-body)) - - ((eq word 'always) - (or cl--loop-finish-flag - (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) - (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body) - (setq cl--loop-result t)) - - ((eq word 'never) - (or cl--loop-finish-flag - (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) - (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args))) - cl--loop-body) - (setq cl--loop-result t)) - - ((eq word 'thereis) - (or cl--loop-finish-flag - (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) - (or cl--loop-result-var - (setq cl--loop-result-var (make-symbol "--cl-var--"))) - (push `(setq ,cl--loop-finish-flag - (not (setq ,cl--loop-result-var ,(pop cl--loop-args)))) - cl--loop-body)) - - ((memq word '(if when unless)) - (let* ((cond (pop cl--loop-args)) - (then (let ((cl--loop-body nil)) - (cl--parse-loop-clause) - (cl--loop-build-ands (nreverse cl--loop-body)))) - (else (let ((cl--loop-body nil)) - (if (eq (car cl--loop-args) 'else) - (progn (pop cl--loop-args) (cl--parse-loop-clause))) - (cl--loop-build-ands (nreverse cl--loop-body)))) - (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car cl--loop-args) 'end) (pop cl--loop-args)) - (if (eq word 'unless) (setq then (prog1 else (setq else then)))) - (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) - (if simple (nth 1 else) (list (nth 2 else)))))) - (setq form (if (cl--expr-contains form 'it) - `(let ((it ,cond)) (if it ,@form)) - `(if ,cond ,@form))) - (push (if simple `(progn ,form t) form) cl--loop-body)))) - - ((memq word '(do doing)) - (let ((body nil)) - (or (consp (car cl--loop-args)) (error "Syntax error on `do' clause")) - (while (consp (car cl--loop-args)) (push (pop cl--loop-args) body)) - (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) - - ((eq word 'return) - (or cl--loop-finish-flag - (setq cl--loop-finish-flag (make-symbol "--cl-var--"))) - (or cl--loop-result-var - (setq cl--loop-result-var (make-symbol "--cl-var--"))) - (push `(setq ,cl--loop-result-var ,(pop cl--loop-args) - ,cl--loop-finish-flag nil) - cl--loop-body)) - - (t - ;; This is an advertised interface: (info "(cl)Other Clauses"). - (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) - (or handler (error "Expected a cl-loop keyword, found %s" word)) - (funcall handler)))) - (if (eq (car cl--loop-args) 'and) - (progn (pop cl--loop-args) (cl--parse-loop-clause))))) + cl--loop-body))) + + ((memq word '(concat concating)) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum ""))) + (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body))) + + ((memq word '(vconcat vconcating)) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum []))) + (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body))) + + ((memq word '(sum summing)) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum 0))) + (push `(progn (cl-incf ,var ,what) t) cl--loop-body))) + + ((memq word '(count counting)) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum 0))) + (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) + + ((memq word '(minimize minimizing maximize maximizing)) + (push `(progn ,(macroexp-let2 macroexp-copyable-p temp + (pop cl--loop-args) + (let* ((var (cl--loop-handle-accum nil)) + (func (intern (substring (symbol-name word) + 0 3)))) + `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) + t) + cl--loop-body)) + + ((eq word 'with) + (let ((bindings nil)) + (while (progn (push (list (pop cl--loop-args) + (and (eq (peek) '=) + (cl--pop2 cl--loop-args))) + bindings) + (eq (peek) 'and)) + (pop cl--loop-args)) + (push (nreverse bindings) cl--loop-bindings))) + + ((eq word 'while) + (push (pop cl--loop-args) cl--loop-body)) + + ((eq word 'until) + (push `(not ,(pop cl--loop-args)) cl--loop-body)) + + ((eq word 'always) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body) + (setq cl--loop-result t)) + + ((eq word 'never) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args))) + cl--loop-body) + (setq cl--loop-result t)) + + ((eq word 'thereis) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (or cl--loop-result-var + (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-finish-flag + (not (setq ,cl--loop-result-var ,(pop cl--loop-args)))) + cl--loop-body)) + + ((memq word '(if when unless)) + (let* ((cond (pop cl--loop-args)) + (then (let ((cl--loop-body nil)) + (cl--parse-loop-clause) + (cl--loop-build-ands (nreverse cl--loop-body)))) + (else (let ((cl--loop-body nil)) + (if (eq (peek) 'else) + (progn (pop cl--loop-args) (cl--parse-loop-clause))) + (cl--loop-build-ands (nreverse cl--loop-body)))) + (simple (and (eq (car then) t) (eq (car else) t)))) + (if (eq (peek) 'end) (pop cl--loop-args)) + (if (eq word 'unless) (setq then (prog1 else (setq else then)))) + (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) + (if simple (nth 1 else) (list (nth 2 else)))))) + (setq form (if (cl--expr-contains form 'it) + `(let ((it ,cond)) (if it ,@form)) + `(if ,cond ,@form))) + (push (if simple `(progn ,form t) form) cl--loop-body)))) + + ((memq word '(do doing)) + (let ((body nil)) + (or (consp (peek)) (error "Syntax error on `do' clause")) + (while (consp (peek)) (push (pop cl--loop-args) body)) + (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) + + ((eq word 'return) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-var--"))) + (or cl--loop-result-var + (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-result-var ,(pop cl--loop-args) + ,cl--loop-finish-flag nil) + cl--loop-body)) + + (t + ;; This is an advertised interface: (info "(cl)Other Clauses"). + (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) + (or handler (error "Expected a cl-loop keyword, found %s" word)) + (funcall handler)))) + (if (eq (peek) 'and) + (progn (pop cl--loop-args) (cl--parse-loop-clause)))))) (defun cl--unused-var-p (sym) (or (null sym) (eq ?_ (aref (symbol-name sym) 0)))) -- 2.37.3 ^ permalink raw reply related [flat|nested] 13+ messages in thread
* bug#57907: 29.0.50; Using keywords with cl-loop 2022-09-18 12:03 bug#57907: 29.0.50; Using keywords with cl-loop Philip Kaludercic 2022-09-18 12:20 ` Lars Ingebrigtsen [not found] ` <handler.57907.B.166350264228653.ack@debbugs.gnu.org> @ 2022-09-18 12:38 ` Gerd Möllmann 2022-09-18 12:52 ` Philip Kaludercic 2 siblings, 1 reply; 13+ messages in thread From: Gerd Möllmann @ 2022-09-18 12:38 UTC (permalink / raw) To: philipk; +Cc: 57907 From: Philip Kaludercic @ 2022-09-18 12:03 UTC (permalink / raw) To: 57907 > In Common Lisp the following to are equivalent > > (loop :repeat 5 :collect t) > > and > > (loop repeat 5 collect t) > > as keywords are shared among all packages. Actually, that's not the reason why Common Lisp accepts that. The reason is that the loop macro only looks at symbol names. In Common Lisp (symbol-name :a) => "A" (symbol-package :a) => #<PACKAGE "KEYWORD"> (symbol-name foo:a) => "A" (symbol-package foo:a) => #<PACKAGE "FOO"> while in Emacs (symbol-name :a) => ":a" Wouldn't it be nice if Emacs finally decided to have Common Lisp packages? ^ permalink raw reply [flat|nested] 13+ messages in thread
* bug#57907: 29.0.50; Using keywords with cl-loop 2022-09-18 12:38 ` bug#57907: 29.0.50; Using keywords with cl-loop Gerd Möllmann @ 2022-09-18 12:52 ` Philip Kaludercic 2022-09-18 13:01 ` Gerd Möllmann 0 siblings, 1 reply; 13+ messages in thread From: Philip Kaludercic @ 2022-09-18 12:52 UTC (permalink / raw) To: Gerd Möllmann; +Cc: 57907 Gerd Möllmann <gerd.moellmann@gmail.com> writes: > From: Philip Kaludercic @ 2022-09-18 12:03 UTC (permalink / raw) > To: 57907 > > >> In Common Lisp the following to are equivalent >> >> (loop :repeat 5 :collect t) >> >> and >> >> (loop repeat 5 collect t) >> >> as keywords are shared among all packages. > > Actually, that's not the reason why Common Lisp accepts that. The > reason is that the loop macro only looks at symbol names. In Common > Lisp > > (symbol-name :a) => "A" > (symbol-package :a) => #<PACKAGE "KEYWORD"> > (symbol-name foo:a) => "A" > (symbol-package foo:a) => #<PACKAGE "FOO"> Interesting, I did not know this. But the point remains that Common Lisp's loop accepts both the symbol "a" from the "COMMON-LISP" package and from the "KEYWORD" package, right? > while in Emacs > > (symbol-name :a) => ":a" > > Wouldn't it be nice if Emacs finally decided to have Common Lisp packages? Yeah, if only we could convince Emacs to do that ;) ^ permalink raw reply [flat|nested] 13+ messages in thread
* bug#57907: 29.0.50; Using keywords with cl-loop 2022-09-18 12:52 ` Philip Kaludercic @ 2022-09-18 13:01 ` Gerd Möllmann 0 siblings, 0 replies; 13+ messages in thread From: Gerd Möllmann @ 2022-09-18 13:01 UTC (permalink / raw) To: Philip Kaludercic; +Cc: 57907 Philip Kaludercic <philipk@posteo.net> writes: > Interesting, I did not know this. But the point remains that Common > Lisp's loop accepts both the symbol "a" from the "COMMON-LISP" package > and from the "KEYWORD" package, right? Right, from any package. The reason is that otherwise one couldn't write (loop repeat ...), for example, if a package defines its own repeat symbol. >> Wouldn't it be nice if Emacs finally decided to have Common Lisp packages? > > Yeah, if only we could convince Emacs to do that ;) I could convince Emacs, amd I would even invest the effort doing this, seriously. But there are obstacles... Hold on, I'm getting my popcorn out :-) ^ permalink raw reply [flat|nested] 13+ messages in thread
end of thread, other threads:[~2022-09-19 12:52 UTC | newest]
Thread overview: 13+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2022-09-18 12:03 bug#57907: 29.0.50; Using keywords with cl-loop Philip Kaludercic
2022-09-18 12:20 ` Lars Ingebrigtsen
2022-09-18 12:28 ` Philip Kaludercic
2022-09-18 12:37 ` Lars Ingebrigtsen
2022-09-18 12:46 ` Philip Kaludercic
2022-09-19 8:06 ` Lars Ingebrigtsen
2022-09-19 10:16 ` Philip Kaludercic
2022-09-19 12:52 ` Lars Ingebrigtsen
[not found] ` <handler.57907.B.166350264228653.ack@debbugs.gnu.org>
2022-09-18 12:26 ` bug#57907: Acknowledgement (29.0.50; Using keywords with cl-loop) Philip Kaludercic
2022-09-18 20:12 ` Philip Kaludercic
2022-09-18 12:38 ` bug#57907: 29.0.50; Using keywords with cl-loop Gerd Möllmann
2022-09-18 12:52 ` Philip Kaludercic
2022-09-18 13:01 ` Gerd Möllmann
Code repositories for project(s) associated with this external index https://git.savannah.gnu.org/cgit/emacs.git https://git.savannah.gnu.org/cgit/emacs/org-mode.git This is an external index of several public inboxes, see mirroring instructions on how to clone and mirror all data and code used by this external index.