Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 4906:6ef8256a020a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
implement equalp in C, fix case-folding, add equal() method for keymaps -------------------- ChangeLog entries follow: -------------------- lisp/ChangeLog addition: 2010-02-01 Ben Wing <ben@xemacs.org> * cl-extra.el: * cl-extra.el (cl-string-vector-equalp): Removed. * cl-extra.el (cl-bit-vector-vector-equalp): Removed. * cl-extra.el (cl-vector-array-equalp): Removed. * cl-extra.el (cl-hash-table-contents-equalp): Removed. * cl-extra.el (equalp): Removed. * cl-extra.el (cl-mapcar-many): Comment out the whole `equalp' implementation for the moment; remove once we're sure the C implementation works. * cl-macs.el: * cl-macs.el (equalp): Simplify the compiler-macro for `equalp' -- once it's in C, we don't need to try so hard to expand it. src/ChangeLog addition: 2010-02-01 Ben Wing <ben@xemacs.org> * abbrev.c (abbrev_match_mapper): * buffer.h (CANON_TABLE_OF): * buffer.h: * editfns.c (Fchar_equal): * minibuf.c (scmp_1): * text.c (qxestrcasecmp_i18n): * text.c (qxestrncasecmp_i18n): * text.c (qxetextcasecmp): * text.c (qxetextcasecmp_matching): Create new macro CANONCASE that converts to a canonical mapping and use it to do caseless comparisons instead of DOWNCASE. * alloc.c: * alloc.c (cons_equal): * alloc.c (vector_equal): * alloc.c (string_equal): * bytecode.c (compiled_function_equal): * chartab.c (char_table_entry_equal): * chartab.c (char_table_equal): * data.c (weak_list_equal): * data.c (weak_box_equal): * data.c (ephemeron_equal): * device-msw.c (equal_devmode): * elhash.c (hash_table_equal): * events.c (event_equal): * extents.c (properties_equal): * extents.c (extent_equal): * faces.c: * faces.c (face_equal): * faces.c (face_hash): * floatfns.c (float_equal): * fns.c: * fns.c (bit_vector_equal): * fns.c (plists_differ): * fns.c (Fplists_eq): * fns.c (Fplists_equal): * fns.c (Flax_plists_eq): * fns.c (Flax_plists_equal): * fns.c (internal_equal): * fns.c (internal_equalp): * fns.c (internal_equal_0): * fns.c (syms_of_fns): * glyphs.c (image_instance_equal): * glyphs.c (glyph_equal): * glyphs.c (glyph_hash): * gui.c (gui_item_equal): * lisp.h: * lrecord.h (struct lrecord_implementation): * marker.c (marker_equal): * number.c (bignum_equal): * number.c (ratio_equal): * number.c (bigfloat_equal): * objects.c (color_instance_equal): * objects.c (font_instance_equal): * opaque.c (equal_opaque): * opaque.c (equal_opaque_ptr): * rangetab.c (range_table_equal): * specifier.c (specifier_equal): Add a `foldcase' param to the equal() method and use it to implement `equalp' comparisons. Also add to plists_differ(), although we don't currently use it here. Rewrite internal_equalp(). Implement cross-type vector comparisons. Don't implement our own handling of numeric promotion -- just use the `=' primitive. Add internal_equal_0(), which takes a `foldcase' param and calls either internal_equal() or internal_equalp(). * buffer.h: When given a 0 for buffer (which is the norm when functions don't have a specific buffer available), use the current buffer's table, not `standard-case-table'; otherwise the current settings are ignored. * casetab.c: * casetab.c (set_case_table): When handling old-style vectors of 256 in `set-case-table' don't overwrite the existing table! Instead create a new table and populate. * device-msw.c (sync_printer_with_devmode): * lisp.h: * text.c (lisp_strcasecmp_ascii): Rename lisp_strcasecmp to lisp_strcasecmp_ascii and use lisp_strcasecmp_i18n for caseless comparisons in some places. * elhash.c: Delete unused lisp_string_hash and lisp_string_equal(). * events.h: * keymap-buttons.h: * keymap.h: * keymap.c (keymap_lookup_directly): * keymap.c (keymap_store): * keymap.c (FROB): * keymap.c (key_desc_list_to_event): * keymap.c (describe_map_mapper): * keymap.c (INCLUDE_BUTTON_ZERO): New file keymap-buttons.h; use to handle buttons 1-26 in place of duplicating code 26 times. * frame-gtk.c (allocate_gtk_frame_struct): * frame-msw.c (mswindows_init_frame_1): Fix some comments about internal_equal() in redisplay that don't apply any more. * keymap-slots.h: * keymap.c: New file keymap-slots.h. Use it to notate the slots in a keymap structure, similar to frameslots.h or coding-system-slots.h. * keymap.c (MARKED_SLOT): * keymap.c (keymap_equal): * keymap.c (keymap_hash): Implement. tests/ChangeLog addition: 2010-02-01 Ben Wing <ben@xemacs.org> * automated/case-tests.el: * automated/case-tests.el (uni-mappings): * automated/search-tests.el: Delete old pristine-case-table code. Rewrite the Unicode torture test to take into account whether overlapping mappings exist for more than one character, and not doing the upcase/downcase comparisons in such cases. * automated/lisp-tests.el (foo): * automated/lisp-tests.el (string-variable): * automated/lisp-tests.el (featurep): Replace Assert (equal ... with Assert-equal; same for other types of equality. Replace some awkward equivalents of Assert-equalp with Assert-equalp. Add lots of equalp tests. * automated/case-tests.el: * automated/regexp-tests.el: * automated/search-tests.el: Fix up the comments at the top of the files. Move rules about where to put tests into case-tests.el. * automated/test-harness.el: * automated/test-harness.el (test-harness-aborted-summary-template): New. * automated/test-harness.el (test-harness-from-buffer): * automated/test-harness.el (batch-test-emacs): Fix Assert-test-not. Create Assert-not-equal and variants. Delete the doc strings from all these convenience functions to avoid excessive repetition; instead use one copy in a comment.
author Ben Wing <ben@xemacs.org>
date Mon, 01 Feb 2010 01:02:40 -0600
parents b828e06dbe38
children c17c857e20bf
comparison
equal deleted inserted replaced
4903:70089046adef 4906:6ef8256a020a
85 wl))) 85 wl)))
86 ((typep x type) x) 86 ((typep x type) x)
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 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 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. 94 ;;;; introduce bytecode problems with the compiler macro in cl-macs.el.
95 (defsubst cl-string-vector-equalp (cl-string cl-vector) 95 ;;(defsubst cl-string-vector-equalp (cl-string cl-vector)
96 "Helper function for `equalp', which see." 96 ;; "Helper function for `equalp', which see."
97 ; (check-argument-type #'stringp cl-string) 97 ;;; (check-argument-type #'stringp cl-string)
98 ; (check-argument-type #'vector cl-vector) 98 ;;; (check-argument-type #'vector cl-vector)
99 (let ((cl-i (length cl-string)) 99 ;; (let ((cl-i (length cl-string))
100 cl-char cl-other) 100 ;; cl-char cl-other)
101 (when (= cl-i (length cl-vector)) 101 ;; (when (= cl-i (length cl-vector))
102 (while (and (>= (setq cl-i (1- cl-i)) 0) 102 ;; (while (and (>= (setq cl-i (1- cl-i)) 0)
103 (or (eq (setq cl-char (aref cl-string cl-i)) 103 ;; (or (eq (setq cl-char (aref cl-string cl-i))
104 (setq cl-other (aref cl-vector cl-i))) 104 ;; (setq cl-other (aref cl-vector cl-i)))
105 (and (characterp cl-other) ; Note we want to call this 105 ;; (and (characterp cl-other) ; Note we want to call this
106 ; as rarely as possible, it 106 ;; ; as rarely as possible, it
107 ; doesn't have a bytecode. 107 ;; ; doesn't have a bytecode.
108 (eq (downcase cl-char) (downcase cl-other)))))) 108 ;; (eq (downcase cl-char) (downcase cl-other))))))
109 (< cl-i 0)))) 109 ;; (< cl-i 0))))
110 110 ;;
111 ;; See comment on cl-string-vector-equalp above. 111 ;;;; See comment on cl-string-vector-equalp above.
112 (defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector) 112 ;;(defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector)
113 "Helper function for `equalp', which see." 113 ;; "Helper function for `equalp', which see."
114 ; (check-argument-type #'bit-vector-p cl-bit-vector) 114 ;;; (check-argument-type #'bit-vector-p cl-bit-vector)
115 ; (check-argument-type #'vectorp cl-vector) 115 ;;; (check-argument-type #'vectorp cl-vector)
116 (let ((cl-i (length cl-bit-vector)) 116 ;; (let ((cl-i (length cl-bit-vector))
117 cl-other) 117 ;; cl-other)
118 (when (= cl-i (length cl-vector)) 118 ;; (when (= cl-i (length cl-vector))
119 (while (and (>= (setq cl-i (1- cl-i)) 0) 119 ;; (while (and (>= (setq cl-i (1- cl-i)) 0)
120 (numberp (setq cl-other (aref cl-vector cl-i))) 120 ;; (numberp (setq cl-other (aref cl-vector cl-i)))
121 ;; Differs from clisp here. 121 ;; ;; Differs from clisp here.
122 (= (aref cl-bit-vector cl-i) cl-other))) 122 ;; (= (aref cl-bit-vector cl-i) cl-other)))
123 (< cl-i 0)))) 123 ;; (< cl-i 0))))
124 124 ;;
125 ;; These two helper functions call equalp recursively, the two above have no 125 ;;;; These two helper functions call equalp recursively, the two above have no
126 ;; need to. 126 ;;;; need to.
127 (defsubst cl-vector-array-equalp (cl-vector cl-array) 127 ;;(defsubst cl-vector-array-equalp (cl-vector cl-array)
128 "Helper function for `equalp', which see." 128 ;; "Helper function for `equalp', which see."
129 ; (check-argument-type #'vector cl-vector) 129 ;;; (check-argument-type #'vector cl-vector)
130 ; (check-argument-type #'arrayp cl-array) 130 ;;; (check-argument-type #'arrayp cl-array)
131 (let ((cl-i (length cl-vector))) 131 ;; (let ((cl-i (length cl-vector)))
132 (when (= cl-i (length cl-array)) 132 ;; (when (= cl-i (length cl-array))
133 (while (and (>= (setq cl-i (1- cl-i)) 0) 133 ;; (while (and (>= (setq cl-i (1- cl-i)) 0)
134 (equalp (aref cl-vector cl-i) (aref cl-array cl-i)))) 134 ;; (equalp (aref cl-vector cl-i) (aref cl-array cl-i))))
135 (< cl-i 0)))) 135 ;; (< cl-i 0))))
136 136 ;;
137 (defsubst cl-hash-table-contents-equalp (cl-hash-table-1 cl-hash-table-2) 137 ;;(defsubst cl-hash-table-contents-equalp (cl-hash-table-1 cl-hash-table-2)
138 "Helper function for `equalp', which see." 138 ;; "Helper function for `equalp', which see."
139 (symbol-macrolet 139 ;; (symbol-macrolet
140 ;; If someone has gone and fished the uninterned symbol out of this 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 141 ;; ;; function's constants vector, and subsequently stored it as a value
142 ;; in a hash table, it's their own damn fault when 142 ;; ;; in a hash table, it's their own damn fault when
143 ;; `cl-hash-table-contents-equalp' gives the wrong answer. 143 ;; ;; `cl-hash-table-contents-equalp' gives the wrong answer.
144 ((equalp-default '#:equalp-default)) 144 ;; ((equalp-default '#:equalp-default))
145 (loop 145 ;; (loop
146 for x-key being the hash-key in cl-hash-table-1 146 ;; for x-key being the hash-key in cl-hash-table-1
147 using (hash-value x-value) 147 ;; using (hash-value x-value)
148 with y-value = nil 148 ;; with y-value = nil
149 always (and (not (eq equalp-default 149 ;; always (and (not (eq equalp-default
150 (setq y-value (gethash x-key cl-hash-table-2 150 ;; (setq y-value (gethash x-key cl-hash-table-2
151 equalp-default)))) 151 ;; equalp-default))))
152 (equalp y-value x-value))))) 152 ;; (equalp y-value x-value)))))
153 153 ;;
154 (defun equalp (x y) 154 ;;(defun equalp (x y)
155 "Return t if two Lisp objects have similar structures and contents. 155 ;; "Return t if two Lisp objects have similar structures and contents.
156 156 ;;
157 This is like `equal', except that it accepts numerically equal 157 ;;This is like `equal', except that it accepts numerically equal
158 numbers of different types (float, integer, bignum, bigfloat), and also 158 ;;numbers of different types (float, integer, bignum, bigfloat), and also
159 compares strings and characters case-insensitively. 159 ;;compares strings and characters case-insensitively.
160 160 ;;
161 Arrays (that is, strings, bit-vectors, and vectors) of the same length and 161 ;;Arrays (that is, strings, bit-vectors, and vectors) of the same length and
162 with contents that are `equalp' are themselves `equalp'. 162 ;;with contents that are `equalp' are themselves `equalp'.
163 163 ;;
164 Two hash tables are `equalp' if they have the same test (see 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 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 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 167 ;;hash table using the hash table test, and its value is `equalp' to the other
168 hash table's value for that key." 168 ;;hash table's value for that key."
169 (cond ((eq x y)) 169 ;; (cond ((eq x y))
170 ((stringp x) 170 ;; ((stringp x)
171 (if (stringp y) 171 ;; (if (stringp y)
172 (eq t (compare-strings x nil nil y nil nil t)) 172 ;; (eq t (compare-strings x nil nil y nil nil t))
173 (if (vectorp y) 173 ;; (if (vectorp y)
174 (cl-string-vector-equalp x y) 174 ;; (cl-string-vector-equalp x y)
175 ;; bit-vectors and strings are only equalp if they're 175 ;; ;; bit-vectors and strings are only equalp if they're
176 ;; zero-length: 176 ;; ;; zero-length:
177 (and (equal "" x) (equal #* y))))) 177 ;; (and (equal "" x) (equal #* y)))))
178 ((numberp x) 178 ;; ((numberp x)
179 (and (numberp y) (= x y))) 179 ;; (and (numberp y) (= x y)))
180 ((consp x) 180 ;; ((consp x)
181 (while (and (consp x) (consp y) (equalp (car x) (car y))) 181 ;; (while (and (consp x) (consp y) (equalp (car x) (car y)))
182 (setq x (cdr x) y (cdr y))) 182 ;; (setq x (cdr x) y (cdr y)))
183 (and (not (consp x)) (equalp x y))) 183 ;; (and (not (consp x)) (equalp x y)))
184 (t 184 ;; (t
185 ;; From here on, the type tests don't (yet) have bytecodes. 185 ;; ;; From here on, the type tests don't (yet) have bytecodes.
186 (let ((x-type (type-of x))) 186 ;; (let ((x-type (type-of x)))
187 (cond ((eq 'vector x-type) 187 ;; (cond ((eq 'vector x-type)
188 (if (stringp y) 188 ;; (if (stringp y)
189 (cl-string-vector-equalp y x) 189 ;; (cl-string-vector-equalp y x)
190 (if (vectorp y) 190 ;; (if (vectorp y)
191 (cl-vector-array-equalp x y) 191 ;; (cl-vector-array-equalp x y)
192 (if (bit-vector-p y) 192 ;; (if (bit-vector-p y)
193 (cl-bit-vector-vector-equalp y x))))) 193 ;; (cl-bit-vector-vector-equalp y x)))))
194 ((eq 'character x-type) 194 ;; ((eq 'character x-type)
195 (and (characterp y) 195 ;; (and (characterp y)
196 ;; If the characters are actually identical, the 196 ;; ;; If the characters are actually identical, the
197 ;; first eq test will have caught them above; we only 197 ;; ;; first eq test will have caught them above; we only
198 ;; need to check them case-insensitively here. 198 ;; ;; need to check them case-insensitively here.
199 (eq (downcase x) (downcase y)))) 199 ;; (eq (downcase x) (downcase y))))
200 ((eq 'hash-table x-type) 200 ;; ((eq 'hash-table x-type)
201 (and (hash-table-p y) 201 ;; (and (hash-table-p y)
202 (eq (hash-table-test x) (hash-table-test y)) 202 ;; (eq (hash-table-test x) (hash-table-test y))
203 (= (hash-table-count x) (hash-table-count y)) 203 ;; (= (hash-table-count x) (hash-table-count y))
204 (cl-hash-table-contents-equalp x y))) 204 ;; (cl-hash-table-contents-equalp x y)))
205 ((eq 'bit-vector x-type) 205 ;; ((eq 'bit-vector x-type)
206 (if (bit-vector-p y) 206 ;; (if (bit-vector-p y)
207 (equal x y) 207 ;; (equal x y)
208 (if (vectorp y) 208 ;; (if (vectorp y)
209 (cl-bit-vector-vector-equalp x y) 209 ;; (cl-bit-vector-vector-equalp x y)
210 ;; bit-vectors and strings are only equalp if they're 210 ;; ;; bit-vectors and strings are only equalp if they're
211 ;; zero-length: 211 ;; ;; zero-length:
212 (and (equal "" y) (equal #* x))))) 212 ;; (and (equal "" y) (equal #* x)))))
213 (t (equal x y))))))) 213 ;; (t (equal x y)))))))
214 214
215 ;;; Control structures. 215 ;;; Control structures.
216 216
217 (defun cl-mapcar-many (cl-func cl-seqs) 217 (defun cl-mapcar-many (cl-func cl-seqs)
218 (if (cdr (cdr cl-seqs)) 218 (if (cdr (cdr cl-seqs))