>From e44291e055b167548a9b5166764e144644cc6291 Mon Sep 17 00:00:00 2001 From: Noam Postavsky 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