[Emacs-diffs] master 801eda8: * lisp/emacs-lisp/cl-macs.el (cl--transform-lambda): Optimize &aux.

[Stefan Monnier]

branch: master
commit 801eda8a2a00b3f28a69ffe51b05a649fffc5c58
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    * 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.
---
 lisp/ChangeLog                 |    7 ++
 lisp/emacs-lisp/cl-generic.el  |    1 +
 lisp/emacs-lisp/cl-macs.el     |  148 +++++++++++++++++++++++++++-------------
 test/automated/cl-lib-tests.el |   17 +++++
 4 files changed, 124 insertions(+), 49 deletions(-)

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index e9e910a..41898be 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,12 @@
 2015-03-16  Stefan Monnier  <address@hidden>
 
+       * 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 a8483ea..41c760e 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 <address@hidden>
+;; 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 36f263c..712a748 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 1c36e7d..2c188a4 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