* lisp/emacs-lisp/cl-macs.el (cl--transform-lambda): Optimize &aux.
Rework to avoid cl--do-arglist in more cases; add comments to explain what's going on. (cl--do-&aux): New function extracted from cl--do-arglist. (cl--do-arglist): Use it. * lisp/emacs-lisp/cl-generic.el: Add Version: header, for ELPA purposes.
This commit is contained in:
Stefan Monnier
parent
f925fc93ba
commit
801eda8a2a
4 changed files with 124 additions and 49 deletions
|
|
@ -1,5 +1,12 @@
|
|||
2015-03-16 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/cl-macs.el (cl--transform-lambda): Rework to avoid
|
||||
cl--do-arglist in more cases; add comments to explain what's going on.
|
||||
(cl--do-&aux): New function extracted from cl--do-arglist.
|
||||
(cl--do-arglist): Use it.
|
||||
|
||||
* emacs-lisp/cl-generic.el: Add Version: header, for ELPA purposes.
|
||||
|
||||
* obsolete/iswitchb.el (iswitchb-read-buffer): Add `predicate' arg.
|
||||
* isearchb.el (isearchb-iswitchb): Adjust accordingly.
|
||||
* ido.el (ido-read-buffer): Add `predicate' argument.
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
;; Copyright (C) 2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
;; Version: 1.0
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
|
|
|
|||
|
|
@ -220,7 +220,20 @@ The name is made by appending a number to PREFIX, default \"G\"."
|
|||
(defconst cl--lambda-list-keywords
|
||||
'(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
|
||||
|
||||
(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
|
||||
;; Internal hacks used in formal arg lists:
|
||||
;; - &cl-quote: Added to formal-arglists to mean that any default value
|
||||
;; mentioned in the formal arglist should be considered as implicitly
|
||||
;; quoted rather than evaluated. This is used in `cl-defsubst' when
|
||||
;; performing compiler-macro-expansion, since at that time the
|
||||
;; arguments hold expressions rather than values.
|
||||
;; - &cl-defs (DEF . DEFS): Gives the default value to use for missing
|
||||
;; optional arguments which don't have an explicit default value.
|
||||
;; DEFS is an alist mapping vars to their default default value.
|
||||
;; and DEF is the default default to use for all other vars.
|
||||
|
||||
(defvar cl--bind-block) ;Name of surrounding block, only use for `signal' data.
|
||||
(defvar cl--bind-defs) ;(DEF . DEFS) giving the "default default" for optargs.
|
||||
(defvar cl--bind-enquote) ;Non-nil if &cl-quote was in the formal arglist!
|
||||
(defvar cl--bind-lets) (defvar cl--bind-forms)
|
||||
|
||||
(defun cl--transform-lambda (form bind-block)
|
||||
|
|
@ -229,19 +242,26 @@ BIND-BLOCK is the name of the symbol to which the function will be bound,
|
|||
and which will be used for the name of the `cl-block' surrounding the
|
||||
function's body.
|
||||
FORM is of the form (ARGS . BODY)."
|
||||
;; FIXME: (lambda (a &aux b) 1) expands to (lambda (a &rest --cl-rest--) ...)
|
||||
;; where the --cl-rest-- is clearly undesired.
|
||||
(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)
|
||||
(parsed-body (macroexp-parse-body body))
|
||||
(header (car parsed-body)) (simple-args nil))
|
||||
(setq body (cdr parsed-body))
|
||||
;; "(. X) to (&rest X)" conversion already done in cl--do-arglist, but we
|
||||
;; do it here as well, so as to be able to see if we can avoid
|
||||
;; cl--do-arglist.
|
||||
(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)))
|
||||
(setq args (delq '&cl-defs (delq cl--bind-defs args))
|
||||
cl--bind-defs (cadr cl--bind-defs)))
|
||||
(let ((cl-defs (memq '&cl-defs args)))
|
||||
(when cl-defs
|
||||
(setq cl--bind-defs (cadr cl-defs))
|
||||
;; Remove "&cl-defs DEFS" from args.
|
||||
(setcdr cl-defs (cddr cl-defs))
|
||||
(setq args (delq '&cl-defs args))
|
||||
;; Optimize away trivial &cl-defs.
|
||||
(if (and (null (car cl--bind-defs))
|
||||
(cl-every (lambda (x) (null (cadr x))) (cdr cl--bind-defs)))
|
||||
(setq cl--bind-defs nil))))
|
||||
(if (setq cl--bind-enquote (memq '&cl-quote args))
|
||||
(setq args (delq '&cl-quote args)))
|
||||
(if (memq '&whole args) (error "&whole not currently implemented"))
|
||||
|
|
@ -249,6 +269,9 @@ FORM is of the form (ARGS . BODY)."
|
|||
(v (cadr p)))
|
||||
(if p (setq args (nconc (delq (car p) (delq v args))
|
||||
`(&aux (,v macroexpand-all-environment))))))
|
||||
;; Take away all the simple args whose parsing can be handled more
|
||||
;; efficiently by a plain old `lambda' than the manual parsing generated
|
||||
;; by `cl--do-arglist'.
|
||||
(while (and args (symbolp (car args))
|
||||
(not (memq (car args) '(nil &rest &body &key &aux)))
|
||||
(not (and (eq (car args) '&optional)
|
||||
|
|
@ -256,30 +279,50 @@ FORM is of the form (ARGS . BODY)."
|
|||
(push (pop args) simple-args))
|
||||
(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 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)))
|
||||
(setq cl--bind-lets (nreverse cl--bind-lets))
|
||||
(cl-list* nil
|
||||
(nconc (nreverse simple-args)
|
||||
(list '&rest (car (pop cl--bind-lets))))
|
||||
(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)))))))
|
||||
(let* ((cl--bind-lets nil) (cl--bind-forms nil)
|
||||
(rest-args
|
||||
(cond
|
||||
((null args) nil)
|
||||
((eq (car args) '&aux)
|
||||
(cl--do-&aux args)
|
||||
(setq cl--bind-lets (nreverse cl--bind-lets))
|
||||
nil)
|
||||
(t ;; `simple-args' doesn't handle all the parsing that we need,
|
||||
;; so we pass the rest to cl--do-arglist which will do
|
||||
;; "manual" parsing.
|
||||
(let ((slen (length simple-args)))
|
||||
(when (memq '&optional simple-args)
|
||||
(push '&optional args) (cl-decf slen))
|
||||
(setq 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 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)))
|
||||
;; FIXME: we'd want to choose an arg name for the &rest param
|
||||
;; and pass that as `expr' to cl--do-arglist, but that ends up
|
||||
;; generating code with a redundant let-binding, so we instead
|
||||
;; pass a dummy and then look in cl--bind-lets to find what var
|
||||
;; this was bound to.
|
||||
(cl--do-arglist args :dummy slen)
|
||||
(setq cl--bind-lets (nreverse cl--bind-lets))
|
||||
;; (cl-assert (eq :dummy (nth 1 (car cl--bind-lets))))
|
||||
(list '&rest (car (pop cl--bind-lets))))))))
|
||||
`(nil
|
||||
(,@(nreverse simple-args) ,@rest-args)
|
||||
,@header
|
||||
,(macroexp-let* cl--bind-lets
|
||||
(macroexp-progn
|
||||
`(,@(nreverse cl--bind-forms)
|
||||
,@body)))))))
|
||||
|
||||
;;;###autoload
|
||||
(defmacro cl-defun (name args &rest body)
|
||||
|
|
@ -422,8 +465,7 @@ its argument list allows full Common Lisp conventions."
|
|||
(setcdr last nil)
|
||||
(nconc (cl--make-usage-args arglist) (cl--make-usage-var tail)))
|
||||
(setcdr last tail)))
|
||||
;; `orig-args' can contain &cl-defs (an internal
|
||||
;; CL thingy I don't understand), so remove it.
|
||||
;; `orig-args' can contain &cl-defs.
|
||||
(let ((x (memq '&cl-defs arglist)))
|
||||
(when x (setq arglist (delq (car x) (remq (cadr x) arglist)))))
|
||||
(let ((state nil))
|
||||
|
|
@ -450,6 +492,17 @@ its argument list allows full Common Lisp conventions."
|
|||
))))
|
||||
arglist))))
|
||||
|
||||
(defun cl--do-&aux (args)
|
||||
(while (and (eq (car args) '&aux) (pop args))
|
||||
(while (and args (not (memq (car args) cl--lambda-list-keywords)))
|
||||
(if (consp (car args))
|
||||
(if (and cl--bind-enquote (cl-cadar args))
|
||||
(cl--do-arglist (caar args)
|
||||
`',(cadr (pop args)))
|
||||
(cl--do-arglist (caar args) (cadr (pop args))))
|
||||
(cl--do-arglist (pop args) nil))))
|
||||
(if args (error "Malformed argument list ends with: %S" args)))
|
||||
|
||||
(defun cl--do-arglist (args expr &optional num) ; uses cl--bind-*
|
||||
(if (nlistp args)
|
||||
(if (or (memq args cl--lambda-list-keywords) (not (symbolp args)))
|
||||
|
|
@ -459,8 +512,7 @@ its argument list allows full Common Lisp conventions."
|
|||
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
|
||||
(let ((p (memq '&body args))) (if p (setcar p '&rest)))
|
||||
(if (memq '&environment args) (error "&environment used incorrectly"))
|
||||
(let ((save-args args)
|
||||
(restarg (memq '&rest args))
|
||||
(let ((restarg (memq '&rest args))
|
||||
(safety (if (cl--compiling-file) cl--optimize-safety 3))
|
||||
(keys nil)
|
||||
(laterarg nil) (exactarg nil) minarg)
|
||||
|
|
@ -530,7 +582,12 @@ its argument list allows full Common Lisp conventions."
|
|||
(intern (format ":%s" name)))))
|
||||
(varg (if (consp (car arg)) (cl-cadar arg) (car arg)))
|
||||
(def (if (cdr arg) (cadr arg)
|
||||
(or (car cl--bind-defs) (cadr (assq varg cl--bind-defs)))))
|
||||
;; The ordering between those two or clauses is
|
||||
;; irrelevant, since in practice only one of the two
|
||||
;; is ever non-nil (the car is only used for
|
||||
;; cl-deftype which doesn't use the cdr).
|
||||
(or (car cl--bind-defs)
|
||||
(cadr (assq varg cl--bind-defs)))))
|
||||
(look `(plist-member ,restarg ',karg)))
|
||||
(and def cl--bind-enquote (setq def `',def))
|
||||
(if (cddr arg)
|
||||
|
|
@ -567,15 +624,8 @@ its argument list allows full Common Lisp conventions."
|
|||
keys)
|
||||
(car ,var)))))))
|
||||
(push `(let ((,var ,restarg)) ,check) cl--bind-forms)))
|
||||
(while (and (eq (car args) '&aux) (pop args))
|
||||
(while (and args (not (memq (car args) cl--lambda-list-keywords)))
|
||||
(if (consp (car args))
|
||||
(if (and cl--bind-enquote (cl-cadar args))
|
||||
(cl--do-arglist (caar args)
|
||||
`',(cadr (pop args)))
|
||||
(cl--do-arglist (caar args) (cadr (pop args))))
|
||||
(cl--do-arglist (pop args) nil))))
|
||||
(if args (error "Malformed argument list %s" save-args)))))
|
||||
(cl--do-&aux args)
|
||||
nil)))
|
||||
|
||||
(defun cl--arglist-args (args)
|
||||
(if (nlistp args) (list args)
|
||||
|
|
@ -2608,7 +2658,7 @@ non-nil value, that slot cannot be set via `setf'.
|
|||
(make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d)))
|
||||
slots defaults)))
|
||||
(push `(cl-defsubst ,name
|
||||
(&cl-defs '(nil ,@descs) ,@args)
|
||||
(&cl-defs (nil ,@descs) ,@args)
|
||||
,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
|
||||
'((declare (side-effect-free t))))
|
||||
(,(or type #'vector) ,@make))
|
||||
|
|
@ -2716,8 +2766,8 @@ Of course, we really can't know that for sure, so it's just a heuristic."
|
|||
(t
|
||||
(inline-quote (or (cl-typep ,val ',head)
|
||||
(cl-typep ,val ',rest)))))))))
|
||||
(`(member . ,args)
|
||||
(inline-quote (and (memql ,val ',args) t)))
|
||||
(`(eql ,v) (inline-quote (and (eql ,val ',v) t)))
|
||||
(`(member . ,args) (inline-quote (and (memql ,val ',args) t)))
|
||||
(`(satisfies ,pred) (inline-quote (funcall #',pred ,val)))
|
||||
((and (pred symbolp) type (guard (get type 'cl-deftype-handler)))
|
||||
(inline-quote
|
||||
|
|
@ -2977,7 +3027,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc."
|
|||
(declare (debug cl-defmacro) (doc-string 3) (indent 2))
|
||||
`(cl-eval-when (compile load eval)
|
||||
(put ',name 'cl-deftype-handler
|
||||
(cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
|
||||
(cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body)))))
|
||||
|
||||
(cl-deftype extended-char () `(and character (not base-char)))
|
||||
|
||||
|
|
|
|||
|
|
@ -427,4 +427,21 @@
|
|||
(ert-deftest cl-flet-test ()
|
||||
(should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5)))
|
||||
|
||||
(ert-deftest cl-lib-test-typep ()
|
||||
(cl-deftype cl-lib-test-type (&optional x) `(member ,x))
|
||||
;; Make sure we correctly implement the rule that deftype's optional args
|
||||
;; default to `*' rather than to nil.
|
||||
(should (cl-typep '* 'cl-lib-test-type))
|
||||
(should-not (cl-typep 1 'cl-lib-test-type)))
|
||||
|
||||
(ert-deftest cl-lib-arglist-performance ()
|
||||
;; An `&aux' should not cause lambda's arglist to be turned into an &rest
|
||||
;; that's parsed by hand.
|
||||
(should (eq () (nth 1 (nth 1 (macroexpand
|
||||
'(cl-function (lambda (&aux (x 1)) x)))))))
|
||||
(cl-defstruct (cl-lib--s (:constructor cl-lib--s-make (&optional a))) a)
|
||||
;; Similarly the &cl-defs thingy shouldn't cause fallback to manual parsing
|
||||
;; of args if the default for optional args is nil.
|
||||
(should (equal '(&optional a) (help-function-arglist 'cl-lib--s-make))))
|
||||
|
||||
;;; cl-lib.el ends here
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue