returns @code{t} if they are not, and @code{nil} if they are.
@end defun
+@anchor{definition of <}
@defun < number-or-marker &rest number-or-markers
This function tests whether each argument is strictly less than the
following argument. It returns @code{t} if so, @code{nil} otherwise.
@end example
@end defun
+@cindex comparing values
+@cindex standard sorting order
+@defun value< a b
+This function returns non-@code{nil} if @var{a} comes before @var{b} in
+the standard sorting order; this means that it returns @code{nil} when
+@var{b} comes before @var{a}, or if they are equal or unordered.
+
+@var{a} and @var{b} must have the same type. Specifically:
+
+@itemize @bullet
+@item
+Numbers are compared using @code{<} (@pxref{definition of <}).
+@item
+Strings and symbols are compared using @code{string<}
+(@pxref{definition of string<}).
+@item
+Conses, lists, vectors and records are compared lexicographically.
+@item
+Markers are compared first by buffer, then by position.
+@item
+Buffers and processes are compared by name.
+@item
+Other types are considered unordered and the return value will be @code{nil}.
+@end itemize
+
+Examples:
+@example
+(value< -4 3.5) @result{} t
+(value< "dog" "cat") @result{} nil
+(value< 'yip 'yip) @result{} nil
+(value< '(3 2) '(3 2 0)) @result{} t
+(value< [3 2 1] [3 2 0]) @result{} nil
+@end example
+@end defun
+
Sometimes, computation of sort keys of list or vector elements is
expensive, and therefore it is important to perform it the minimum
number of times. By contrast, computing the sort keys of elements
@end defun
@cindex lexical comparison of strings
+@anchor{definition of string<}
@defun string< string1 string2
@c (findex string< causes problems for permuted index!!)
This function compares two strings a character at a time. It
Mostly used internally to do a kind of topological sort of
inheritance hierarchies.
++++
+** New polymorphic comparison function 'value<'.
+This function returns non-nil if the first argument is less than the
+second. It works for any two values of the same type with reasonable
+ordering for numbers, strings, symbols, bool-vectors, markers, buffers
+and processes. Conses, lists, vectors and records are ordered
+lexicographically.
+It is intended as a convenient ordering predicate for sorting, and is
+likely to be faster than hand-written Lisp functions.
+
** New function 'sort-on'.
This function implements the Schwartzian transform, and is appropriate
for sorting lists when the computation of the sort key of a list
string-version-lessp
substring substring-no-properties
sxhash-eq sxhash-eql sxhash-equal sxhash-equal-including-properties
- take vconcat
+ take value< vconcat
;; frame.c
frame-ancestor-p frame-bottom-divider-width frame-char-height
frame-char-width frame-child-frame-border-width frame-focus
hash-table-p identity length length< length=
length> member memq memql nth nthcdr proper-list-p rassoc rassq
safe-length string-bytes string-distance string-equal string-lessp
- string-search string-version-lessp take
+ string-search string-version-lessp take value<
;; search.c
regexp-quote
;; syntax.c
}
}
-static bits_word
-bits_word_to_host_endian (bits_word val)
-{
-#ifndef WORDS_BIGENDIAN
- return val;
-#else
- if (BITS_WORD_MAX >> 31 == 1)
- return bswap_32 (val);
- if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1)
- return bswap_64 (val);
- {
- int i;
- bits_word r = 0;
- for (i = 0; i < sizeof val; i++)
- {
- r = ((r << 1 << (CHAR_BIT - 1))
- | (val & ((1u << 1 << (CHAR_BIT - 1)) - 1)));
- val = val >> 1 >> (CHAR_BIT - 1);
- }
- return r;
- }
-#endif
-}
-
DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or,
Sbool_vector_exclusive_or, 2, 3, 0,
doc: /* Return A ^ B, bitwise exclusive or.
DEFSYM (Qminibuffer_quit, "minibuffer-quit");
DEFSYM (Qwrong_length_argument, "wrong-length-argument");
DEFSYM (Qwrong_type_argument, "wrong-type-argument");
+ DEFSYM (Qtype_mismatch, "type-mismatch")
DEFSYM (Qargs_out_of_range, "args-out-of-range");
DEFSYM (Qvoid_function, "void-function");
DEFSYM (Qcyclic_function_indirection, "cyclic-function-indirection");
PUT_ERROR (Quser_error, error_tail, "");
PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument");
PUT_ERROR (Qwrong_type_argument, error_tail, "Wrong type argument");
+ PUT_ERROR (Qtype_mismatch, error_tail, "Types do not match");
PUT_ERROR (Qargs_out_of_range, error_tail, "Args out of range");
PUT_ERROR (Qvoid_function, error_tail,
"Symbol's function definition is void");
#include <vla.h>
#include <errno.h>
#include <ctype.h>
+#include <math.h>
#include "lisp.h"
#include "bignum.h"
return x;
}
-DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
- doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
-Case is significant.
-Symbols are also allowed; their print names are used instead. */)
- (Lisp_Object string1, Lisp_Object string2)
+/* Return -1/0/1 to indicate the relation </=/> between string1 and string2. */
+static int
+string_cmp (Lisp_Object string1, Lisp_Object string2)
{
- if (SYMBOLP (string1))
- string1 = SYMBOL_NAME (string1);
- else
- CHECK_STRING (string1);
- if (SYMBOLP (string2))
- string2 = SYMBOL_NAME (string2);
- else
- CHECK_STRING (string2);
-
ptrdiff_t n = min (SCHARS (string1), SCHARS (string2));
if ((!STRING_MULTIBYTE (string1) || SCHARS (string1) == SBYTES (string1))
/* Each argument is either unibyte or all-ASCII multibyte:
we can compare bytewise. */
int d = memcmp (SSDATA (string1), SSDATA (string2), n);
- return d < 0 || (d == 0 && n < SCHARS (string2)) ? Qt : Qnil;
+ if (d)
+ return d;
+ return n < SCHARS (string2) ? -1 : n > SCHARS (string2);
}
else if (STRING_MULTIBYTE (string1) && STRING_MULTIBYTE (string2))
{
if (b >= nb)
/* One string is a prefix of the other. */
- return b < nb2 ? Qt : Qnil;
+ return b < nb2 ? -1 : b > nb2;
/* Now back up to the start of the differing characters:
it's the last byte not having the bit pattern 10xxxxxx. */
ptrdiff_t i1_byte = b, i2_byte = b;
int c1 = fetch_string_char_advance_no_check (string1, &i1, &i1_byte);
int c2 = fetch_string_char_advance_no_check (string2, &i2, &i2_byte);
- return c1 < c2 ? Qt : Qnil;
+ return c1 < c2 ? -1 : c1 > c2;
}
else if (STRING_MULTIBYTE (string1))
{
int c1 = fetch_string_char_advance_no_check (string1, &i1, &i1_byte);
int c2 = SREF (string2, i2++);
if (c1 != c2)
- return c1 < c2 ? Qt : Qnil;
+ return c1 < c2 ? -1 : 1;
}
- return i1 < SCHARS (string2) ? Qt : Qnil;
+ return i1 < SCHARS (string2) ? -1 : i1 > SCHARS (string2);
}
else
{
int c1 = SREF (string1, i1++);
int c2 = fetch_string_char_advance_no_check (string2, &i2, &i2_byte);
if (c1 != c2)
- return c1 < c2 ? Qt : Qnil;
+ return c1 < c2 ? -1 : 1;
}
- return i1 < SCHARS (string2) ? Qt : Qnil;
+ return i1 < SCHARS (string2) ? -1 : i1 > SCHARS (string2);
}
}
+DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
+ doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
+Case is significant.
+Symbols are also allowed; their print names are used instead. */)
+ (Lisp_Object string1, Lisp_Object string2)
+{
+ if (SYMBOLP (string1))
+ string1 = SYMBOL_NAME (string1);
+ else
+ CHECK_STRING (string1);
+ if (SYMBOLP (string2))
+ string2 = SYMBOL_NAME (string2);
+ else
+ CHECK_STRING (string2);
+
+ return string_cmp (string1, string2) < 0 ? Qt : Qnil;
+}
+
DEFUN ("string-version-lessp", Fstring_version_lessp,
Sstring_version_lessp, 2, 2, 0,
doc: /* Return non-nil if S1 is less than S2, as version strings.
return false;
}
+
+/* Return -1/0/1 for the </=/> lexicographic relation between bool-vectors. */
+static int
+bool_vector_cmp (Lisp_Object a, Lisp_Object b)
+{
+ ptrdiff_t na = bool_vector_size (a);
+ ptrdiff_t nb = bool_vector_size (b);
+ /* Skip equal words. */
+ ptrdiff_t words_min = min (na, nb) / BITS_PER_BITS_WORD;
+ bits_word *ad = bool_vector_data (a);
+ bits_word *bd = bool_vector_data (b);
+ ptrdiff_t i = 0;
+ while (i < words_min && ad[i] == bd[i])
+ i++;
+ na -= i * BITS_PER_BITS_WORD;
+ nb -= i * BITS_PER_BITS_WORD;
+ eassume (na >= 0 && nb >= 0);
+ if (nb == 0)
+ return na != 0;
+ if (na == 0)
+ return -1;
+
+ bits_word aw = bits_word_to_host_endian (ad[i]);
+ bits_word bw = bits_word_to_host_endian (bd[i]);
+ bits_word xw = aw ^ bw;
+ if (xw == 0)
+ return na < nb ? -1 : na > nb;
+
+ bits_word d = xw & -xw; /* Isolate first difference. */
+ eassume (d != 0);
+ return (d & aw) ? 1 : -1;
+}
+
+/* Return -1, 0 or 1 to indicate whether a<b, a=b or a>b in the sense of value<.
+ In particular 0 does not mean equality in the sense of Fequal, only
+ that the arguments cannot be ordered yet they can be compared (same
+ type). */
+static int
+value_cmp (Lisp_Object a, Lisp_Object b, int maxdepth)
+{
+ if (maxdepth < 0)
+ error ("Maximum depth exceeded in comparison");
+
+ tail_recurse:
+ /* Shortcut for a common case. */
+ if (BASE_EQ (a, b))
+ return 0;
+
+ switch (XTYPE (a))
+ {
+ case_Lisp_Int:
+ {
+ EMACS_INT ia = XFIXNUM (a);
+ if (FIXNUMP (b))
+ return ia < XFIXNUM (b) ? -1 : 1; /* we know that a≠b */
+ if (FLOATP (b))
+ return ia < XFLOAT_DATA (b) ? -1 : ia > XFLOAT_DATA (b);
+ if (BIGNUMP (b))
+ return -mpz_sgn (*xbignum_val (b));
+ }
+ goto type_mismatch;
+
+ case Lisp_Symbol:
+ if (BARE_SYMBOL_P (b))
+ return string_cmp (XBARE_SYMBOL (a)->u.s.name,
+ XBARE_SYMBOL (b)->u.s.name);
+ if (CONSP (b) && NILP (a))
+ return -1;
+ if (SYMBOLP (b))
+ /* Slow-path branch when B is a symbol-with-pos. */
+ return string_cmp (XBARE_SYMBOL (a)->u.s.name, XSYMBOL (b)->u.s.name);
+ goto type_mismatch;
+
+ case Lisp_String:
+ if (STRINGP (b))
+ return string_cmp (a, b);
+ goto type_mismatch;
+
+ case Lisp_Cons:
+ /* FIXME: Optimise for difference in the first element? */
+ FOR_EACH_TAIL (b)
+ {
+ int cmp = value_cmp (XCAR (a), XCAR (b), maxdepth - 1);
+ if (cmp != 0)
+ return cmp;
+ a = XCDR (a);
+ if (!CONSP (a))
+ {
+ b = XCDR (b);
+ goto tail_recurse;
+ }
+ }
+ if (NILP (b))
+ return 1;
+ else
+ goto type_mismatch;
+ goto tail_recurse;
+
+ case Lisp_Vectorlike:
+ if (VECTORLIKEP (b))
+ {
+ enum pvec_type ta = PSEUDOVECTOR_TYPE (XVECTOR (a));
+ enum pvec_type tb = PSEUDOVECTOR_TYPE (XVECTOR (b));
+ if (ta == tb)
+ switch (ta)
+ {
+ case PVEC_NORMAL_VECTOR:
+ case PVEC_RECORD:
+ {
+ ptrdiff_t len_a = ASIZE (a);
+ ptrdiff_t len_b = ASIZE (b);
+ if (ta == PVEC_RECORD)
+ {
+ len_a &= PSEUDOVECTOR_SIZE_MASK;
+ len_b &= PSEUDOVECTOR_SIZE_MASK;
+ }
+ ptrdiff_t len_min = min (len_a, len_b);
+ for (ptrdiff_t i = 0; i < len_min; i++)
+ {
+ int cmp = value_cmp (AREF (a, i), AREF (b, i),
+ maxdepth - 1);
+ if (cmp != 0)
+ return cmp;
+ }
+ return len_a < len_b ? -1 : len_a > len_b;
+ }
+
+ case PVEC_BOOL_VECTOR:
+ return bool_vector_cmp (a, b);
+
+ case PVEC_MARKER:
+ {
+ Lisp_Object buf_a = Fmarker_buffer (a);
+ Lisp_Object buf_b = Fmarker_buffer (b);
+ if (NILP (buf_a))
+ return NILP (buf_b) ? 0 : -1;
+ if (NILP (buf_b))
+ return 1;
+ int cmp = value_cmp (buf_a, buf_b, maxdepth - 1);
+ if (cmp != 0)
+ return cmp;
+ ptrdiff_t pa = XMARKER (a)->charpos;
+ ptrdiff_t pb = XMARKER (b)->charpos;
+ return pa < pb ? -1 : pa > pb;
+ }
+
+ case PVEC_PROCESS:
+ a = Fprocess_name (a);
+ b = Fprocess_name (b);
+ goto tail_recurse;
+
+ case PVEC_BUFFER:
+ {
+ /* Killed buffers lack names and sort before those alive. */
+ Lisp_Object na = Fbuffer_name (a);
+ Lisp_Object nb = Fbuffer_name (b);
+ if (NILP (na))
+ return NILP (nb) ? 0 : -1;
+ if (NILP (nb))
+ return 1;
+ a = na;
+ b = nb;
+ goto tail_recurse;
+ }
+
+ case PVEC_BIGNUM:
+ return mpz_cmp (*xbignum_val (a), *xbignum_val (b));
+
+ case PVEC_SYMBOL_WITH_POS:
+ /* Compare by name, enabled or not. */
+ a = XSYMBOL_WITH_POS_SYM (a);
+ b = XSYMBOL_WITH_POS_SYM (b);
+ goto tail_recurse;
+
+ default:
+ /* Treat other types as unordered. */
+ return 0;
+ }
+ }
+ else if (BIGNUMP (a))
+ return -value_cmp (b, a, maxdepth);
+ else if (SYMBOL_WITH_POS_P (a) && symbols_with_pos_enabled)
+ {
+ a = XSYMBOL_WITH_POS_SYM (a);
+ goto tail_recurse;
+ }
+
+ goto type_mismatch;
+
+ case Lisp_Float:
+ {
+ double fa = XFLOAT_DATA (a);
+ if (FLOATP (b))
+ return fa < XFLOAT_DATA (b) ? -1 : fa > XFLOAT_DATA (b);
+ if (FIXNUMP (b))
+ return fa < XFIXNUM (b) ? -1 : fa > XFIXNUM (b);
+ if (BIGNUMP (b))
+ {
+ if (isnan (fa))
+ return 0;
+ return -mpz_cmp_d (*xbignum_val (b), fa);
+ }
+ }
+ goto type_mismatch;
+
+ default:
+ eassume (0);
+ }
+ type_mismatch:
+ xsignal2 (Qtype_mismatch, a, b);
+}
+
+DEFUN ("value<", Fvaluelt, Svaluelt, 2, 2, 0,
+ doc: /* Return non-nil if A precedes B in standard value order.
+A and B must have the same basic type.
+Numbers are compared with `<'.
+Strings and symbols are compared with `string-lessp'.
+Lists, vectors, bool-vectors and records are compared lexicographically.
+Markers are compared lexicographically by buffer and position.
+Buffers and processes are compared by name.
+Other types are considered unordered and the return value will be `nil'. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ int maxdepth = 20; /* FIXME: arbitrary value */
+ return value_cmp (a, b, maxdepth) < 0 ? Qt : Qnil;
+}
+
\f
DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
defsubr (&Seql);
defsubr (&Sequal);
defsubr (&Sequal_including_properties);
+ defsubr (&Svaluelt);
defsubr (&Sfillarray);
defsubr (&Sclear_string);
defsubr (&Snconc);
return (size + BOOL_VECTOR_BITS_PER_CHAR - 1) / BOOL_VECTOR_BITS_PER_CHAR;
}
+INLINE bits_word
+bits_word_to_host_endian (bits_word val)
+{
+#ifndef WORDS_BIGENDIAN
+ return val;
+#else
+ if (BITS_WORD_MAX >> 31 == 1)
+ return bswap_32 (val);
+ if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1)
+ return bswap_64 (val);
+ {
+ int i;
+ bits_word r = 0;
+ for (i = 0; i < sizeof val; i++)
+ {
+ r = ((r << 1 << (CHAR_BIT - 1))
+ | (val & ((1u << 1 << (CHAR_BIT - 1)) - 1)));
+ val = val >> 1 >> (CHAR_BIT - 1);
+ }
+ return r;
+ }
+#endif
+}
+
INLINE bool
BOOL_VECTOR_P (Lisp_Object a)
{
(should-error (copy-alist "abc")
:type 'wrong-type-argument))
+(ert-deftest fns-value<-ordered ()
+ ;; values (X . Y) where X<Y
+ (let* ((big (* 10 most-positive-fixnum))
+ (buf1 (get-buffer-create " *one*"))
+ (buf2 (get-buffer-create " *two*"))
+ (buf3 (get-buffer-create " *three*"))
+ (_ (progn (with-current-buffer buf1 (insert (make-string 20 ?a)))
+ (with-current-buffer buf2 (insert (make-string 20 ?b)))))
+ (mark1 (set-marker (make-marker) 12 buf1))
+ (mark2 (set-marker (make-marker) 13 buf1))
+ (mark3 (set-marker (make-marker) 12 buf2))
+ (mark4 (set-marker (make-marker) 13 buf2))
+ (proc1 (make-pipe-process :name " *proc one*"))
+ (proc2 (make-pipe-process :name " *proc two*")))
+ (kill-buffer buf3)
+ (unwind-protect
+ (dolist (c
+ `(
+ ;; fixnums
+ (1 . 2) (-2 . -1) (-2 . 1) (-1 . 2)
+ ;; bignums
+ (,big . ,(1+ big)) (,(- big) . ,big)
+ (,(- -1 big) . ,(- big))
+ ;; fixnums/bignums
+ (1 . ,big) (-1 . ,big) (,(- big) . -1) (,(- big) . 1)
+ ;; floats
+ (1.5 . 1.6) (-1.3 . -1.2) (-13.0 . 12.0)
+ ;; floats/fixnums
+ (1 . 1.1) (1.9 . 2) (-2.0 . 1) (-2 . 1.0)
+ ;; floats/bignums
+ (,big . ,(float (* 2 big))) (,(float big) . ,(* 2 big))
+ ;; symbols
+ (a . b) (nil . nix) (b . ba) (## . a) (A . a)
+ (#:a . #:b) (a . #:b) (#:a . b)
+ ;; strings
+ ("" . "a") ("a" . "b") ("A" . "a") ("abc" . "abd")
+ ("b" . "ba")
+
+ ;; lists
+ ((1 2 3) . (2 3 4)) ((2) . (2 1)) (() . (0))
+ ((1 2 3) . (1 3)) ((1 2 3) . (1 3 2))
+ (((b a) (c d) e) . ((b a) (c d) f))
+ (((b a) (c D) e) . ((b a) (c d) e))
+ (((b a) (c d () x) e) . ((b a) (c d (1) x) e))
+ ((1 . 2) . (1 . 3)) ((1 2 . 3) . (1 2 . 4))
+
+ ;; vectors
+ ([1 2 3] . [2 3 4]) ([2] . [2 1]) ([] . [0])
+ ([1 2 3] . [1 3]) ([1 2 3] . [1 3 2])
+ ([[b a] [c d] e] . [[b a] [c d] f])
+ ([[b a] [c D] e] . [[b a] [c d] e])
+ ([[b a] [c d [] x] e] . [[b a] [c d [1] x] e])
+
+ ;; bool-vectors
+ (,(bool-vector) . ,(bool-vector nil))
+ (,(bool-vector nil) . ,(bool-vector t))
+ (,(bool-vector t nil t nil) . ,(bool-vector t nil t t))
+ (,(bool-vector t nil t) . ,(bool-vector t nil t nil))
+
+ ;; records
+ (#s(a 2 3) . #s(b 3 4)) (#s(b) . #s(b a))
+ (#s(a 2 3) . #s(a 3)) (#s(a 2 3) . #s(a 3 2))
+ (#s(#s(b a) #s(c d) e) . #s(#s(b a) #s(c d) f))
+ (#s(#s(b a) #s(c D) e) . #s(#s(b a) #s(c d) e))
+ (#s(#s(b a) #s(c d #s(u) x) e)
+ . #s(#s(b a) #s(c d #s(v) x) e))
+
+ ;; markers
+ (,mark1 . ,mark2) (,mark1 . ,mark3) (,mark1 . ,mark4)
+ (,mark2 . ,mark3) (,mark2 . ,mark4) (,mark3 . ,mark4)
+
+ ;; buffers
+ (,buf1 . ,buf2) (,buf3 . ,buf1) (,buf3 . ,buf2)
+
+ ;; processes
+ (,proc1 . ,proc2)
+ ))
+ (let ((x (car c))
+ (y (cdr c)))
+ (should (value< x y))
+ (should-not (value< y x))
+ (should-not (value< x x))
+ (should-not (value< y y))))
+
+ (delete-process proc2)
+ (delete-process proc1)
+ (kill-buffer buf2)
+ (kill-buffer buf1))))
+
+(ert-deftest fns-value<-unordered ()
+ ;; values (X . Y) where neither X<Y nor Y<X
+
+ (let ((buf1 (get-buffer-create " *one*"))
+ (buf2 (get-buffer-create " *two*")))
+ (kill-buffer buf2)
+ (kill-buffer buf1)
+ (dolist (c `(
+ ;; numbers
+ (0 . 0.0) (0 . -0.0) (0.0 . -0.0)
+
+ ;; symbols
+ (a . #:a)
+
+ ;; (dead) buffers
+ (,buf1 . ,buf2)
+
+ ;; unordered types
+ (,(make-hash-table) . ,(make-hash-table))
+ (,(obarray-make) . ,(obarray-make))
+ ;; FIXME: more?
+ ))
+ (let ((x (car c))
+ (y (cdr c)))
+ (should-not (value< x y))
+ (should-not (value< y x))))))
+
+(ert-deftest fns-value<-type-mismatch ()
+ ;; values of disjoint (incomparable) types
+ (let ((incomparable
+ `( 1 a "a" (a b) [a b] ,(bool-vector nil t) #s(a b)
+ ,(make-char-table 'test)
+ ,(make-hash-table)
+ ,(obarray-make)
+ ;; FIXME: more?
+ )))
+ (let ((tail incomparable))
+ (while tail
+ (let ((x (car tail)))
+ (dolist (y (cdr tail))
+ (should-error (value< x y) :type 'type-mismatch)
+ (should-error (value< y x) :type 'type-mismatch)))
+ (setq tail (cdr tail))))))
+
+(ert-deftest fns-value<-symbol-with-pos ()
+ ;; values (X . Y) where X<Y
+ (let* ((a-sp-1 (position-symbol 'a 1))
+ (a-sp-2 (position-symbol 'a 2))
+ (b-sp-1 (position-symbol 'b 1))
+ (b-sp-2 (position-symbol 'b 2)))
+
+ (dolist (swp '(nil t))
+ (let ((symbols-with-pos-enabled swp))
+ ;; Enabled or not, they compare by name.
+ (dolist (c `((,a-sp-1 . ,b-sp-1) (,a-sp-1 . ,b-sp-2)
+ (,a-sp-2 . ,b-sp-1) (,a-sp-2 . ,b-sp-2)))
+ (let ((x (car c))
+ (y (cdr c)))
+ (should (value< x y))
+ (should-not (value< y x))
+ (should-not (value< x x))
+ (should-not (value< y y))))
+ (should-not (value< a-sp-1 a-sp-2))
+ (should-not (value< a-sp-2 a-sp-1))))
+
+ ;; When disabled, symbol-with-pos and symbols do not compare.
+ (should-error (value< a-sp-1 'a) :type 'type-mismatch)
+ (should-error (value< 'a a-sp-1) :type 'type-mismatch)
+
+ (let ((symbols-with-pos-enabled t))
+ ;; When enabled, a symbol-with-pos compares as a plain symbol.
+ (dolist (c `((,a-sp-1 . b) (a . ,b-sp-1)))
+ (let ((x (car c))
+ (y (cdr c)))
+ (should (value< x y))
+ (should-not (value< y x))
+ (should-not (value< x x))
+ (should-not (value< y y))))
+ (should-not (value< a-sp-1 'a))
+ (should-not (value< 'a a-sp-1)))))
+
+(ert-deftest fns-value<-circle ()
+ ;; Check that we at least don't hang when comparing two circular lists.
+ (let ((a (number-sequence 1 5))
+ (b (number-sequence 1 5)))
+ (setcdr (last a) (nthcdr 2 a))
+ (setcdr (last b) (nthcdr 2 b))
+ (should-error (value< a b :type 'circular))
+ (should-error (value< b a :type 'circular))))
+
+(ert-deftest fns-value<-bool-vector ()
+ ;; More thorough test of `value<' for bool-vectors.
+ (random "my seed")
+ (dolist (na '(0 1 5 8 9 32 63 64 65 200 1001 1024))
+ (let ((a (make-bool-vector na nil)))
+ (dotimes (i na)
+ (aset a i (zerop (random 2))))
+ (dolist (nb '(0 1 5 8 9 32 63 64 65 200 1001 1024))
+ (when (<= nb na)
+ (let ((b (make-bool-vector nb nil)))
+ (dotimes (i nb)
+ (aset b i (aref a i)))
+ ;; `b' is now a prefix of `a'.
+ (should-not (value< a b))
+ (cond ((= nb na)
+ (should (equal a b))
+ (should-not (value< b a)))
+ (t
+ (should-not (equal a b))
+ (should (value< b a))))
+ (unless (zerop nb)
+ ;; Flip random bits in `b' and check how it affects the order.
+ (dotimes (_ 3)
+ (let ((i (random nb)))
+ (let ((val (aref b i)))
+ (aset b i (not val))
+ (should-not (equal a b))
+ (cond
+ (val
+ ;; t -> nil: `b' is now always a proper prefix of `a'.
+ (should-not (value< a b))
+ (should (value< b a)))
+ (t
+ ;; nil -> t: `a' is now less than `b'.
+ (should (value< a b))
+ (should-not (value< b a))))
+ ;; Undo the flip.
+ (aset b i val)))))))))))
+
;;; fns-tests.el ends here
projects / emacs.git / commitdiff