Mercurial > hg > xemacs-beta
changeset 4906:6ef8256a020a
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 | 70089046adef |
| children | 9e7f5a77cc84 |
| files | lisp/ChangeLog lisp/cl-extra.el lisp/cl-macs.el src/ChangeLog src/abbrev.c src/alloc.c src/buffer.h src/bytecode.c src/casetab.c src/chartab.c src/data.c src/device-msw.c src/editfns.c src/elhash.c src/events.c src/events.h src/extents.c src/faces.c src/floatfns.c src/fns.c src/frame-gtk.c src/frame-msw.c src/glyphs.c src/gui.c src/keymap-buttons.h src/keymap-slots.h src/keymap.c src/keymap.h src/lisp.h src/lrecord.h src/marker.c src/minibuf.c src/number.c src/objects.c src/opaque.c src/rangetab.c src/specifier.c src/text.c tests/ChangeLog tests/automated/case-tests.el tests/automated/lisp-tests.el tests/automated/regexp-tests.el tests/automated/search-tests.el tests/automated/test-harness.el |
| diffstat | 44 files changed, 1255 insertions(+), 1108 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sat Jan 30 20:34:23 2010 -0600 +++ b/lisp/ChangeLog Mon Feb 01 01:02:40 2010 -0600 @@ -1,3 +1,20 @@ +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. + 2010-01-30 Aidan Kehoe <kehoea@parhasard.net> * loadup.el: @@ -10,14 +27,6 @@ 2010-01-29 Ben Wing <ben@xemacs.org> * mule/cyrillic.el (for): - -2010-01-29 Ben Wing <ben@xemacs.org> - - * mule/cyrillic.el (for): - -2010-01-29 Ben Wing <ben@xemacs.org> - - * mule/cyrillic.el (for): Upper and lowercase mappings were reversed for some old-Cyrillic chars.
--- a/lisp/cl-extra.el Sat Jan 30 20:34:23 2010 -0600 +++ b/lisp/cl-extra.el Mon Feb 01 01:02:40 2010 -0600 @@ -87,130 +87,130 @@ (t (error "Can't coerce %s to type %s" x type)))) -;;; Predicates. - -;; I'd actually prefer not to have this inline, the space -;; vs. amount-it's-called trade-off isn't reasonable, but that would -;; introduce bytecode problems with the compiler macro in cl-macs.el. -(defsubst cl-string-vector-equalp (cl-string cl-vector) - "Helper function for `equalp', which see." -; (check-argument-type #'stringp cl-string) -; (check-argument-type #'vector cl-vector) - (let ((cl-i (length cl-string)) - cl-char cl-other) - (when (= cl-i (length cl-vector)) - (while (and (>= (setq cl-i (1- cl-i)) 0) - (or (eq (setq cl-char (aref cl-string cl-i)) - (setq cl-other (aref cl-vector cl-i))) - (and (characterp cl-other) ; Note we want to call this - ; as rarely as possible, it - ; doesn't have a bytecode. - (eq (downcase cl-char) (downcase cl-other)))))) - (< cl-i 0)))) - -;; See comment on cl-string-vector-equalp above. -(defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector) - "Helper function for `equalp', which see." -; (check-argument-type #'bit-vector-p cl-bit-vector) -; (check-argument-type #'vectorp cl-vector) - (let ((cl-i (length cl-bit-vector)) - cl-other) - (when (= cl-i (length cl-vector)) - (while (and (>= (setq cl-i (1- cl-i)) 0) - (numberp (setq cl-other (aref cl-vector cl-i))) - ;; Differs from clisp here. - (= (aref cl-bit-vector cl-i) cl-other))) - (< cl-i 0)))) - -;; These two helper functions call equalp recursively, the two above have no -;; need to. -(defsubst cl-vector-array-equalp (cl-vector cl-array) - "Helper function for `equalp', which see." -; (check-argument-type #'vector cl-vector) -; (check-argument-type #'arrayp cl-array) - (let ((cl-i (length cl-vector))) - (when (= cl-i (length cl-array)) - (while (and (>= (setq cl-i (1- cl-i)) 0) - (equalp (aref cl-vector cl-i) (aref cl-array cl-i)))) - (< cl-i 0)))) - -(defsubst cl-hash-table-contents-equalp (cl-hash-table-1 cl-hash-table-2) - "Helper function for `equalp', which see." - (symbol-macrolet - ;; If someone has gone and fished the uninterned symbol out of this - ;; function's constants vector, and subsequently stored it as a value - ;; in a hash table, it's their own damn fault when - ;; `cl-hash-table-contents-equalp' gives the wrong answer. - ((equalp-default '#:equalp-default)) - (loop - for x-key being the hash-key in cl-hash-table-1 - using (hash-value x-value) - with y-value = nil - always (and (not (eq equalp-default - (setq y-value (gethash x-key cl-hash-table-2 - equalp-default)))) - (equalp y-value x-value))))) - -(defun equalp (x y) - "Return t if two Lisp objects have similar structures and contents. - -This is like `equal', except that it accepts numerically equal -numbers of different types (float, integer, bignum, bigfloat), and also -compares strings and characters case-insensitively. - -Arrays (that is, strings, bit-vectors, and vectors) of the same length and -with contents that are `equalp' are themselves `equalp'. - -Two hash tables are `equalp' if they have the same test (see -`hash-table-test'), if they have the same number of entries, and if, for -each entry in one hash table, its key is equivalent to a key in the other -hash table using the hash table test, and its value is `equalp' to the other -hash table's value for that key." - (cond ((eq x y)) - ((stringp x) - (if (stringp y) - (eq t (compare-strings x nil nil y nil nil t)) - (if (vectorp y) - (cl-string-vector-equalp x y) - ;; bit-vectors and strings are only equalp if they're - ;; zero-length: - (and (equal "" x) (equal #* y))))) - ((numberp x) - (and (numberp y) (= x y))) - ((consp x) - (while (and (consp x) (consp y) (equalp (car x) (car y))) - (setq x (cdr x) y (cdr y))) - (and (not (consp x)) (equalp x y))) - (t - ;; From here on, the type tests don't (yet) have bytecodes. - (let ((x-type (type-of x))) - (cond ((eq 'vector x-type) - (if (stringp y) - (cl-string-vector-equalp y x) - (if (vectorp y) - (cl-vector-array-equalp x y) - (if (bit-vector-p y) - (cl-bit-vector-vector-equalp y x))))) - ((eq 'character x-type) - (and (characterp y) - ;; If the characters are actually identical, the - ;; first eq test will have caught them above; we only - ;; need to check them case-insensitively here. - (eq (downcase x) (downcase y)))) - ((eq 'hash-table x-type) - (and (hash-table-p y) - (eq (hash-table-test x) (hash-table-test y)) - (= (hash-table-count x) (hash-table-count y)) - (cl-hash-table-contents-equalp x y))) - ((eq 'bit-vector x-type) - (if (bit-vector-p y) - (equal x y) - (if (vectorp y) - (cl-bit-vector-vector-equalp x y) - ;; bit-vectors and strings are only equalp if they're - ;; zero-length: - (and (equal "" y) (equal #* x))))) - (t (equal x y))))))) +;;;;; Predicates. +;; +;;;; I'd actually prefer not to have this inline, the space +;;;; vs. amount-it's-called trade-off isn't reasonable, but that would +;;;; introduce bytecode problems with the compiler macro in cl-macs.el. +;;(defsubst cl-string-vector-equalp (cl-string cl-vector) +;; "Helper function for `equalp', which see." +;;; (check-argument-type #'stringp cl-string) +;;; (check-argument-type #'vector cl-vector) +;; (let ((cl-i (length cl-string)) +;; cl-char cl-other) +;; (when (= cl-i (length cl-vector)) +;; (while (and (>= (setq cl-i (1- cl-i)) 0) +;; (or (eq (setq cl-char (aref cl-string cl-i)) +;; (setq cl-other (aref cl-vector cl-i))) +;; (and (characterp cl-other) ; Note we want to call this +;; ; as rarely as possible, it +;; ; doesn't have a bytecode. +;; (eq (downcase cl-char) (downcase cl-other)))))) +;; (< cl-i 0)))) +;; +;;;; See comment on cl-string-vector-equalp above. +;;(defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector) +;; "Helper function for `equalp', which see." +;;; (check-argument-type #'bit-vector-p cl-bit-vector) +;;; (check-argument-type #'vectorp cl-vector) +;; (let ((cl-i (length cl-bit-vector)) +;; cl-other) +;; (when (= cl-i (length cl-vector)) +;; (while (and (>= (setq cl-i (1- cl-i)) 0) +;; (numberp (setq cl-other (aref cl-vector cl-i))) +;; ;; Differs from clisp here. +;; (= (aref cl-bit-vector cl-i) cl-other))) +;; (< cl-i 0)))) +;; +;;;; These two helper functions call equalp recursively, the two above have no +;;;; need to. +;;(defsubst cl-vector-array-equalp (cl-vector cl-array) +;; "Helper function for `equalp', which see." +;;; (check-argument-type #'vector cl-vector) +;;; (check-argument-type #'arrayp cl-array) +;; (let ((cl-i (length cl-vector))) +;; (when (= cl-i (length cl-array)) +;; (while (and (>= (setq cl-i (1- cl-i)) 0) +;; (equalp (aref cl-vector cl-i) (aref cl-array cl-i)))) +;; (< cl-i 0)))) +;; +;;(defsubst cl-hash-table-contents-equalp (cl-hash-table-1 cl-hash-table-2) +;; "Helper function for `equalp', which see." +;; (symbol-macrolet +;; ;; If someone has gone and fished the uninterned symbol out of this +;; ;; function's constants vector, and subsequently stored it as a value +;; ;; in a hash table, it's their own damn fault when +;; ;; `cl-hash-table-contents-equalp' gives the wrong answer. +;; ((equalp-default '#:equalp-default)) +;; (loop +;; for x-key being the hash-key in cl-hash-table-1 +;; using (hash-value x-value) +;; with y-value = nil +;; always (and (not (eq equalp-default +;; (setq y-value (gethash x-key cl-hash-table-2 +;; equalp-default)))) +;; (equalp y-value x-value))))) +;; +;;(defun equalp (x y) +;; "Return t if two Lisp objects have similar structures and contents. +;; +;;This is like `equal', except that it accepts numerically equal +;;numbers of different types (float, integer, bignum, bigfloat), and also +;;compares strings and characters case-insensitively. +;; +;;Arrays (that is, strings, bit-vectors, and vectors) of the same length and +;;with contents that are `equalp' are themselves `equalp'. +;; +;;Two hash tables are `equalp' if they have the same test (see +;;`hash-table-test'), if they have the same number of entries, and if, for +;;each entry in one hash table, its key is equivalent to a key in the other +;;hash table using the hash table test, and its value is `equalp' to the other +;;hash table's value for that key." +;; (cond ((eq x y)) +;; ((stringp x) +;; (if (stringp y) +;; (eq t (compare-strings x nil nil y nil nil t)) +;; (if (vectorp y) +;; (cl-string-vector-equalp x y) +;; ;; bit-vectors and strings are only equalp if they're +;; ;; zero-length: +;; (and (equal "" x) (equal #* y))))) +;; ((numberp x) +;; (and (numberp y) (= x y))) +;; ((consp x) +;; (while (and (consp x) (consp y) (equalp (car x) (car y))) +;; (setq x (cdr x) y (cdr y))) +;; (and (not (consp x)) (equalp x y))) +;; (t +;; ;; From here on, the type tests don't (yet) have bytecodes. +;; (let ((x-type (type-of x))) +;; (cond ((eq 'vector x-type) +;; (if (stringp y) +;; (cl-string-vector-equalp y x) +;; (if (vectorp y) +;; (cl-vector-array-equalp x y) +;; (if (bit-vector-p y) +;; (cl-bit-vector-vector-equalp y x))))) +;; ((eq 'character x-type) +;; (and (characterp y) +;; ;; If the characters are actually identical, the +;; ;; first eq test will have caught them above; we only +;; ;; need to check them case-insensitively here. +;; (eq (downcase x) (downcase y)))) +;; ((eq 'hash-table x-type) +;; (and (hash-table-p y) +;; (eq (hash-table-test x) (hash-table-test y)) +;; (= (hash-table-count x) (hash-table-count y)) +;; (cl-hash-table-contents-equalp x y))) +;; ((eq 'bit-vector x-type) +;; (if (bit-vector-p y) +;; (equal x y) +;; (if (vectorp y) +;; (cl-bit-vector-vector-equalp x y) +;; ;; bit-vectors and strings are only equalp if they're +;; ;; zero-length: +;; (and (equal "" y) (equal #* x))))) +;; (t (equal x y))))))) ;;; Control structures.
--- a/lisp/cl-macs.el Sat Jan 30 20:34:23 2010 -0600 +++ b/lisp/cl-macs.el Mon Feb 01 01:02:40 2010 -0600 @@ -1,7 +1,7 @@ ;;; cl-macs.el --- Common Lisp extensions for XEmacs Lisp (part four) ;; Copyright (C) 1993, 2003, 2004 Free Software Foundation, Inc. -;; Copyright (C) 2002 Ben Wing. +;; Copyright (C) 2002, 2010 Ben Wing. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 @@ -3357,6 +3357,21 @@ (regexp-quote string) form)) +;; NOTE: `equalp' is now a primitive, although as of yet it still doesn't +;; have a byte-compiler opcode for it. The compiler-macro for `equalp' used +;; to try and remove as much as possible of the logic of the Lisp `equalp' as +;; possible whenever one of the arguments is a constant, boiling things down +;; to a few if-statements and some calls to various no-longer-defined +;; helper functions. Besides the fact that the helper functions aren't +;; defined, there's little point in doing any of that expansion, since it will +;; end up executing in Lisp what would otherwise be done in C by a direct +;; call to `equalp'. The only exception is when the reduction is quite +;; simple and is to functions that do have op-codes; that may gain something. +;; However, if `equalp' becomes an opcode itself, consider removing everything +;; here except maybe when the call can directly be reduced to `equal' or `eq'. +;; +;; --ben + (define-compiler-macro equalp (&whole form x y) "Expand calls to `equalp' where X or Y is a constant expression. @@ -3372,8 +3387,6 @@ ;; constant here. (let* ((equalp-sym (eval-when-compile (gensym))) (let-form '(progn)) - (check-bit-vector t) - (check-string t) (original-y y) equalp-temp checked) (macrolet @@ -3398,44 +3411,11 @@ ((member x '("" #* [])) ;; No need to protect against multiple evaluation here: `(and (member ,original-y '("" #* [])) t)) - ((stringp x) - `(,@let-form - (if (stringp ,y) - (eq t (compare-strings ,x nil nil - ,y nil nil t)) - (if (vectorp ,y) - (cl-string-vector-equalp ,x ,y))))) - ((bit-vector-p x) - `(,@let-form - (if (bit-vector-p ,y) - ;; No need to call equalp on each element here: - (equal ,x ,y) - (if (vectorp ,y) - (cl-bit-vector-vector-equalp ,x ,y))))) - (t - (loop - for elt across x - ;; We may not need to check the other argument if it's a - ;; string or bit vector, depending on the contents of x: - always (progn - (unless (characterp elt) (setq check-string nil)) - (unless (and (numberp elt) (or (= elt 0) (= elt 1))) - (setq check-bit-vector nil)) - (or check-string check-bit-vector))) - `(,@let-form - (cond - ,@(if check-string - `(((stringp ,y) - (cl-string-vector-equalp ,y ,x)))) - ,@(if check-bit-vector - `(((bit-vector-p ,y) - (cl-bit-vector-vector-equalp ,y ,x)))) - ((vectorp ,y) - (cl-vector-array-equalp ,x ,y))))))) + (t form))) ((unordered-check (and (characterp x) (not (cl-const-expr-p y)))) `(,@let-form (or (eq ,x ,y) - ;; eq has a bytecode, char-equal doesn't. + ;; eq has a bytecode, char-equal doesn't. (and (characterp ,y) (eq (downcase ,x) (downcase ,y)))))) ((unordered-check (and (numberp x) (not (cl-const-expr-p y)))) @@ -3443,31 +3423,146 @@ (and (numberp ,y) (= ,x ,y)))) ((unordered-check (and (hash-table-p x) (not (cl-const-expr-p y)))) - ;; Hash tables; follow the CL spec. - `(,@let-form - (and (hash-table-p ,y) - (eq ',(hash-table-test x) (hash-table-test ,y)) - (= ,(hash-table-count x) (hash-table-count ,y)) - (cl-hash-table-contents-equalp ,x ,y)))) + form) ((unordered-check ;; Symbols; eq. (and (not (cl-const-expr-p y)) (or (memq x '(nil t)) (and (eq (car-safe x) 'quote) (symbolp (second x)))))) (cons 'eq (cdr form))) - ((unordered-check - ;; Compare conses at runtime, there's no real upside to - ;; unrolling the function -> they fall through to the next - ;; clause in this function. - (and (cl-const-expr-p x) (not (consp x)) - (not (cl-const-expr-p y)))) - ;; All other types; use equal. - (cons 'equal (cdr form))) + + ;; This clause is wrong -- e.g. when comparing a constant char-table + ;; against a non-constant expression that evaluates to a char-table, + ;; or some for range tables or certain other types, `equalp' is + ;; not the same as `equal'. We could insert the known list of + ;; types with special `equalp' property, but it's fragile and may + ;; not be much of an optimization, esp. since these types don't + ;; occur that often are often big. + ;;((unordered-check + ;; ;; Compare conses at runtime, there's no real upside to + ;; ;; unrolling the function -> they fall through to the next + ;; ;; clause in this function. + ;; (and (cl-const-expr-p x) (not (consp x)) + ;; (not (cl-const-expr-p y)))) + ;; ;; All other types; use equal. + ;; (cons 'equal (cdr form))) + ;; Neither side is a constant expression, do all our evaluation at ;; runtime (or both are, and equalp will be called from ;; byte-optimize.el). (t form))))) +;;(define-compiler-macro equalp (&whole form x y) +;; "Expand calls to `equalp' where X or Y is a constant expression. +;; +;;Much of the processing that `equalp' does is dependent on the types of both +;;of its arguments, and with type information for one of them, we can +;;eliminate much of the body of the function at compile time. +;; +;;Where both X and Y are constant expressions, `equalp' is evaluated at +;;compile time by byte-optimize.el--this compiler macro passes FORM through to +;;the byte optimizer in those cases." +;; ;; Cases where both arguments are constant are handled in +;; ;; byte-optimize.el, we only need to handle those cases where one is +;; ;; constant here. +;; (let* ((equalp-sym (eval-when-compile (gensym))) +;; (let-form '(progn)) +;; (check-bit-vector t) +;; (check-string t) +;; (original-y y) +;; equalp-temp checked) +;; (macrolet +;; ((unordered-check (check) +;; `(prog1 +;; (setq checked +;; (or ,check +;; (prog1 ,(sublis '((x . y) (y . x)) check :test #'eq) +;; (setq equalp-temp x x y y equalp-temp)))) +;; (when checked +;; (unless (symbolp y) +;; (setq let-form `(let ((,equalp-sym ,y))) y equalp-sym)))))) +;; ;; In the bodies of the below clauses, x is always a constant expression +;; ;; of the type we're interested in, and y is always a symbol that refers +;; ;; to the result non-constant side of the comparison. +;; (cond ((unordered-check (and (arrayp x) (not (cl-const-expr-p y)))) +;; ;; Strings and other arrays. A vector containing the same +;; ;; character elements as a given string is equalp to that string; +;; ;; a bit-vector can only be equalp to a string if both are +;; ;; zero-length. +;; (cond +;; ((member x '("" #* [])) +;; ;; No need to protect against multiple evaluation here: +;; `(and (member ,original-y '("" #* [])) t)) +;; ((stringp x) +;; `(,@let-form +;; (if (stringp ,y) +;; (eq t (compare-strings ,x nil nil +;; ,y nil nil t)) +;; (if (vectorp ,y) +;; (cl-string-vector-equalp ,x ,y))))) +;; ((bit-vector-p x) +;; `(,@let-form +;; (if (bit-vector-p ,y) +;; ;; No need to call equalp on each element here: +;; (equal ,x ,y) +;; (if (vectorp ,y) +;; (cl-bit-vector-vector-equalp ,x ,y))))) +;; (t +;; (loop +;; for elt across x +;; ;; We may not need to check the other argument if it's a +;; ;; string or bit vector, depending on the contents of x: +;; always (progn +;; (unless (characterp elt) (setq check-string nil)) +;; (unless (and (numberp elt) (or (= elt 0) (= elt 1))) +;; (setq check-bit-vector nil)) +;; (or check-string check-bit-vector))) +;; `(,@let-form +;; (cond +;; ,@(if check-string +;; `(((stringp ,y) +;; (cl-string-vector-equalp ,y ,x)))) +;; ,@(if check-bit-vector +;; `(((bit-vector-p ,y) +;; (cl-bit-vector-vector-equalp ,y ,x)))) +;; ((vectorp ,y) +;; (cl-vector-array-equalp ,x ,y))))))) +;; ((unordered-check (and (characterp x) (not (cl-const-expr-p y)))) +;; `(,@let-form +;; (or (eq ,x ,y) +;; ;; eq has a bytecode, char-equal doesn't. +;; (and (characterp ,y) +;; (eq (downcase ,x) (downcase ,y)))))) +;; ((unordered-check (and (numberp x) (not (cl-const-expr-p y)))) +;; `(,@let-form +;; (and (numberp ,y) +;; (= ,x ,y)))) +;; ((unordered-check (and (hash-table-p x) (not (cl-const-expr-p y)))) +;; ;; Hash tables; follow the CL spec. +;; `(,@let-form +;; (and (hash-table-p ,y) +;; (eq ',(hash-table-test x) (hash-table-test ,y)) +;; (= ,(hash-table-count x) (hash-table-count ,y)) +;; (cl-hash-table-contents-equalp ,x ,y)))) +;; ((unordered-check +;; ;; Symbols; eq. +;; (and (not (cl-const-expr-p y)) +;; (or (memq x '(nil t)) +;; (and (eq (car-safe x) 'quote) (symbolp (second x)))))) +;; (cons 'eq (cdr form))) +;; ((unordered-check +;; ;; Compare conses at runtime, there's no real upside to +;; ;; unrolling the function -> they fall through to the next +;; ;; clause in this function. +;; (and (cl-const-expr-p x) (not (consp x)) +;; (not (cl-const-expr-p y)))) +;; ;; All other types; use equal. +;; (cons 'equal (cdr form))) +;; ;; Neither side is a constant expression, do all our evaluation at +;; ;; runtime (or both are, and equalp will be called from +;; ;; byte-optimize.el). +;; (t form))))) + (define-compiler-macro map (&whole form cl-type cl-func cl-seq &rest cl-rest) "If CL-TYPE is a constant expression that we know how to handle, transform
--- a/src/ChangeLog Sat Jan 30 20:34:23 2010 -0600 +++ b/src/ChangeLog Mon Feb 01 01:02:40 2010 -0600 @@ -1,3 +1,122 @@ +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. + 2010-01-30 Ben Wing <ben@xemacs.org> * intl-auto-encap-win32.c:
--- a/src/abbrev.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/abbrev.c Mon Feb 01 01:02:40 2010 -0600 @@ -131,10 +131,10 @@ for (idx = 0; idx < abbrev_length; idx++) { - if (DOWNCASE (closure->buf, + if (CANONCASE (closure->buf, BUF_FETCH_CHAR (closure->buf, closure->point - abbrev_length + idx)) - != DOWNCASE (closure->buf, itext_ichar (ptr))) + != CANONCASE (closure->buf, itext_ichar (ptr))) { break; }
--- a/src/alloc.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/alloc.c Mon Feb 01 01:02:40 2010 -0600 @@ -1223,15 +1223,15 @@ } static int -cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth) +cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth, int foldcase) { depth++; - while (internal_equal (XCAR (ob1), XCAR (ob2), depth)) + while (internal_equal_0 (XCAR (ob1), XCAR (ob2), depth, foldcase)) { ob1 = XCDR (ob1); ob2 = XCDR (ob2); if (! CONSP (ob1) || ! CONSP (ob2)) - return internal_equal (ob1, ob2, depth); + return internal_equal_0 (ob1, ob2, depth, foldcase); } return 0; } @@ -1547,7 +1547,7 @@ } static int -vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) { int len = XVECTOR_LENGTH (obj1); if (len != XVECTOR_LENGTH (obj2)) @@ -1557,7 +1557,7 @@ Lisp_Object *ptr1 = XVECTOR_DATA (obj1); Lisp_Object *ptr2 = XVECTOR_DATA (obj2); while (len--) - if (!internal_equal (*ptr1++, *ptr2++, depth + 1)) + if (!internal_equal_0 (*ptr1++, *ptr2++, depth + 1, foldcase)) return 0; } return 1; @@ -2251,11 +2251,15 @@ } static int -string_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +string_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int foldcase) { Bytecount len; - return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && - !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); + if (foldcase) + return !lisp_strcasecmp_i18n (obj1, obj2); + else + return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && + !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); } static const struct memory_description string_description[] = {
--- a/src/buffer.h Sat Jan 30 20:34:23 2010 -0600 +++ b/src/buffer.h Mon Feb 01 01:02:40 2010 -0600 @@ -1188,7 +1188,10 @@ BUFFER_CASE_TABLE (struct buffer *buf) ) { - return buf ? buf->case_table : Vstandard_case_table; + return buf ? buf->case_table : current_buffer->case_table; + /* When buf=0, was Vstandard_case_table, but this sucks. If I set a + different case table in this buffer, operations that use a case table + by default should use the current one. */ } /* Macros used below. */ @@ -1196,6 +1199,8 @@ TRT_TABLE_OF (XCASE_TABLE_DOWNCASE (BUFFER_CASE_TABLE (buf)), c) #define UPCASE_TABLE_OF(buf, c) \ TRT_TABLE_OF (XCASE_TABLE_UPCASE (BUFFER_CASE_TABLE (buf)), c) +#define CANON_TABLE_OF(buf, c) \ + TRT_TABLE_OF (XCASE_TABLE_CANON (BUFFER_CASE_TABLE (buf)), c) /* 1 if CH is upper case. */ @@ -1246,4 +1251,9 @@ #define DOWNCASE(buf, ch) DOWNCASE_TABLE_OF (buf, ch) +/* Convert a character to a canonical representation, so that case-independent + comparisons will work. */ + +#define CANONCASE(buf, ch) CANON_TABLE_OF (buf, ch) + #endif /* INCLUDED_buffer_h_ */
--- a/src/bytecode.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/bytecode.c Mon Feb 01 01:02:40 2010 -0600 @@ -2299,7 +2299,8 @@ } static int -compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, + int UNUSED (foldcase)) { Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1); Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
--- a/src/casetab.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/casetab.c Mon Feb 01 01:02:40 2010 -0600 @@ -404,24 +404,20 @@ /* This function can GC */ struct buffer *buf = standard ? XBUFFER (Vbuffer_defaults) : current_buffer; + Lisp_Object casetab; check_case_table (table); if (CASE_TABLEP (table)) - { - if (standard) - Vstandard_case_table = table; - - buf->case_table = table; - } + casetab = table; else { /* For backward compatibility. */ Lisp_Object down, up, canon, eqv, tail = table; - Lisp_Object casetab = - standard ? Vstandard_case_table : buf->case_table; struct chartab_range range; + casetab = Fmake_case_table (); + range.type = CHARTAB_RANGE_ALL; Freset_char_table (XCASE_TABLE_DOWNCASE (casetab)); @@ -467,6 +463,12 @@ convert_old_style_syntax_string (XCASE_TABLE_CANON (casetab), eqv); } + + if (standard) + Vstandard_case_table = casetab; + + buf->case_table = casetab; + return buf->case_table; }
--- a/src/chartab.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/chartab.c Mon Feb 01 01:02:40 2010 -0600 @@ -112,14 +112,16 @@ } static int -char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, + int foldcase) { Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1); Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2); int i; for (i = 0; i < 96; i++) - if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1)) + if (!internal_equal_0 (cte1->level2[i], cte2->level2[i], depth + 1, + foldcase)) return 0; return 1; @@ -344,7 +346,7 @@ } static int -char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) { Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1); Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2); @@ -354,16 +356,16 @@ return 0; for (i = 0; i < NUM_ASCII_CHARS; i++) - if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1)) + if (!internal_equal_0 (ct1->ascii[i], ct2->ascii[i], depth + 1, foldcase)) return 0; #ifdef MULE for (i = 0; i < NUM_LEADING_BYTES; i++) - if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1)) + if (!internal_equal_0 (ct1->level1[i], ct2->level1[i], depth + 1, foldcase)) return 0; #endif /* MULE */ - return internal_equal (ct1->default_, ct2->default_, depth + 1); + return internal_equal_0 (ct1->default_, ct2->default_, depth + 1, foldcase); } static Hashcode
--- a/src/data.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/data.c Mon Feb 01 01:02:40 2010 -0600 @@ -2628,13 +2628,13 @@ } static int -weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) { struct weak_list *w1 = XWEAK_LIST (obj1); struct weak_list *w2 = XWEAK_LIST (obj2); return ((w1->type == w2->type) && - internal_equal (w1->list, w2->list, depth + 1)); + internal_equal_0 (w1->list, w2->list, depth + 1, foldcase)); } static Hashcode @@ -3104,12 +3104,12 @@ } static int -weak_box_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +weak_box_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) { struct weak_box *wb1 = XWEAK_BOX (obj1); struct weak_box *wb2 = XWEAK_BOX (obj2); - return (internal_equal (wb1->value, wb2->value, depth + 1)); + return (internal_equal_0 (wb1->value, wb2->value, depth + 1, foldcase)); } static Hashcode @@ -3330,10 +3330,11 @@ } static int -ephemeron_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +ephemeron_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) { return - internal_equal (XEPHEMERON_REF (obj1), XEPHEMERON_REF(obj2), depth + 1); + internal_equal_0 (XEPHEMERON_REF (obj1), XEPHEMERON_REF(obj2), depth + 1, + foldcase); } static Hashcode
--- a/src/device-msw.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/device-msw.c Mon Feb 01 01:02:40 2010 -0600 @@ -658,7 +658,7 @@ { /* Change connection if the device changed */ if (!NILP (devname) - && lisp_strcasecmp (devname, DEVICE_MSPRINTER_NAME (d)) != 0) + && lisp_strcasecmp_i18n (devname, DEVICE_MSPRINTER_NAME (d)) != 0) { Lisp_Object new_connection = devname; @@ -1181,7 +1181,8 @@ } static int -equal_devmode (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +equal_devmode (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int UNUSED (foldcase)) { Lisp_Devmode *dm1 = XDEVMODE (obj1); Lisp_Devmode *dm2 = XDEVMODE (obj2); @@ -1194,7 +1195,7 @@ return 0; if (NILP (dm1->printer_name) || NILP (dm2->printer_name)) return 1; - return lisp_strcasecmp (dm1->printer_name, dm2->printer_name) == 0; + return lisp_strcasecmp_i18n (dm1->printer_name, dm2->printer_name) == 0; } static Hashcode
--- a/src/editfns.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/editfns.c Mon Feb 01 01:02:40 2010 -0600 @@ -2258,7 +2258,7 @@ x2 = XCHAR (character2); return (!NILP (b->case_fold_search) - ? DOWNCASE (b, x1) == DOWNCASE (b, x2) + ? CANONCASE (b, x1) == CANONCASE (b, x2) : x1 == x2) ? Qt : Qnil; }
--- a/src/elhash.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/elhash.c Mon Feb 01 01:02:40 2010 -0600 @@ -184,25 +184,6 @@ } -#if 0 /* I don't think these are needed any more. - If using the general lisp_object_equal_*() functions - causes efficiency problems, these can be resurrected. --ben */ -/* equality and hash functions for Lisp strings */ -int -lisp_string_equal (Lisp_Object str1, Lisp_Object str2) -{ - /* This is wrong anyway. You can't use strcmp() on Lisp strings, - because they can contain zero characters. */ - return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2)); -} - -static Hashcode -lisp_string_hash (Lisp_Object obj) -{ - return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str)); -} - -#endif /* 0 */ static int lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2) @@ -263,7 +244,8 @@ the same result -- if the keys are not equal according to the test function, then Fgethash() in hash_table_equal_mapper() will fail. */ static int -hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth) +hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth, + int foldcase) { Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1); Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2); @@ -282,7 +264,7 @@ { Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound); if (UNBOUNDP (value_in_other) || - !internal_equal (e->value, value_in_other, depth)) + !internal_equal_0 (e->value, value_in_other, depth, foldcase)) return 0; /* Give up */ }
--- a/src/events.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/events.c Mon Feb 01 01:02:40 2010 -0600 @@ -396,7 +396,8 @@ } static int -event_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +event_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int UNUSED (foldcase)) { Lisp_Event *e1 = XEVENT (obj1); Lisp_Event *e2 = XEVENT (obj2);
--- a/src/events.h Sat Jan 30 20:34:23 2010 -0600 +++ b/src/events.h Mon Feb 01 01:02:40 2010 -0600 @@ -910,38 +910,18 @@ /* The modifiers XEmacs knows about; these appear in key and button events. */ -#define XEMACS_MOD_CONTROL (1<<0) -#define XEMACS_MOD_META (1<<1) -#define XEMACS_MOD_SUPER (1<<2) -#define XEMACS_MOD_HYPER (1<<3) -#define XEMACS_MOD_ALT (1<<4) -#define XEMACS_MOD_SHIFT (1<<5) /* not used for dual-case characters */ -#define XEMACS_MOD_BUTTON1 (1<<6) -#define XEMACS_MOD_BUTTON2 (1<<7) -#define XEMACS_MOD_BUTTON3 (1<<8) -#define XEMACS_MOD_BUTTON4 (1<<9) -#define XEMACS_MOD_BUTTON5 (1<<10) -#define XEMACS_MOD_BUTTON6 (1<<11) -#define XEMACS_MOD_BUTTON7 (1<<12) -#define XEMACS_MOD_BUTTON8 (1<<13) -#define XEMACS_MOD_BUTTON9 (1<<14) -#define XEMACS_MOD_BUTTON10 (1<<15) -#define XEMACS_MOD_BUTTON11 (1<<16) -#define XEMACS_MOD_BUTTON12 (1<<17) -#define XEMACS_MOD_BUTTON13 (1<<18) -#define XEMACS_MOD_BUTTON14 (1<<19) -#define XEMACS_MOD_BUTTON15 (1<<20) -#define XEMACS_MOD_BUTTON16 (1<<21) -#define XEMACS_MOD_BUTTON17 (1<<22) -#define XEMACS_MOD_BUTTON18 (1<<23) -#define XEMACS_MOD_BUTTON19 (1<<24) -#define XEMACS_MOD_BUTTON20 (1<<25) -#define XEMACS_MOD_BUTTON21 (1<<26) -#define XEMACS_MOD_BUTTON22 (1<<27) -#define XEMACS_MOD_BUTTON23 (1<<28) -#define XEMACS_MOD_BUTTON24 (1<<29) -#define XEMACS_MOD_BUTTON25 (1<<30) -#define XEMACS_MOD_BUTTON26 (1<<31) +enum event_modifiers + { + XEMACS_MOD_CONTROL = (1<<0), + XEMACS_MOD_META = (1<<1), + XEMACS_MOD_SUPER = (1<<2), + XEMACS_MOD_HYPER = (1<<3), + XEMACS_MOD_ALT = (1<<4), + XEMACS_MOD_SHIFT = (1<<5) /* not used for dual-case characters */, +#define FROB(num) \ + XEMACS_MOD_BUTTON##num = (1<<(num+5)), +#include "keymap-buttons.h" + }; /* Note: under X Windows, XEMACS_MOD_ALT is generated by the Alt key if there are both Alt and Meta keys. If there are no Meta keys,
--- a/src/extents.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/extents.c Mon Feb 01 01:02:40 2010 -0600 @@ -3410,11 +3410,12 @@ /* compare the random elements of the plists. */ return !plists_differ (extent_no_chase_plist (e1), extent_no_chase_plist (e2), - 0, 0, depth + 1); + 0, 0, depth + 1, 0); } static int -extent_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +extent_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, + int UNUSED (foldcase)) { struct extent *e1 = XEXTENT (obj1); struct extent *e2 = XEXTENT (obj2);
--- a/src/faces.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/faces.c Mon Feb 01 01:02:40 2010 -0600 @@ -1,7 +1,7 @@ /* "Face" primitives Copyright (C) 1994 Free Software Foundation, Inc. Copyright (C) 1995 Board of Trustees, University of Illinois. - Copyright (C) 1995, 1996, 2001, 2002 Ben Wing. + Copyright (C) 1995, 1996, 2001, 2002, 2010 Ben Wing. Copyright (C) 1995 Sun Microsystems, Inc. This file is part of XEmacs. @@ -148,7 +148,8 @@ This isn't concerned with "unspecified" attributes, that's what #'face-differs-from-default-p is for. */ static int -face_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +face_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, + int UNUSED (foldcase)) { Lisp_Face *f1 = XFACE (obj1); Lisp_Face *f2 = XFACE (obj2); @@ -168,7 +169,7 @@ internal_equal (f1->blinking, f2->blinking, depth) && internal_equal (f1->reverse, f2->reverse, depth) && - ! plists_differ (f1->plist, f2->plist, 0, 0, depth + 1)); + ! plists_differ (f1->plist, f2->plist, 0, 0, depth + 1, 0)); } static Hashcode
--- a/src/floatfns.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/floatfns.c Mon Feb 01 01:02:40 2010 -0600 @@ -176,7 +176,8 @@ } static int -float_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +float_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int UNUSED (foldcase)) { return (extract_float (obj1) == extract_float (obj2)); }
--- a/src/fns.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/fns.c Mon Feb 01 01:02:40 2010 -0600 @@ -95,7 +95,8 @@ } static int -bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int UNUSED (foldcase)) { Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); @@ -1982,7 +1983,7 @@ */ int plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, - int laxp, int depth) + int laxp, int depth, int foldcase) { int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */ int la, lb, m, i, fill; @@ -2026,12 +2027,13 @@ if (nil_means_not_present && NILP (v)) continue; for (i = 0; i < fill; i++) { - if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth)) + if (!laxp ? EQ (k, keys [i]) : + internal_equal_0 (k, keys [i], depth, foldcase)) { if (eqp /* We narrowly escaped being Ebolified here. */ ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) - : !internal_equal (v, vals [i], depth)) + : !internal_equal_0 (v, vals [i], depth, foldcase)) /* a property in B has a different value than in A */ goto MISMATCH; flags [i] = 1; @@ -2067,7 +2069,7 @@ */ (a, b, nil_means_not_present)) { - return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1) + return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1, 0) ? Qnil : Qt); } @@ -2084,7 +2086,7 @@ */ (a, b, nil_means_not_present)) { - return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1) + return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1, 0) ? Qnil : Qt); } @@ -2104,7 +2106,7 @@ */ (a, b, nil_means_not_present)) { - return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1) + return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1, 0) ? Qnil : Qt); } @@ -2123,7 +2125,7 @@ */ (a, b, nil_means_not_present)) { - return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1) + return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1, 0) ? Qnil : Qt); } @@ -2845,49 +2847,81 @@ return (imp1 == imp2) && /* EQ-ness of the objects was noticed above */ - (imp1->equal && (imp1->equal) (obj1, obj2, depth)); + (imp1->equal && (imp1->equal) (obj1, obj2, depth, 0)); } return 0; } +enum array_type + { + ARRAY_NONE = 0, + ARRAY_STRING, + ARRAY_VECTOR, + ARRAY_BIT_VECTOR + }; + +static enum array_type +array_type (Lisp_Object obj) +{ + if (STRINGP (obj)) + return ARRAY_STRING; + if (VECTORP (obj)) + return ARRAY_VECTOR; + if (BIT_VECTORP (obj)) + return ARRAY_BIT_VECTOR; + return ARRAY_NONE; +} + int internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) stack_overflow ("Stack overflow in equalp", Qunbound); QUIT; + + /* 1. Objects that are `eq' are equal. This will catch the common case + of two equal fixnums or the same object seen twice. */ if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) return 1; -#ifdef WITH_NUMBER_TYPES + + /* 2. If both numbers, compare with `='. */ if (NUMBERP (obj1) && NUMBERP (obj2)) { - switch (promote_args (&obj1, &obj2)) - { - case FIXNUM_T: - return XREALINT (obj1) == XREALINT (obj2); -#ifdef HAVE_BIGNUM - case BIGNUM_T: - return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); -#endif -#ifdef HAVE_RATIO - case RATIO_T: - return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); -#endif - case FLOAT_T: - return XFLOAT_DATA (obj1) == XFLOAT_DATA (obj2); -#ifdef HAVE_BIGFLOAT - case BIGFLOAT_T: - return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); -#endif - } + Lisp_Object args[2]; + args[0] = obj1; + args[1] = obj2; + return !NILP (Feqlsign (2, args)); } -#else - if ((INTP (obj1) && FLOATP (obj2)) || (FLOATP (obj1) && INTP (obj2))) - return extract_float (obj1) == extract_float (obj2); -#endif + + /* 3. If characters, compare case-insensitively. */ if (CHARP (obj1) && CHARP (obj2)) return DOWNCASE (0, XCHAR (obj1)) == DOWNCASE (0, XCHAR (obj2)); + + /* 4. If arrays of different types, compare their lengths, and + then compare element-by-element. */ + { + enum array_type artype1, artype2; + artype1 = array_type (obj1); + artype2 = array_type (obj2); + if (artype1 != artype2 && artype1 && artype2) + { + EMACS_INT i; + EMACS_INT l1 = XINT (Flength (obj1)); + EMACS_INT l2 = XINT (Flength (obj2)); + /* Both arrays, but of different types */ + if (l1 != l2) + return 0; + for (i = 0; i < l1; i++) + if (!internal_equalp (Faref (obj1, make_int (i)), + Faref (obj2, make_int (i)), depth + 1)) + return 0; + return 1; + } + } + /* 5. Else, they must be the same type. If so, call the equal() method, + telling it to fold case. For objects that care about case-folding + their contents, the equal() method will call internal_equal_0(). */ if (XTYPE (obj1) != XTYPE (obj2)) return 0; if (LRECORDP (obj1)) @@ -2896,16 +2930,23 @@ *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); - /* #### not yet implemented properly, needs another flag to specify - equalp-ness */ return (imp1 == imp2) && /* EQ-ness of the objects was noticed above */ - (imp1->equal && (imp1->equal) (obj1, obj2, depth)); + (imp1->equal && (imp1->equal) (obj1, obj2, depth, 1)); } return 0; } +int +internal_equal_0 (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) +{ + if (foldcase) + return internal_equalp (obj1, obj2, depth); + else + return internal_equal (obj1, obj2, depth); +} + /* Note that we may be calling sub-objects that will use internal_equal() (instead of internal_old_equal()). Oh well. We will get an Ebola note if there's any possibility of confusion, @@ -2938,6 +2979,37 @@ return internal_equal (object1, object2, 0) ? Qt : Qnil; } +DEFUN ("equalp", Fequalp, 2, 2, 0, /* +Return t if two Lisp objects have similar structure and contents. + +This is like `equal', except that it accepts numerically equal +numbers of different types (float, integer, bignum, bigfloat), and also +compares strings and characters case-insensitively. + +Type objects that are arrays (that is, strings, bit-vectors, and vectors) +of the same length and with contents that are `equalp' are themselves +`equalp', regardless of whether the two objects have the same type. + +Other objects whose primary purpose is as containers of other objects are +`equalp' if they would otherwise be equal (same length, type, etc.) and +their contents are `equalp'. This goes for conses, weak lists, +weak boxes, ephemerons, specifiers, hash tables, char tables and range +tables. However, objects that happen to contain other objects but are not +primarily designed for this purpose (e.g. compiled functions, events or +display-related objects such as glyphs, faces or extents) are currently +compared using `equalp' the same way as using `equal'. + +More specifically, two hash tables are `equalp' if they have the same test +(see `hash-table-test'), the same number of entries, and the same value for +`hash-table-weakness', and if, for each entry in one hash table, its key is +equivalent to a key in the other hash table using the hash table test, and +its value is `equalp' to the other hash table's value for that key. +*/ + (object1, object2)) +{ + return internal_equalp (object1, object2, 0) ? Qt : Qnil; +} + DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* Return t if two Lisp objects have similar structure and contents. They must have the same data type. @@ -4106,6 +4178,7 @@ DEFSUBR (Fremprop); DEFSUBR (Fobject_plist); DEFSUBR (Fequal); + DEFSUBR (Fequalp); DEFSUBR (Fold_equal); DEFSUBR (Ffillarray); DEFSUBR (Fnconc);
--- a/src/frame-gtk.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/frame-gtk.c Mon Feb 01 01:02:40 2010 -0600 @@ -988,9 +988,11 @@ FRAME_GTK_LISP_WIDGETS (f)[i] = Qnil; /* - Hashtables of callback data for glyphs on the frame. Make them EQ because - we only use ints as keys. Otherwise we run into stickiness in redisplay - because internal_equal() can QUIT. See enter_redisplay_critical_section(). + Hashtables of callback data for glyphs on the frame. [[ Make them EQ + because we only use ints as keys. Otherwise we run into stickiness in + redisplay because internal_equal() can QUIT. See + enter_redisplay_critical_section() ]] -- probably not true any more, + now that we have internal_equal_trapping_problems(). --ben */ FRAME_GTK_WIDGET_INSTANCE_HASH_TABLE (f) = make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQ);
--- a/src/frame-msw.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/frame-msw.c Mon Feb 01 01:02:40 2010 -0600 @@ -195,10 +195,11 @@ FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f) = make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); #endif - /* hashtable of instantiated glyphs on the frame. Make them EQ because + /* hashtable of instantiated glyphs on the frame. [[ Make them EQ because we only use ints as keys. Otherwise we run into stickiness in redisplay because internal_equal() can QUIT. See - enter_redisplay_critical_section(). */ + enter_redisplay_critical_section(). ]] -- probably not true any more, + now that we have internal_equal_trapping_problems(). --ben */ FRAME_MSWINDOWS_WIDGET_HASH_TABLE1 (f) = make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQ); FRAME_MSWINDOWS_WIDGET_HASH_TABLE2 (f) =
--- a/src/glyphs.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/glyphs.c Mon Feb 01 01:02:40 2010 -0600 @@ -1133,7 +1133,8 @@ } static int -image_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +image_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, + int UNUSED (foldcase)) { Lisp_Image_Instance *i1 = XIMAGE_INSTANCE (obj1); Lisp_Image_Instance *i2 = XIMAGE_INSTANCE (obj2); @@ -3706,7 +3707,8 @@ This isn't concerned with "unspecified" attributes, that's what #'glyph-differs-from-default-p is for. */ static int -glyph_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +glyph_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, + int UNUSED (foldcase)) { Lisp_Glyph *g1 = XGLYPH (obj1); Lisp_Glyph *g2 = XGLYPH (obj2); @@ -3717,7 +3719,7 @@ internal_equal (g1->contrib_p, g2->contrib_p, depth) && internal_equal (g1->baseline, g2->baseline, depth) && internal_equal (g1->face, g2->face, depth) && - !plists_differ (g1->plist, g2->plist, 0, 0, depth + 1)); + !plists_differ (g1->plist, g2->plist, 0, 0, depth + 1, 0)); } static Hashcode
--- a/src/gui.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/gui.c Mon Feb 01 01:02:40 2010 -0600 @@ -678,7 +678,8 @@ } static int -gui_item_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +gui_item_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, + int UNUSED (foldcase)) { Lisp_Gui_Item *p1 = XGUI_ITEM (obj1); Lisp_Gui_Item *p2 = XGUI_ITEM (obj2);
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/keymap-buttons.h Mon Feb 01 01:02:40 2010 -0600 @@ -0,0 +1,62 @@ +/* Include file for iterating over all buttons. + Copyright (C) 1985, 1991-1995 Free Software Foundation, Inc. + Copyright (C) 1995 Board of Trustees, University of Illinois. + Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 2001, 2002, 2010 Ben Wing. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. Split out of keymap.c. */ + +/* To use this, define FROB to do something with the button number. No + need to undefine, it happens automatically at the end of this file. If + you want button 0 included, define INCLUDE_BUTTON_ZERO (also undefined + automatically). */ + +#ifdef INCLUDE_BUTTON_ZERO +FROB(0) +#endif +FROB(1) +FROB(2) +FROB(3) +FROB(4) +FROB(5) +FROB(6) +FROB(7) +FROB(8) +FROB(9) +FROB(10) +FROB(11) +FROB(12) +FROB(13) +FROB(14) +FROB(15) +FROB(16) +FROB(17) +FROB(18) +FROB(19) +FROB(20) +FROB(21) +FROB(22) +FROB(23) +FROB(24) +FROB(25) +FROB(26) + +#undef FROB +#undef INCLUDE_BUTTON_ZERO
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/keymap-slots.h Mon Feb 01 01:02:40 2010 -0600 @@ -0,0 +1,62 @@ +/* Definitions of marked slots in keymaps. + Copyright (C) 1985, 1991-1995 Free Software Foundation, Inc. + Copyright (C) 1995 Board of Trustees, University of Illinois. + Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 2001, 2002, 2010 Ben Wing. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. Split out of keymap.c. */ + +/* We define the Lisp_Objects in the keymap structure in a separate + file because there are numerous places we want to iterate over them, + such as when defining them in the structure, initializing them, or + marking them. + + To use, define MARKED_SLOT before including this file. No need to + undefine; that happens automatically. + + MARKED_SLOT_NOCOMPARE is used to indicate a slot that should not be + compared in the equal() method or hashed in the hash() method -- + basically, a slot used for caching, debugging, etc. instead of for + defining a property of the keymap. +*/ + +#ifndef MARKED_SLOT_NOCOMPARE +#define MARKED_SLOT_NOCOMPARE MARKED_SLOT +#endif + + MARKED_SLOT (parents) /* Keymaps to be searched after this one. + An ordered list */ + MARKED_SLOT (prompt) /* Qnil or a string to print in the minibuffer + when reading from this keymap */ + MARKED_SLOT (table) /* The contents of this keymap */ + MARKED_SLOT_NOCOMPARE (inverse_table) /* The inverse mapping of the above */ + MARKED_SLOT (default_binding) /* Use this if no other binding is found + (this overrides parent maps and the + normal global-map lookup). */ + MARKED_SLOT_NOCOMPARE (sub_maps_cache) /* Cache of directly inferior + keymaps; This holds an alist, + of the key and the maps, or the + modifier bit and the map. If + this is the symbol t, then the + cache needs to be recomputed. */ + MARKED_SLOT_NOCOMPARE (name) /* Just for debugging convenience */ + +#undef MARKED_SLOT +#undef MARKED_SLOT_NOCOMPARE
--- a/src/keymap.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/keymap.c Mon Feb 01 01:02:40 2010 -0600 @@ -149,21 +149,8 @@ struct Lisp_Keymap { struct LCRECORD_HEADER header; - Lisp_Object parents; /* Keymaps to be searched after this one. - An ordered list */ - Lisp_Object prompt; /* Qnil or a string to print in the minibuffer - when reading from this keymap */ - Lisp_Object table; /* The contents of this keymap */ - Lisp_Object inverse_table; /* The inverse mapping of the above */ - Lisp_Object default_binding; /* Use this if no other binding is found - (this overrides parent maps and the - normal global-map lookup). */ - Lisp_Object sub_maps_cache; /* Cache of directly inferior keymaps; - This holds an alist, of the key and the - maps, or the modifier bit and the map. - If this is the symbol t, then the cache - needs to be recomputed. */ - Lisp_Object name; /* Just for debugging convenience */ +#define MARKED_SLOT(x) Lisp_Object x; +#include "keymap-slots.h" }; #define MAKE_MODIFIER_HASH_KEY(modifier) make_int (modifier) @@ -217,49 +204,20 @@ static Lisp_Object keymap_submaps (Lisp_Object keymap); Lisp_Object Qcontrol, Qctrl, Qmeta, Qsuper, Qhyper, Qalt, Qshift; -Lisp_Object Qbutton0; -Lisp_Object Qbutton1, Qbutton2, Qbutton3, Qbutton4, Qbutton5; -Lisp_Object Qbutton6, Qbutton7, Qbutton8, Qbutton9, Qbutton10; -Lisp_Object Qbutton11, Qbutton12, Qbutton13, Qbutton14, Qbutton15; -Lisp_Object Qbutton16, Qbutton17, Qbutton18, Qbutton19, Qbutton20; -Lisp_Object Qbutton21, Qbutton22, Qbutton23, Qbutton24, Qbutton25; -Lisp_Object Qbutton26; -Lisp_Object Qbutton0up; -Lisp_Object Qbutton1up, Qbutton2up, Qbutton3up, Qbutton4up, Qbutton5up; -Lisp_Object Qbutton6up, Qbutton7up, Qbutton8up, Qbutton9up, Qbutton10up; -Lisp_Object Qbutton11up, Qbutton12up, Qbutton13up, Qbutton14up, Qbutton15up; -Lisp_Object Qbutton16up, Qbutton17up, Qbutton18up, Qbutton19up, Qbutton20up; -Lisp_Object Qbutton21up, Qbutton22up, Qbutton23up, Qbutton24up, Qbutton25up; -Lisp_Object Qbutton26up; + +#define INCLUDE_BUTTON_ZERO +#define FROB(num) \ +Lisp_Object Qbutton##num; \ +Lisp_Object Qbutton##num##up; +#include "keymap-buttons.h" Lisp_Object Qmenu_selection; + /* Emacs compatibility */ -Lisp_Object Qdown_mouse_1, Qmouse_1; -Lisp_Object Qdown_mouse_2, Qmouse_2; -Lisp_Object Qdown_mouse_3, Qmouse_3; -Lisp_Object Qdown_mouse_4, Qmouse_4; -Lisp_Object Qdown_mouse_5, Qmouse_5; -Lisp_Object Qdown_mouse_6, Qmouse_6; -Lisp_Object Qdown_mouse_7, Qmouse_7; -Lisp_Object Qdown_mouse_8, Qmouse_8; -Lisp_Object Qdown_mouse_9, Qmouse_9; -Lisp_Object Qdown_mouse_10, Qmouse_10; -Lisp_Object Qdown_mouse_11, Qmouse_11; -Lisp_Object Qdown_mouse_12, Qmouse_12; -Lisp_Object Qdown_mouse_13, Qmouse_13; -Lisp_Object Qdown_mouse_14, Qmouse_14; -Lisp_Object Qdown_mouse_15, Qmouse_15; -Lisp_Object Qdown_mouse_16, Qmouse_16; -Lisp_Object Qdown_mouse_17, Qmouse_17; -Lisp_Object Qdown_mouse_18, Qmouse_18; -Lisp_Object Qdown_mouse_19, Qmouse_19; -Lisp_Object Qdown_mouse_20, Qmouse_20; -Lisp_Object Qdown_mouse_21, Qmouse_21; -Lisp_Object Qdown_mouse_22, Qmouse_22; -Lisp_Object Qdown_mouse_23, Qmouse_23; -Lisp_Object Qdown_mouse_24, Qmouse_24; -Lisp_Object Qdown_mouse_25, Qmouse_25; -Lisp_Object Qdown_mouse_26, Qmouse_26; +#define FROB(num) \ +Lisp_Object Qmouse_##num; \ +Lisp_Object Qdown_mouse_##num; +#include "keymap-buttons.h" /* Kludge kludge kludge */ Lisp_Object QLFD, QTAB, QRET, QESC, QDEL, QSPC, QBS; @@ -269,17 +227,54 @@ /* The keymap Lisp object */ /************************************************************************/ +/* Keymaps are equal if Faces are equal if all of their display attributes are equal. We + don't compare names or doc-strings, because that would make equal + be eq. + + This isn't concerned with "unspecified" attributes, that's what + #'face-differs-from-default-p is for. */ +static int +keymap_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, + int UNUSED (foldcase)) +{ + Lisp_Keymap *k1 = XKEYMAP (obj1); + Lisp_Keymap *k2 = XKEYMAP (obj2); + + depth++; + + return + ( +#define MARKED_SLOT(x) \ + internal_equal (k1->x, k2->x, depth) && +#define MARKED_SLOT_NOCOMPARE(x) +#include "keymap-slots.h" + 1 + ); +} + +static Hashcode +keymap_hash (Lisp_Object obj, int depth) +{ + Lisp_Keymap *k = XKEYMAP (obj); + Hashcode hash = 0xCAFEBABE; /* why not? */ + + depth++; + +#define MARKED_SLOT(x) \ + hash = HASH2 (hash, internal_hash (k->x, depth)); +#define MARKED_SLOT_NOCOMPARE(x) +#include "keymap-slots.h" + + return hash; +} + static Lisp_Object mark_keymap (Lisp_Object obj) { Lisp_Keymap *keymap = XKEYMAP (obj); - mark_object (keymap->parents); - mark_object (keymap->prompt); - mark_object (keymap->inverse_table); - mark_object (keymap->sub_maps_cache); - mark_object (keymap->default_binding); - mark_object (keymap->name); - return keymap->table; +#define MARKED_SLOT(x) mark_object (keymap->x); +#include "keymap-slots.h" + return Qnil; } static void @@ -300,20 +295,15 @@ } static const struct memory_description keymap_description[] = { - { XD_LISP_OBJECT, offsetof (Lisp_Keymap, parents) }, - { XD_LISP_OBJECT, offsetof (Lisp_Keymap, prompt) }, - { XD_LISP_OBJECT, offsetof (Lisp_Keymap, table) }, - { XD_LISP_OBJECT, offsetof (Lisp_Keymap, inverse_table) }, - { XD_LISP_OBJECT, offsetof (Lisp_Keymap, default_binding) }, - { XD_LISP_OBJECT, offsetof (Lisp_Keymap, sub_maps_cache) }, - { XD_LISP_OBJECT, offsetof (Lisp_Keymap, name) }, +#define MARKED_SLOT(x) { XD_LISP_OBJECT, offsetof (Lisp_Keymap, x) }, +#include "keymap-slots.h" { XD_END } }; -/* No need for keymap_equal #### Why not? */ DEFINE_LRECORD_IMPLEMENTATION ("keymap", keymap, 1, /*dumpable-flag*/ - mark_keymap, print_keymap, 0, 0, 0, + mark_keymap, print_keymap, 0, + keymap_equal, keymap_hash, keymap_description, Lisp_Keymap); @@ -496,15 +486,10 @@ { Lisp_Keymap *k; - modifiers &= ~(XEMACS_MOD_BUTTON1 | XEMACS_MOD_BUTTON2 | XEMACS_MOD_BUTTON3 - | XEMACS_MOD_BUTTON4 | XEMACS_MOD_BUTTON5 | XEMACS_MOD_BUTTON6 - | XEMACS_MOD_BUTTON7 | XEMACS_MOD_BUTTON8 | XEMACS_MOD_BUTTON9 - | XEMACS_MOD_BUTTON10 | XEMACS_MOD_BUTTON11 | XEMACS_MOD_BUTTON12 - | XEMACS_MOD_BUTTON13 | XEMACS_MOD_BUTTON14 | XEMACS_MOD_BUTTON15 - | XEMACS_MOD_BUTTON16 | XEMACS_MOD_BUTTON17 | XEMACS_MOD_BUTTON18 - | XEMACS_MOD_BUTTON19 | XEMACS_MOD_BUTTON20 | XEMACS_MOD_BUTTON21 - | XEMACS_MOD_BUTTON22 | XEMACS_MOD_BUTTON23 | XEMACS_MOD_BUTTON24 - | XEMACS_MOD_BUTTON25 | XEMACS_MOD_BUTTON26); + modifiers &= ~( +#define FROB(num) XEMACS_MOD_BUTTON##num | +#include "keymap-buttons.h" + 0); if ((modifiers & ~(XEMACS_MOD_CONTROL | XEMACS_MOD_META | XEMACS_MOD_SUPER | XEMACS_MOD_HYPER | XEMACS_MOD_ALT | XEMACS_MOD_SHIFT)) != 0) @@ -684,15 +669,10 @@ int modifiers = KEY_DATA_MODIFIERS (key); Lisp_Keymap *k = XKEYMAP (keymap); - modifiers &= ~(XEMACS_MOD_BUTTON1 | XEMACS_MOD_BUTTON2 | XEMACS_MOD_BUTTON3 - | XEMACS_MOD_BUTTON4 | XEMACS_MOD_BUTTON5 | XEMACS_MOD_BUTTON6 - | XEMACS_MOD_BUTTON7 | XEMACS_MOD_BUTTON8 | XEMACS_MOD_BUTTON9 - | XEMACS_MOD_BUTTON10 | XEMACS_MOD_BUTTON11 | XEMACS_MOD_BUTTON12 - | XEMACS_MOD_BUTTON13 | XEMACS_MOD_BUTTON14 | XEMACS_MOD_BUTTON15 - | XEMACS_MOD_BUTTON16 | XEMACS_MOD_BUTTON17 | XEMACS_MOD_BUTTON18 - | XEMACS_MOD_BUTTON19 | XEMACS_MOD_BUTTON20 | XEMACS_MOD_BUTTON21 - | XEMACS_MOD_BUTTON22 | XEMACS_MOD_BUTTON23 | XEMACS_MOD_BUTTON24 - | XEMACS_MOD_BUTTON25 | XEMACS_MOD_BUTTON26); + modifiers &= ~( +#define FROB(num) XEMACS_MOD_BUTTON##num | +#include "keymap-buttons.h" + 0); assert ((modifiers & ~(XEMACS_MOD_CONTROL | XEMACS_MOD_META | XEMACS_MOD_SUPER | XEMACS_MOD_HYPER | XEMACS_MOD_ALT | XEMACS_MOD_SHIFT)) == 0); @@ -803,13 +783,8 @@ result = wrap_keymap (keymap); - keymap->parents = Qnil; - keymap->prompt = Qnil; - keymap->table = Qnil; - keymap->inverse_table = Qnil; - keymap->default_binding = Qnil; - keymap->sub_maps_cache = Qnil; /* No possible submaps */ - keymap->name = Qnil; +#define MARKED_SLOT(x) keymap->x = Qnil; +#include "keymap-slots.h" if (size != 0) /* hack for copy-keymap */ { @@ -1406,110 +1381,12 @@ else if (EQ (*keysym, QBS)) *keysym = QKbackspace; /* Emacs compatibility */ - else if (EQ(*keysym, Qdown_mouse_1)) - *keysym = Qbutton1; - else if (EQ(*keysym, Qdown_mouse_2)) - *keysym = Qbutton2; - else if (EQ(*keysym, Qdown_mouse_3)) - *keysym = Qbutton3; - else if (EQ(*keysym, Qdown_mouse_4)) - *keysym = Qbutton4; - else if (EQ(*keysym, Qdown_mouse_5)) - *keysym = Qbutton5; - else if (EQ(*keysym, Qdown_mouse_6)) - *keysym = Qbutton6; - else if (EQ(*keysym, Qdown_mouse_7)) - *keysym = Qbutton7; - else if (EQ(*keysym, Qdown_mouse_8)) - *keysym = Qbutton8; - else if (EQ(*keysym, Qdown_mouse_9)) - *keysym = Qbutton9; - else if (EQ(*keysym, Qdown_mouse_10)) - *keysym = Qbutton10; - else if (EQ(*keysym, Qdown_mouse_11)) - *keysym = Qbutton11; - else if (EQ(*keysym, Qdown_mouse_12)) - *keysym = Qbutton12; - else if (EQ(*keysym, Qdown_mouse_13)) - *keysym = Qbutton13; - else if (EQ(*keysym, Qdown_mouse_14)) - *keysym = Qbutton14; - else if (EQ(*keysym, Qdown_mouse_15)) - *keysym = Qbutton15; - else if (EQ(*keysym, Qdown_mouse_16)) - *keysym = Qbutton16; - else if (EQ(*keysym, Qdown_mouse_17)) - *keysym = Qbutton17; - else if (EQ(*keysym, Qdown_mouse_18)) - *keysym = Qbutton18; - else if (EQ(*keysym, Qdown_mouse_19)) - *keysym = Qbutton19; - else if (EQ(*keysym, Qdown_mouse_20)) - *keysym = Qbutton20; - else if (EQ(*keysym, Qdown_mouse_21)) - *keysym = Qbutton21; - else if (EQ(*keysym, Qdown_mouse_22)) - *keysym = Qbutton22; - else if (EQ(*keysym, Qdown_mouse_23)) - *keysym = Qbutton23; - else if (EQ(*keysym, Qdown_mouse_24)) - *keysym = Qbutton24; - else if (EQ(*keysym, Qdown_mouse_25)) - *keysym = Qbutton25; - else if (EQ(*keysym, Qdown_mouse_26)) - *keysym = Qbutton26; - else if (EQ(*keysym, Qmouse_1)) - *keysym = Qbutton1up; - else if (EQ(*keysym, Qmouse_2)) - *keysym = Qbutton2up; - else if (EQ(*keysym, Qmouse_3)) - *keysym = Qbutton3up; - else if (EQ(*keysym, Qmouse_4)) - *keysym = Qbutton4up; - else if (EQ(*keysym, Qmouse_5)) - *keysym = Qbutton5up; - else if (EQ(*keysym, Qmouse_6)) - *keysym = Qbutton6up; - else if (EQ(*keysym, Qmouse_7)) - *keysym = Qbutton7up; - else if (EQ(*keysym, Qmouse_8)) - *keysym = Qbutton8up; - else if (EQ(*keysym, Qmouse_9)) - *keysym = Qbutton9up; - else if (EQ(*keysym, Qmouse_10)) - *keysym = Qbutton10up; - else if (EQ(*keysym, Qmouse_11)) - *keysym = Qbutton11up; - else if (EQ(*keysym, Qmouse_12)) - *keysym = Qbutton12up; - else if (EQ(*keysym, Qmouse_13)) - *keysym = Qbutton13up; - else if (EQ(*keysym, Qmouse_14)) - *keysym = Qbutton14up; - else if (EQ(*keysym, Qmouse_15)) - *keysym = Qbutton15up; - else if (EQ(*keysym, Qmouse_16)) - *keysym = Qbutton16up; - else if (EQ(*keysym, Qmouse_17)) - *keysym = Qbutton17up; - else if (EQ(*keysym, Qmouse_18)) - *keysym = Qbutton18up; - else if (EQ(*keysym, Qmouse_19)) - *keysym = Qbutton19up; - else if (EQ(*keysym, Qmouse_20)) - *keysym = Qbutton20up; - else if (EQ(*keysym, Qmouse_21)) - *keysym = Qbutton21up; - else if (EQ(*keysym, Qmouse_22)) - *keysym = Qbutton22up; - else if (EQ(*keysym, Qmouse_23)) - *keysym = Qbutton23up; - else if (EQ(*keysym, Qmouse_24)) - *keysym = Qbutton24up; - else if (EQ(*keysym, Qmouse_25)) - *keysym = Qbutton25up; - else if (EQ(*keysym, Qmouse_26)) - *keysym = Qbutton26up; +#define FROB(num) \ + else if (EQ(*keysym, Qdown_mouse_##num)) \ + *keysym = Qbutton##num; \ + else if (EQ(*keysym, Qmouse_##num)) \ + *keysym = Qbutton##num##up; +#include "keymap-buttons.h" } } @@ -1552,89 +1429,20 @@ int down = (XEVENT_TYPE (spec) == button_press_event); switch (XEVENT_BUTTON_BUTTON (spec)) { - case 1: - SET_KEY_DATA_KEYSYM (returned_value, (down ? Qbutton1 : Qbutton1up)); - break; - case 2: - SET_KEY_DATA_KEYSYM (returned_value, (down ? Qbutton2 : Qbutton2up)); - break; - case 3: - SET_KEY_DATA_KEYSYM (returned_value, (down ? Qbutton3 : Qbutton3up)); - break; - case 4: - SET_KEY_DATA_KEYSYM (returned_value, (down ? Qbutton4 : Qbutton4up)); - break; - case 5: - SET_KEY_DATA_KEYSYM (returned_value, (down ? Qbutton5 : Qbutton5up)); - break; - case 6: - SET_KEY_DATA_KEYSYM (returned_value, (down ? Qbutton6 : Qbutton6up)); - break; - case 7: - SET_KEY_DATA_KEYSYM (returned_value, (down ? Qbutton7 : Qbutton7up)); +#define FROB(num) \ + case num: \ + SET_KEY_DATA_KEYSYM (returned_value, \ + (down ? Qbutton##num : \ + Qbutton##num##up)); \ break; - case 8: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton8 : Qbutton8up)); - break; - case 9: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton9 : Qbutton9up)); - break; - case 10: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton10 : Qbutton10up)); - break; - case 11: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton11 : Qbutton11up)); - break; - case 12: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton12 : Qbutton12up)); - break; - case 13: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton13 : Qbutton13up)); - break; - case 14: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton14 : Qbutton14up)); - break; - case 15: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton15 : Qbutton15up)); - break; - case 16: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton16 : Qbutton16up)); - break; - case 17: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton17 : Qbutton17up)); - break; - case 18: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton18 : Qbutton18up)); - break; - case 19: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton19 : Qbutton19up)); - break; - case 20: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton20 : Qbutton20up)); - break; - case 21: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton21 : Qbutton21up)); - break; - case 22: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton22 : Qbutton22up)); - break; - case 23: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton23 : Qbutton23up)); - break; - case 24: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton24 : Qbutton24up)); - break; - case 25: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton25 : Qbutton25up)); - break; - case 26: - SET_KEY_DATA_KEYSYM(returned_value, (down ? Qbutton26 : Qbutton26up)); - break; +#include "keymap-buttons.h" default: - SET_KEY_DATA_KEYSYM (returned_value, (down ? Qbutton0 : Qbutton0up)); + SET_KEY_DATA_KEYSYM (returned_value, (down ? Qbutton0 : + Qbutton0up)); break; } - SET_KEY_DATA_MODIFIERS (returned_value, XEVENT_BUTTON_MODIFIERS (spec)); + SET_KEY_DATA_MODIFIERS (returned_value, + XEVENT_BUTTON_MODIFIERS (spec)); break; } default: @@ -1722,33 +1530,13 @@ define_key_parser (list, &raw_key); - if (EQ (raw_key.keysym, Qbutton0) || EQ (raw_key.keysym, Qbutton0up) || - EQ (raw_key.keysym, Qbutton1) || EQ (raw_key.keysym, Qbutton1up) || - EQ (raw_key.keysym, Qbutton2) || EQ (raw_key.keysym, Qbutton2up) || - EQ (raw_key.keysym, Qbutton3) || EQ (raw_key.keysym, Qbutton3up) || - EQ (raw_key.keysym, Qbutton4) || EQ (raw_key.keysym, Qbutton4up) || - EQ (raw_key.keysym, Qbutton5) || EQ (raw_key.keysym, Qbutton5up) || - EQ (raw_key.keysym, Qbutton6) || EQ (raw_key.keysym, Qbutton6up) || - EQ (raw_key.keysym, Qbutton7) || EQ (raw_key.keysym, Qbutton7up) || - EQ (raw_key.keysym, Qbutton8) || EQ (raw_key.keysym, Qbutton8up) || - EQ (raw_key.keysym, Qbutton9) || EQ (raw_key.keysym, Qbutton9up) || - EQ (raw_key.keysym, Qbutton10) || EQ (raw_key.keysym, Qbutton10up) || - EQ (raw_key.keysym, Qbutton11) || EQ (raw_key.keysym, Qbutton11up) || - EQ (raw_key.keysym, Qbutton12) || EQ (raw_key.keysym, Qbutton12up) || - EQ (raw_key.keysym, Qbutton13) || EQ (raw_key.keysym, Qbutton13up) || - EQ (raw_key.keysym, Qbutton14) || EQ (raw_key.keysym, Qbutton14up) || - EQ (raw_key.keysym, Qbutton15) || EQ (raw_key.keysym, Qbutton15up) || - EQ (raw_key.keysym, Qbutton16) || EQ (raw_key.keysym, Qbutton16up) || - EQ (raw_key.keysym, Qbutton17) || EQ (raw_key.keysym, Qbutton17up) || - EQ (raw_key.keysym, Qbutton18) || EQ (raw_key.keysym, Qbutton18up) || - EQ (raw_key.keysym, Qbutton19) || EQ (raw_key.keysym, Qbutton19up) || - EQ (raw_key.keysym, Qbutton20) || EQ (raw_key.keysym, Qbutton20up) || - EQ (raw_key.keysym, Qbutton21) || EQ (raw_key.keysym, Qbutton21up) || - EQ (raw_key.keysym, Qbutton22) || EQ (raw_key.keysym, Qbutton22up) || - EQ (raw_key.keysym, Qbutton23) || EQ (raw_key.keysym, Qbutton23up) || - EQ (raw_key.keysym, Qbutton24) || EQ (raw_key.keysym, Qbutton24up) || - EQ (raw_key.keysym, Qbutton25) || EQ (raw_key.keysym, Qbutton25up) || - EQ (raw_key.keysym, Qbutton26) || EQ (raw_key.keysym, Qbutton26up)) + if ( +#define INCLUDE_BUTTON_ZERO +#define FROB(num) \ + EQ (raw_key.keysym, Qbutton##num) || \ + EQ (raw_key.keysym, Qbutton##num##up) || +#include "keymap-buttons.h" + 0) invalid_operation ("Mouse-clicks can't appear in saved keyboard macros", Qunbound); @@ -4252,60 +4040,12 @@ /* If we're only supposed to display mouse bindings and this isn't one, then bug out. */ if (closure->mice_only_p && - (! (EQ (keysym, Qbutton0) || - EQ (keysym, Qbutton1) || - EQ (keysym, Qbutton2) || - EQ (keysym, Qbutton3) || - EQ (keysym, Qbutton4) || - EQ (keysym, Qbutton5) || - EQ (keysym, Qbutton6) || - EQ (keysym, Qbutton7) || - EQ (keysym, Qbutton8) || - EQ (keysym, Qbutton9) || - EQ (keysym, Qbutton10) || - EQ (keysym, Qbutton11) || - EQ (keysym, Qbutton12) || - EQ (keysym, Qbutton13) || - EQ (keysym, Qbutton14) || - EQ (keysym, Qbutton15) || - EQ (keysym, Qbutton16) || - EQ (keysym, Qbutton17) || - EQ (keysym, Qbutton18) || - EQ (keysym, Qbutton19) || - EQ (keysym, Qbutton20) || - EQ (keysym, Qbutton21) || - EQ (keysym, Qbutton22) || - EQ (keysym, Qbutton23) || - EQ (keysym, Qbutton24) || - EQ (keysym, Qbutton25) || - EQ (keysym, Qbutton26) || - EQ (keysym, Qbutton0up) || - EQ (keysym, Qbutton1up) || - EQ (keysym, Qbutton2up) || - EQ (keysym, Qbutton3up) || - EQ (keysym, Qbutton4up) || - EQ (keysym, Qbutton5up) || - EQ (keysym, Qbutton6up) || - EQ (keysym, Qbutton7up) || - EQ (keysym, Qbutton8up) || - EQ (keysym, Qbutton9up) || - EQ (keysym, Qbutton10up) || - EQ (keysym, Qbutton11up) || - EQ (keysym, Qbutton12up) || - EQ (keysym, Qbutton13up) || - EQ (keysym, Qbutton14up) || - EQ (keysym, Qbutton15up) || - EQ (keysym, Qbutton16up) || - EQ (keysym, Qbutton17up) || - EQ (keysym, Qbutton18up) || - EQ (keysym, Qbutton19up) || - EQ (keysym, Qbutton20up) || - EQ (keysym, Qbutton21up) || - EQ (keysym, Qbutton22up) || - EQ (keysym, Qbutton23up) || - EQ (keysym, Qbutton24up) || - EQ (keysym, Qbutton25up) || - EQ (keysym, Qbutton26up)))) + (! ( +#define INCLUDE_BUTTON_ZERO +#define FROB(num) EQ (keysym, Qbutton##num) || \ + EQ (keysym, Qbutton##num##up) || +#include "keymap-buttons.h" + 0))) return; /* If this command in this map is shadowed by some other map, ignore it. */ @@ -4609,112 +4349,15 @@ DEFSYMBOL (Qhyper); DEFSYMBOL (Qalt); DEFSYMBOL (Qshift); - DEFSYMBOL (Qbutton0); - DEFSYMBOL (Qbutton1); - DEFSYMBOL (Qbutton2); - DEFSYMBOL (Qbutton3); - DEFSYMBOL (Qbutton4); - DEFSYMBOL (Qbutton5); - DEFSYMBOL (Qbutton6); - DEFSYMBOL (Qbutton7); - DEFSYMBOL (Qbutton8); - DEFSYMBOL (Qbutton9); - DEFSYMBOL (Qbutton10); - DEFSYMBOL (Qbutton11); - DEFSYMBOL (Qbutton12); - DEFSYMBOL (Qbutton13); - DEFSYMBOL (Qbutton14); - DEFSYMBOL (Qbutton15); - DEFSYMBOL (Qbutton16); - DEFSYMBOL (Qbutton17); - DEFSYMBOL (Qbutton18); - DEFSYMBOL (Qbutton19); - DEFSYMBOL (Qbutton20); - DEFSYMBOL (Qbutton21); - DEFSYMBOL (Qbutton22); - DEFSYMBOL (Qbutton23); - DEFSYMBOL (Qbutton24); - DEFSYMBOL (Qbutton25); - DEFSYMBOL (Qbutton26); - DEFSYMBOL (Qbutton0up); - DEFSYMBOL (Qbutton1up); - DEFSYMBOL (Qbutton2up); - DEFSYMBOL (Qbutton3up); - DEFSYMBOL (Qbutton4up); - DEFSYMBOL (Qbutton5up); - DEFSYMBOL (Qbutton6up); - DEFSYMBOL (Qbutton7up); - DEFSYMBOL (Qbutton8up); - DEFSYMBOL (Qbutton9up); - DEFSYMBOL (Qbutton10up); - DEFSYMBOL (Qbutton11up); - DEFSYMBOL (Qbutton12up); - DEFSYMBOL (Qbutton13up); - DEFSYMBOL (Qbutton14up); - DEFSYMBOL (Qbutton15up); - DEFSYMBOL (Qbutton16up); - DEFSYMBOL (Qbutton17up); - DEFSYMBOL (Qbutton18up); - DEFSYMBOL (Qbutton19up); - DEFSYMBOL (Qbutton20up); - DEFSYMBOL (Qbutton21up); - DEFSYMBOL (Qbutton22up); - DEFSYMBOL (Qbutton23up); - DEFSYMBOL (Qbutton24up); - DEFSYMBOL (Qbutton25up); - DEFSYMBOL (Qbutton26up); - DEFSYMBOL (Qmouse_1); - DEFSYMBOL (Qmouse_2); - DEFSYMBOL (Qmouse_3); - DEFSYMBOL (Qmouse_4); - DEFSYMBOL (Qmouse_5); - DEFSYMBOL (Qmouse_6); - DEFSYMBOL (Qmouse_7); - DEFSYMBOL (Qmouse_8); - DEFSYMBOL (Qmouse_9); - DEFSYMBOL (Qmouse_10); - DEFSYMBOL (Qmouse_11); - DEFSYMBOL (Qmouse_12); - DEFSYMBOL (Qmouse_13); - DEFSYMBOL (Qmouse_14); - DEFSYMBOL (Qmouse_15); - DEFSYMBOL (Qmouse_16); - DEFSYMBOL (Qmouse_17); - DEFSYMBOL (Qmouse_18); - DEFSYMBOL (Qmouse_19); - DEFSYMBOL (Qmouse_20); - DEFSYMBOL (Qmouse_21); - DEFSYMBOL (Qmouse_22); - DEFSYMBOL (Qmouse_23); - DEFSYMBOL (Qmouse_24); - DEFSYMBOL (Qmouse_25); - DEFSYMBOL (Qmouse_26); - DEFSYMBOL (Qdown_mouse_1); - DEFSYMBOL (Qdown_mouse_2); - DEFSYMBOL (Qdown_mouse_3); - DEFSYMBOL (Qdown_mouse_4); - DEFSYMBOL (Qdown_mouse_5); - DEFSYMBOL (Qdown_mouse_6); - DEFSYMBOL (Qdown_mouse_7); - DEFSYMBOL (Qdown_mouse_8); - DEFSYMBOL (Qdown_mouse_9); - DEFSYMBOL (Qdown_mouse_10); - DEFSYMBOL (Qdown_mouse_11); - DEFSYMBOL (Qdown_mouse_12); - DEFSYMBOL (Qdown_mouse_13); - DEFSYMBOL (Qdown_mouse_14); - DEFSYMBOL (Qdown_mouse_15); - DEFSYMBOL (Qdown_mouse_16); - DEFSYMBOL (Qdown_mouse_17); - DEFSYMBOL (Qdown_mouse_18); - DEFSYMBOL (Qdown_mouse_19); - DEFSYMBOL (Qdown_mouse_20); - DEFSYMBOL (Qdown_mouse_21); - DEFSYMBOL (Qdown_mouse_22); - DEFSYMBOL (Qdown_mouse_23); - DEFSYMBOL (Qdown_mouse_24); - DEFSYMBOL (Qdown_mouse_25); - DEFSYMBOL (Qdown_mouse_26); +#define INCLUDE_BUTTON_ZERO +#define FROB(num) \ + DEFSYMBOL (Qbutton##num); \ + DEFSYMBOL (Qbutton##num##up); +#include "keymap-buttons.h" +#define FROB(num) \ + DEFSYMBOL (Qmouse_##num); \ + DEFSYMBOL (Qdown_mouse_##num); +#include "keymap-buttons.h" DEFSYMBOL (Qmenu_selection); DEFSYMBOL (QLFD); DEFSYMBOL (QTAB);
--- a/src/keymap.h Sat Jan 30 20:34:23 2010 -0600 +++ b/src/keymap.h Mon Feb 01 01:02:40 2010 -0600 @@ -39,12 +39,10 @@ EXFUN (Fwhere_is_internal, 5); extern Lisp_Object Qalt, Qcontrol, Qhyper, Qmeta, Qshift, Qsuper; -extern Lisp_Object Qbutton1, Qbutton2, Qbutton3, Qbutton4, Qbutton5; -extern Lisp_Object Qbutton6, Qbutton7, Qbutton8, Qbutton9, Qbutton10; -extern Lisp_Object Qbutton11, Qbutton12, Qbutton13, Qbutton14, Qbutton15; -extern Lisp_Object Qbutton16, Qbutton17, Qbutton18, Qbutton19, Qbutton20; -extern Lisp_Object Qbutton21, Qbutton22, Qbutton23, Qbutton24, Qbutton25; -extern Lisp_Object Qbutton26; + +#define FROB(num) \ +extern Lisp_Object Qbutton##num; +#include "keymap-buttons.h" extern Lisp_Object Vmeta_prefix_char; Lisp_Object get_keymap (Lisp_Object object, int errorp, int autoload);
--- a/src/lisp.h Sat Jan 30 20:34:23 2010 -0600 +++ b/src/lisp.h Mon Feb 01 01:02:40 2010 -0600 @@ -5047,6 +5047,8 @@ EXFUN (Felt, 2); MODULE_API EXFUN (Fequal, 2); MODULE_API EXFUN (Fget, 3); +MODULE_API EXFUN (Feqlsign, MANY); +MODULE_API EXFUN (Fequalp, 2); EXFUN (Flast, 2); EXFUN (Flax_plist_get, 3); EXFUN (Flax_plist_remprop, 2); @@ -5092,7 +5094,7 @@ Lisp_Object remassq_no_quit (Lisp_Object, Lisp_Object); Lisp_Object remrassq_no_quit (Lisp_Object, Lisp_Object); -int plists_differ (Lisp_Object, Lisp_Object, int, int, int); +int plists_differ (Lisp_Object, Lisp_Object, int, int, int, int); Lisp_Object internal_plist_get (Lisp_Object, Lisp_Object); void internal_plist_put (Lisp_Object *, Lisp_Object, Lisp_Object); int internal_remprop (Lisp_Object *, Lisp_Object); @@ -5110,6 +5112,7 @@ int depth); int internal_equal (Lisp_Object, Lisp_Object, int); int internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth); +int internal_equal_0 (Lisp_Object, Lisp_Object, int, int); Lisp_Object concat2 (Lisp_Object, Lisp_Object); Lisp_Object concat3 (Lisp_Object, Lisp_Object, Lisp_Object); Lisp_Object vconcat2 (Lisp_Object, Lisp_Object); @@ -5777,7 +5780,7 @@ int qxestrcasecmp_ascii (const Ibyte *s1, const Ascbyte *s2); int qxestrcasecmp_i18n (const Ibyte *s1, const Ibyte *s2); int ascii_strcasecmp (const Ascbyte *s1, const Ascbyte *s2); -int lisp_strcasecmp (Lisp_Object s1, Lisp_Object s2); +int lisp_strcasecmp_ascii (Lisp_Object s1, Lisp_Object s2); int lisp_strcasecmp_i18n (Lisp_Object s1, Lisp_Object s2); int qxestrncasecmp (const Ibyte *s1, const Ibyte *s2, Bytecount len); int qxestrncasecmp_ascii (const Ibyte *s1, const Ascbyte *s2,
--- a/src/lrecord.h Sat Jan 30 20:34:23 2010 -0600 +++ b/src/lrecord.h Mon Feb 01 01:02:40 2010 -0600 @@ -381,7 +381,8 @@ void (*finalizer) (void *header, int for_disksave); /* This can be NULL, meaning compare objects with EQ(). */ - int (*equal) (Lisp_Object obj1, Lisp_Object obj2, int depth); + int (*equal) (Lisp_Object obj1, Lisp_Object obj2, int depth, + int foldcase); /* `hash' generates hash values for use with hash tables that have `equal' as their test function. This can be NULL, meaning use
--- a/src/marker.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/marker.c Mon Feb 01 01:02:40 2010 -0600 @@ -77,7 +77,8 @@ } static int -marker_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +marker_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int UNUSED (foldcase)) { Lisp_Marker *marker1 = XMARKER (obj1); Lisp_Marker *marker2 = XMARKER (obj2);
--- a/src/minibuf.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/minibuf.c Mon Feb 01 01:02:40 2010 -0600 @@ -218,8 +218,8 @@ { while (l) { - Ichar c1 = DOWNCASE (0, itext_ichar (s1)); - Ichar c2 = DOWNCASE (0, itext_ichar (s2)); + Ichar c1 = CANONCASE (0, itext_ichar (s1)); + Ichar c2 = CANONCASE (0, itext_ichar (s2)); if (c1 == c2) {
--- a/src/number.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/number.c Mon Feb 01 01:02:40 2010 -0600 @@ -74,7 +74,8 @@ #endif static int -bignum_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +bignum_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int UNUSED (foldcase)) { return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); } @@ -166,7 +167,8 @@ #endif static int -ratio_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +ratio_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int UNUSED (foldcase)) { return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); } @@ -270,7 +272,8 @@ #endif static int -bigfloat_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +bigfloat_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int UNUSED (foldcase)) { return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); }
--- a/src/objects.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/objects.c Mon Feb 01 01:02:40 2010 -0600 @@ -124,7 +124,8 @@ } static int -color_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +color_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, + int UNUSED (foldcase)) { Lisp_Color_Instance *c1 = XCOLOR_INSTANCE (obj1); Lisp_Color_Instance *c2 = XCOLOR_INSTANCE (obj2); @@ -347,7 +348,8 @@ this means the `equal' could cause XListFonts to be run the first time. */ static int -font_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +font_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, + int UNUSED (foldcase)) { /* #### should this be moved into a device method? */ return internal_equal (font_instance_truename_internal
--- a/src/opaque.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/opaque.c Mon Feb 01 01:02:40 2010 -0600 @@ -93,7 +93,8 @@ /* This will not work correctly for opaques with subobjects! */ static int -equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int UNUSED (foldcase)) { Bytecount size; return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) && @@ -138,7 +139,8 @@ } static int -equal_opaque_ptr (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +equal_opaque_ptr (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int UNUSED (foldcase)) { return (XOPAQUE_PTR (obj1)->ptr == XOPAQUE_PTR (obj2)->ptr); }
--- a/src/rangetab.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/rangetab.c Mon Feb 01 01:02:40 2010 -0600 @@ -137,7 +137,7 @@ } static int -range_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +range_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) { Lisp_Range_Table *rt1 = XRANGE_TABLE (obj1); Lisp_Range_Table *rt2 = XRANGE_TABLE (obj2); @@ -153,7 +153,7 @@ if (rte1->first != rte2->first || rte1->last != rte2->last - || !internal_equal (rte1->val, rte2->val, depth + 1)) + || !internal_equal_0 (rte1->val, rte2->val, depth + 1, foldcase)) return 0; }
--- a/src/specifier.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/specifier.c Mon Feb 01 01:02:40 2010 -0600 @@ -311,7 +311,7 @@ #endif /* not NEW_GC */ static int -specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) { Lisp_Specifier *s1 = XSPECIFIER (obj1); Lisp_Specifier *s2 = XSPECIFIER (obj2); @@ -325,12 +325,12 @@ depth++; retval = (s1->methods == s2->methods && - internal_equal (s1->global_specs, s2->global_specs, depth) && - internal_equal (s1->device_specs, s2->device_specs, depth) && - internal_equal (s1->frame_specs, s2->frame_specs, depth) && - internal_equal (s1->window_specs, s2->window_specs, depth) && - internal_equal (s1->buffer_specs, s2->buffer_specs, depth) && - internal_equal (s1->fallback, s2->fallback, depth)); + internal_equal_0 (s1->global_specs, s2->global_specs, depth, foldcase) && + internal_equal_0 (s1->device_specs, s2->device_specs, depth, foldcase) && + internal_equal_0 (s1->frame_specs, s2->frame_specs, depth, foldcase) && + internal_equal_0 (s1->window_specs, s2->window_specs, depth, foldcase) && + internal_equal_0 (s1->buffer_specs, s2->buffer_specs, depth, foldcase) && + internal_equal_0 (s1->fallback, s2->fallback, depth, foldcase)); if (retval && HAS_SPECMETH_P (s1, equal)) retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1));
--- a/src/text.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/text.c Mon Feb 01 01:02:40 2010 -0600 @@ -1422,15 +1422,15 @@ { while (*s1 && *s2) { - if (DOWNCASE (0, itext_ichar (s1)) != - DOWNCASE (0, itext_ichar (s2))) + if (CANONCASE (0, itext_ichar (s1)) != + CANONCASE (0, itext_ichar (s2))) break; INC_IBYTEPTR (s1); INC_IBYTEPTR (s2); } - return (DOWNCASE (0, itext_ichar (s1)) - - DOWNCASE (0, itext_ichar (s2))); + return (CANONCASE (0, itext_ichar (s1)) - + CANONCASE (0, itext_ichar (s2))); } /* The only difference between these next two and @@ -1481,8 +1481,8 @@ while (len_from_s1 > 0) { const Ibyte *old_s1 = s1; - int diff = (DOWNCASE (0, itext_ichar (s1)) - - DOWNCASE (0, itext_ichar (s2))); + int diff = (CANONCASE (0, itext_ichar (s1)) - + CANONCASE (0, itext_ichar (s2))); if (diff != 0) return diff; if (!*s1) @@ -1604,8 +1604,8 @@ { const Ibyte *old_s1 = s1; const Ibyte *old_s2 = s2; - int diff = (DOWNCASE (0, itext_ichar (s1)) - - DOWNCASE (0, itext_ichar (s2))); + int diff = (CANONCASE (0, itext_ichar (s1)) - + CANONCASE (0, itext_ichar (s2))); if (diff != 0) return diff; INC_IBYTEPTR (s1); @@ -1631,8 +1631,8 @@ { const Ibyte *old_s1 = s1; const Ibyte *old_s2 = s2; - int diff = (DOWNCASE (0, itext_ichar (s1)) - - DOWNCASE (0, itext_ichar (s2))); + int diff = (CANONCASE (0, itext_ichar (s1)) - + CANONCASE (0, itext_ichar (s2))); if (diff != 0) return diff; INC_IBYTEPTR (s1); @@ -1647,7 +1647,7 @@ } int -lisp_strcasecmp (Lisp_Object s1, Lisp_Object s2) +lisp_strcasecmp_ascii (Lisp_Object s1, Lisp_Object s2) { Ibyte *cm = strcasecmp_charmap; Ibyte *p1 = XSTRING_DATA (s1);
--- a/tests/ChangeLog Sat Jan 30 20:34:23 2010 -0600 +++ b/tests/ChangeLog Mon Feb 01 01:02:40 2010 -0600 @@ -1,3 +1,34 @@ +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. + 2010-01-30 Ben Wing <ben@xemacs.org> * automated/search-tests.el:
--- a/tests/automated/case-tests.el Sat Jan 30 20:34:23 2010 -0600 +++ b/tests/automated/case-tests.el Mon Feb 01 01:02:40 2010 -0600 @@ -29,28 +29,30 @@ ;;; Commentary: -;; Test case-table related functionality. +;; Test case-table related functionality. See test-harness.el for +;; instructions on how to run these tests. ;; NOTE NOTE NOTE: See also: ;; ;; (1) regexp-tests.el, for case-related regexp searching. ;; (2) search-tests.el, for case-related non-regexp searching. - -;; NOTE NOTE NOTE: There is some domain overlap among regexp-tests.el, -;; search-tests.el and case-tests.el. See search-tests.el. -;; - -;; Ben thinks this is unnecessary. See comment in search-tests.el. +;; (3) lisp-tests.el, for case-related comparisons with `equalp'. -;;(defvar pristine-case-table nil -;; "The standard case table, without manipulation from case-tests.el") +;; NOTE NOTE NOTE: There is some domain overlap among case-tests.el, +;; lisp-tests.el, regexp-tests.el, and search-tests.el. The current rule +;; for what goes where is: ;; -;;(setq pristine-case-table (or -;; ;; This is the compiled run; we've retained -;; ;; it from the interpreted run. -;; pristine-case-table -;; ;; This is the interpreted run; set it. -;; (copy-case-table (standard-case-table)))) +;; (1) Anything regexp-related goes in regexp-tests.el, including searches. +;; (2) Non-regexp searches go in search-tests.el. This includes case-folding +;; searches in the situation where the test tests both folding and +;; non-folding behavior. +;; (3) Anything else that involves case-testing but in an ancillary manner +;; goes into whichever primary area it is involved in (e.g. searches for +;; search-tests.el, Lisp primitives in lisp-tests.el). But if it is +;; primarily case-related and happens to involve other areas in an +;; ancillary manner, it goes into case-tests.el. This includes, for +;; example, the Unicode case map torture tests. + (Assert (case-table-p (standard-case-table))) ;; Old case table test. @@ -1442,62 +1444,113 @@ (?\U00010426 ?\U0001044E) ;; DESERET CAPITAL LETTER OI (?\U00010427 ?\U0001044F) ;; DESERET CAPITAL LETTER EW )) - (uni-casetab (loop - with case-table = (make-case-table) - for (uc lc) in uni-mappings - do (put-case-table-pair uc lc case-table) - finally return case-table)) - ;; All lowercase - (lower (with-output-to-string - (loop for (uc lc) in uni-mappings do (princ lc)))) - ;; All uppercase - (upper (with-output-to-string - (loop for (uc lc) in uni-mappings do (princ lc)))) - ;; For each pair, lower followed by upper - (lowerupper (with-output-to-string - (loop for (uc lc) in uni-mappings - do (princ lc) (princ uc)))) - ;; For each pair, upper followed by lower - (upperlower (with-output-to-string - (loop for (uc lc) in uni-mappings - do (princ uc) (princ lc)))) - ) - (with-case-table uni-casetab - (Assert-equalp lower upper) - (Assert-equalp lowerupper upperlower) - (Assert-equal lower (downcase upper)) - (Assert-equal upper (downcase lower)) - (Assert-equal lower (downcase upper)) - (Assert-equal upper (downcase lower)) - (Assert-equal (downcase lower) (downcase (downcase lower))) - (Assert-equal (upcase lowerupper) (upcase upperlower)) - (Assert-equal (downcase lowerupper) (downcase upperlower)) - (with-temp-buffer - (set-case-table uni-casetab) - (loop for (str1 str2) in `((,lower ,upper) - (,lowerupper ,upperlower) - (,upper ,lower) - (,upperlower ,lowerupper)) - do - (erase-buffer) - (Assert= (point-min) 1) - (Assert= (point) 1) - (insert str1) - (let ((point (point)) - (case-fold-search t)) - (Assert= (length str1) (1- point)) - (goto-char (point-min)) - (Assert-eql (search-forward str2 nil t) point))) - (loop for (uc lc) in uni-mappings do - (loop for (ch1 ch2) in `((,uc ,lc) - (,lc ,uc)) + ;; a table to track mappings that overlap with some other mapping + (multi-hash (make-hash-table)) + (uni-casetab + (loop + with case-table = (make-case-table) + for (uc lc) in uni-mappings do + ;; see if there are existing mappings for either char of the new + ;; mapping pair. + (let* ((curucval (get-case-table 'downcase uc case-table)) + (curlcval (get-case-table 'upcase lc case-table)) + (curucval (and (not (eq curucval uc)) curucval)) + (curlcval (and (not (eq curlcval lc)) curlcval)) + ) + ;; if so, flag both the existing and new mapping pair as having + ;; an overlapping mapping. + (when (or curucval curlcval) + (loop for ch in (list curucval curlcval uc lc) do + (puthash ch t multi-hash))) + + ;; finally, make the new mapping. + (put-case-table-pair uc lc case-table)) + finally return case-table))) + (flet ((ismulti (uc lc) + (or (gethash uc multi-hash) (gethash lc multi-hash)))) + (let ( + ;; All lowercase + (lowermulti (with-output-to-string + (loop for (uc lc) in uni-mappings do (princ lc)))) + ;; All uppercase + (uppermulti (with-output-to-string + (loop for (uc lc) in uni-mappings do (princ uc)))) + ;; For each pair, lower followed by upper + (loweruppermulti (with-output-to-string + (loop for (uc lc) in uni-mappings + do (princ lc) (princ uc)))) + ;; For each pair, upper followed by lower + (upperlowermulti (with-output-to-string + (loop for (uc lc) in uni-mappings + do (princ uc) (princ lc)))) + ;; All lowercase, no complex mappings + (lower (with-output-to-string + (loop for (uc lc) in uni-mappings do + (unless (ismulti uc lc) (princ lc))))) + ;; All uppercase, no complex mappings + (upper (with-output-to-string + (loop for (uc lc) in uni-mappings do + (unless (ismulti uc lc) (princ uc))))) + ;; For each pair, lower followed by upper, no complex mappings + (lowerupper (with-output-to-string + (loop for (uc lc) in uni-mappings do + (unless (ismulti uc lc) (princ lc) (princ uc))))) + ;; For each pair, upper followed by lower, no complex mappings + (upperlower (with-output-to-string + (loop for (uc lc) in uni-mappings do + (unless (ismulti uc lc) (princ uc) (princ lc))))) + ) + (with-case-table + uni-casetab + ;; Comparison with `equalp' uses a canonical mapping internally and + ;; so should be able to handle multi-mappings. Just comparing + ;; using downcase and upcase, however, won't necessarily work in + ;; the presence of such mappings -- that's what the internal canon + ;; and eqv tables are for. + (Assert-equalp lowermulti uppermulti) + (Assert-equalp loweruppermulti upperlowermulti) + (Assert-equal lower (downcase upper)) + (Assert-equal upper (upcase lower)) + (Assert-equal (downcase lower) (downcase (downcase lower))) + (Assert-equal (upcase lowerupper) (upcase upperlower)) + (Assert-equal (downcase lowerupper) (downcase upperlower)) + ;; Individually -- we include multi-mappings since we're using + ;; `equalp'. + (loop + for (uc lc) in uni-mappings do + (Assert-equalp uc lc) + (Assert-equalp (string uc) (string lc))) + ) + + ;; Here we include multi-mappings -- searching should be able to + ;; handle it. + (with-temp-buffer + (set-case-table uni-casetab) + (loop for (str1 str2) in `((,lowermulti ,uppermulti) + (,loweruppermulti ,upperlowermulti) + (,uppermulti ,lowermulti) + (,upperlowermulti ,loweruppermulti)) do (erase-buffer) - (insert ?0) - (insert ch1) - (insert ?1) - (goto-char (point-min)) - (Assert-eql (search-forward (char-to-string ch2) nil t) 3 - (format "Case-folded searching doesn't equate %s and %s" - (char-as-unicode-escape ch1) - (char-as-unicode-escape ch2)))))))) + (Assert= (point-min) 1) + (Assert= (point) 1) + (insert str1) + (let ((point (point)) + (case-fold-search t)) + (Assert= (length str1) (1- point)) + (goto-char (point-min)) + (Assert-eql (search-forward str2 nil t) point))) + (loop for (uc lc) in uni-mappings do + (loop for (ch1 ch2) in `((,uc ,lc) + (,lc ,uc)) + do + (erase-buffer) + (insert ?0) + (insert ch1) + (insert ?1) + (goto-char (point-min)) + (Assert-eql (search-forward (char-to-string ch2) nil t) 3 + (format "Case-folded searching doesn't equate %s and %s" + (char-as-unicode-escape ch1) + (char-as-unicode-escape ch2)))))) + )))
--- a/tests/automated/lisp-tests.el Sat Jan 30 20:34:23 2010 -0600 +++ b/tests/automated/lisp-tests.el Mon Feb 01 01:02:40 2010 -0600 @@ -1957,35 +1957,28 @@ (foo-zero 400 (1+ most-positive-fixnum))))) "Checking multiple values are discarded correctly when forced") (Check-Error setting-constant (setq multiple-values-limit 20)) - (Assert - (equal '(-1 1) - (multiple-value-list (floor -3 4))) + (Assert-equal '(-1 1) + (multiple-value-list (floor -3 4)) "Checking #'multiple-value-list gives a sane result") (let ((ey 40000) (bee "this is a string") (cee #s(hash-table size 256 data (969 ?\xF9)))) - (Assert - (equal - (multiple-value-list (values ey bee cee)) - (multiple-value-list (values-list (list ey bee cee)))) + (Assert-equal + (multiple-value-list (values ey bee cee)) + (multiple-value-list (values-list (list ey bee cee))) "Checking that #'values and #'values-list are correctly related") - (Assert - (equal - (multiple-value-list (values-list (list ey bee cee))) - (multiple-value-list (apply #'values (list ey bee cee)))) + (Assert-equal + (multiple-value-list (values-list (list ey bee cee))) + (multiple-value-list (apply #'values (list ey bee cee))) "Checking #'values-list and #'apply with #values are correctly related")) - (Assert - (= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10) + (Assert= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10 "Checking #'multiple-value-call gives reasonable results.") - (Assert - (= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10) + (Assert= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10 "Checking #'multiple-value-call correct when first arg multiple.") - (Assert - (= 1 (length (multiple-value-list (prog1 (floor pi) "hi there")))) + (Assert= 1 (length (multiple-value-list (prog1 (floor pi) "hi there"))) "Checking #'prog1 does not pass back multiple values") - (Assert - (= 2 (length (multiple-value-list - (multiple-value-prog1 (floor pi) "hi there")))) + (Assert= 2 (length (multiple-value-list + (multiple-value-prog1 (floor pi) "hi there"))) "Checking #'multiple-value-prog1 passes back multiple values") (multiple-value-bind (floored remainder this-is-nil) (floor pi 1.0) @@ -2003,75 +1996,59 @@ (Assert-eql 2.0 ey "Checking ey set correctly") (Assert-eql bee (- e 2.0) "Checking bee set correctly") (Assert (null cee) "Checking cee set to nil correctly")) - (Assert - (= 3 (length (multiple-value-list (eval '(values nil t pi))))) + (Assert= 3 (length (multiple-value-list (eval '(values nil t pi)))) "Checking #'eval passes back multiple values") - (Assert - (= 2 (length (multiple-value-list (apply #'floor '(5 3))))) + (Assert= 2 (length (multiple-value-list (apply #'floor '(5 3)))) "Checking #'apply passes back multiple values") - (Assert - (= 2 (length (multiple-value-list (funcall #'floor 5 3)))) + (Assert= 2 (length (multiple-value-list (funcall #'floor 5 3))) "Checking #'funcall passes back multiple values") - (Assert - (equal '(1 2) (multiple-value-list - (multiple-value-call #'floor (values 5 3)))) + (Assert-equal '(1 2) (multiple-value-list + (multiple-value-call #'floor (values 5 3))) "Checking #'multiple-value-call passes back multiple values correctly") - (Assert - (= 1 (length (multiple-value-list - (and (multiple-value-function-returning-nil) t)))) + (Assert= 1 (length (multiple-value-list + (and (multiple-value-function-returning-nil) t))) "Checking multiple values from non-trailing forms discarded by #'and") - (Assert - (= 5 (length (multiple-value-list - (and t (multiple-value-function-returning-nil))))) + (Assert= 5 (length (multiple-value-list + (and t (multiple-value-function-returning-nil)))) "Checking multiple values from final forms not discarded by #'and") - (Assert - (= 1 (length (multiple-value-list - (or (multiple-value-function-returning-t) t)))) + (Assert= 1 (length (multiple-value-list + (or (multiple-value-function-returning-t) t))) "Checking multiple values from non-trailing forms discarded by #'and") - (Assert - (= 5 (length (multiple-value-list - (or nil (multiple-value-function-returning-t))))) + (Assert= 5 (length (multiple-value-list + (or nil (multiple-value-function-returning-t)))) "Checking multiple values from final forms not discarded by #'and") - (Assert - (= 1 (length (multiple-value-list - (cond ((multiple-value-function-returning-t)))))) + (Assert= 1 (length (multiple-value-list + (cond ((multiple-value-function-returning-t))))) "Checking cond doesn't pass back multiple values in tests.") - (Assert - (equal (list nil pi e radians-to-degrees degrees-to-radians) + (Assert-equal (list nil pi e radians-to-degrees degrees-to-radians) (multiple-value-list - (cond (t (multiple-value-function-returning-nil))))) + (cond (t (multiple-value-function-returning-nil)))) "Checking cond passes back multiple values in clauses.") - (Assert - (= 1 (length (multiple-value-list - (prog1 (multiple-value-function-returning-nil))))) + (Assert= 1 (length (multiple-value-list + (prog1 (multiple-value-function-returning-nil)))) "Checking prog1 discards multiple values correctly.") - (Assert - (= 5 (length (multiple-value-list + (Assert= 5 (length (multiple-value-list (multiple-value-prog1 - (multiple-value-function-returning-nil))))) + (multiple-value-function-returning-nil)))) "Checking multiple-value-prog1 passes back multiple values correctly.") - (Assert - (equal (list t pi e degrees-to-radians radians-to-degrees) + (Assert-equal (list t pi e degrees-to-radians radians-to-degrees) (multiple-value-list - (catch 'VoN61Lo4Y (function-throwing-multiple-values))))) - (Assert - (equal (list t pi e degrees-to-radians radians-to-degrees) + (catch 'VoN61Lo4Y (function-throwing-multiple-values)))) + (Assert-equal (list t pi e degrees-to-radians radians-to-degrees) (multiple-value-list (loop for eye in `(a b c d ,e f g ,nil ,pi) do (when (null eye) - (return (multiple-value-function-returning-t)))))) + (return (multiple-value-function-returning-t))))) "Checking #'loop passes back multiple values correctly.") (Assert (null (or)) "Checking #'or behaves correctly with zero arguments.") - (Assert - (eq t (and)) + (Assert-eq t (and) "Checking #'and behaves correctly with zero arguments.") - (Assert - (= (* 3.0 (- pi 3.0)) + (Assert= (* 3.0 (- pi 3.0)) (letf (((values three one-four-one-five-nine) (floor pi))) - (* three one-four-one-five-nine))) + (* three one-four-one-five-nine)) "checking letf handles #'values in a basic sense")) ;; #'equalp tests. @@ -2079,66 +2056,105 @@ (eacute-character ?\u00E9) (Eacute-character ?\u00c9) (+base-chars+ (loop - with res = (make-string 96 ?\x20) - for int-char from #x20 to #x7f - for char being each element in-ref res - do (setf char (int-to-char int-char)) - finally return res))) + with res = (make-string 96 ?\x20) + for int-char from #x20 to #x7f + for char being each element in-ref res + do (setf char (int-to-char int-char)) + finally return res))) + (let ((equal-lists + '((111111111111111111111111111111111111111111111111111 + 111111111111111111111111111111111111111111111111111.0) + (0 0.0 0.000 -0 -0.0 -0.000 #b0 0/5 -0/5) + (21845 #b101010101010101 #x5555) + (1.5 1.500000000000000000000000000000000000000000000000000000000 + 3/2) + (-55 -110/2) + ;; Can't use this, these values aren't `='. + ;;(-12345678901234567890123457890123457890123457890123457890123457890 + ;; -12345678901234567890123457890123457890123457890123457890123457890.0) + ))) + (loop for li in equal-lists do + (loop for (x . tail) on li do + (loop for y in tail do + (Assert-equalp x y) + (Assert-equalp y x))))) + + (let ((diff-list + `(0 1 2 3 1000 5000000000 5555555555555555555555555555555555555 + -1 -2 -3 -1000 -5000000000 -5555555555555555555555555555555555555 + 1/2 1/3 2/3 8/2 355/113 (/ 3/2 0.2) (/ 3/2 0.7) + 55555555555555555555555555555555555555555/2718281828459045 + 0.111111111111111111111111111111111111111111111111111111111111111 + 1e+300 1e+301 -1e+300 -1e+301))) + (loop for (x . tail) on diff-list do + (loop for y in tail do + (Assert-not-equalp x y) + (Assert-not-equalp y x)))) + (Assert-equalp "hi there" "Hi There" - "checking equalp isn't case-sensitive") + "checking equalp isn't case-sensitive") (Assert-equalp 99 99.0 - "checking equalp compares numerical values of different types") + "checking equalp compares numerical values of different types") (Assert (null (equalp 99 ?c)) "checking equalp does not convert characters to numbers") ;; Fixed in Hg d0ea57eb3de4. (Assert (null (equalp "hi there" [hi there])) "checking equalp doesn't error with string and non-string") - (Assert-eq t (equalp "ABCDEEFGH\u00CDJ" string-variable) - "checking #'equalp is case-insensitive with an upcased constant") - (Assert-eq t (equalp "abcdeefgh\xedj" string-variable) - "checking #'equalp is case-insensitive with a downcased constant") - (Assert-eq t (equalp string-variable string-variable) - "checking #'equalp works when handed the same string twice") - (Assert-eq t (equalp string-variable "aBcDeeFgH\u00Edj") - "check #'equalp is case-insensitive with a variable-cased constant") - (Assert-eq t (equalp "" (bit-vector)) - "check empty string and empty bit-vector are #'equalp.") - (Assert-eq t (equalp (string) (bit-vector)) - "check empty string and empty bit-vector are #'equalp, no constants") - (Assert-eq t (equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e)) - "check string and vector with same contents #'equalp") - (Assert-eq t (equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) - (vector ?h ?i ?\ ?t ?h ?e ?r ?e)) - "check string and vector with same contents #'equalp, no constants") - (Assert-eq t (equalp [?h ?i ?\ ?t ?h ?e ?r ?e] - (string ?h ?i ?\ ?t ?h ?e ?r ?e)) - "check string and vector with same contents #'equalp, vector constant") - (Assert-eq t (equalp [0 1.0 0.0 0 1] - (bit-vector 0 1 0 0 1)) - "check vector and bit-vector with same contents #'equalp,\ + (Assert-equalp "ABCDEEFGH\u00CDJ" string-variable + "checking #'equalp is case-insensitive with an upcased constant") + (Assert-equalp "abcdeefgh\xedj" string-variable + "checking #'equalp is case-insensitive with a downcased constant") + (Assert-equalp string-variable string-variable + "checking #'equalp works when handed the same string twice") + (Assert-equalp string-variable "aBcDeeFgH\u00Edj" + "check #'equalp is case-insensitive with a variable-cased constant") + (Assert-equalp "" (bit-vector) + "check empty string and empty bit-vector are #'equalp.") + (Assert-equalp (string) (bit-vector) + "check empty string and empty bit-vector are #'equalp, no constants") + (Assert-equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e) + "check string and vector with same contents #'equalp") + (Assert-equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) + (vector ?h ?i ?\ ?t ?h ?e ?r ?e) + "check string and vector with same contents #'equalp, no constants") + (Assert-equalp [?h ?i ?\ ?t ?h ?e ?r ?e] + (string ?h ?i ?\ ?t ?h ?e ?r ?e) + "check string and vector with same contents #'equalp, vector constant") + (Assert-equalp [0 1.0 0.0 0 1] + (bit-vector 0 1 0 0 1) + "check vector and bit-vector with same contents #'equalp,\ + vector constant") + (Assert-not-equalp [0 2 0.0 0 1] + (bit-vector 0 1 0 0 1) + "check vector and bit-vector with different contents not #'equalp,\ vector constant") - (Assert-eq t (equalp #*01001 - (vector 0 1.0 0.0 0 1)) - "check vector and bit-vector with same contents #'equalp,\ + (Assert-equalp #*01001 + (vector 0 1.0 0.0 0 1) + "check vector and bit-vector with same contents #'equalp,\ bit-vector constant") - (Assert-eq t (equalp ?\u00E9 Eacute-character) - "checking characters are case-insensitive, one constant") - (Assert-eq nil (equalp ?\u00E9 (aref (format "%c" ?a) 0)) - "checking distinct characters are not equalp, one constant") - (Assert-eq t (equalp t (and)) - "checking symbols are correctly #'equalp") - (Assert-eq nil (equalp t (or nil '#:t)) - "checking distinct symbols with the same name are not #'equalp") - (Assert-eq t (equalp #s(char-table type generic data (?\u0080 "hi-there")) - (let ((aragh (make-char-table 'generic))) - (put-char-table ?\u0080 "hi-there" aragh) - aragh)) - "checking #'equalp succeeds correctly, char-tables") - (Assert-eq nil (equalp #s(char-table type generic data (?\u0080 "hi-there")) - (let ((aragh (make-char-table 'generic))) - (put-char-table ?\u0080 "HI-THERE" aragh) - aragh)) - "checking #'equalp fails correctly, char-tables")) + (Assert-equalp ?\u00E9 Eacute-character + "checking characters are case-insensitive, one constant") + (Assert-not-equalp ?\u00E9 (aref (format "%c" ?a) 0) + "checking distinct characters are not equalp, one constant") + (Assert-equalp t (and) + "checking symbols are correctly #'equalp") + (Assert-not-equalp t (or nil '#:t) + "checking distinct symbols with the same name are not #'equalp") + (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) + (let ((aragh (make-char-table 'generic))) + (put-char-table ?\u0080 "hi-there" aragh) + aragh) + "checking #'equalp succeeds correctly, char-tables") + (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) + (let ((aragh (make-char-table 'generic))) + (put-char-table ?\u0080 "HI-THERE" aragh) + aragh) + "checking #'equalp succeeds correctly, char-tables") + (Assert-not-equalp #s(char-table type generic data (?\u0080 "hi-there")) + (let ((aragh (make-char-table 'generic))) + (put-char-table ?\u0080 "hi there" aragh) + aragh) + "checking #'equalp fails correctly, char-tables")) ;; There are more tests available for equalp here: ;; @@ -2199,10 +2215,8 @@ (rassoc* (1- most-negative-fixnum) assoc*-list) (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql) "checking #'rassoc* correct if #'eql not explicitly specified") - (Assert-eq - (eql (1+most-positive-fixnum) (1+ most-positive-fixnum)) - t - "checking #'eql handles a bignum literal properly.") + (Assert-eql (1+most-positive-fixnum) (1+ most-positive-fixnum) + "checking #'eql handles a bignum literal properly.") (Assert-eq (member* (1+most-positive-fixnum) member*-list) (member* (1+ most-positive-fixnum) member*-list :test #'equal)
--- a/tests/automated/regexp-tests.el Sat Jan 30 20:34:23 2010 -0600 +++ b/tests/automated/regexp-tests.el Mon Feb 01 01:02:40 2010 -0600 @@ -30,9 +30,8 @@ ;; Test regular expressions. -;; NOTE NOTE NOTE: There is some domain overlap among regexp-tests.el, -;; search-tests.el and case-tests.el. See search-tests.el. -;; +;; NOTE NOTE NOTE: There is some domain overlap among case-tests.el, +;; regexp-tests.el and search-tests.el. See case-tests.el. (Check-Error-Message error "Trailing backslash" (string-match "\\" "a"))
--- a/tests/automated/search-tests.el Sat Jan 30 20:34:23 2010 -0600 +++ b/tests/automated/search-tests.el Mon Feb 01 01:02:40 2010 -0600 @@ -38,17 +38,8 @@ ;; (1) regexp-tests.el, for regexp searching. ;; (2) case-tests.el, for some case-related searches. -;; NOTE NOTE NOTE: There is some domain overlap among regexp-tests.el, -;; search-tests.el and case-tests.el. The current rule for what goes where -;; is: -;; -;; (1) Anything regexp-related goes in regexp-tests.el, including searches. -;; (2) Non-regexp searches go in search-tests.el. This includes case-folding -;; searches in the situation where the test tests both folding and -;; non-folding behavior. -;; (3) If it tests specifically case-folding search behavior, it may go in -;; case-tets.el, especially if it is testing something non-search-related -;; at the same time (e.g. the Unicode case map torture tests). +;; NOTE NOTE NOTE: There is some domain overlap among case-tests.el, +;; regexp-tests.el and search-tests.el. See case-tests.el. (with-temp-buffer (insert "Test Buffer") @@ -194,9 +185,6 @@ "checks that the algorithm chosen by #'search-forward is relatively sane" (let ((debug-xemacs-searches 1)) (with-temp-buffer - ;;#### Ben thinks this is unnecessary. with-temp-buffer creates - ;;a new buffer, which automatically inherits the standard case table. - ;;(set-case-table pristine-case-table) (insert "\n\nDer beruhmte deutsche Fleiss\n\n") (goto-char (point-min)) (Assert (search-forward "Fleiss"))
--- a/tests/automated/test-harness.el Sat Jan 30 20:34:23 2010 -0600 +++ b/tests/automated/test-harness.el Mon Feb 01 01:02:40 2010 -0600 @@ -115,6 +115,12 @@ (length "byte-compiler-tests.el:")) ; use the longest file name "Format for \"No tests\" lines printed after a file is run.") +(defconst test-harness-aborted-summary-template + (format "%%-%ds %%%dd tests completed (aborted)." + (length "byte-compiler-tests.el:") ; use the longest file name + 5) + "Format for summary lines printed after a test run on a file was aborted.") + ;;;###autoload (defun test-emacs-test-file (filename) "Test a file of Lisp code named FILENAME. @@ -338,7 +344,7 @@ DESCRIPTION describes the assertion; by default, the unevalated comparison expressions are given. FAILING-CASE and DESCRIPTION are useful when Assert is used in a loop." - (let* ((assertion `(,test ,testval ,expected)) + (let* ((assertion `(not (,test ,testval ,expected))) (failmsg `(format "%S shouldn't be `%s' to %S but is" ,testval ',test ,expected)) (failmsg2 (if failing-case `(concat @@ -347,71 +353,52 @@ failmsg))) `(Assert ,assertion ,failmsg2 ,description))) - (defmacro Assert-eq (testval expected &optional failing-case description) - "Test passes if TESTVAL is 'eq' to EXPECTED. -Optional FAILING-CASE describes the particular failure; any value given -here will be concatenated with a phrase describing the expected and actual -values of the comparison. Optional DESCRIPTION describes the assertion; by -default, the unevalated comparison expressions are given. FAILING-CASE and -DESCRIPTION are useful when Assert is used in a loop." + ;; Specific versions of `Assert-test'. These are just convenience + ;; functions, functioning identically to `Assert-test', and duplicating + ;; the doc string for each would be too annoying. + (defmacro Assert-eq (testval expected &optional failing-case + description) `(Assert-test eq ,testval ,expected ,failing-case ,description)) - - (defmacro Assert-eql (testval expected &optional failing-case description) - "Test passes if TESTVAL is 'eql' to EXPECTED. -Optional FAILING-CASE describes the particular failure; any value given -here will be concatenated with a phrase describing the expected and actual -values of the comparison. Optional DESCRIPTION describes the assertion; by -default, the unevalated comparison expressions are given. FAILING-CASE and -DESCRIPTION are useful when Assert is used in a loop." + (defmacro Assert-eql (testval expected &optional failing-case + description) `(Assert-test eql ,testval ,expected ,failing-case ,description)) - (defmacro Assert-equal (testval expected &optional failing-case description) - "Test passes if TESTVAL is 'equal' to EXPECTED. -Optional FAILING-CASE describes the particular failure; any value given -here will be concatenated with a phrase describing the expected and actual -values of the comparison. Optional DESCRIPTION describes the assertion; by -default, the unevalated comparison expressions are given. FAILING-CASE and -DESCRIPTION are useful when Assert is used in a loop." `(Assert-test equal ,testval ,expected ,failing-case ,description)) - (defmacro Assert-equalp (testval expected &optional failing-case description) - "Test passes if TESTVAL is 'equalp' to EXPECTED. -Optional FAILING-CASE describes the particular failure; any value given -here will be concatenated with a phrase describing the expected and actual -values of the comparison. Optional DESCRIPTION describes the assertion; by -default, the unevalated comparison expressions are given. FAILING-CASE and -DESCRIPTION are useful when Assert is used in a loop." `(Assert-test equalp ,testval ,expected ,failing-case ,description)) - (defmacro Assert-string= (testval expected &optional failing-case description) - "Test passes if TESTVAL is 'string=' to EXPECTED. -Optional FAILING-CASE describes the particular failure; any value given -here will be concatenated with a phrase describing the expected and actual -values of the comparison. Optional DESCRIPTION describes the assertion; by -default, the unevalated comparison expressions are given. FAILING-CASE and -DESCRIPTION are useful when Assert is used in a loop." `(Assert-test string= ,testval ,expected ,failing-case ,description)) + (defmacro Assert= (testval expected &optional failing-case + description) + `(Assert-test = ,testval ,expected ,failing-case ,description)) + (defmacro Assert<= (testval expected &optional failing-case + description) + `(Assert-test <= ,testval ,expected ,failing-case ,description)) - (defmacro Assert= (testval expected &optional failing-case description) - "Test passes if TESTVAL is '=' to EXPECTED. -Optional FAILING-CASE describes the particular failure; any value given -here will be concatenated with a phrase describing the expected and actual -values of the comparison. Optional DESCRIPTION describes the assertion; by -default, the unevalated comparison expressions are given. FAILING-CASE and -DESCRIPTION are useful when Assert is used in a loop." - `(Assert-test = ,testval ,expected ,failing-case ,description)) - - (defmacro Assert<= (testval expected &optional failing-case description) - "Test passes if TESTVAL is '<=' to EXPECTED. -Optional FAILING-CASE describes the particular failure; any value given -here will be concatenated with a phrase describing the expected and actual -values of the comparison. Optional DESCRIPTION describes the assertion; by -default, the unevalated comparison expressions are given. FAILING-CASE and -DESCRIPTION are useful when Assert is used in a loop." - `(Assert-test <= ,testval ,expected ,failing-case ,description)) + ;; Specific versions of `Assert-test-not'. These are just convenience + ;; functions, functioning identically to `Assert-test-not', and + ;; duplicating the doc string for each would be too annoying. + (defmacro Assert-not-eq (testval expected &optional failing-case + description) + `(Assert-test-not eq ,testval ,expected ,failing-case ,description)) + (defmacro Assert-not-eql (testval expected &optional failing-case + description) + `(Assert-test-not eql ,testval ,expected ,failing-case ,description)) + (defmacro Assert-not-equal (testval expected &optional failing-case + description) + `(Assert-test-not equal ,testval ,expected ,failing-case ,description)) + (defmacro Assert-not-equalp (testval expected &optional failing-case + description) + `(Assert-test-not equalp ,testval ,expected ,failing-case ,description)) + (defmacro Assert-not-string= (testval expected &optional failing-case + description) + `(Assert-test-not string= ,testval ,expected ,failing-case ,description)) + (defmacro Assert-not= (testval expected &optional failing-case + description) + `(Assert-test-not = ,testval ,expected ,failing-case ,description)) (defmacro Check-Error (expected-error &rest body) (let ((quoted-body (if (= 1 (length body)) @@ -517,7 +504,7 @@ (princ (format "Unexpected error %S while executing interpreted code\n" error-info)) (message "Unexpected error %S while executing interpreted code." error-info) - (message "Test suite execution aborted." error-info) + (message "Test suite execution aborted.") )) (princ "\nTesting Compiled Lisp\n\n") (let (code @@ -538,7 +525,7 @@ (princ (format "Unexpected error %S while executing byte-compiled code\n" error-info)) (message "Unexpected error %S while executing byte-compiled code." error-info) - (message "Test suite execution aborted." error-info) + (message "Test suite execution aborted.") ))) (princ (format "\nSUMMARY for %s:\n" filename)) (princ (format "\t%5d passes\n" passes)) @@ -555,12 +542,16 @@ other-failures)) (basename (file-name-nondirectory filename)) (summary-msg - (if (> total 0) - (format test-harness-file-summary-template - (concat basename ":") - passes total (/ (* 100 passes) total)) - (format test-harness-null-summary-template - (concat basename ":")))) + (cond ((> unexpected-test-file-failures 0) + (format test-harness-aborted-summary-template + (concat basename ":") total)) + ((> total 0) + (format test-harness-file-summary-template + (concat basename ":") + passes total (/ (* 100 passes) total))) + (t + (format test-harness-null-summary-template + (concat basename ":"))))) (reasons "")) (maphash (lambda (key value) (setq reasons @@ -700,14 +691,19 @@ (basename (file-name-nondirectory (first head))) (nsucc (second head)) (ntest (third head))) - (if (> ntest 0) - (message test-harness-file-summary-template - (concat basename ":") - nsucc - ntest - (/ (* 100 nsucc) ntest)) - (message test-harness-null-summary-template - (concat basename ":"))) + (cond ((member (first head) unexpected-test-suite-failure-files) + (message test-harness-aborted-summary-template + (concat basename ":") + ntest)) + ((> ntest 0) + (message test-harness-file-summary-template + (concat basename ":") + nsucc + ntest + (/ (* 100 nsucc) ntest))) + (t + (message test-harness-null-summary-template + (concat basename ":")))) (setq results (cdr results))))) (when (> unexpected-test-suite-failures 0) (message "\n***** There %s %d unexpected test suite %s in %s:"