From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Philip Kaludercic Newsgroups: gmane.emacs.bugs Subject: bug#57907: Acknowledgement (29.0.50; Using keywords with cl-loop) Date: Sun, 18 Sep 2022 12:26:46 +0000 Message-ID: <87pmfsdg1l.fsf@posteo.net> References: <87tu54dh3t.fsf@posteo.net> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="1801"; mail-complaints-to="usenet@ciao.gmane.io" To: 57907@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Sun Sep 18 14:28:50 2022 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1oZtPk-0000EV-4f for geb-bug-gnu-emacs@m.gmane-mx.org; Sun, 18 Sep 2022 14:28:48 +0200 Original-Received: from localhost ([::1]:40270 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1oZtPi-0005qH-ME for geb-bug-gnu-emacs@m.gmane-mx.org; Sun, 18 Sep 2022 08:28:46 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:42424) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1oZtP9-0005p3-4V for bug-gnu-emacs@gnu.org; Sun, 18 Sep 2022 08:28:11 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:49147) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1oZtOz-0007tH-T8 for bug-gnu-emacs@gnu.org; Sun, 18 Sep 2022 08:28:10 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1oZtOz-0008Ba-Lx for bug-gnu-emacs@gnu.org; Sun, 18 Sep 2022 08:28:01 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Philip Kaludercic Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sun, 18 Sep 2022 12:28:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 57907 X-GNU-PR-Package: emacs X-Debbugs-Original-To: help-debbugs@gnu.org (GNU bug Tracking System) X-Debbugs-Original-Cc: 57907@debbugs.gnu.org Original-Received: via spool by 57907-submit@debbugs.gnu.org id=B57907.166350402331378 (code B ref 57907); Sun, 18 Sep 2022 12:28:01 +0000 Original-Received: (at 57907) by debbugs.gnu.org; 18 Sep 2022 12:27:03 +0000 Original-Received: from localhost ([127.0.0.1]:48224 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1oZtO0-00089Z-T8 for submit@debbugs.gnu.org; Sun, 18 Sep 2022 08:27:03 -0400 Original-Received: from mout02.posteo.de ([185.67.36.66]:36725) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1oZtNx-00089I-MY for 57907@debbugs.gnu.org; Sun, 18 Sep 2022 08:26:59 -0400 Original-Received: from submission (posteo.de [185.67.36.169]) by mout02.posteo.de (Postfix) with ESMTPS id B49B7240105 for <57907@debbugs.gnu.org>; Sun, 18 Sep 2022 14:26:49 +0200 (CEST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=posteo.net; s=2017; t=1663504011; bh=BPshzgyVtjWlAQNha+wQgYZZtxt2OI0VTbLqM216dko=; h=From:To:Cc:Subject:Autocrypt:Date:From; b=sCM4xh+b/0fqJqEI2+BqJm7XN0+uNPwPaqLs1TH/XEGLxfvyY6ysnTqbyd1CDDmvA WmX4+/5NBQM1+4X+VNFsHP14TI88Oy7xalTqBSk6BRkFlxPxGXxAPNh0Du/Jl3H5mV jLzyt+dBK3w6iQAKIQ0rdX8zdPwWoQaDje8ewWgdks3BuktYc6+LkzU4lwV/BK6/eV +URYjSEpK6XZjzHE0hk4QDTjB1QtlhCAYe4320RUER73sfU/fLYCN92GLPk8xurDuc JBfyzEC65gA4hWNrjLL2O80V6Oxmm8r4MMpNPfpJq5ErwqwIFwZyNoadyX94EDjcWs gyyhuL6z+7HVQ== Original-Received: from customer (localhost [127.0.0.1]) by submission (posteo.de) with ESMTPSA id 4MVn9h25nzz9rxL; Sun, 18 Sep 2022 14:26:47 +0200 (CEST) In-Reply-To: (GNU bug Tracking System's message of "Sun, 18 Sep 2022 12:05:02 +0000") Autocrypt: addr=philipk@posteo.net; prefer-encrypt=nopreference; keydata= mDMEYHHqUhYJKwYBBAHaRw8BAQdAp3GdmYJ6tm5McweY6dEvIYIiry+Oz9rU4MH6NHWK0Ee0QlBo aWxpcCBLYWx1ZGVyY2ljIChnZW5lcmF0ZWQgYnkgYXV0b2NyeXB0LmVsKSA8cGhpbGlwa0Bwb3N0 ZW8ubmV0PoiQBBMWCAA4FiEEDM2H44ZoPt9Ms0eHtVrAHPRh1FwFAmBx6lICGwMFCwkIBwIGFQoJ CAsCBBYCAwECHgECF4AACgkQtVrAHPRh1FyTkgEAjlbGPxFchvMbxzAES3r8QLuZgCxeAXunM9gh io0ePtUBALVhh9G6wIoZhl0gUCbQpoN/UJHI08Gm1qDob5zDxnIHuDgEYHHqUhIKKwYBBAGXVQEF AQEHQNcRB+MUimTMqoxxMMUERpOR+Q4b1KgncDZkhrO2ql1tAwEIB4h4BBgWCAAgFiEEDM2H44Zo Pt9Ms0eHtVrAHPRh1FwFAmBx6lICGwwACgkQtVrAHPRh1Fw1JwD/Qo7kvtib8jy7puyWrSv0MeTS g8qIxgoRWJE/KKdkCLEA/jb9b9/g8nnX+UcwHf/4VfKsjExlnND3FrBviXUW6NcB X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.io gmane.emacs.bugs:242975 Archived-At: --=-=-= Content-Type: text/plain It seems it isn't that difficult to do this (though the patch is longer than it ought to be because of indentation changes): --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-Have-cl-loop-handle-keyword-symbols.patch >From d98dc3e0905d41305061708a601d63659fa7ce81 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic 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 --=-=-= Content-Type: text/plain Perhaps I could pull the cl-flet out and replace each (next) with a (cl--loop-parse-next)? --=-=-=--