From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED.blaine.gmane.org!not-for-mail From: Noam Postavsky Newsgroups: gmane.emacs.bugs Subject: bug#16963: A patch to create a list-with-tail primitive. Date: Thu, 27 Jun 2019 23:14:31 -0400 Message-ID: <87v9wq5rl4.fsf@gmail.com> References: <1394200708.1710.4.camel@localhost.localdomain> <877fhuom68.fsf@gnus.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: blaine.gmane.org; posting-host="blaine.gmane.org:195.159.176.226"; logging-data="22344"; mail-complaints-to="usenet@blaine.gmane.org" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2.90 (gnu/linux) Cc: 16963@debbugs.gnu.org, Demetrios Obenour To: Lars Ingebrigtsen Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Fri Jun 28 05:15:25 2019 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([209.51.188.17]) by blaine.gmane.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.89) (envelope-from ) id 1hghMD-0005fM-9L for geb-bug-gnu-emacs@m.gmane.org; Fri, 28 Jun 2019 05:15:25 +0200 Original-Received: from localhost ([::1]:55954 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hghMC-0001LM-AE for geb-bug-gnu-emacs@m.gmane.org; Thu, 27 Jun 2019 23:15:24 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:33923) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hghLt-0001LD-D3 for bug-gnu-emacs@gnu.org; Thu, 27 Jun 2019 23:15:07 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hghLq-0006I4-J0 for bug-gnu-emacs@gnu.org; Thu, 27 Jun 2019 23:15:05 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:54851) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hghLq-0006Hb-3E for bug-gnu-emacs@gnu.org; Thu, 27 Jun 2019 23:15:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hghLp-0006QO-R6 for bug-gnu-emacs@gnu.org; Thu, 27 Jun 2019 23:15:01 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Noam Postavsky Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Fri, 28 Jun 2019 03:15:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 16963 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 16963-submit@debbugs.gnu.org id=B16963.156169168224659 (code B ref 16963); Fri, 28 Jun 2019 03:15:01 +0000 Original-Received: (at 16963) by debbugs.gnu.org; 28 Jun 2019 03:14:42 +0000 Original-Received: from localhost ([127.0.0.1]:40162 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hghLV-0006Pe-Mq for submit@debbugs.gnu.org; Thu, 27 Jun 2019 23:14:42 -0400 Original-Received: from mail-io1-f41.google.com ([209.85.166.41]:34291) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hghLS-0006PM-Te for 16963@debbugs.gnu.org; Thu, 27 Jun 2019 23:14:40 -0400 Original-Received: by mail-io1-f41.google.com with SMTP id k8so9495511iot.1 for <16963@debbugs.gnu.org>; Thu, 27 Jun 2019 20:14:38 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:cc:subject:references:date:in-reply-to:message-id :user-agent:mime-version; bh=6L0P5pEERkjGOIsTj1qDHmZcweFS2aq6FpcGTg4vbvo=; b=NlY7suauwy2XN9zWiC9+9O0YjFFbcEy6E5YADZu6p1kUr0VhLkUKNI4LbkhC5yOIml 0Mf8cyc3OC5CFRJ2d68nweRu2iHruTXOBgUJ2Sy0qU8WCMub8meUrxl8rCk3VIWTyn1C dnVVUlPTdN3SYx4cQkmXq+ZUEX7IUm+c3e/9PnQzCTN7A2tk+xvxeD03/1q6DjkahKii s7+LSa88mSUEU1ldpc3b6DhekxrK1oPCQ7uUeqzBzmzQNP1xRHW8REuczFrI+sueHibV HVyyW8M42pEd0nKot7D4l94T0B9hObH4Maq6ScuZevFaWpuE2vCcjoaZ/GHe8jk4ExdY aKRA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:cc:subject:references:date:in-reply-to :message-id:user-agent:mime-version; bh=6L0P5pEERkjGOIsTj1qDHmZcweFS2aq6FpcGTg4vbvo=; b=CmVk1win2TOcIYmnl/zXeTIk+bj3gXLkblNNEFKebZstoGM3Z0rvqLHGnSaDm0D9B4 7bTFixgk4XNq44sZHycpCK+z5PCDMViBFDzf52zgtYgtsXgnk2zd9/4fpKbNp7OWgZlP FdAHGXLk2mN4JRdTGnSzI7FeqTLsJx1A2Nko+U48jE4qKnY1MVf/uLLwvZsz/D8YwkJa It+M2RxmOf+sa/mD2/RspaaylXNrv/41PKzR8Xu5dPYB9MBgJiAJ6qT+EGahUM86zWzx M3eGV2PI8Qq4TtVsLTUVRGEsmOu02BWzXa6gQckh9CtgOaIl2muiwsgUHG43z/Rtwl8T llDg== X-Gm-Message-State: APjAAAVATPFec+MpdHbrHqaqMX5/khWRHEfbXF3gdUk8p0cIIHGX7/n7 m1TFEetjx6SQVPde2+mra3dBOBKD X-Google-Smtp-Source: APXvYqxD6IgYDsAcsXGF7+qgGg8ml0s3pzdNtCXPt5WumoKVQpCyHsIgDS5Y+8NFvmtT0W5k8PSOtw== X-Received: by 2002:a05:6602:2252:: with SMTP id o18mr7928633ioo.63.1561691673151; Thu, 27 Jun 2019 20:14:33 -0700 (PDT) Original-Received: from minid (cbl-45-2-119-34.yyz.frontiernetworks.ca. [45.2.119.34]) by smtp.gmail.com with ESMTPSA id y20sm815517ion.77.2019.06.27.20.14.32 (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Thu, 27 Jun 2019 20:14:32 -0700 (PDT) In-Reply-To: (Lars Ingebrigtsen's message of "Wed, 26 Jun 2019 16:30:21 +0200") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.org gmane.emacs.bugs:161681 Archived-At: --=-=-= Content-Type: text/plain Lars Ingebrigtsen writes: > Lars Ingebrigtsen 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: --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=0001-Implement-cons-as-a-C-subroutine-Bug-16963.patch Content-Description: patch >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 --=-=-=--