[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] trunk r114465: * lisp/emacs-lisp/cl-macs.el:
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] trunk r114465: * lisp/emacs-lisp/cl-macs.el: |
|
Date: |
Sat, 28 Sep 2013 01:07:22 +0000 |
|
User-agent: |
Bazaar (2.6b2) |
------------------------------------------------------------
revno: 114465
revision-id: address@hidden
parent: address@hidden
fixes bug: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=15326
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Fri 2013-09-27 21:07:18 -0400
message:
* lisp/emacs-lisp/cl-macs.el:
(cl--loop-destr-temps): Remove.
(cl--loop-iterator-function): Rename from cl--loop-map-form and change
its convention.
(cl--loop-set-iterator-function): New function.
(cl-loop): Adjust accordingly, so as not to use cl-subst.
(cl--parse-loop-clause): Adjust all uses of cl--loop-map-form.
Bind `it' with `let' instead of substituting it with `cl-subst'.
(cl--unused-var-p): New function.
(cl--loop-let): Don't use the cl--loop-destr-temps hack any more.
Eliminate some unused variable warnings.
modified:
lisp/ChangeLog changelog-20091113204419-o5vbwnq5f7feedwu-1432
lisp/emacs-lisp/cl-macs.el clmacs.el-20091113204419-o5vbwnq5f7feedwu-612
=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog 2013-09-27 06:46:49 +0000
+++ b/lisp/ChangeLog 2013-09-28 01:07:18 +0000
@@ -1,3 +1,17 @@
+2013-09-28 Stefan Monnier <address@hidden>
+
+ * emacs-lisp/cl-macs.el:
+ (cl--loop-destr-temps): Remove.
+ (cl--loop-iterator-function): Rename from cl--loop-map-form and change
+ its convention.
+ (cl--loop-set-iterator-function): New function.
+ (cl-loop): Adjust accordingly, so as not to use cl-subst.
+ (cl--parse-loop-clause): Adjust all uses of cl--loop-map-form.
+ Bind `it' with `let' instead of substituting it with `cl-subst'.
+ (cl--unused-var-p): New function.
+ (cl--loop-let): Don't use the cl--loop-destr-temps hack any more.
+ Eliminate some unused variable warnings (bug#15326).
+
2013-09-27 Tassilo Horn <address@hidden>
* doc-view.el (doc-view-scale-reset): Rename from
=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- a/lisp/emacs-lisp/cl-macs.el 2013-09-25 22:39:53 +0000
+++ b/lisp/emacs-lisp/cl-macs.el 2013-09-28 01:07:18 +0000
@@ -756,14 +756,22 @@
;;; The "cl-loop" macro.
(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars)
-(defvar cl--loop-bindings) (defvar cl--loop-body) (defvar cl--loop-destr-temps)
-(defvar cl--loop-finally) (defvar cl--loop-finish-flag)
+(defvar cl--loop-bindings) (defvar cl--loop-body)
+(defvar cl--loop-finally)
+(defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop?
(defvar cl--loop-first-flag)
-(defvar cl--loop-initially) (defvar cl--loop-map-form) (defvar cl--loop-name)
+(defvar cl--loop-initially) (defvar cl--loop-iterator-function)
+(defvar cl--loop-name)
(defvar cl--loop-result) (defvar cl--loop-result-explicit)
(defvar cl--loop-result-var) (defvar cl--loop-steps)
(defvar cl--loop-symbol-macs)
+(defun cl--loop-set-iterator-function (kind iterator)
+ (if cl--loop-iterator-function
+ ;; FIXME: Of course, we could make it work, but why bother.
+ (error "Iteration on %S does not support this combination" kind)
+ (setq cl--loop-iterator-function iterator)))
+
;;;###autoload
(defmacro cl-loop (&rest loop-args)
"The Common Lisp `loop' macro.
@@ -817,13 +825,35 @@
(delq nil (delq t (cl-copy-list 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)
- (cl--loop-result nil) (cl--loop-result-explicit nil)
- (cl--loop-result-var nil) (cl--loop-finish-flag nil)
+ (cl--loop-body nil) (cl--loop-steps nil)
+ (cl--loop-result nil) (cl--loop-result-explicit nil)
+ (cl--loop-result-var nil) (cl--loop-finish-flag nil)
(cl--loop-accum-var nil) (cl--loop-accum-vars nil)
(cl--loop-initially nil) (cl--loop-finally nil)
- (cl--loop-map-form nil) (cl--loop-first-flag nil)
- (cl--loop-destr-temps nil) (cl--loop-symbol-macs nil))
+ (cl--loop-iterator-function nil) (cl--loop-first-flag nil)
+ (cl--loop-symbol-macs nil))
+ ;; Here is more or less how those dynbind vars are used after looping
+ ;; over cl--parse-loop-clause:
+ ;;
+ ;; (cl-block ,cl--loop-name
+ ;; (cl-symbol-macrolet ,cl--loop-symbol-macs
+ ;; (foldl #'cl--loop-let
+ ;; `((,cl--loop-result-var)
+ ;; ((,cl--loop-first-flag t))
+ ;; ((,cl--loop-finish-flag t))
+ ;; ,@cl--loop-bindings)
+ ;; ,@(nreverse cl--loop-initially)
+ ;; (while ;(well: cl--loop-iterator-function)
+ ;; ,(car (cl--loop-build-ands (nreverse cl--loop-body)))
+ ;; ,@(cadr (cl--loop-build-ands (nreverse cl--loop-body)))
+ ;; ,@(nreverse cl--loop-steps)
+ ;; (setq ,cl--loop-first-flag nil))
+ ;; (if (not ,cl--loop-finish-flag) ;FIXME: Why `if' vs `progn'?
+ ;; ,cl--loop-result-var
+ ;; ,@(nreverse cl--loop-finally)
+ ;; ,(or cl--loop-result-explicit
+ ;; cl--loop-result)))))
+ ;;
(setq cl--loop-args (append cl--loop-args '(cl-end-loop)))
(while (not (eq (car cl--loop-args) 'cl-end-loop))
(cl--parse-loop-clause))
@@ -839,15 +869,15 @@
(while-body (nconc (cadr ands) (nreverse cl--loop-steps)))
(body (append
(nreverse cl--loop-initially)
- (list (if cl--loop-map-form
+ (list (if cl--loop-iterator-function
`(cl-block --cl-finish--
- ,(cl-subst
- (if (eq (car ands) t) while-body
- (cons `(or ,(car ands)
- (cl-return-from --cl-finish--
- nil))
- while-body))
- '--cl-map cl--loop-map-form))
+ ,(funcall cl--loop-iterator-function
+ (if (eq (car ands) t) while-body
+ (cons `(or ,(car ands)
+ (cl-return-from
+ --cl-finish--
+ nil))
+ while-body))))
`(while ,(car ands) ,@while-body)))
(if cl--loop-finish-flag
(if (equal epilogue '(nil)) (list cl--loop-result-var)
@@ -1216,15 +1246,18 @@
(make-symbol "--cl-var--"))))
(if (memq word '(hash-value hash-values))
(setq var (prog1 other (setq other var))))
- (setq cl--loop-map-form
- `(maphash (lambda (,var ,other) . --cl-map) ,table))))
+ (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))))
- (setq cl--loop-map-form
- `(mapatoms (lambda (,var) . --cl-map) ,ob))))
+ (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))
@@ -1234,11 +1267,12 @@
((eq (car cl--loop-args) 'to)
(setq to (cl--pop2 cl--loop-args)))
(t (setq buf (cl--pop2 cl--loop-args)))))
- (setq cl--loop-map-form
- `(cl--map-overlays
- (lambda (,var ,(make-symbol "--cl-var--"))
- (progn . --cl-map) nil)
- ,buf ,from ,to))))
+ (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)
@@ -1255,10 +1289,11 @@
(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))
- (setq cl--loop-map-form
- `(cl--map-intervals
- (lambda (,var1 ,var2) . --cl-map)
- ,buf ,prop ,from ,to))))
+ (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))
@@ -1274,10 +1309,11 @@
(make-symbol "--cl-var--"))))
(if (memq word '(key-binding key-bindings))
(setq var (prog1 other (setq other var))))
- (setq cl--loop-map-form
- `(,(if (memq word '(key-seq key-seqs))
- 'cl--map-keymap-recursively 'map-keymap)
- (lambda (,var ,other) . --cl-map) ,cl-map))))
+ (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--")))
@@ -1448,12 +1484,9 @@
(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))))))
- (if (cl--expr-contains form 'it)
- (let ((temp (make-symbol "--cl-var--")))
- (push (list temp) cl--loop-bindings)
- (setq form `(if (setq ,temp ,cond)
- ,@(cl-subst temp 'it form))))
- (setq form `(if ,cond ,@form)))
+ (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))
@@ -1478,36 +1511,50 @@
(if (eq (car cl--loop-args) 'and)
(progn (pop cl--loop-args) (cl--parse-loop-clause)))))
-(defun cl--loop-let (specs body par) ; uses loop-*
- (let ((p specs) (temps nil) (new nil))
- (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p))))
- (setq p (cdr p)))
- (and par p
- (progn
- (setq par nil p specs)
- (while p
- (or (macroexp-const-p (cl-cadar p))
- (let ((temp (make-symbol "--cl-var--")))
- (push (list temp (cl-cadar p)) temps)
- (setcar (cdar p) temp)))
- (setq p (cdr p)))))
+(defun cl--unused-var-p (sym)
+ (or (null sym) (eq ?_ (aref (symbol-name sym) 0))))
+
+(defun cl--loop-let (specs body par) ; modifies cl--loop-bindings
+ "Build an expression equivalent to (let SPECS BODY).
+SPECS can include bindings using `cl-loop's destructuring (not to be
+confused with the patterns of `cl-destructuring-bind').
+If PAR is nil, do the bindings step by step, like `let*'.
+If BODY is `setq', then use SPECS for assignments rather than for bindings."
+ (let ((temps nil) (new nil))
+ (when par
+ (let ((p specs))
+ (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p))))
+ (setq p (cdr p)))
+ (when p
+ (setq par nil)
+ (dolist (spec specs)
+ (or (macroexp-const-p (cadr spec))
+ (let ((temp (make-symbol "--cl-var--")))
+ (push (list temp (cadr spec)) temps)
+ (setcar (cdr spec) temp)))))))
(while specs
- (if (and (consp (car specs)) (listp (caar specs)))
- (let* ((spec (caar specs)) (nspecs nil)
- (expr (cadr (pop specs)))
- (temp
- (cdr (or (assq spec cl--loop-destr-temps)
- (car (push (cons spec
- (or (last spec 0)
- (make-symbol "--cl-var--")))
- cl--loop-destr-temps))))))
- (push (list temp expr) new)
- (while (consp spec)
- (push (list (pop spec)
- (and expr (list (if spec 'pop 'car) temp)))
- nspecs))
- (setq specs (nconc (nreverse nspecs) specs)))
- (push (pop specs) new)))
+ (let* ((binding (pop specs))
+ (spec (car-safe binding)))
+ (if (and (consp binding) (or (consp spec) (cl--unused-var-p spec)))
+ (let* ((nspecs nil)
+ (expr (car (cdr-safe binding)))
+ (temp (last spec 0)))
+ (if (and (cl--unused-var-p temp) (null expr))
+ nil ;; Don't bother declaring/setting `temp' since it won't
+ ;; be used when `expr' is nil, anyway.
+ (when (and (eq body 'setq) (cl--unused-var-p temp))
+ ;; Prefer a fresh uninterned symbol over "_to", to avoid
+ ;; warnings that we set an unused variable.
+ (setq temp (make-symbol "--cl-var--"))
+ ;; Make sure this temp variable is locally declared.
+ (push (list (list temp)) cl--loop-bindings))
+ (push (list temp expr) new))
+ (while (consp spec)
+ (push (list (pop spec)
+ (and expr (list (if spec 'pop 'car) temp)))
+ nspecs))
+ (setq specs (nconc (nreverse nspecs) specs)))
+ (push binding new))))
(if (eq body 'setq)
(let ((set (cons (if par 'cl-psetq 'setq)
(apply 'nconc (nreverse new)))))
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] trunk r114465: * lisp/emacs-lisp/cl-macs.el:,
Stefan Monnier <=