Commit 2fde6275 authored by Basil L. Contovounesios's avatar Basil L. Contovounesios Committed by Paul Eggert
Browse files

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 <eggert@cs.ucla.edu> 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.
parent e4ad2d1a
...@@ -153,6 +153,22 @@ considered a list and @code{not} when it is considered a truth value ...@@ -153,6 +153,22 @@ considered a list and @code{not} when it is considered a truth value
@end example @end example
@end defun @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 @node List Elements
@section Accessing Elements of Lists @section Accessing Elements of Lists
......
...@@ -703,6 +703,11 @@ manual for more details. ...@@ -703,6 +703,11 @@ manual for more details.
* Lisp Changes in Emacs 27.1 * 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 ** define-minor-mode automatically documents the meaning of ARG
+++ +++
......
...@@ -982,8 +982,7 @@ ...@@ -982,8 +982,7 @@
;; (if <test> <then> nil) ==> (if <test> <then>) ;; (if <test> <then> nil) ==> (if <test> <then>)
(let ((clause (nth 1 form))) (let ((clause (nth 1 form)))
(cond ((and (eq (car-safe clause) 'progn) (cond ((and (eq (car-safe clause) 'progn)
;; `clause' is a proper list. (proper-list-p clause))
(null (cdr (last clause))))
(if (null (cddr clause)) (if (null (cddr clause))
;; A trivial `progn'. ;; A trivial `progn'.
(byte-optimize-if `(if ,(cadr clause) ,@(nthcdr 2 form))) (byte-optimize-if `(if ,(cadr clause) ,@(nthcdr 2 form)))
......
...@@ -498,7 +498,7 @@ its argument list allows full Common Lisp conventions." ...@@ -498,7 +498,7 @@ its argument list allows full Common Lisp conventions."
;; `&aux' args aren't arguments, so let's just drop them from the ;; `&aux' args aren't arguments, so let's just drop them from the
;; usage info. ;; usage info.
(setq arglist (cl-subseq arglist 0 aux)))) (setq arglist (cl-subseq arglist 0 aux))))
(if (cdr-safe (last arglist)) ;Not a proper list. (if (not (proper-list-p arglist))
(let* ((last (last arglist)) (let* ((last (last arglist))
(tail (cdr last))) (tail (cdr last)))
(unwind-protect (unwind-protect
......
...@@ -472,18 +472,6 @@ Errors during evaluation are caught and handled like nil." ...@@ -472,18 +472,6 @@ Errors during evaluation are caught and handled like nil."
;; buffer. Perhaps explanations should be reported through `ert-info' ;; buffer. Perhaps explanations should be reported through `ert-info'
;; rather than as part of the condition. ;; 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) (defun ert--explain-format-atom (x)
"Format the atom X for `ert--explain-equal'." "Format the atom X for `ert--explain-equal'."
(pcase x (pcase x
...@@ -494,17 +482,17 @@ Errors during evaluation are caught and handled like nil." ...@@ -494,17 +482,17 @@ Errors during evaluation are caught and handled like nil."
(defun ert--explain-equal-rec (a b) (defun ert--explain-equal-rec (a b)
"Return a programmer-readable explanation of why A and B are not `equal'. "Return a programmer-readable explanation of why A and B are not `equal'.
Returns nil if they are." 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) `(different-types ,a ,b)
(pcase-exhaustive a (pcase-exhaustive a
((pred consp) ((pred consp)
(let ((a-proper-p (ert--proper-list-p a)) (let ((a-length (proper-list-p a))
(b-proper-p (ert--proper-list-p b))) (b-length (proper-list-p b)))
(if (not (eql (not a-proper-p) (not b-proper-p))) (if (not (eq (not a-length) (not b-length)))
`(one-list-proper-one-improper ,a ,b) `(one-list-proper-one-improper ,a ,b)
(if a-proper-p (if a-length
(if (not (equal (length a) (length b))) (if (/= a-length b-length)
`(proper-lists-of-different-length ,(length a) ,(length b) `(proper-lists-of-different-length ,a-length ,b-length
,a ,b ,a ,b
first-mismatch-at first-mismatch-at
,(cl-mismatch a b :test 'equal)) ,(cl-mismatch a b :test 'equal))
...@@ -523,7 +511,7 @@ Returns nil if they are." ...@@ -523,7 +511,7 @@ Returns nil if they are."
(cl-assert (equal a b) t) (cl-assert (equal a b) t)
nil)))))))) nil))))))))
((pred arrayp) ((pred arrayp)
(if (not (equal (length a) (length b))) (if (/= (length a) (length b))
`(arrays-of-different-length ,(length a) ,(length b) `(arrays-of-different-length ,(length a) ,(length b)
,a ,b ,a ,b
,@(unless (char-table-p a) ,@(unless (char-table-p a)
......
...@@ -539,14 +539,6 @@ Compare using `equal'." ...@@ -539,14 +539,6 @@ Compare using `equal'."
(setq tail next))) (setq tail next)))
(cons acopy bcopy))) (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) (defun format-reorder (items order)
"Arrange ITEMS to follow partial ORDER. "Arrange ITEMS to follow partial ORDER.
Elements of ITEMS equal to elements of ORDER will be rearranged Elements of ITEMS equal to elements of ORDER will be rearranged
...@@ -1005,8 +997,8 @@ either strings, or lists of the form (PARAMETER VALUE)." ...@@ -1005,8 +997,8 @@ either strings, or lists of the form (PARAMETER VALUE)."
;; If either old or new is a list, have to treat both that way. ;; If either old or new is a list, have to treat both that way.
(if (and (or (listp old) (listp new)) (if (and (or (listp old) (listp new))
(not (get prop 'format-list-atomic-p))) (not (get prop 'format-list-atomic-p)))
(if (or (not (format-proper-list-p old)) (if (not (and (proper-list-p old)
(not (format-proper-list-p new))) (proper-list-p new)))
(format-annotate-atomic-property-change prop-alist old new) (format-annotate-atomic-property-change prop-alist old new)
(let* ((old (if (listp old) old (list old))) (let* ((old (if (listp old) old (list old)))
(new (if (listp new) new (list new))) (new (if (listp new) new (list new)))
......
...@@ -2310,10 +2310,9 @@ INFO may provide the values of these header arguments (in the ...@@ -2310,10 +2310,9 @@ INFO may provide the values of these header arguments (in the
(lambda (r) (lambda (r)
;; Non-nil when result R can be turned into ;; Non-nil when result R can be turned into
;; a table. ;; a table.
(and (listp r) (and (proper-list-p r)
(null (cdr (last r)))
(cl-every (cl-every
(lambda (e) (or (atom e) (null (cdr (last e))))) (lambda (e) (or (atom e) (proper-list-p e)))
result))))) result)))))
;; insert results based on type ;; insert results based on type
(cond (cond
......
...@@ -555,6 +555,12 @@ If N is omitted or nil, remove the last element." ...@@ -555,6 +555,12 @@ If N is omitted or nil, remove the last element."
(declare (compiler-macro (lambda (_) `(= 0 ,number)))) (declare (compiler-macro (lambda (_) `(= 0 ,number))))
(= 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) (defun delete-dups (list)
"Destructively remove `equal' duplicates from LIST. "Destructively remove `equal' duplicates from LIST.
Store the result in LIST and return it. LIST must be a proper list. Store the result in LIST and return it. LIST must be a proper list.
......
...@@ -496,48 +496,6 @@ This macro is used to test if macroexpansion in `should' works." ...@@ -496,48 +496,6 @@ This macro is used to test if macroexpansion in `should' works."
;;; Tests for utility functions. ;;; 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 () (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 '(foo)) '(nil (foo))))
(should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil))) (should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil)))
......
...@@ -306,6 +306,24 @@ cf. Bug#25477." ...@@ -306,6 +306,24 @@ cf. Bug#25477."
(should (eq (string-to-char (symbol-name (gensym))) ?g)) (should (eq (string-to-char (symbol-name (gensym))) ?g))
(should (eq (string-to-char (symbol-name (gensym "X"))) ?X))) (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 () (ert-deftest subr-tests--assq-delete-all ()
"Test `assq-delete-all' behavior." "Test `assq-delete-all' behavior."
(cl-flet ((new-list-fn (cl-flet ((new-list-fn
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment