>From f42cb45f449dbb6c3d806398a128bc5914fdebab Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Fri, 6 Jul 2018 00:41:11 +0300 Subject: [PATCH 1/3] Add convenience function proper-list-length * lisp/subr.el (proper-list-length): New function. Suggested by Paul Eggert in https://lists.gnu.org/archive/html/emacs-devel/2018-06/msg00138.html. * doc/lispref/lists.texi (List Elements): * etc/NEWS: Mention it. * lisp/emacs-lisp/byte-opt.el (byte-optimize-if): * lisp/emacs-lisp/cl-macs.el (cl--make-usage-args): * lisp/org/ob-core.el (org-babel-insert-result): Use it. * lisp/emacs-lisp/ert.el (ert--proper-list-p): Remove. (ert--explain-equal-rec): Use proper-list-length instead. * lisp/format.el (format-proper-list-p): Remove. (format-annotate-single-property-change): Use proper-list-length instead. * test/lisp/emacs-lisp/ert-tests.el (ert-test-proper-list-p): Move from here... * test/lisp/subr-tests.el (subr-tests--proper-list-length): ...to here, mutatis mutandis. --- doc/lispref/lists.texi | 17 +++++++++++++ etc/NEWS | 6 +++++ lisp/emacs-lisp/byte-opt.el | 2 +- lisp/emacs-lisp/cl-macs.el | 2 +- lisp/emacs-lisp/ert.el | 22 ++++------------ lisp/format.el | 12 ++------- lisp/org/ob-core.el | 5 ++-- lisp/subr.el | 6 +++++ test/lisp/emacs-lisp/ert-tests.el | 42 ------------------------------- test/lisp/subr-tests.el | 18 +++++++++++++ 10 files changed, 58 insertions(+), 74 deletions(-) diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index 761750eb20..6850e9d74e 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -338,6 +338,23 @@ List Elements If @var{list} is not @code{nil} or a cons cell, @code{safe-length} returns 0. address@hidden defun + address@hidden proper-list-length object +This function returns the length of @var{object} if it is a proper +list, @code{nil} otherwise. In addition to satisfying @code{listp}, a +proper list is neither circular nor dotted. + address@hidden address@hidden +(proper-list-length '(a b c)) + @result{} 3 address@hidden group address@hidden +(proper-list-length '(a b . c)) + @result{} nil address@hidden group address@hidden example @end defun The most common way to compute the length of a list, when you are not diff --git a/etc/NEWS b/etc/NEWS index c92ee6e680..bd1b4509d6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -689,6 +689,12 @@ manual for more details. * Lisp Changes in Emacs 27.1 ++++ +** New function 'proper-list-length'. +Given a proper list as argument, this function returns its length; +otherwise, it returns nil. This function can thus be used as a +predicate for proper lists. + ** define-minor-mode automatically documents the meaning of ARG +++ diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 3bc4c438d6..880bd6982d 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -983,7 +983,7 @@ byte-optimize-if (let ((clause (nth 1 form))) (cond ((and (eq (car-safe clause) 'progn) ;; `clause' is a proper list. - (null (cdr (last clause)))) + (proper-list-length clause)) (if (null (cddr clause)) ;; A trivial `progn'. (byte-optimize-if `(if ,(cadr clause) ,@(nthcdr 2 form))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index b50961adac..d95448afb8 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -498,7 +498,7 @@ cl--make-usage-args ;; `&aux' args aren't arguments, so let's just drop them from the ;; usage info. (setq arglist (cl-subseq arglist 0 aux)))) - (if (cdr-safe (last arglist)) ;Not a proper list. + (if (not (proper-list-length arglist)) ; Not a proper list. (let* ((last (last arglist)) (tail (cdr last))) (unwind-protect diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 32bb367cdb..3b50225afb 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -472,18 +472,6 @@ ert--should-error-handle-error ;; buffer. Perhaps explanations should be reported through `ert-info' ;; rather than as part of the condition. -(defun ert--proper-list-p (x) - "Return non-nil if X is a proper list, nil otherwise." - (cl-loop - for firstp = t then nil - for fast = x then (cddr fast) - for slow = x then (cdr slow) do - (when (null fast) (cl-return t)) - (when (not (consp fast)) (cl-return nil)) - (when (null (cdr fast)) (cl-return t)) - (when (not (consp (cdr fast))) (cl-return nil)) - (when (and (not firstp) (eq fast slow)) (cl-return nil)))) - (defun ert--explain-format-atom (x) "Format the atom X for `ert--explain-equal'." (pcase x @@ -498,12 +486,12 @@ ert--explain-equal-rec `(different-types ,a ,b) (pcase-exhaustive a ((pred consp) - (let ((a-proper-p (ert--proper-list-p a)) - (b-proper-p (ert--proper-list-p b))) - (if (not (eql (not a-proper-p) (not b-proper-p))) + (let ((a-proper-p (proper-list-length a)) + (b-proper-p (proper-list-length b))) + (if (not (eq (not a-proper-p) (not b-proper-p))) `(one-list-proper-one-improper ,a ,b) (if a-proper-p - (if (not (equal (length a) (length b))) + (if (/= (length a) (length b)) `(proper-lists-of-different-length ,(length a) ,(length b) ,a ,b first-mismatch-at @@ -523,7 +511,7 @@ ert--explain-equal-rec (cl-assert (equal a b) t) nil)))))))) ((pred arrayp) - (if (not (equal (length a) (length b))) + (if (/= (length a) (length b)) `(arrays-of-different-length ,(length a) ,(length b) ,a ,b ,@(unless (char-table-p a) diff --git a/lisp/format.el b/lisp/format.el index 2f198e3eb7..bf535ca174 100644 --- a/lisp/format.el +++ b/lisp/format.el @@ -539,14 +539,6 @@ format-make-relatively-unique (setq tail next))) (cons acopy bcopy))) -(defun format-proper-list-p (list) - "Return t if LIST is a proper list. -A proper list is a list ending with a nil cdr, not with an atom " - (when (listp list) - (while (consp list) - (setq list (cdr list))) - (null list))) - (defun format-reorder (items order) "Arrange ITEMS to follow partial ORDER. Elements of ITEMS equal to elements of ORDER will be rearranged @@ -1005,8 +997,8 @@ format-annotate-single-property-change ;; If either old or new is a list, have to treat both that way. (if (and (or (listp old) (listp new)) (not (get prop 'format-list-atomic-p))) - (if (or (not (format-proper-list-p old)) - (not (format-proper-list-p new))) + (if (not (and (proper-list-length old) + (proper-list-length new))) (format-annotate-atomic-property-change prop-alist old new) (let* ((old (if (listp old) old (list old))) (new (if (listp new) new (list new))) diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 5d5faaa6fd..09c43d8716 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -2310,10 +2310,9 @@ org-babel-insert-result (lambda (r) ;; Non-nil when result R can be turned into ;; a table. - (and (listp r) - (null (cdr (last r))) + (and (proper-list-length r) (cl-every - (lambda (e) (or (atom e) (null (cdr (last e))))) + (lambda (e) (or (atom e) (proper-list-length e))) result))))) ;; insert results based on type (cond diff --git a/lisp/subr.el b/lisp/subr.el index ca184d8fc8..cb809a4ec7 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -555,6 +555,12 @@ zerop (declare (compiler-macro (lambda (_) `(= 0 ,number)))) (= 0 number)) +(defun proper-list-length (object) + "Return OBJECT's length if it is a proper list, nil otherwise. +A proper list is neither circular nor dotted (i.e., its last cdr +is nil)." + (and (listp object) (ignore-errors (length object)))) + (defun delete-dups (list) "Destructively remove `equal' duplicates from LIST. Store the result in LIST and return it. LIST must be a proper list. diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index e92b434274..cb957bd9fd 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -496,48 +496,6 @@ ert-test--which-file ;;; Tests for utility functions. -(ert-deftest ert-test-proper-list-p () - (should (ert--proper-list-p '())) - (should (ert--proper-list-p '(1))) - (should (ert--proper-list-p '(1 2))) - (should (ert--proper-list-p '(1 2 3))) - (should (ert--proper-list-p '(1 2 3 4))) - (should (not (ert--proper-list-p 'a))) - (should (not (ert--proper-list-p '(1 . a)))) - (should (not (ert--proper-list-p '(1 2 . a)))) - (should (not (ert--proper-list-p '(1 2 3 . a)))) - (should (not (ert--proper-list-p '(1 2 3 4 . a)))) - (let ((a (list 1))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) (cddr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cddr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cl-cdddr a)) - (should (not (ert--proper-list-p a))))) - (ert-deftest ert-test-parse-keys-and-body () (should (equal (ert--parse-keys-and-body '(foo)) '(nil (foo)))) (should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil))) diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 52b61d9fb9..06e9a2b319 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -306,6 +306,24 @@ subr-test--frames-1 (should (eq (string-to-char (symbol-name (gensym))) ?g)) (should (eq (string-to-char (symbol-name (gensym "X"))) ?X))) +(ert-deftest subr-tests--proper-list-length () + "Test `proper-list-length' behavior." + (dotimes (length 4) + ;; Proper and dotted lists. + (let ((list (make-list length 0))) + (should (= (proper-list-length list) length)) + (should (not (proper-list-length (nconc list 0))))) + ;; Circular lists. + (dotimes (n (1+ length)) + (let ((circle (make-list (1+ length) 0))) + (should (not (proper-list-length (nconc circle (nthcdr n circle)))))))) + ;; Atoms. + (should (not (proper-list-length 0))) + (should (not (proper-list-length ""))) + (should (not (proper-list-length []))) + (should (not (proper-list-length (make-bool-vector 0 nil)))) + (should (not (proper-list-length (make-symbol "a"))))) + (ert-deftest subr-tests--assq-delete-all () "Test `assq-delete-all' behavior." (cl-flet ((new-list-fn -- 2.18.0