Commit 801eda8a authored by Stefan Monnier's avatar Stefan Monnier

* 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.
parent f925fc93
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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment