>From 15a5e9f48543dc114c2a9fe69fabddd0d41ec24c Mon Sep 17 00:00:00 2001
From: "Basil L. Contovounesios"
Date: Mon, 16 Apr 2018 17:47:22 +0100
Subject: [PATCH] Add predicate 'list-true-p'
* lisp/subr.el (list-true-p): New function.
* doc/lispref/lists.texi (List-related Predicates):
* 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/format.el (format-proper-list-p): Remove.
(format-annotate-single-property-change): Use list-true-p instead.
* lisp/emacs-lisp/ert.el (ert--proper-list-p): Remove.
(ert--explain-equal-rec): Use list-true-p instead.
* test/lisp/emacs-lisp/ert-tests.el (ert-test-proper-list-p):
Move from here...
* test/lisp/subr-tests.el (subr-tests--list-true-p): ...to here,
mutatis mutandis.
---
doc/lispref/lists.texi | 16 ++++++++++++
etc/NEWS | 4 +++
lisp/emacs-lisp/byte-opt.el | 3 +--
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, 55 insertions(+), 75 deletions(-)
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 761750eb20..62c14e963a 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -153,6 +153,22 @@ List-related Predicates
@end example
@end defun
address@hidden list-true-p object
+This function returns @code{t} if OBJECT is a true list, @code{nil}
+otherwise. In addition to satistying @code{listp}, a true list is
+neither circular nor dotted.
+
address@hidden
address@hidden
+(list-true-p '(1 2 3))
+ @result{} t
address@hidden group
address@hidden
+(list-true-p '(1 2 . 3))
+ @result{} nil
address@hidden group
address@hidden example
address@hidden defun
@node List Elements
@section Accessing Elements of Lists
diff --git a/etc/NEWS b/etc/NEWS
index 5aa92e2991..c20b9ade97 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -487,6 +487,10 @@ x-lost-selection-hooks, x-sent-selection-hooks
* Lisp Changes in Emacs 27.1
++++
+** New function 'list-true-p' returns t for true lists which are
+neither circular nor dotted.
+
+++
** New function assoc-delete-all.
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 3bc4c438d6..d62ee2b95c 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -982,8 +982,7 @@ byte-optimize-if
;; (if nil) ==> (if )
(let ((clause (nth 1 form)))
(cond ((and (eq (car-safe clause) 'progn)
- ;; `clause' is a proper list.
- (null (cdr (last clause))))
+ (list-true-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 9600230c07..2ed8347ba8 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 (list-true-p arglist))
(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..4134511f5d 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 (list-true-p a))
+ (b-proper-p (list-true-p 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..e5bc60712b 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 (list-true-p old)
+ (list-true-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..f931bb3c31 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 (list-true-p r)
(cl-every
- (lambda (e) (or (atom e) (null (cdr (last e)))))
+ (lambda (e) (or (atom e) (list-true-p e)))
result)))))
;; insert results based on type
(cond
diff --git a/lisp/subr.el b/lisp/subr.el
index 9cf7d596cd..4a0ab321bc 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -548,6 +548,12 @@ nbutlast
(if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
list))))
+(defun list-true-p (object)
+ "Return t if OBJECT is a true list.
+A true list is neither circular nor dotted (i.e., its last `cdr'
+is nil)."
+ (null (nthcdr (safe-length object) object)))
+
(defun zerop (number)
"Return t if NUMBER is zero."
;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because
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..63fe7ee139 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--list-true-p ()
+ "Test `list-true-p' behavior."
+ (dotimes (length 4)
+ ;; True and dotted lists
+ (let ((list (make-list length 0)))
+ (should (list-true-p list))
+ (should (not (list-true-p (nconc list 0)))))
+ ;; Circular lists
+ (dotimes (n (1+ length))
+ (let ((circle (make-list (1+ length) 0)))
+ (should (not (list-true-p (nconc circle (nthcdr n circle))))))))
+ ;; Atoms
+ (should (not (list-true-p 0)))
+ (should (not (list-true-p "")))
+ (should (not (list-true-p [])))
+ (should (not (list-true-p (make-bool-vector 0 nil))))
+ (should (not (list-true-p (make-symbol "a")))))
+
(ert-deftest subr-tests--assq-delete-all ()
"Test `assq-delete-all' behavior."
(cl-flet ((new-list-fn
--
2.17.0