* lisp/emacs-lisp/macroexp.el (macroexp-parse-body): Handle cl-declare

and :documentation.  Change return value format accordingly.
* lisp/emacs-lisp/cl-generic.el (cl--generic-lambda):
* lisp/emacs-lisp/pcase.el (pcase-lambda): Adjust accordingly.
* lisp/emacs-lisp/cl-macs.el (cl--transform-lambda): Use macroexp-parse-body.
This commit is contained in:
Stefan Monnier 2015-02-22 23:50:03 -05:00
parent 3f006e1d47
commit e846bbf360
5 changed files with 36 additions and 30 deletions

View file

@ -278,7 +278,7 @@ This macro can only be used within the lexical scope of a cl-generic method."
(uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
(cons (not (not uses-cnm))
`#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
,@(delq nil (car parsed-body))
,@(car parsed-body)
,(if (not (memq nmp uses-cnm))
nbody
`(let ((,nmp (lambda ()

View file

@ -234,10 +234,9 @@ FORM is of the form (ARGS . BODY)."
(let* ((args (car form)) (body (cdr form)) (orig-args args)
(cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
(cl--bind-lets nil) (cl--bind-forms nil)
(header nil) (simple-args nil))
(while (or (stringp (car body))
(memq (car-safe (car body)) '(interactive declare cl-declare)))
(push (pop body) header))
(parsed-body (macroexp-parse-body body))
(header (car parsed-body)) (simple-args nil))
(setq body (cdr parsed-body))
(setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
@ -258,7 +257,7 @@ FORM is of the form (ARGS . BODY)."
(or (eq cl--bind-block 'cl-none)
(setq body (list `(cl-block ,cl--bind-block ,@body))))
(if (null args)
(cl-list* nil (nreverse simple-args) (nconc (nreverse header) body))
(cl-list* nil (nreverse simple-args) (nconc header body))
(if (memq '&optional simple-args) (push '&optional args))
(cl--do-arglist args nil (- (length simple-args)
(if (memq '&optional simple-args) 1 0)))
@ -266,20 +265,18 @@ FORM is of the form (ARGS . BODY)."
(cl-list* nil
(nconc (nreverse simple-args)
(list '&rest (car (pop cl--bind-lets))))
(nconc (let ((hdr (nreverse header)))
;; Macro expansion can take place in the middle of
;; apparently harmless computation, so it should not
;; touch the match-data.
(save-match-data
(require 'help-fns)
(cons (help-add-fundoc-usage
(if (stringp (car hdr)) (pop hdr))
;; Be careful with make-symbol and (back)quote,
;; see bug#12884.
(let ((print-gensym nil) (print-quoted t))
(format "%S" (cons 'fn (cl--make-usage-args
orig-args)))))
hdr)))
(nconc (save-match-data ;; Macro expansion can take place in the
;; middle of apparently harmless computation, so it
;; should not touch the match-data.
(require 'help-fns)
(cons (help-add-fundoc-usage
(if (stringp (car header)) (pop header))
;; Be careful with make-symbol and (back)quote,
;; see bug#12884.
(let ((print-gensym nil) (print-quoted t))
(format "%S" (cons 'fn (cl--make-usage-args
orig-args)))))
header))
(list `(let* ,cl--bind-lets
,@(nreverse cl--bind-forms)
,@body)))))))

View file

@ -297,15 +297,16 @@ definitions to shadow the loaded ones for use in file byte-compilation."
;;; Handy functions to use in macros.
(defun macroexp-parse-body (exps)
"Parse EXPS into ((DOC DECLARE-FORM INTERACTIVE-FORM) . BODY)."
`((,(and (stringp (car exps))
(pop exps))
,(and (eq (car-safe (car exps)) 'declare)
(pop exps))
,(and (eq (car-safe (car exps)) 'interactive)
(pop exps)))
,@exps))
(defun macroexp-parse-body (body)
"Parse a function BODY into (DECLARATIONS . EXPS)."
(let ((decls ()))
(while (and (cdr body)
(let ((e (car body)))
(or (stringp e)
(memq (car-safe e)
'(:documentation declare interactive cl-declare)))))
(push (pop body) decls))
(cons (nreverse decls) body)))
(defun macroexp-progn (exps)
"Return an expression equivalent to `(progn ,@EXPS)."

View file

@ -180,7 +180,7 @@ like `(,a . ,(pred (< a))) or, with more checks:
(when (eq nil (car (last pats 2)))
(setq pats (append (butlast pats 2) (car (last pats)))))
`(lambda (&rest ,args)
,@(remq nil (car body))
,@(car body)
(pcase ,args
(,(list '\` pats) . ,(cdr body))))))