Mercurial > hg > xemacs-beta
annotate tests/automated/byte-compiler-tests.el @ 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 | 189fb67ca31a |
| children | 0f66906b6e37 |
| rev | line source |
|---|---|
| 428 | 1 ;; Copyright (C) 1998 Free Software Foundation, Inc. |
| 2 | |
| 3 ;; Author: Martin Buchholz <martin@xemacs.org> | |
| 4 ;; Maintainer: Martin Buchholz <martin@xemacs.org> | |
| 5 ;; Created: 1998 | |
| 6 ;; Keywords: tests | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
| 10 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 11 ;; under the terms of the GNU General Public License as published by | |
| 12 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 13 ;; any later version. | |
| 14 | |
| 15 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 18 ;; General Public License for more details. | |
| 19 | |
| 20 ;; You should have received a copy of the GNU General Public License | |
| 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 23 ;; 02111-1307, USA. | |
| 24 | |
| 25 ;;; Synched up with: Not in FSF. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 | |
| 29 ;;; Test byte-compiler functionality | |
| 30 ;;; See test-harness.el | |
| 31 | |
| 32 (condition-case err | |
| 33 (require 'test-harness) | |
| 34 (file-error | |
| 35 (when (and (boundp 'load-file-name) (stringp load-file-name)) | |
| 36 (push (file-name-directory load-file-name) load-path) | |
| 37 (require 'test-harness)))) | |
| 38 | |
| 39 (require 'bytecomp) | |
| 40 | |
| 41 ;; test constant symbol warnings | |
| 42 (defmacro check-byte-compiler-message (message-regexp &rest body) | |
| 43 `(Check-Message ,message-regexp (byte-compile '(lambda () ,@body)))) | |
| 44 | |
| 45 (check-byte-compiler-message "Attempt to set non-symbol" (setq 1 1)) | |
| 46 (check-byte-compiler-message "Attempt to set constant symbol" (setq t 1)) | |
| 47 (check-byte-compiler-message "Attempt to set constant symbol" (setq nil 1)) | |
| 48 (check-byte-compiler-message "^$" (defconst :foo 1)) | |
| 49 | |
| 50 (check-byte-compiler-message "Attempt to let-bind non-symbol" (let ((1 'x)) 1)) | |
| 51 (check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((t 'x)) (foo))) | |
| 52 (check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((nil 'x)) (foo))) | |
| 53 (check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((:foo 'x)) (foo))) | |
| 54 | |
| 55 | |
| 56 (check-byte-compiler-message "bound but not referenced" (let ((foo 'x)) 1)) | |
| 57 (Assert (not (boundp 'free-variable))) | |
| 58 (Assert (boundp 'byte-compile-warnings)) | |
| 59 (check-byte-compiler-message "assignment to free variable" (setq free-variable 1)) | |
| 60 (check-byte-compiler-message "reference to free variable" (car free-variable)) | |
| 61 (check-byte-compiler-message "called with 2 args, but requires 1" (car 'x 'y)) | |
| 62 | |
| 63 (check-byte-compiler-message "^$" (setq :foo 1)) | |
| 64 (let ((fun '(lambda () (setq :foo 1)))) | |
| 65 (fset 'test-byte-compiler-fun fun)) | |
| 66 (Check-Error setting-constant (test-byte-compiler-fun)) | |
| 67 (byte-compile 'test-byte-compiler-fun) | |
| 68 (Check-Error setting-constant (test-byte-compiler-fun)) | |
| 69 | |
| 70 (eval-when-compile (defvar setq-test-foo nil) (defvar setq-test-bar nil)) | |
| 71 (progn | |
| 72 (check-byte-compiler-message "set called with 1 arg, but requires 2" (setq setq-test-foo)) | |
| 73 (check-byte-compiler-message "set called with 1 arg, but requires 2" (setq setq-test-foo 1 setq-test-bar)) | |
| 74 (check-byte-compiler-message "set-default called with 1 arg, but requires 2" (setq-default setq-test-foo)) | |
| 75 (check-byte-compiler-message "set-default called with 1 arg, but requires 2" (setq-default setq-test-foo 1 setq-test-bar)) | |
| 76 ) | |
| 77 | |
| 78 ;;----------------------------------------------------- | |
| 79 ;; let, let* | |
| 80 ;;----------------------------------------------------- | |
| 81 | |
| 82 ;; Test interpreted and compiled lisp separately here | |
| 83 (check-byte-compiler-message "malformed let binding" (let ((x 1 2)) 3)) | |
| 84 (check-byte-compiler-message "malformed let binding" (let* ((x 1 2)) 3)) | |
| 85 | |
| 86 (Check-Error-Message | |
| 87 error "`let' bindings can have only one value-form" | |
| 88 (eval '(let ((x 1 2)) 3))) | |
| 89 | |
| 90 (Check-Error-Message | |
| 91 error "`let' bindings can have only one value-form" | |
| 92 (eval '(let* ((x 1 2)) 3))) | |
| 93 | |
| 434 | 94 (defmacro before-and-after-compile-equal (&rest form) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
452
diff
changeset
|
95 `(Assert-equal (funcall (quote (lambda () ,@form))) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
452
diff
changeset
|
96 (funcall (byte-compile (quote (lambda () ,@form)))))) |
| 434 | 97 |
| 98 (defvar simplyamarker (point-min-marker)) | |
| 99 | |
| 100 ;; The byte optimizer must be careful with +/- with a single argument. | |
| 101 | |
| 102 (before-and-after-compile-equal (+)) | |
| 103 (before-and-after-compile-equal (+ 2 2)) | |
| 104 (before-and-after-compile-equal (+ 2 1)) | |
| 105 (before-and-after-compile-equal (+ 1 2)) | |
| 106 ;; (+ 1) is OK. but (+1) signals an error. | |
| 107 (before-and-after-compile-equal (+ 1)) | |
| 108 (before-and-after-compile-equal (+ 3)) | |
| 109 (before-and-after-compile-equal (+ simplyamarker 1)) | |
| 110 ;; The optimization (+ m) --> m is invalid when m is a marker. | |
| 111 ;; Currently the following test fails - controversial. | |
| 112 ;; (before-and-after-compile-equal (+ simplyamarker)) | |
| 113 ;; Same tests for minus. | |
| 114 (before-and-after-compile-equal (- 2 2)) | |
| 115 (before-and-after-compile-equal (- 2 1)) | |
| 116 (before-and-after-compile-equal (- 1 2)) | |
| 117 (before-and-after-compile-equal (- 1)) | |
| 118 (before-and-after-compile-equal (- 3)) | |
| 119 (before-and-after-compile-equal (- simplyamarker 1)) | |
| 120 (before-and-after-compile-equal (- simplyamarker)) | |
| 444 | 121 |
| 452 | 122 (before-and-after-compile-equal (let ((z 1)) (or (setq z 42)) z)) |
| 123 | |
| 444 | 124 ;; byte-after-unbind-ops |
| 125 | |
| 126 ;; byte-constant | |
| 127 ;; byte-dup | |
| 128 | |
| 129 ;; byte-symbolp | |
| 130 (before-and-after-compile-equal | |
| 131 (let ((x 's)) | |
| 132 (unwind-protect | |
| 133 (symbolp x) | |
| 134 (setq x 1)))) | |
| 135 | |
| 136 ;; byte-consp | |
| 137 (before-and-after-compile-equal | |
| 138 (let ((x '(a b))) | |
| 139 (unwind-protect | |
| 140 (consp x) | |
| 141 (setq x 1)))) | |
| 142 | |
| 143 ;; byte-stringp | |
| 144 (before-and-after-compile-equal | |
| 145 (let ((x "a")) | |
| 146 (unwind-protect | |
| 147 (stringp x) | |
| 148 (setq x 1)))) | |
| 149 | |
| 150 ;; byte-listp | |
| 151 (before-and-after-compile-equal | |
| 152 (let ((x '(a b c))) | |
| 153 (unwind-protect | |
| 154 (listp x) | |
| 155 (setq x 1)))) | |
| 156 | |
| 157 ;; byte-numberp | |
| 158 (before-and-after-compile-equal | |
| 159 (let ((x 1)) | |
| 160 (unwind-protect | |
| 161 (numberp x) | |
| 162 (setq x nil)))) | |
| 163 | |
| 164 ;; byte-integerp | |
| 165 (before-and-after-compile-equal | |
| 166 (let ((x 1)) | |
| 167 (unwind-protect | |
| 168 (integerp x) | |
| 169 (setq x nil)))) | |
| 170 | |
| 171 ;; byte-equal | |
| 172 (before-and-after-compile-equal | |
| 173 (let ((x 'a) | |
| 174 (y 'a)) | |
| 175 (unwind-protect | |
| 176 (eq x y) | |
| 177 (setq x 'c)))) | |
| 178 | |
| 179 ;; byte-not | |
| 180 (before-and-after-compile-equal | |
| 181 (let (x) | |
| 182 (unwind-protect | |
| 183 (not x) | |
| 184 (setq x t)))) | |
| 185 | |
| 186 ;; byte-cons | |
| 187 (before-and-after-compile-equal | |
| 188 (equal '(1 . 2) | |
| 189 (let ((x 1) | |
| 190 (y 2)) | |
| 191 (unwind-protect | |
| 192 (cons x y) | |
| 193 (setq x t))))) | |
| 194 | |
| 195 ;; byte-list1 | |
| 196 (before-and-after-compile-equal | |
| 197 (equal '(1) | |
| 198 (let ((x 1)) | |
| 199 (unwind-protect | |
| 200 (list x) | |
| 201 (setq x t))))) | |
| 202 | |
| 203 ;; byte-list2 | |
| 204 (before-and-after-compile-equal | |
| 205 (equal '(1 . 2) | |
| 206 (let ((x 1) | |
| 207 (y 2)) | |
| 208 (unwind-protect | |
| 209 (list x y) | |
| 210 (setq x t))))) | |
| 211 | |
| 212 ;; byte-interactive-p | |
| 213 | |
| 214 ;; byte-equal | |
| 215 (before-and-after-compile-equal | |
| 216 (let (x y) | |
| 217 (setq x '(1 . 2)) | |
| 218 (setq y '(1 . 2)) | |
| 219 (unwind-protect | |
| 220 (equal x y) | |
| 221 (setq y '(1 . 3))))) |