Mercurial > hg > xemacs-beta
annotate tests/glyph-test.el @ 5191:71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
tests/ChangeLog addition:
2010-04-05 Aidan Kehoe <kehoea@parhasard.net>
* automated/hash-table-tests.el:
Test the new built-in #'equalp hash table test. Test
#'define-hash-table-test.
* automated/lisp-tests.el:
When asserting that two objects are #'equalp, also assert that
their #'equalp-hash is identical.
man/ChangeLog addition:
2010-04-03 Aidan Kehoe <kehoea@parhasard.net>
* lispref/hash-tables.texi (Introduction to Hash Tables):
Document that we now support #'equalp as a hash table test by
default, and mention #'define-hash-table-test.
(Working With Hash Tables): Document #'define-hash-table-test.
src/ChangeLog addition:
2010-04-05 Aidan Kehoe <kehoea@parhasard.net>
* elhash.h:
* elhash.c (struct Hash_Table_Test, lisp_object_eql_equal)
(lisp_object_eql_hash, lisp_object_equal_equal)
(lisp_object_equal_hash, lisp_object_equalp_hash)
(lisp_object_equalp_equal, lisp_object_general_hash)
(lisp_object_general_equal, Feq_hash, Feql_hash, Fequal_hash)
(Fequalp_hash, define_hash_table_test, Fdefine_hash_table_test)
(init_elhash_once_early, mark_hash_table_tests, string_equalp_hash):
* glyphs.c (vars_of_glyphs):
Add a new hash table test in C, #'equalp.
Make it possible to specify new hash table tests with functions
define_hash_table_test, #'define-hash-table-test.
Use define_hash_table_test() in glyphs.c.
Expose the hash functions (besides that used for #'equal) to Lisp,
for people writing functions to be used with #'define-hash-table-test.
Call define_hash_table_test() very early in temacs, to create the
built-in hash table tests.
* ui-gtk.c (emacs_gtk_boxed_hash):
* specifier.h (struct specifier_methods):
* specifier.c (specifier_hash):
* rangetab.c (range_table_entry_hash, range_table_hash):
* number.c (bignum_hash, ratio_hash, bigfloat_hash):
* marker.c (marker_hash):
* lrecord.h (struct lrecord_implementation):
* keymap.c (keymap_hash):
* gui.c (gui_item_id_hash, gui_item_hash):
* glyphs.c (image_instance_hash, glyph_hash):
* glyphs-x.c (x_image_instance_hash):
* glyphs-msw.c (mswindows_image_instance_hash):
* glyphs-gtk.c (gtk_image_instance_hash):
* frame-msw.c (mswindows_set_title_from_ibyte):
* fontcolor.c (color_instance_hash, font_instance_hash):
* fontcolor-x.c (x_color_instance_hash):
* fontcolor-tty.c (tty_color_instance_hash):
* fontcolor-msw.c (mswindows_color_instance_hash):
* fontcolor-gtk.c (gtk_color_instance_hash):
* fns.c (bit_vector_hash):
* floatfns.c (float_hash):
* faces.c (face_hash):
* extents.c (extent_hash):
* events.c (event_hash):
* data.c (weak_list_hash, weak_box_hash):
* chartab.c (char_table_entry_hash, char_table_hash):
* bytecode.c (compiled_function_hash):
* alloc.c (vector_hash):
Change the various object hash methods to take a new EQUALP
parameter, hashing appropriately for #'equalp if it is true.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 05 Apr 2010 13:03:35 +0100 |
| parents | 8a653fbe5c27 |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
|
4781
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
1 ;;; Copyright (C) 1998 Andy Piper |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
2 |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
3 ;;; This file is part of XEmacs. |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
4 |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
5 ;;; XEmacs is free software; you can redistribute it and/or modify it |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
6 ;;; under the terms of the GNU General Public License as published by |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
7 ;;; the Free Software Foundation; either version 2, or (at your |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
8 ;;; option) any later version. |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
9 |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
10 ;;; XEmacs is distributed in the hope that it will be useful, but |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
11 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
13 ;;; General Public License for more details. |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
14 |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
15 ;;; You should have received a copy of the GNU General Public License |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
16 ;;; along with XEmacs; see the file COPYING. If not, write to the Free |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
17 ;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
18 ;;; Boston, MA 02110-1301, USA. |
|
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
19 |
| 428 | 20 (set-extent-begin-glyph |
| 21 (make-extent (point) (point)) | |
| 442 | 22 (setq im (make-glyph [xbm :file "xemacsicon.xbm"]))) |
| 428 | 23 |
| 438 | 24 (set-extent-begin-glyph |
| 25 (make-extent (point) (point)) | |
| 26 (make-glyph [string :data "xemacs"])) | |
| 27 | |
| 428 | 28 (defun foo () |
| 29 (interactive) | |
| 30 (setq ok-select (not ok-select))) | |
| 31 | |
| 32 (defun fee () (interactive) (message "hello")) | |
| 33 | |
| 34 ;; button in a group | |
| 35 (setq ok-select nil) | |
| 36 (set-extent-begin-glyph | |
| 37 (make-extent (point) (point)) | |
| 442 | 38 (make-glyph |
| 39 (setq radio-button1 | |
| 40 [button :face widget | |
| 41 :descriptor ["ok1" (setq ok-select t) | |
| 428 | 42 :style radio :selected ok-select]]))) |
| 43 ;; button in a group | |
| 44 (set-extent-begin-glyph | |
| 45 (make-extent (point) (point)) | |
| 442 | 46 (make-glyph |
| 47 (setq radio-button2 | |
| 48 [button :descriptor ["ok2" (setq ok-select nil) :style radio | |
| 428 | 49 :selected (not ok-select)]]))) |
| 50 ;; toggle button | |
| 51 (set-extent-begin-glyph | |
| 52 (make-extent (point) (point)) | |
| 53 (setq tbutton | |
| 442 | 54 (make-glyph [button :descriptor ["ok3" (setq ok-select nil) |
| 428 | 55 :style toggle |
| 56 :selected (not ok-select)]]))) | |
| 57 (set-extent-begin-glyph | |
| 58 (make-extent (point) (point)) | |
| 442 | 59 (make-glyph |
| 60 (setq toggle-button | |
| 61 [button :descriptor ["ok4" :style toggle | |
| 62 :callback | |
| 63 (setq ok-select (not ok-select)) | |
| 64 :selected ok-select]]))) | |
| 428 | 65 |
| 66 ;; normal pushbutton | |
| 67 (set-extent-begin-glyph | |
| 68 (make-extent (point) (point)) | |
| 69 (setq push-button | |
| 70 (make-glyph [button :width 10 :height 2 | |
| 71 :face modeline-mousable | |
| 442 | 72 :descriptor "ok" :callback foo |
| 428 | 73 :selected t]))) |
| 74 ;; tree view | |
| 75 (set-extent-begin-glyph | |
| 76 (make-extent (point) (point)) | |
| 77 (setq tree (make-glyph | |
| 78 [tree-view :width 10 | |
| 79 :descriptor "My Tree" | |
| 442 | 80 :items (["One" foo] |
| 81 (["Two" foo] | |
| 82 ["Four" foo] | |
| 83 "Six") | |
| 84 "Three")]))) | |
| 428 | 85 |
| 86 ;; tab control | |
| 87 (set-extent-begin-glyph | |
| 88 (make-extent (point) (point)) | |
| 89 (setq tab (make-glyph | |
| 90 [tab-control :descriptor "My Tab" | |
| 91 :face highlight | |
| 438 | 92 :orientation right |
| 442 | 93 :items (["One" foo :selected t] |
| 94 ["Two" fee :selected nil] | |
| 95 ["Three" foo :selected nil])]))) | |
| 428 | 96 |
| 97 ;; progress gauge | |
| 98 (set-extent-begin-glyph | |
| 99 (make-extent (point) (point)) | |
| 100 (setq pgauge (make-glyph | |
| 442 | 101 [progress-gauge :width 10 :height 2 :value 0 |
| 428 | 102 :descriptor "ok"]))) |
| 103 ;; progress the progress ... | |
| 104 (let ((x 0)) | |
| 105 (while (<= x 100) | |
| 442 | 106 (set-glyph-image pgauge `[progress-gauge :width 10 :height 2 |
| 107 :descriptor "ok" :value ,x]) | |
| 428 | 108 (setq x (+ x 5)) |
| 109 (sit-for 0.1))) | |
| 110 | |
| 111 ;; progress gauge in the modeline | |
| 112 (setq global-mode-string | |
| 113 (cons (make-extent nil nil) | |
| 114 (setq pg (make-glyph | |
| 115 [progress-gauge :width 5 :pixel-height 16 | |
| 116 :descriptor "ok"])))) | |
| 117 ;; progress the progress ... | |
| 118 (let ((x 0)) | |
| 119 (while (<= x 100) | |
| 442 | 120 (set-glyph-image pg |
| 121 `[progress-gauge :width 5 :pixel-height 16 | |
| 122 :descriptor "ok" :value ,x]) | |
| 428 | 123 (setq x (+ x 5)) |
| 462 | 124 (redisplay-frame) |
| 428 | 125 (sit-for 0.1))) |
| 126 | |
| 127 (set-extent-begin-glyph | |
| 128 (make-extent (point) (point)) | |
| 129 (make-glyph | |
| 130 [button :face modeline-mousable | |
| 131 :descriptor "ok" :callback foo | |
| 132 :image [xpm :file "../etc/xemacs-icon.xpm"]])) | |
| 133 | |
| 134 ;; normal pushbutton | |
| 135 (set-extent-begin-glyph | |
| 136 (make-extent (point) (point)) | |
| 438 | 137 (setq pbutton |
| 138 (make-glyph [button :descriptor ["A Big Button" foo ]]))) | |
| 428 | 139 |
| 140 ;; edit box | |
| 141 (set-extent-begin-glyph | |
| 142 (make-extent (point) (point)) | |
| 442 | 143 (make-glyph (setq edit-field [edit-field :pixel-width 50 :pixel-height 30 |
| 428 | 144 :face bold-italic |
| 145 :descriptor ["Hello"]]))) | |
| 146 ;; combo box | |
| 147 (set-extent-begin-glyph | |
| 148 (make-extent (point) (point)) | |
| 442 | 149 (make-glyph (setq combo-box |
| 150 [combo-box :width 10 :descriptor ["Hello"] | |
| 151 :items ("One" "Two" "Three")]))) | |
| 428 | 152 |
| 153 ;; label | |
| 154 (set-extent-begin-glyph | |
| 155 (make-extent (point) (point)) | |
| 442 | 156 (make-glyph (setq label [label :pixel-width 150 :descriptor "Hello"]))) |
| 428 | 157 |
| 158 ;; string | |
| 159 (set-extent-begin-glyph | |
| 160 (make-extent (point) (point)) | |
| 442 | 161 (make-glyph |
| 162 (setq str | |
| 163 [string :data "Hello There"]))) | |
| 428 | 164 |
| 165 ;; scrollbar | |
| 166 ;(set-extent-begin-glyph | |
| 167 ; (make-extent (point) (point)) | |
| 168 ; (make-glyph [scrollbar :width 50 :height 20 :descriptor ["Hello"]])) | |
| 169 | |
| 170 ;; generic subwindow | |
| 171 (setq sw (make-glyph [subwindow :pixel-width 50 :pixel-height 70])) | |
| 172 (set-extent-begin-glyph (make-extent (point) (point)) sw) | |
| 173 | |
| 174 ;; layout | |
| 175 (setq layout | |
| 176 (make-glyph | |
| 442 | 177 `[layout :descriptor "The Layout" |
| 178 :orientation vertical | |
| 179 :justify left | |
| 180 :border [string :data "Hello There Mrs"] | |
| 181 :items ([layout :orientation horizontal | |
| 182 :items (,radio-button1 ,radio-button2)] | |
| 183 ,edit-field ,toggle-button ,label ,str)])) | |
| 184 ;(set-glyph-face layout 'gui-element) | |
| 428 | 185 (set-extent-begin-glyph |
| 186 (make-extent (point) (point)) layout) | |
| 434 | 187 |
| 442 | 188 ;; another test layout |
| 189 (set-extent-begin-glyph | |
| 190 (make-extent (point) (point)) | |
| 191 (setq layout-2 | |
| 192 (make-glyph `[layout :descriptor "The Layout" | |
| 193 :orientation vertical | |
| 194 :items ([progress-gauge :value 0 :width 10 :height 2 | |
| 195 :descriptor "ok"])]))) | |
| 196 | |
| 197 (set-glyph-image layout-2 `[layout :descriptor "The Layout" | |
| 198 :orientation vertical | |
| 199 :items ([progress-gauge :value 4 :width 10 :height 2 | |
| 200 :descriptor "ok"])]) | |
| 434 | 201 (setq test-toggle-widget nil) |
| 202 | |
| 203 (defun test-toggle (widget) | |
| 204 (set-extent-begin-glyph | |
| 205 (make-extent (point) (point)) | |
| 206 (make-glyph (vector 'button | |
| 207 :descriptor "ok" | |
| 208 :style 'toggle | |
| 209 :selected `(funcall test-toggle-value | |
| 210 ,widget) | |
| 211 :callback `(funcall test-toggle-action | |
| 212 ,widget))))) | |
| 213 | |
| 214 (defun test-toggle-action (widget &optional event) | |
| 215 (if widget | |
| 216 (message "Widget is t") | |
| 217 (message "Widget is nil"))) | |
| 218 | |
| 219 (defun test-toggle-value (widget) | |
| 220 (setq widget (not widget)) | |
| 221 (not widget)) |