From: Stefan Monnier Date: Mon, 16 Mar 2015 20:11:38 +0000 (-0400) Subject: * lisp/emacs-lisp/cl-macs.el (cl--transform-lambda): Optimize &aux. X-Git-Tag: emacs-25.0.90~2564^2~152 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=801eda8a2a00b3f28a69ffe51b05a649fffc5c58;p=emacs.git * 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. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e9e910a8857..41898bee686 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,12 @@ 2015-03-16 Stefan Monnier + * 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. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index a8483ea1355..41c760e960e 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -3,6 +3,7 @@ ;; Copyright (C) 2015 Free Software Foundation, Inc. ;; Author: Stefan Monnier +;; Version: 1.0 ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 36f263cd20a..712a7485167 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -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))) diff --git a/test/automated/cl-lib-tests.el b/test/automated/cl-lib-tests.el index 1c36e7d7abf..2c188a40059 100644 --- a/test/automated/cl-lib-tests.el +++ b/test/automated/cl-lib-tests.el @@ -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