bug#16963: A patch to create a list-with-tail primitive.

[Noam Postavsky <npostavs@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 796 bytes --]

Lars Ingebrigtsen <larsi@gnus.org> writes:

> Lars Ingebrigtsen <larsi@gnus.org> writes:
>
>> Reading this bug report, there seemed to be general agreement that Emacs
>> should have `list*', and that `cl-list*' should be an alias for it, but
>> these patches were not applied.
>>
>> I can't find your name in the Emacs copyright assignment file -- would
>> you be willing to sign a copyright assignment to the FSF?
>
> I asked that three years ago, when the patch was already two years old,
> so I'm guessing that this is not going to happen, so I'm closing this
> bug report.

Oh, this reminds me I had started writing a patch for this.  I used the
name cons* instead of list* though, I always found it more logical:
cons* is cons repeated, just like let* is let repeated.  Let me dust it
off:


[-- Attachment #2: patch --]
[-- Type: text/plain, Size: 19149 bytes --]

From e44291e055b167548a9b5166764e144644cc6291 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Sun, 2 Jul 2017 17:44:02 -0400
Subject: [PATCH] Implement cons* as a C subroutine (Bug#16963)

* src/alloc.c (Fcons_star): New subr.
* doc/lispref/lists.texi (Building Lists): Document it.
* etc/NEWS: Announce it.
* lisp/emacs-lisp/cl-macs.el (cl--compiler-macro-list*): Move to...
* lisp/subr.el (internal--compiler-macro-cons*): ...here, and rename.
Set as compiler-macro for `cons*'.
* lisp/emacs-lisp/backquote.el (backquote-list*-function)
(backquote-list*-macro, backquote-list*): Remove.
(backquote-listify):
* lisp/emacs-lisp/byte-opt.el:
* lisp/emacs-lisp/inline.el (inline--do-quote):
* lisp/emacs-lisp/macroexp.el (macroexp--expand-all): Replace
`backquote-list*' with `cons*'.
* lisp/emacs-lisp/cl-lib.el (cl-list*): Make into alias for `cons*'.
* lisp/emacs-lisp/macroexp.el (macroexp--expand-all): Change special
case for `backquote-list*' macro to special case for
`internal--compiler-macro-cons*' compiler-macro.
---
 doc/lispref/lists.texi       |  18 +++++
 etc/NEWS                     |   3 +
 lisp/emacs-lisp/backquote.el |  50 +-------------
 lisp/emacs-lisp/byte-opt.el  |   2 +-
 lisp/emacs-lisp/cl-lib.el    |  15 +---
 lisp/emacs-lisp/cl-macs.el   |   8 ---
 lisp/emacs-lisp/inline.el    |   2 +-
 lisp/emacs-lisp/macroexp.el  | 161 +++++++++++++++++++++----------------------
 lisp/subr.el                 |   9 +++
 src/alloc.c                  |  13 ++++
 10 files changed, 129 insertions(+), 152 deletions(-)

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 746b4643c1..a398721c79 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -503,6 +503,24 @@ Building Lists
 @end example
 @end defun
 
+@defun cons* object1 &rest objects
+This function is similar to @code{list}, but instead of terminating
+the returned list with @code{nil}, it uses the last argument instead.
+This is mainly useful when adding several elements to a list, to avoid
+having to call @code{cons} repeatedly.  For example:
+
+@example
+(setq list (cons* newelt1 newelt2 list))
+@end example
+
+is equivalent to
+
+@example
+(setq list (cons newelt1 (cons newelt2 list)))
+@end example
+
+@end defun
+
 @defun make-list length object
 This function creates a list of @var{length} elements, in which each
 element is @var{object}.  Compare @code{make-list} with
diff --git a/etc/NEWS b/etc/NEWS
index b1f1f7293a..06d5e93d02 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1862,6 +1862,9 @@ according to the given numeric value.
 ** 'condition-case' now accepts 't' to match any error symbol.
 
 +++
+** New subr 'cons*'.
+
++++
 ** New function 'proper-list-p'.
 Given a proper list as argument, this predicate returns its length;
 otherwise, it returns nil.  'format-proper-list-p' is now an obsolete
diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el
index 5e72dc3b40..fd31d82728 100644
--- a/lisp/emacs-lisp/backquote.el
+++ b/lisp/emacs-lisp/backquote.el
@@ -29,56 +29,10 @@
 ;; When it sees ,... inside such a backquote form, it generates (\, ...).
 ;; For ,@... it generates (\,@ ...).
 
-;; This backquote will generate calls to the backquote-list* form.
-;; Both a function version and a macro version are included.
-;; The macro version is used by default because it is faster
-;; and needs no run-time support.  It should really be a subr.
-
 ;;; Code:
 
 (provide 'backquote)
 
-;; function and macro versions of backquote-list*
-
-(defun backquote-list*-function (first &rest list)
-  "Like `list' but the last argument is the tail of the new list.
-
-For example (backquote-list* \\='a \\='b \\='c) => (a b . c)"
-  ;; The recursive solution is much nicer:
-  ;; (if list (cons first (apply 'backquote-list*-function list)) first))
-  ;; but Emacs is not very good at efficiently processing recursion.
-  (if list
-      (let* ((rest list) (newlist (cons first nil)) (last newlist))
-	(while (cdr rest)
-	  (setcdr last (cons (car rest) nil))
-	  (setq last (cdr last)
-		rest (cdr rest)))
-	(setcdr last (car rest))
-	newlist)
-    first))
-
-(defmacro backquote-list*-macro (first &rest list)
-  "Like `list' but the last argument is the tail of the new list.
-
-For example (backquote-list* \\='a \\='b \\='c) => (a b . c)"
-  ;; The recursive solution is much nicer:
-  ;; (if list (list 'cons first (cons 'backquote-list*-macro list)) first))
-  ;; but Emacs is not very good at efficiently processing such things.
-  (setq list (nreverse (cons first list))
-	first (car list)
-	list (cdr list))
-  (if list
-      (let* ((second (car list))
-	     (rest (cdr list))
-	     (newlist (list 'cons second first)))
-	(while rest
-	  (setq newlist (list 'cons (car rest) newlist)
-		rest (cdr rest)))
-	newlist)
-    first))
-
-(defalias 'backquote-list* (symbol-function 'backquote-list*-macro))
-
 ;; A few advertised variables that control which symbols are used
 ;; to represent the backquote, unquote, and splice operations.
 (defconst backquote-backquote-symbol '\`
@@ -219,7 +173,7 @@ backquote-process
       (cons (if (eq (car-safe expression) 'quote) 0 1) expression)))))
 
 ;; backquote-listify takes (tag . structure) pairs from backquote-process
-;; and decides between append, list, backquote-list*, and cons depending
+;; and decides between append, list, cons*, and cons depending
 ;; on which tags are in the list.
 
 (defun backquote-listify (list old-tail)
@@ -242,7 +196,7 @@ backquote-listify
 			       (and (consp (car heads))
 				    (eq (car (car heads))
 					backquote-splice-symbol)))))
-	    (cons (if use-list* 'backquote-list* 'cons)
+            (cons (if use-list* 'cons* 'cons)
 		  (append heads (list tail))))
 	tail))
      (t (cons 'list heads)))))
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 2e09601639..0e53ab85ec 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1168,7 +1168,7 @@ byte-optimize-set
 	 buffer-substring byte-code-function-p
 	 capitalize car-less-than-car car cdr ceiling char-after char-before
 	 char-equal char-to-string char-width compare-strings
-	 compare-window-configurations concat coordinates-in-window-p
+         compare-window-configurations concat cons* coordinates-in-window-p
 	 copy-alist copy-sequence copy-marker cos count-lines
 	 current-time-string current-time-zone
 	 decode-char
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index c51c70d317..2f1274b71e 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -434,19 +434,8 @@ 'cl-cddddr
 ;;    (while (consp (cdr x)) (pop x))
 ;;    x))
 
-(defun cl-list* (arg &rest rest)
-  "Return a new list with specified ARGs as elements, consed to last ARG.
-Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
-`(cons A (cons B (cons C D)))'.
-\n(fn ARG...)"
-  (declare (compiler-macro cl--compiler-macro-list*))
-  (cond ((not rest) arg)
-	((not (cdr rest)) (cons arg (car rest)))
-	(t (let* ((n (length rest))
-		  (copy (copy-sequence rest))
-		  (last (nthcdr (- n 2) copy)))
-	     (setcdr last (car (cdr last)))
-	     (cons arg copy)))))
+(defalias 'cl-list* 'cons*)
+(function-put 'cl-list* 'compiler-macro #'internal--compiler-macro-cons*)
 
 (defun cl-ldiff (list sublist)
   "Return a copy of LIST with the tail SUBLIST removed."
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 54974ceb7d..18b6707655 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -62,14 +62,6 @@ cl--optimize-speed
 ;; functions can lead to recursive-loads that prevent the calls from
 ;; being optimized.
 
-;;;###autoload
-(defun cl--compiler-macro-list* (_form arg &rest others)
-  (let* ((args (reverse (cons arg others)))
-	 (form (car args)))
-    (while (setq args (cdr args))
-      (setq form `(cons ,(car args) ,form)))
-    form))
-
 ;; Note: `cl--compiler-macro-cXXr' has been copied to
 ;; `internal--compiler-macro-cXXr' in subr.el.  If you amend either
 ;; one, you may want to amend the other, too.
diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el
index 70dbff2147..25aee42db2 100644
--- a/lisp/emacs-lisp/inline.el
+++ b/lisp/emacs-lisp/inline.el
@@ -185,7 +185,7 @@ inline--do-quote
          (push (inline--do-quote (pop exp)) args))
        (setq args (nreverse args))
        (if exp
-           `(backquote-list* ,@args ,(inline--do-quote exp))
+           `(cons* ,@args ,(inline--do-quote exp))
          `(list ,@args))))
     (_ (macroexp-quote exp))))
 
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 9af75320ec..fd5a2864ce 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -201,85 +201,84 @@ macroexp--expand-all
   "Expand all macros in FORM.
 This is an internal version of `macroexpand-all'.
 Assumes the caller has bound `macroexpand-all-environment'."
-  (if (eq (car-safe form) 'backquote-list*)
-      ;; Special-case `backquote-list*', as it is normally a macro that
-      ;; generates exceedingly deep expansions from relatively shallow input
-      ;; forms.  We just process it `in reverse' -- first we expand all the
-      ;; arguments, _then_ we expand the top-level definition.
-      (macroexpand (macroexp--all-forms form 1)
-		   macroexpand-all-environment)
-    ;; Normal form; get its expansion, and then expand arguments.
-    (setq form (macroexp-macroexpand form macroexpand-all-environment))
-    (pcase form
-      (`(cond . ,clauses)
-       (macroexp--cons 'cond (macroexp--all-clauses clauses) form))
-      (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare))
-       (macroexp--cons
-        'condition-case
-        (macroexp--cons err
-                        (macroexp--cons (macroexp--expand-all body)
-                                        (macroexp--all-clauses handlers 1)
-                                        (cddr form))
-                        (cdr form))
-        form))
-      (`(,(or 'defvar 'defconst) . ,_) (macroexp--all-forms form 2))
-      (`(function ,(and f `(lambda . ,_)))
-       (macroexp--cons 'function
-                       (macroexp--cons (macroexp--all-forms f 2)
-                                       nil
-                                       (cdr form))
-                       form))
-      (`(,(or 'function 'quote) . ,_) form)
-      (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) dontcare))
-       (macroexp--cons fun
-                       (macroexp--cons (macroexp--all-clauses bindings 1)
-                                       (macroexp--all-forms body)
-                                       (cdr form))
-                       form))
-      (`(,(and fun `(lambda . ,_)) . ,args)
-       ;; Embedded lambda in function position.
-       (macroexp--cons (macroexp--all-forms fun 2)
-                       (macroexp--all-forms args)
-                       form))
-      ;; The following few cases are for normal function calls that
-      ;; are known to funcall one of their arguments.  The byte
-      ;; compiler has traditionally handled these functions specially
-      ;; by treating a lambda expression quoted by `quote' as if it
-      ;; were quoted by `function'.  We make the same transformation
-      ;; here, so that any code that cares about the difference will
-      ;; see the same transformation.
-      ;; First arg is a function:
-      (`(,(and fun (or 'funcall 'apply 'mapcar 'mapatoms 'mapconcat 'mapc))
-         ',(and f `(lambda . ,_)) . ,args)
-       (macroexp--warn-and-return
-        (format "%s quoted with ' rather than with #'"
-                (list 'lambda (nth 1 f) '...))
-        (macroexp--expand-all `(,fun ,f . ,args))))
-      ;; Second arg is a function:
-      (`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
-       (macroexp--warn-and-return
-        (format "%s quoted with ' rather than with #'"
-                (list 'lambda (nth 1 f) '...))
-        (macroexp--expand-all `(,fun ,arg1 ,f . ,args))))
-      (`(funcall #',(and f (pred symbolp)) . ,args)
-       ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
-       ;; has a compiler-macro.
-       (macroexp--expand-all `(,f . ,args)))
-      (`(,func . ,_)
-       ;; Macro expand compiler macros.  This cannot be delayed to
-       ;; byte-optimize-form because the output of the compiler-macro can
-       ;; use macros.
-       (let ((handler (function-get func 'compiler-macro)))
-         (if (null handler)
-             ;; No compiler macro.  We just expand each argument (for
-             ;; setq/setq-default this works alright because the variable names
-             ;; are symbols).
-             (macroexp--all-forms form 1)
-           ;; If the handler is not loaded yet, try (auto)loading the
-           ;; function itself, which may in turn load the handler.
-           (unless (functionp handler)
-             (with-demoted-errors "macroexp--expand-all: %S"
-               (autoload-do-load (indirect-function func) func)))
+  ;; Normal form; get its expansion, and then expand arguments.
+  (setq form (macroexp-macroexpand form macroexpand-all-environment))
+  (pcase form
+    (`(cond . ,clauses)
+     (macroexp--cons 'cond (macroexp--all-clauses clauses) form))
+    (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare))
+     (macroexp--cons
+      'condition-case
+      (macroexp--cons err
+                      (macroexp--cons (macroexp--expand-all body)
+                                      (macroexp--all-clauses handlers 1)
+                                      (cddr form))
+                      (cdr form))
+      form))
+    (`(,(or 'defvar 'defconst) . ,_) (macroexp--all-forms form 2))
+    (`(function ,(and f `(lambda . ,_)))
+     (macroexp--cons 'function
+                     (macroexp--cons (macroexp--all-forms f 2)
+                                     nil
+                                     (cdr form))
+                     form))
+    (`(,(or 'function 'quote) . ,_) form)
+    (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) dontcare))
+     (macroexp--cons fun
+                     (macroexp--cons (macroexp--all-clauses bindings 1)
+                                     (macroexp--all-forms body)
+                                     (cdr form))
+                     form))
+    (`(,(and fun `(lambda . ,_)) . ,args)
+     ;; Embedded lambda in function position.
+     (macroexp--cons (macroexp--all-forms fun 2)
+                     (macroexp--all-forms args)
+                     form))
+    ;; The following few cases are for normal function calls that
+    ;; are known to funcall one of their arguments.  The byte
+    ;; compiler has traditionally handled these functions specially
+    ;; by treating a lambda expression quoted by `quote' as if it
+    ;; were quoted by `function'.  We make the same transformation
+    ;; here, so that any code that cares about the difference will
+    ;; see the same transformation.
+    ;; First arg is a function:
+    (`(,(and fun (or 'funcall 'apply 'mapcar 'mapatoms 'mapconcat 'mapc))
+       ',(and f `(lambda . ,_)) . ,args)
+     (macroexp--warn-and-return
+      (format "%s quoted with ' rather than with #'"
+              (list 'lambda (nth 1 f) '...))
+      (macroexp--expand-all `(,fun ,f . ,args))))
+    ;; Second arg is a function:
+    (`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
+     (macroexp--warn-and-return
+      (format "%s quoted with ' rather than with #'"
+              (list 'lambda (nth 1 f) '...))
+      (macroexp--expand-all `(,fun ,arg1 ,f . ,args))))
+    (`(funcall #',(and f (pred symbolp)) . ,args)
+     ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
+     ;; has a compiler-macro.
+     (macroexp--expand-all `(,f . ,args)))
+    (`(,func . ,_)
+     ;; Macro expand compiler macros.  This cannot be delayed to
+     ;; byte-optimize-form because the output of the compiler-macro can
+     ;; use macros.
+     (let ((handler (function-get func 'compiler-macro)))
+       (if (null handler)
+           ;; No compiler macro.  We just expand each argument (for
+           ;; setq/setq-default this works alright because the variable names
+           ;; are symbols).
+           (macroexp--all-forms form 1)
+         ;; If the handler is not loaded yet, try (auto)loading the
+         ;; function itself, which may in turn load the handler.
+         (unless (functionp handler)
+           (with-demoted-errors "macroexp--expand-all: %S"
+             (autoload-do-load (indirect-function func) func)))
+         (if (eq handler 'internal--compiler-macro-cons*)
+             ;; The `cons*' compiler-macro generates very deep
+             ;; expansions, so macroexpand the arguments first to
+             ;; reduce the chance of exceeding recusion depth while
+             ;; macroexpanding.
+             (macroexp--compiler-macro handler (macroexp--all-forms form 1))
            (let ((newform (macroexp--compiler-macro handler form)))
              (if (eq form newform)
                  ;; The compiler macro did not find anything to do.
@@ -291,9 +290,9 @@ macroexp--expand-all
                    (if (eq newform form)
                        newform
                      (macroexp--expand-all newform)))
-               (macroexp--expand-all newform))))))
+               (macroexp--expand-all newform)))))))
 
-      (_ form))))
+    (_ form)))
 
 ;;;###autoload
 (defun macroexpand-all (form &optional environment)
diff --git a/lisp/subr.el b/lisp/subr.el
index c59f13b24c..c0b3c68229 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -577,6 +577,15 @@ cddddr
   (declare (compiler-macro internal--compiler-macro-cXXr))
   (cdr (cdr (cdr (cdr x)))))
 
+(defun internal--compiler-macro-cons* (_form arg &rest others)
+  (let* ((args (reverse (cons arg others)))
+         (form (car args)))
+    (while (setq args (cdr args))
+      (setq form `(cons ,(car args) ,form)))
+    form))
+
+(function-put 'cons* 'compiler-macro #'internal--compiler-macro-cons*)
+
 (defun last (list &optional n)
   "Return the last link of LIST.  Its car is the last element.
 If LIST is nil, return nil.
diff --git a/src/alloc.c b/src/alloc.c
index 64aaa8acdf..1fb7b1fc0b 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -2699,6 +2699,18 @@ DEFUN ("list", Flist, Slist, 0, MANY, 0,
   return val;
 }
 
+DEFUN ("cons*", FconsX, SconsX, 1, MANY, 0,
+       doc: /* Like `list' but the last argument is the tail of the new list.
+(cons* A B C) is equivalent to (cons A (cons B C)).
+usage: (cons* FIRST &rest LIST)  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  Lisp_Object val = args[--nargs];
+
+  while (nargs > 0)
+    val = Fcons (args[--nargs], val);
+  return val;
+}
 
 DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
        doc: /* Return a newly created list of length LENGTH, with each element being INIT.  */)
@@ -7374,6 +7386,7 @@ syms_of_alloc (void)
 N should be nonnegative.  */);
 
   defsubr (&Scons);
+  defsubr (&SconsX);
   defsubr (&Slist);
   defsubr (&Svector);
   defsubr (&Srecord);
-- 
2.11.0