[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 69f36af 2/2: * lisp/emacs-lisp/cl-macs.el: Fix last
From: |
Stefan Monnier |
Subject: |
[Emacs-diffs] master 69f36af 2/2: * lisp/emacs-lisp/cl-macs.el: Fix last change. |
Date: |
Fri, 16 Jan 2015 22:49:21 +0000 |
branch: master
commit 69f36afa11c0b754c40f4fc57408ccd85428e2b0
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>
* lisp/emacs-lisp/cl-macs.el: Fix last change.
(cl--labels-magic): New constant.
(cl--labels-convert): Use it to ask the macro what is its replacement
in the #'f case.
---
lisp/ChangeLog | 4 ++++
lisp/emacs-lisp/cl-macs.el | 37 ++++++++++++++++++++++---------------
test/automated/cl-lib-tests.el | 3 +++
3 files changed, 29 insertions(+), 15 deletions(-)
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index c6e315e..c80f8f7 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -38,6 +38,10 @@
2015-01-15 Stefan Monnier <address@hidden>
+ * emacs-lisp/cl-macs.el (cl--labels-magic): New constant.
+ (cl--labels-convert): Use it to ask the macro what is its replacement
+ in the #'f case.
+
* emacs-lisp/cl-generic.el (cl--generic-build-combined-method):
Return the value of the primary rather than the after method.
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 0070599..38f15b8 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1807,6 +1807,8 @@ a `let' form, except that the list of symbols can be
computed at run-time."
(push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds))
(eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun))))))))
+(defconst cl--labels-magic (make-symbol "cl--labels-magic"))
+
(defvar cl--labels-convert-cache nil)
(defun cl--labels-convert (f)
@@ -1818,10 +1820,12 @@ a `let' form, except that the list of symbols can be
computed at run-time."
;; being expanded even though we don't receive it.
((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache))
(t
- (let ((found (assq f macroexpand-all-environment)))
- (if (and found (ignore-errors
- (eq (cadr (cl-caddr found)) 'cl-labels-args)))
- (cadr (cl-caddr (cl-cadddr found)))
+ (let* ((found (assq f macroexpand-all-environment))
+ (replacement (and found
+ (ignore-errors
+ (funcall (cdr found) cl--labels-magic)))))
+ (if (and replacement (eq cl--labels-magic (car replacement)))
+ (nth 1 replacement)
(let ((res `(function ,f)))
(setq cl--labels-convert-cache (cons f res))
res))))))
@@ -1850,17 +1854,18 @@ for (FUNC (lambda ARGLIST BODY)).
`(cl-function (lambda . ,args-and-body))))
binds))
(push (cons (car binding)
- (lambda (&rest cl-labels-args)
- (cl-list* 'funcall var cl-labels-args)))
+ (lambda (&rest args)
+ (if (eq (car args) cl--labels-magic)
+ (list cl--labels-magic var)
+ `(funcall ,var ,@args))))
newenv)))
;; FIXME: Eliminate those functions which aren't referenced.
- `(let ,(nreverse binds)
- ,@(macroexp-unprogn
- (macroexpand-all
- `(progn ,@body)
- ;; Don't override lexical-let's macro-expander.
- (if (assq 'function newenv) newenv
- (cons (cons 'function #'cl--labels-convert) newenv)))))))
+ (macroexp-let* (nreverse binds)
+ (macroexpand-all
+ `(progn ,@body)
+ ;; Don't override lexical-let's macro-expander.
+ (if (assq 'function newenv) newenv
+ (cons (cons 'function #'cl--labels-convert) newenv))))))
;;;###autoload
(defmacro cl-flet* (bindings &rest body)
@@ -1887,8 +1892,10 @@ in closures will only work if `lexical-binding' is in
use.
(let ((var (make-symbol (format "--cl-%s--" (car binding)))))
(push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
(push (cons (car binding)
- (lambda (&rest cl-labels-args)
- (cl-list* 'funcall var cl-labels-args)))
+ (lambda (&rest args)
+ (if (eq (car args) cl--labels-magic)
+ (list cl--labels-magic var)
+ (cl-list* 'funcall var args))))
newenv)))
(macroexpand-all `(letrec ,(nreverse binds) ,@body)
;; Don't override lexical-let's macro-expander.
diff --git a/test/automated/cl-lib-tests.el b/test/automated/cl-lib-tests.el
index bbfb8d1..c83391b 100644
--- a/test/automated/cl-lib-tests.el
+++ b/test/automated/cl-lib-tests.el
@@ -245,4 +245,7 @@
(ert-deftest cl-loop-destructuring-with ()
(should (equal (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6)))
+(ert-deftest cl-flet-test ()
+ (should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5)))
+
;;; cl-lib.el ends here