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
@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
......
......@@ -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
+++
......
......@@ -982,8 +982,7 @@
;; (if <test> <then> nil) ==> (if <test> <then>)
(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)))
......
......@@ -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
;; usage info.
(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))
(tail (cdr last)))
(unwind-protect
......
......@@ -472,18 +472,6 @@ Errors during evaluation are caught and handled like nil."
;; 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 @@ Errors during evaluation are caught and handled like nil."
(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 @@ Returns nil if they are."
(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)
......
......@@ -539,14 +539,6 @@ Compare using `equal'."
(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 @@ either strings, or lists of the form (PARAMETER VALUE)."
;; 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)))
......
......@@ -2310,10 +2310,9 @@ INFO may provide the values of these header arguments (in the
(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
......
......@@ -555,6 +555,12 @@ If N is omitted or nil, remove the last element."
(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.
......
......@@ -496,48 +496,6 @@ This macro is used to test if macroexpansion in `should' works."
;;; 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)))
......
......@@ -306,6 +306,24 @@ cf. Bug#25477."
(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
......
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