Mercurial > hg > xemacs-beta

comparison src/elhash.c @ 241:f955c73f5258 r20-5b19

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b19
author cvs
date Mon, 13 Aug 2007 10:16:16 +0200
parents 557eaa0339bf
children f220cc83d72e
comparison
equal deleted inserted replaced
240:835e739f3c17 241:f955c73f5258
49 static Lisp_Object Vall_weak_hashtables; 49 static Lisp_Object Vall_weak_hashtables;
50 50
51 static Lisp_Object mark_hashtable (Lisp_Object, void (*) (Lisp_Object)); 51 static Lisp_Object mark_hashtable (Lisp_Object, void (*) (Lisp_Object));
52 static void print_hashtable (Lisp_Object, Lisp_Object, int); 52 static void print_hashtable (Lisp_Object, Lisp_Object, int);
53 static int hashtable_equal (Lisp_Object t1, Lisp_Object t2, int depth); 53 static int hashtable_equal (Lisp_Object t1, Lisp_Object t2, int depth);
54 static unsigned long hashtable_hash (Lisp_Object obj, int depth);
54 DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable, 55 DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable,
55 mark_hashtable, print_hashtable, 0, 56 mark_hashtable, print_hashtable, 0,
56 hashtable_equal, 0, struct hashtable); 57 hashtable_equal, hashtable_hash,
58 struct hashtable);
57 59
58 static Lisp_Object 60 static Lisp_Object
59 mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object)) 61 mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object))
60 { 62 {
61 struct hashtable *table = XHASHTABLE (obj); 63 struct hashtable *table = XHASHTABLE (obj);
76 /* Equality of hashtables. Two hashtables are equal when they are of 78 /* Equality of hashtables. Two hashtables are equal when they are of
77 the same type and test function, they have the same number of 79 the same type and test function, they have the same number of
78 elements, and for each key in hashtable, the values are `equal'. 80 elements, and for each key in hashtable, the values are `equal'.
79 81
80 This is similar to Common Lisp `equalp' of hashtables, with the 82 This is similar to Common Lisp `equalp' of hashtables, with the
81 difference that CL requires the keys to be compared using the 83 difference that CL requires the keys to be compared with the test
82 `:test' function, which we don't do. Doing that would require 84 function, which we don't do. Doing that would require consing, and
83 consing, and consing is bad idea in `equal'. Anyway, our method 85 consing is bad idea in `equal'. Anyway, our method should provide
84 should provide the same result -- if the keys are not equal 86 the same result -- if the keys are not equal according to test
85 according to `:test', then Fgethash() in hashtable_equal_mapper() 87 function, then Fgethash() in hashtable_equal_mapper() will fail. */
86 will fail. */
87 struct hashtable_equal_closure 88 struct hashtable_equal_closure
88 { 89 {
89 int depth; 90 int depth;
90 int equal_so_far; 91 int equal;
91 Lisp_Object other_table; 92 Lisp_Object other_table;
92 }; 93 };
93 94
94 static void 95 static int
95 hashtable_equal_mapper (void *key, void *contents, void *arg) 96 hashtable_equal_mapper (void *key, void *contents, void *arg)
96 { 97 {
97 struct hashtable_equal_closure *closure = 98 struct hashtable_equal_closure *closure =
98 (struct hashtable_equal_closure *)arg; 99 (struct hashtable_equal_closure *)arg;
99 Lisp_Object keytem, valuetem; 100 Lisp_Object keytem, valuetem;
100 101 Lisp_Object value_in_other;
101 /* It would be beautiful if maphash() allowed us to bail out when C 102
102 function returns non-zero, a la map_extents() et al. #### Make 103 CVOID_TO_LISP (keytem, key);
103 it so! */ 104 CVOID_TO_LISP (valuetem, contents);
104 if (closure->equal_so_far) 105 /* Look up the key in the other hashtable, and compare the values. */
105 { 106 value_in_other = Fgethash (keytem, closure->other_table, Qunbound);
106 Lisp_Object value_in_other; 107 if (UNBOUNDP (value_in_other)
107 CVOID_TO_LISP (keytem, key); 108 || !internal_equal (valuetem, value_in_other, closure->depth))
108 CVOID_TO_LISP (valuetem, contents); 109 {
109 /* Look up the key in the other hashtable, and compare the 110 /* Give up. */
110 values. */ 111 closure->equal = 0;
111 value_in_other = Fgethash (keytem, closure->other_table, Qunbound); 112 return 1;
112 if (UNBOUNDP (value_in_other) 113 }
113 || !internal_equal (valuetem, value_in_other, closure->depth)) 114 return 0;
114 closure->equal_so_far = 0;
115 /* return 1; */
116 }
117 /* return 0; */
118 } 115 }
119 116
120 static int 117 static int
121 hashtable_equal (Lisp_Object t1, Lisp_Object t2, int depth) 118 hashtable_equal (Lisp_Object t1, Lisp_Object t2, int depth)
122 { 119 {
131 || (table1->type != table2->type) 128 || (table1->type != table2->type)
132 || (table1->fullness != table2->fullness)) 129 || (table1->fullness != table2->fullness))
133 return 0; 130 return 0;
134 131
135 closure.depth = depth + 1; 132 closure.depth = depth + 1;
136 closure.equal_so_far = 1; 133 closure.equal = 1;
137 closure.other_table = t2; 134 closure.other_table = t2;
138 elisp_maphash (hashtable_equal_mapper, t1, &closure); 135 elisp_maphash (hashtable_equal_mapper, t1, &closure);
139 return closure.equal_so_far; 136 return closure.equal;
137 }
138
139 /* Hashtable hash function. This hashes 5 key-value pairs. For EQ
140 hashtables, keys are used as the hash value themselves, whereas
141 values are hashed with internal_hash(). For EQUAL hashtables, both
142 keys and values are hashed properly. EQL tables are handled as
143 necessary. All of this should make the hash function compatible
144 with hashtable_equal(). The elements hashed are the first five
145 mapped over by maphash(). */
146
147 struct hashtable_hash_closure
148 {
149 struct hashtable *table;
150 int depth;
151 unsigned long hash;
152 int count;
153 };
154
155 /* Needed for tests. */
156 static int lisp_object_eql_equal (CONST void *x1, CONST void *x2);
157 static int lisp_object_equal_equal (CONST void *x1, CONST void *x2);
158
159 static int
160 hashtable_hash_mapper (void *key, void *contents, void *arg)
161 {
162 struct hashtable_hash_closure *closure =
163 (struct hashtable_hash_closure *)arg;
164 Lisp_Object valuetem, keytem;
165 unsigned long keyhash;
166
167 CVOID_TO_LISP (keytem, key);
168 CVOID_TO_LISP (valuetem, contents);
169
170 if (!closure->table->test_function)
171 /* For eq, use key itself as hash. */
172 keyhash = LISP_HASH (keytem);
173 else if (closure->table->test_function == lisp_object_eql_equal)
174 /* The same as eq, unless the key is float. */
175 keyhash = (FLOATP (keytem)
176 ? internal_hash (keytem, closure->depth) : LISP_HASH (keytem));
177 else
178 /* equal: hash the key properly. */
179 keyhash = internal_hash (keytem, closure->depth);
180
181 closure->hash = HASH3 (closure->hash, keyhash,
182 internal_hash (valuetem, closure->depth));
183 return (++closure->count > 5) ? 1 : 0;
184 }
185
186 static unsigned long
187 hashtable_hash (Lisp_Object obj, int depth)
188 {
189 struct hashtable_hash_closure closure;
190
191 closure.table = XHASHTABLE (obj);
192 closure.depth = depth + 1;
193 closure.hash = 0;
194 closure.count = 0;
195
196 elisp_maphash (hashtable_hash_mapper, obj, &closure);
197 return closure.hash;
140 } 198 }
141 199
142 /* Printing hashtables. 200 /* Printing hashtables.
143 201
144 This is non-trivial, because we use a readable structure-style 202 This is non-trivial, because we use a readable structure-style
155 instance: 213 instance:
156 214
157 #<hashtable size 2/13 data (key1 value1 key2 value2) 0x874d> 215 #<hashtable size 2/13 data (key1 value1 key2 value2) 0x874d>
158 216
159 The data is truncated to four pairs, and the rest is shown with 217 The data is truncated to four pairs, and the rest is shown with
160 `...'. The actual printer is non-consing. */ 218 `...'. This printer does not cons. */
161 219
162 struct print_hashtable_data_closure 220 struct print_hashtable_data_closure
163 { 221 {
164 EMACS_INT count; /* Used to implement truncation for 222 EMACS_INT count; /* Used to implement truncation for
165 non-readable printing, as well as 223 non-readable printing, as well as
166 to avoid the unnecessary space at 224 to avoid the unnecessary space at
167 the beginning. */ 225 the beginning. */
168 Lisp_Object printcharfun; 226 Lisp_Object printcharfun;
169 }; 227 };
170 228
171 static void 229 static int
172 print_hashtable_data_mapper (void *key, void *contents, void *arg) 230 print_hashtable_data_mapper (void *key, void *contents, void *arg)
173 { 231 {
174 Lisp_Object keytem, valuetem; 232 Lisp_Object keytem, valuetem;
175 struct print_hashtable_data_closure *closure = 233 struct print_hashtable_data_closure *closure =
176 (struct print_hashtable_data_closure *)arg; 234 (struct print_hashtable_data_closure *)arg;
186 print_internal (keytem, closure->printcharfun, 1); 244 print_internal (keytem, closure->printcharfun, 1);
187 write_c_string (" ", closure->printcharfun); 245 write_c_string (" ", closure->printcharfun);
188 print_internal (valuetem, closure->printcharfun, 1); 246 print_internal (valuetem, closure->printcharfun, 1);
189 } 247 }
190 ++closure->count; 248 ++closure->count;
249 return 0;
191 } 250 }
192 251
193 /* Print the data of the hashtable. This maps through a Lisp 252 /* Print the data of the hashtable. This maps through a Lisp
194 hashtable and prints key/value pairs using PRINTCHARFUN. */ 253 hashtable and prints key/value pairs using PRINTCHARFUN. */
195 static void 254 static void
202 write_c_string (" data (", printcharfun); 261 write_c_string (" data (", printcharfun);
203 elisp_maphash (print_hashtable_data_mapper, hashtable, &closure); 262 elisp_maphash (print_hashtable_data_mapper, hashtable, &closure);
204 write_c_string ((!print_readably && closure.count > 4) ? " ...)" : ")", 263 write_c_string ((!print_readably && closure.count > 4) ? " ...)" : ")",
205 printcharfun); 264 printcharfun);
206 } 265 }
207
208 /* Needed for tests. */
209 static int lisp_object_eql_equal (CONST void *x1, CONST void *x2);
210 static int lisp_object_equal_equal (CONST void *x1, CONST void *x2);
211 266
212 static void 267 static void
213 print_hashtable (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 268 print_hashtable (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
214 { 269 {
215 struct hashtable *table = XHASHTABLE (obj); 270 struct hashtable *table = XHASHTABLE (obj);
224 table->type == HASHTABLE_KEY_WEAK ? "key-weak" : 279 table->type == HASHTABLE_KEY_WEAK ? "key-weak" :
225 table->type == HASHTABLE_VALUE_WEAK ? "value-weak" : 280 table->type == HASHTABLE_VALUE_WEAK ? "value-weak" :
226 "you-d-better-not-see-this")); 281 "you-d-better-not-see-this"));
227 write_c_string (buf, printcharfun); 282 write_c_string (buf, printcharfun);
228 } 283 }
229 /* These checks are way kludgy... */ 284 /* These checks have a kludgy look to them, but they are safe. Due
230 if (table->test_function == NULL) 285 to nature of hashing, you cannot use arbitrary test functions
286 anyway. */
287 if (!table->test_function)
231 write_c_string (" test eq", printcharfun); 288 write_c_string (" test eq", printcharfun);
232 else if (table->test_function == lisp_object_equal_equal) 289 else if (table->test_function == lisp_object_equal_equal)
233 write_c_string (" test equal", printcharfun); 290 write_c_string (" test equal", printcharfun);
234 else if (table->test_function == lisp_object_eql_equal) 291 else if (table->test_function == lisp_object_eql_equal)
235 DO_NOTHING; 292 DO_NOTHING;
519 causes efficiency problems, these can be resurrected. --ben */ 576 causes efficiency problems, these can be resurrected. --ben */
520 /* equality and hash functions for Lisp strings */ 577 /* equality and hash functions for Lisp strings */
521 int 578 int
522 lisp_string_equal (CONST void *x1, CONST void *x2) 579 lisp_string_equal (CONST void *x1, CONST void *x2)
523 { 580 {
581 /* This is wrong anyway. You can't use strcmp() on Lisp strings,
582 because they can contain zero characters. */
524 Lisp_Object str1, str2; 583 Lisp_Object str1, str2;
525 CVOID_TO_LISP (str1, x1); 584 CVOID_TO_LISP (str1, x1);
526 CVOID_TO_LISP (str2, x2); 585 CVOID_TO_LISP (str2, x2);
527 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2)); 586 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2));
528 } 587 }
801 return; 860 return;
802 } 861 }
803 signal_error (Qinvalid_function, list1 (function)); 862 signal_error (Qinvalid_function, list1 (function));
804 } 863 }
805 864
806 static void 865 static int
807 lisp_maphash_function (CONST void *void_key, 866 lisp_maphash_function (CONST void *void_key,
808 void *void_val, 867 void *void_val,
809 void *void_fn) 868 void *void_fn)
810 { 869 {
811 /* This function can GC */ 870 /* This function can GC */
812 Lisp_Object key, val, fn; 871 Lisp_Object key, val, fn;
813 CVOID_TO_LISP (key, void_key); 872 CVOID_TO_LISP (key, void_key);
814 VOID_TO_LISP (val, void_val); 873 VOID_TO_LISP (val, void_val);
815 VOID_TO_LISP (fn, void_fn); 874 VOID_TO_LISP (fn, void_fn);
816 call2 (fn, key, val); 875 call2 (fn, key, val);
876 return 0;
817 } 877 }
818 878
819 879
820 DEFUN ("maphash", Fmaphash, 2, 2, 0, /* 880 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
821 Map FUNCTION over entries in HASHTABLE, calling it with two args, 881 Map FUNCTION over entries in HASHTABLE, calling it with two args,
838 898
839 /* This function is for mapping a *C* function over the elements of a 899 /* This function is for mapping a *C* function over the elements of a
840 lisp hashtable. 900 lisp hashtable.
841 */ 901 */
842 void 902 void
843 elisp_maphash (maphash_function function, Lisp_Object hashtable, void *closure) 903 elisp_maphash (void (*function) (CONST void *key, void *contents,
904 void *extra_arg),
905 Lisp_Object hashtable, void *closure)
844 { 906 {
845 struct _C_hashtable htbl; 907 struct _C_hashtable htbl;
846 908
847 if (!gc_in_progress) CHECK_HASHTABLE (hashtable); 909 if (!gc_in_progress) CHECK_HASHTABLE (hashtable);
848 ht_copy_to_c (XHASHTABLE (hashtable), &htbl); 910 ht_copy_to_c (XHASHTABLE (hashtable), &htbl);
849 maphash (function, &htbl, closure); 911 maphash (function, &htbl, closure);
850 } 912 }
851 913
852 void 914 void
853 elisp_map_remhash (remhash_predicate function, Lisp_Object hashtable, 915 elisp_map_remhash (int (*function) (CONST void *key,
916 CONST void *contents,
917 void *extra_arg),
918 Lisp_Object hashtable,
854 void *closure) 919 void *closure)
855 { 920 {
856 struct _C_hashtable htbl; 921 struct _C_hashtable htbl;
857 922
858 if (!gc_in_progress) CHECK_HASHTABLE (hashtable); 923 if (!gc_in_progress) CHECK_HASHTABLE (hashtable);
931 void (*markobj) (Lisp_Object); 996 void (*markobj) (Lisp_Object);
932 enum hashtable_type type; 997 enum hashtable_type type;
933 int did_mark; 998 int did_mark;
934 }; 999 };
935 1000
936 static void 1001 static int
937 marking_mapper (CONST void *key, void *contents, void *closure) 1002 marking_mapper (CONST void *key, void *contents, void *closure)
938 { 1003 {
939 Lisp_Object keytem, valuetem; 1004 Lisp_Object keytem, valuetem;
940 struct marking_closure *fmh = 1005 struct marking_closure *fmh =
941 (struct marking_closure *) closure; 1006 (struct marking_closure *) closure;
999 1064
1000 default: 1065 default:
1001 abort (); /* Huh? */ 1066 abort (); /* Huh? */
1002 } 1067 }
1003 1068
1004 return; 1069 return 0;
1005 } 1070 }
1006 1071
1007 int 1072 int
1008 finish_marking_weak_hashtables (int (*obj_marked_p) (Lisp_Object), 1073 finish_marking_weak_hashtables (int (*obj_marked_p) (Lisp_Object),
1009 void (*markobj) (Lisp_Object)) 1074 void (*markobj) (Lisp_Object))
1187 } 1252 }
1188 1253
1189 return LISP_HASH (obj); 1254 return LISP_HASH (obj);
1190 } 1255 }
1191 1256
1257 #if 0
1258 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1259 Hash value of OBJECT. For debugging.
1260 The value is returned as (HIGH . LOW).
1261 */
1262 (object))
1263 {
1264 /* This function is pretty 32bit-centric. */
1265 unsigned long hash = internal_hash (object, 0);
1266 return Fcons (hash >> 16, hash & 0xffff);
1267 }
1268 #endif
1269
1192 1270
1193 /************************************************************************/ 1271 /************************************************************************/
1194 /* initialization */ 1272 /* initialization */
1195 /************************************************************************/ 1273 /************************************************************************/
1196 1274
1207 DEFSUBR (Fmaphash); 1285 DEFSUBR (Fmaphash);
1208 DEFSUBR (Fhashtable_fullness); 1286 DEFSUBR (Fhashtable_fullness);
1209 DEFSUBR (Fmake_weak_hashtable); 1287 DEFSUBR (Fmake_weak_hashtable);
1210 DEFSUBR (Fmake_key_weak_hashtable); 1288 DEFSUBR (Fmake_key_weak_hashtable);
1211 DEFSUBR (Fmake_value_weak_hashtable); 1289 DEFSUBR (Fmake_value_weak_hashtable);
1290 #if 0
1291 DEFSUBR (Finternal_hash_value);
1292 #endif
1212 defsymbol (&Qhashtablep, "hashtablep"); 1293 defsymbol (&Qhashtablep, "hashtablep");
1213 defsymbol (&Qhashtable, "hashtable"); 1294 defsymbol (&Qhashtable, "hashtable");
1214 defsymbol (&Qweak, "weak"); 1295 defsymbol (&Qweak, "weak");
1215 defsymbol (&Qkey_weak, "key-weak"); 1296 defsymbol (&Qkey_weak, "key-weak");
1216 defsymbol (&Qvalue_weak, "value-weak"); 1297 defsymbol (&Qvalue_weak, "value-weak");