Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 4792:95b04754ea8c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make #'equalp more compatible with CL; add a compiler macro, test & doc it. lisp/ChangeLog addition: 2009-11-08 Aidan Kehoe <kehoea@parhasard.net> * cl-extra.el (cl-string-vector-equalp) (cl-bit-vector-vector-equalp, cl-vector-array-equalp) (cl-hash-table-contents-equalp): New functions, to implement equalp treating arrays with identical contents as equivalent, as specified by Common Lisp. (equalp): Revise this function to implement array equivalence, and the hash-table equalp behaviour specified by CL. * cl-macs.el (equalp): Add a compiler macro for this function, used when one of the arguments is constant, and as such, its type is known at compile time. man/ChangeLog addition: 2009-11-08 Aidan Kehoe <kehoea@parhasard.net> * lispref/objects.texi (Equality Predicates): Document #'equalp here, as well as #'equal and #'eq. tests/ChangeLog addition: 2009-12-31 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el: Test much of the functionality of equalp; add a pointer to Paul Dietz' ANSI test suite for this function, converted to Emacs Lisp. Not including the tests themselves in XEmacs because who owns the copyright on the files is unclear and the GCL people didn't respond to my queries.
author Aidan Kehoe <kehoea@parhasard.net>
date Thu, 31 Dec 2009 15:09:41 +0000
parents d0ea57eb3de4
children b828e06dbe38
comparison
equal deleted inserted replaced
4791:ea07b60c097f 4792:95b04754ea8c
87 (t (error "Can't coerce %s to type %s" x type)))) 87 (t (error "Can't coerce %s to type %s" x type))))
88 88
89 89
90 ;;; Predicates. 90 ;;; Predicates.
91 91
92 ;; I'd actually prefer not to have this inline, the space
93 ;; vs. amount-it's-called trade-off isn't reasonable, but that would
94 ;; introduce bytecode problems with the compiler macro in cl-macs.el.
95 (defsubst cl-string-vector-equalp (cl-string cl-vector)
96 "Helper function for `equalp', which see."
97 ; (check-argument-type #'stringp cl-string)
98 ; (check-argument-type #'vector cl-vector)
99 (let ((cl-i (length cl-string))
100 cl-char cl-other)
101 (when (= cl-i (length cl-vector))
102 (while (and (>= (setq cl-i (1- cl-i)) 0)
103 (or (eq (setq cl-char (aref cl-string cl-i))
104 (setq cl-other (aref cl-vector cl-i)))
105 (and (characterp cl-other) ; Note we want to call this
106 ; as rarely as possible, it
107 ; doesn't have a bytecode.
108 (eq (downcase cl-char) (downcase cl-other))))))
109 (< cl-i 0))))
110
111 ;; See comment on cl-string-vector-equalp above.
112 (defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector)
113 "Helper function for `equalp', which see."
114 ; (check-argument-type #'bit-vector-p cl-bit-vector)
115 ; (check-argument-type #'vectorp cl-vector)
116 (let ((cl-i (length cl-bit-vector))
117 cl-other)
118 (when (= cl-i (length cl-vector))
119 (while (and (>= (setq cl-i (1- cl-i)) 0)
120 (numberp (setq cl-other (aref cl-vector cl-i)))
121 ;; Differs from clisp here.
122 (= (aref cl-bit-vector cl-i) cl-other)))
123 (< cl-i 0))))
124
125 ;; These two helper functions call equalp recursively, the two above have no
126 ;; need to.
127 (defsubst cl-vector-array-equalp (cl-vector cl-array)
128 "Helper function for `equalp', which see."
129 ; (check-argument-type #'vector cl-vector)
130 ; (check-argument-type #'arrayp cl-array)
131 (let ((cl-i (length cl-vector)))
132 (when (= cl-i (length cl-array))
133 (while (and (>= (setq cl-i (1- cl-i)) 0)
134 (equalp (aref cl-vector cl-i) (aref cl-array cl-i))))
135 (< cl-i 0))))
136
137 (defsubst cl-hash-table-contents-equalp (cl-hash-table-1 cl-hash-table-2)
138 "Helper function for `equalp', which see."
139 (symbol-macrolet
140 ;; If someone has gone and fished the uninterned symbol out of this
141 ;; function's constants vector, and subsequently stored it as a value
142 ;; in a hash table, it's their own damn fault when
143 ;; `cl-hash-table-contents-equalp' gives the wrong answer.
144 ((equalp-default '#:equalp-default))
145 (loop
146 for x-key being the hash-key in cl-hash-table-1
147 using (hash-value x-value)
148 with y-value = nil
149 always (and (not (eq equalp-default
150 (setq y-value (gethash x-key cl-hash-table-2
151 equalp-default))))
152 (equalp y-value x-value)))))
153
92 (defun equalp (x y) 154 (defun equalp (x y)
93 "Return t if two Lisp objects have similar structures and contents. 155 "Return t if two Lisp objects have similar structures and contents.
156
94 This is like `equal', except that it accepts numerically equal 157 This is like `equal', except that it accepts numerically equal
95 numbers of different types (float vs. integer), and also compares 158 numbers of different types (float, integer, bignum, bigfloat), and also
96 strings case-insensitively." 159 compares strings and characters case-insensitively.
97 (cond ((eq x y) t) 160
161 Arrays (that is, strings, bit-vectors, and vectors) of the same length and
162 with contents that are `equalp' are themselves `equalp'.
163
164 Two hash tables are `equalp' if they have the same test (see
165 `hash-table-test'), if they have the same number of entries, and if, for
166 each entry in one hash table, its key is equivalent to a key in the other
167 hash table using the hash table test, and its value is `equalp' to the other
168 hash table's value for that key."
169 (cond ((eq x y))
98 ((stringp x) 170 ((stringp x)
99 ;; XEmacs change: avoid downcase 171 (if (stringp y)
100 (and (stringp y) 172 (eq t (compare-strings x nil nil y nil nil t))
101 (eq t (compare-strings x nil nil y nil nil t)))) 173 (if (vectorp y)
102 ;; XEmacs addition: compare characters 174 (cl-string-vector-equalp x y)
103 ((characterp x) 175 ;; bit-vectors and strings are only equalp if they're
104 (and (characterp y) 176 ;; zero-length:
105 (or (char-equal x y) 177 (and (equal "" x) (equal #* y)))))
106 (char-equal (downcase x) (downcase y)))))
107 ((numberp x) 178 ((numberp x)
108 (and (numberp y) (= x y))) 179 (and (numberp y) (= x y)))
109 ((consp x) 180 ((consp x)
110 (while (and (consp x) (consp y) (equalp (car x) (car y))) 181 (while (and (consp x) (consp y) (equalp (car x) (car y)))
111 (setq x (cdr x) y (cdr y))) 182 (setq x (cdr x) y (cdr y)))
112 (and (not (consp x)) (equalp x y))) 183 (and (not (consp x)) (equalp x y)))
113 ((vectorp x) 184 (t
114 (and (vectorp y) (= (length x) (length y)) 185 ;; From here on, the type tests don't (yet) have bytecodes.
115 (let ((i (length x))) 186 (let ((x-type (type-of x)))
116 (while (and (>= (setq i (1- i)) 0) 187 (cond ((eq 'vector x-type)
117 (equalp (aref x i) (aref y i)))) 188 (if (stringp y)
118 (< i 0)))) 189 (cl-string-vector-equalp y x)
119 (t (equal x y)))) 190 (if (vectorp y)
120 191 (cl-vector-array-equalp x y)
192 (if (bit-vector-p y)
193 (cl-bit-vector-vector-equalp y x)))))
194 ((eq 'character x-type)
195 (and (characterp y)
196 ;; If the characters are actually identical, the
197 ;; first eq test will have caught them above; we only
198 ;; need to check them case-insensitively here.
199 (eq (downcase x) (downcase y))))
200 ((eq 'hash-table x-type)
201 (and (hash-table-p y)
202 (eq (hash-table-test x) (hash-table-test y))
203 (= (hash-table-count x) (hash-table-count y))
204 (cl-hash-table-contents-equalp x y)))
205 ((eq 'bit-vector x-type)
206 (if (bit-vector-p y)
207 (equal x y)
208 (if (vectorp y)
209 (cl-bit-vector-vector-equalp x y)
210 ;; bit-vectors and strings are only equalp if they're
211 ;; zero-length:
212 (and (equal "" y) (equal #* x)))))
213 (t (equal x y)))))))
121 214
122 ;;; Control structures. 215 ;;; Control structures.
123 216
124 (defun cl-mapcar-many (cl-func cl-seqs) 217 (defun cl-mapcar-many (cl-func cl-seqs)
125 (if (cdr (cdr cl-seqs)) 218 (if (cdr (cdr cl-seqs))