* 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:
parent
3f006e1d47
commit
e846bbf360
5 changed files with 36 additions and 30 deletions
|
@ -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 ()
|
||||
|
|
|
@ -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)))))))
|
||||
|
|
|
@ -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)."
|
||||
|
|
|
@ -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))))))
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue