mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-04-22 05:51:11 -07:00
Code Issues Projects Releases Wiki Activity

* lisp/emacs-lisp/cl-macs.el: Fix last change.

Browse source 
(cl--labels-magic): New constant.
(cl--labels-convert): Use it to ask the macro what is its replacement
in the #'f case.
This commit is contained in:
Stefan Monnier 2015-01-15 08:58:45 -05:00
parent 9d940c667a
commit 69f36afa11
3 changed files with 29 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

4
lisp/ChangeLog
View file

@ -38,6 +38,10 @@
2015-01-15 Stefan Monnier <monnier@iro.umontreal.ca>
* 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.

37
lisp/emacs-lisp/cl-macs.el
View file

@ -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.

3
test/automated/cl-lib-tests.el
View file

@ -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