From d530bcf1d59a01d37b22fea6a832f0578198350d Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Mon, 9 Jul 2018 18:36:43 +0300 Subject: [PATCH 1/3] Add predicate proper-list-p For discussion, see emacs-devel thread starting at https://lists.gnu.org/archive/html/emacs-devel/2018-04/msg00460.html. * lisp/subr.el (proper-list-p): New function. Implementation 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: Document proper-list-p. * lisp/org/ob-core.el (org-babel-insert-result): * lisp/emacs-lisp/byte-opt.el (byte-optimize-if): * lisp/emacs-lisp/cl-macs.el (cl--make-usage-args): Use proper-list-p. * lisp/emacs-lisp/ert.el (ert--proper-list-p): Remove. Replaced by proper-list-p in lisp/subr.el. (ert--explain-equal-rec): Use proper-list-length. * lisp/format.el (format-proper-list-p): Remove. Replaced by proper-list-p in lisp/subr.el. (format-annotate-single-property-change): Use proper-list-p. * 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 | 16 ++++++++++++ etc/NEWS | 5 ++++ lisp/emacs-lisp/byte-opt.el | 2 +- lisp/emacs-lisp/cl-macs.el | 2 +- lisp/emacs-lisp/ert.el | 28 ++++++--------------- 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, 59 insertions(+), 77 deletions(-) diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index 761750eb20..57cefeac96 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -153,6 +153,22 @@ List-related Predicates @end example @end defun +@defun proper-list-p object +This function returns the length of @var{object} if it is a proper +list, @code{nil} otherwise (@pxref{Cons Cells}). In addition to +satisfying @code{listp}, a proper list is neither circular nor dotted. + +@example +@group +(proper-list-p '(a b c)) + @result{} 3 +@end group +@group +(proper-list-p '(a b . c)) + @result{} nil +@end group +@end example +@end defun @node List Elements @section Accessing Elements of Lists diff --git a/etc/NEWS b/etc/NEWS index dae028be7b..1a1e0d8b70 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -703,6 +703,11 @@ manual for more details. * Lisp Changes in Emacs 27.1 ++++ +** New function 'proper-list-p'. +Given a proper list as argument, this predicate returns its length; +otherwise, it returns nil. + ** 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..11161647a6 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-p 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..58eadbade0 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-p 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..cad21044f1 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 @@ -494,17 +482,17 @@ ert--explain-format-atom (defun ert--explain-equal-rec (a b) "Return a programmer-readable explanation of why A and B are not `equal'. Returns nil if they are." - (if (not (equal (type-of a) (type-of b))) + (if (not (eq (type-of a) (type-of b))) `(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-length (proper-list-p a)) + (b-length (proper-list-p b))) + (if (not (eq (not a-length) (not b-length))) `(one-list-proper-one-improper ,a ,b) - (if a-proper-p - (if (not (equal (length a) (length b))) - `(proper-lists-of-different-length ,(length a) ,(length b) + (if a-length + (if (/= a-length b-length) + `(proper-lists-of-different-length ,a-length ,b-length ,a ,b first-mismatch-at ,(cl-mismatch a b :test 'equal)) @@ -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..1222abbf65 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-p old) + (proper-list-p 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..a5449fe35e 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-p r) (cl-every - (lambda (e) (or (atom e) (null (cdr (last e))))) + (lambda (e) (or (atom e) (proper-list-p e))) result))))) ;; insert results based on type (cond diff --git a/lisp/subr.el b/lisp/subr.el index ca184d8fc8..c1d90e3fb1 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-p (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..86938d5dbe 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-p () + "Test `proper-list-p' behavior." + (dotimes (length 4) + ;; Proper and dotted lists. + (let ((list (make-list length 0))) + (should (= (proper-list-p list) length)) + (should (not (proper-list-p (nconc list 0))))) + ;; Circular lists. + (dotimes (n (1+ length)) + (let ((circle (make-list (1+ length) 0))) + (should (not (proper-list-p (nconc circle (nthcdr n circle)))))))) + ;; Atoms. + (should (not (proper-list-p 0))) + (should (not (proper-list-p ""))) + (should (not (proper-list-p []))) + (should (not (proper-list-p (make-bool-vector 0 nil)))) + (should (not (proper-list-p (make-symbol "a"))))) + (ert-deftest subr-tests--assq-delete-all () "Test `assq-delete-all' behavior." (cl-flet ((new-list-fn -- 2.18.0