Mercurial > hg > xemacs-beta

comparison src/elhash.c @ 5125:b5df3737028a ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge
author Ben Wing <ben@xemacs.org>
date Wed, 24 Feb 2010 01:58:04 -0600
parents 623d57b7fbe8 16112448d484
children a9c41067dd88
comparison
equal deleted inserted replaced
5124:623d57b7fbe8 5125:b5df3737028a
90 static Lisp_Object Qrehash_size, Qrehash_threshold; 90 static Lisp_Object Qrehash_size, Qrehash_threshold;
91 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold; 91 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold;
92 92
93 /* obsolete as of 19990901 in xemacs-21.2 */ 93 /* obsolete as of 19990901 in xemacs-21.2 */
94 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qkey_or_value_weak; 94 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qkey_or_value_weak;
95 static Lisp_Object Qnon_weak, Q_type; 95 static Lisp_Object Qnon_weak, Q_type, Q_data;
96 96
97 struct Lisp_Hash_Table 97 struct Lisp_Hash_Table
98 { 98 {
99 LISP_OBJECT_HEADER header; 99 LISP_OBJECT_HEADER header;
100 Elemcount size; 100 Elemcount size;
182 } 182 }
183 return primes [high]; 183 return primes [high];
184 } 184 }
185 185
186 186
187 #if 0 /* I don't think these are needed any more.
188 If using the general lisp_object_equal_*() functions
189 causes efficiency problems, these can be resurrected. --ben */
190 /* equality and hash functions for Lisp strings */
191 int
192 lisp_string_equal (Lisp_Object str1, Lisp_Object str2)
193 {
194 /* This is wrong anyway. You can't use strcmp() on Lisp strings,
195 because they can contain zero characters. */
196 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2));
197 }
198
199 static Hashcode
200 lisp_string_hash (Lisp_Object obj)
201 {
202 return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str));
203 }
204
205 #endif /* 0 */
206 187
207 static int 188 static int
208 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2) 189 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2)
209 { 190 {
210 return EQ (obj1, obj2) || (FLOATP (obj1) && internal_equal (obj1, obj2, 0)); 191 return EQ (obj1, obj2) ||
192 (NON_FIXNUM_NUMBER_P (obj1) && internal_equal (obj1, obj2, 0));
211 } 193 }
212 194
213 static Hashcode 195 static Hashcode
214 lisp_object_eql_hash (Lisp_Object obj) 196 lisp_object_eql_hash (Lisp_Object obj)
215 { 197 {
216 return FLOATP (obj) ? internal_hash (obj, 0) : LISP_HASH (obj); 198 return NON_FIXNUM_NUMBER_P (obj) ? internal_hash (obj, 0) : LISP_HASH (obj);
217 } 199 }
218 200
219 static int 201 static int
220 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2) 202 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2)
221 { 203 {
260 function, which we don't do. Doing that would require consing, and 242 function, which we don't do. Doing that would require consing, and
261 consing is a bad idea in `equal'. Anyway, our method should provide 243 consing is a bad idea in `equal'. Anyway, our method should provide
262 the same result -- if the keys are not equal according to the test 244 the same result -- if the keys are not equal according to the test
263 function, then Fgethash() in hash_table_equal_mapper() will fail. */ 245 function, then Fgethash() in hash_table_equal_mapper() will fail. */
264 static int 246 static int
265 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth) 247 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth,
248 int foldcase)
266 { 249 {
267 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1); 250 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1);
268 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2); 251 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2);
269 htentry *e, *sentinel; 252 htentry *e, *sentinel;
270 253
279 if (!HTENTRY_CLEAR_P (e)) 262 if (!HTENTRY_CLEAR_P (e))
280 /* Look up the key in the other hash table, and compare the values. */ 263 /* Look up the key in the other hash table, and compare the values. */
281 { 264 {
282 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound); 265 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound);
283 if (UNBOUNDP (value_in_other) || 266 if (UNBOUNDP (value_in_other) ||
284 !internal_equal (e->value, value_in_other, depth)) 267 !internal_equal_0 (e->value, value_in_other, depth, foldcase))
285 return 0; /* Give up */ 268 return 0; /* Give up */
286 } 269 }
287 270
288 return 1; 271 return 1;
289 } 272 }
302 285
303 This is non-trivial, because we use a readable structure-style 286 This is non-trivial, because we use a readable structure-style
304 syntax for hash tables. This means that a typical hash table will be 287 syntax for hash tables. This means that a typical hash table will be
305 readably printed in the form of: 288 readably printed in the form of:
306 289
307 #s(hash-table size 2 data (key1 value1 key2 value2)) 290 #s(hash-table :size 2 :data (key1 value1 key2 value2))
308 291
309 The supported hash table structure keywords and their values are: 292 The supported hash table structure keywords and their values are:
310 `test' (eql (or nil), eq or equal) 293 `:test' (eql (or nil), eq or equal)
311 `size' (a natnum or nil) 294 `:size' (a natnum or nil)
312 `rehash-size' (a float) 295 `:rehash-size' (a float)
313 `rehash-threshold' (a float) 296 `:rehash-threshold' (a float)
314 `weakness' (nil, key, value, key-and-value, or key-or-value) 297 `:weakness' (nil, key, value, key-and-value, or key-or-value)
315 `data' (a list) 298 `:data' (a list)
316 299
317 If `print-readably' is nil, then a simpler syntax is used, for example 300 If `print-readably' is nil, then a simpler syntax is used, for example
318 301
319 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d> 302 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
320 303
328 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun) 311 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun)
329 { 312 {
330 int count = 0; 313 int count = 0;
331 htentry *e, *sentinel; 314 htentry *e, *sentinel;
332 315
333 write_c_string (printcharfun, " data ("); 316 write_ascstring (printcharfun, " :data (");
334 317
335 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) 318 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
336 if (!HTENTRY_CLEAR_P (e)) 319 if (!HTENTRY_CLEAR_P (e))
337 { 320 {
338 if (count > 0) 321 if (count > 0)
339 write_c_string (printcharfun, " "); 322 write_ascstring (printcharfun, " ");
340 if (!print_readably && count > 3) 323 if (!print_readably && count > 3)
341 { 324 {
342 write_c_string (printcharfun, "..."); 325 write_ascstring (printcharfun, "...");
343 break; 326 break;
344 } 327 }
345 print_internal (e->key, printcharfun, 1); 328 print_internal (e->key, printcharfun, 1);
346 write_fmt_string_lisp (printcharfun, " %S", 1, e->value); 329 write_fmt_string_lisp (printcharfun, " %S", 1, e->value);
347 count++; 330 count++;
348 } 331 }
349 332
350 write_c_string (printcharfun, ")"); 333 write_ascstring (printcharfun, ")");
351 } 334 }
352 335
353 static void 336 static void
354 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, 337 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun,
355 int UNUSED (escapeflag)) 338 int UNUSED (escapeflag))
356 { 339 {
357 Lisp_Hash_Table *ht = XHASH_TABLE (obj); 340 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
358 Ascbyte pigbuf[350]; 341 Ascbyte pigbuf[350];
359 342
360 write_c_string (printcharfun, 343 write_ascstring (printcharfun,
361 print_readably ? "#s(hash-table" : "#<hash-table"); 344 print_readably ? "#s(hash-table" : "#<hash-table");
362 345
363 /* These checks have a kludgy look to them, but they are safe. 346 /* These checks have a kludgy look to them, but they are safe.
364 Due to nature of hashing, you cannot use arbitrary 347 Due to nature of hashing, you cannot use arbitrary
365 test functions anyway. */ 348 test functions anyway. */
366 if (!ht->test_function) 349 if (!ht->test_function)
367 write_c_string (printcharfun, " test eq"); 350 write_ascstring (printcharfun, " :test eq");
368 else if (ht->test_function == lisp_object_equal_equal) 351 else if (ht->test_function == lisp_object_equal_equal)
369 write_c_string (printcharfun, " test equal"); 352 write_ascstring (printcharfun, " :test equal");
370 else if (ht->test_function == lisp_object_eql_equal) 353 else if (ht->test_function == lisp_object_eql_equal)
371 DO_NOTHING; 354 DO_NOTHING;
372 else 355 else
373 ABORT (); 356 ABORT ();
374 357
375 if (ht->count || !print_readably) 358 if (ht->count || !print_readably)
376 { 359 {
377 if (print_readably) 360 if (print_readably)
378 write_fmt_string (printcharfun, " size %ld", (long) ht->count); 361 write_fmt_string (printcharfun, " :size %ld", (long) ht->count);
379 else 362 else
380 write_fmt_string (printcharfun, " size %ld/%ld", (long) ht->count, 363 write_fmt_string (printcharfun, " :size %ld/%ld", (long) ht->count,
381 (long) ht->size); 364 (long) ht->size);
382 } 365 }
383 366
384 if (ht->weakness != HASH_TABLE_NON_WEAK) 367 if (ht->weakness != HASH_TABLE_NON_WEAK)
385 { 368 {
386 write_fmt_string 369 write_fmt_string
387 (printcharfun, " weakness %s", 370 (printcharfun, " :weakness %s",
388 (ht->weakness == HASH_TABLE_WEAK ? "key-and-value" : 371 (ht->weakness == HASH_TABLE_WEAK ? "key-and-value" :
389 ht->weakness == HASH_TABLE_KEY_WEAK ? "key" : 372 ht->weakness == HASH_TABLE_KEY_WEAK ? "key" :
390 ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" : 373 ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" :
391 ht->weakness == HASH_TABLE_KEY_VALUE_WEAK ? "key-or-value" : 374 ht->weakness == HASH_TABLE_KEY_VALUE_WEAK ? "key-or-value" :
392 "you-d-better-not-see-this")); 375 "you-d-better-not-see-this"));
393 } 376 }
394 377
395 if (ht->rehash_size != HASH_TABLE_DEFAULT_REHASH_SIZE) 378 if (ht->rehash_size != HASH_TABLE_DEFAULT_REHASH_SIZE)
396 { 379 {
397 float_to_string (pigbuf, ht->rehash_size); 380 float_to_string (pigbuf, ht->rehash_size);
398 write_fmt_string (printcharfun, " rehash-size %s", pigbuf); 381 write_fmt_string (printcharfun, " :rehash-size %s", pigbuf);
399 } 382 }
400 383
401 if (ht->rehash_threshold 384 if (ht->rehash_threshold
402 != HASH_TABLE_DEFAULT_REHASH_THRESHOLD (ht->size, 385 != HASH_TABLE_DEFAULT_REHASH_THRESHOLD (ht->size,
403 ht->test_function)) 386 ht->test_function))
404 { 387 {
405 float_to_string (pigbuf, ht->rehash_threshold); 388 float_to_string (pigbuf, ht->rehash_threshold);
406 write_fmt_string (printcharfun, " rehash-threshold %s", pigbuf); 389 write_fmt_string (printcharfun, " :rehash-threshold %s", pigbuf);
407 } 390 }
408 391
409 if (ht->count) 392 if (ht->count)
410 print_hash_table_data (ht, printcharfun); 393 print_hash_table_data (ht, printcharfun);
411 394
412 if (print_readably) 395 if (print_readably)
413 write_c_string (printcharfun, ")"); 396 write_ascstring (printcharfun, ")");
414 else 397 else
415 write_fmt_string (printcharfun, " 0x%x>", ht->header.uid); 398 write_fmt_string (printcharfun, " 0x%x>", ht->header.uid);
416 } 399 }
417 400
418 #ifndef NEW_GC 401 #ifndef NEW_GC
432 for (e = hentries, sentinel = e + size; e < sentinel; e++) 415 for (e = hentries, sentinel = e + size; e < sentinel; e++)
433 * (unsigned long *) e = 0xdeadbeef; /* -559038737 base 10 */ 416 * (unsigned long *) e = 0xdeadbeef; /* -559038737 base 10 */
434 #endif 417 #endif
435 418
436 if (!DUMPEDP (hentries)) 419 if (!DUMPEDP (hentries))
437 xfree (hentries, htentry *); 420 xfree (hentries);
438 } 421 }
439 422
440 static void 423 static void
441 finalize_hash_table (void *header) 424 finalize_hash_table (void *header)
442 { 425 {
839 Lisp_Object rehash_size = Qnil; 822 Lisp_Object rehash_size = Qnil;
840 Lisp_Object rehash_threshold = Qnil; 823 Lisp_Object rehash_threshold = Qnil;
841 Lisp_Object weakness = Qnil; 824 Lisp_Object weakness = Qnil;
842 Lisp_Object data = Qnil; 825 Lisp_Object data = Qnil;
843 826
844 PROPERTY_LIST_LOOP_3 (key, value, plist) 827 if (KEYWORDP (Fcar (plist)))
845 { 828 {
846 if (EQ (key, Qtest)) test = value; 829 PROPERTY_LIST_LOOP_3 (key, value, plist)
847 else if (EQ (key, Qsize)) size = value; 830 {
848 else if (EQ (key, Qrehash_size)) rehash_size = value; 831 if (EQ (key, Q_test)) test = value;
849 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value; 832 else if (EQ (key, Q_size)) size = value;
850 else if (EQ (key, Qweakness)) weakness = value; 833 else if (EQ (key, Q_rehash_size)) rehash_size = value;
851 else if (EQ (key, Qdata)) data = value; 834 else if (EQ (key, Q_rehash_threshold)) rehash_threshold = value;
852 else if (EQ (key, Qtype))/*obsolete*/ weakness = value; 835 else if (EQ (key, Q_weakness)) weakness = value;
853 else 836 else if (EQ (key, Q_data)) data = value;
854 ABORT (); 837 else if (!KEYWORDP (key))
838 signal_error (Qinvalid_read_syntax,
839 "can't mix keyword and non-keyword hash table syntax",
840 key);
841 else ABORT();
842 }
843 }
844 else
845 {
846 PROPERTY_LIST_LOOP_3 (key, value, plist)
847 {
848 if (EQ (key, Qtest)) test = value;
849 else if (EQ (key, Qsize)) size = value;
850 else if (EQ (key, Qrehash_size)) rehash_size = value;
851 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
852 else if (EQ (key, Qweakness)) weakness = value;
853 else if (EQ (key, Qdata)) data = value;
854 else if (EQ (key, Qtype))/*obsolete*/ weakness = value;
855 else if (KEYWORDP (key))
856 signal_error (Qinvalid_read_syntax,
857 "can't mix keyword and non-keyword hash table syntax",
858 key);
859 else ABORT();
860 }
855 } 861 }
856 862
857 /* Create the hash table. */ 863 /* Create the hash table. */
858 hash_table = make_standard_lisp_hash_table 864 hash_table = make_standard_lisp_hash_table
859 (decode_hash_table_test (test), 865 (decode_hash_table_test (test),
885 structure_type_create_hash_table_structure_name (Lisp_Object structure_name) 891 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
886 { 892 {
887 struct structure_type *st; 893 struct structure_type *st;
888 894
889 st = define_structure_type (structure_name, 0, hash_table_instantiate); 895 st = define_structure_type (structure_name, 0, hash_table_instantiate);
896
897 /* First the keyword syntax: */
898 define_structure_type_keyword (st, Q_test, hash_table_test_validate);
899 define_structure_type_keyword (st, Q_size, hash_table_size_validate);
900 define_structure_type_keyword (st, Q_rehash_size, hash_table_rehash_size_validate);
901 define_structure_type_keyword (st, Q_rehash_threshold, hash_table_rehash_threshold_validate);
902 define_structure_type_keyword (st, Q_weakness, hash_table_weakness_validate);
903 define_structure_type_keyword (st, Q_data, hash_table_data_validate);
904
905 /* Next the mutually exclusive, older, non-keyword syntax: */
890 define_structure_type_keyword (st, Qtest, hash_table_test_validate); 906 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
891 define_structure_type_keyword (st, Qsize, hash_table_size_validate); 907 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
892 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate); 908 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
893 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate); 909 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
894 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate); 910 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate);
1090 } 1106 }
1091 1107
1092 memcpy (ht->hentries, new_entries, ht->size * sizeof (htentry)); 1108 memcpy (ht->hentries, new_entries, ht->size * sizeof (htentry));
1093 1109
1094 #ifndef NEW_GC 1110 #ifndef NEW_GC
1095 xfree (new_entries, htentry *); 1111 xfree (new_entries);
1096 #endif /* not NEW_GC */ 1112 #endif /* not NEW_GC */
1097 } 1113 }
1098 1114
1099 static void 1115 static void
1100 enlarge_hash_table (Lisp_Hash_Table *ht) 1116 enlarge_hash_table (Lisp_Hash_Table *ht)
1385 1401
1386 static Lisp_Object 1402 static Lisp_Object
1387 maphash_unwind (Lisp_Object unwind_obj) 1403 maphash_unwind (Lisp_Object unwind_obj)
1388 { 1404 {
1389 void *ptr = (void *) get_opaque_ptr (unwind_obj); 1405 void *ptr = (void *) get_opaque_ptr (unwind_obj);
1390 xfree (ptr, void *); 1406 xfree (ptr);
1391 free_opaque_ptr (unwind_obj); 1407 free_opaque_ptr (unwind_obj);
1392 return Qnil; 1408 return Qnil;
1393 } 1409 }
1394 1410
1395 /* Return a malloced array of alternating key/value pairs from HT. */ 1411 /* Return a malloced array of alternating key/value pairs from HT. */
1829 DEFSYMBOL (Qkey_weak); /* obsolete */ 1845 DEFSYMBOL (Qkey_weak); /* obsolete */
1830 DEFSYMBOL (Qkey_or_value_weak); /* obsolete */ 1846 DEFSYMBOL (Qkey_or_value_weak); /* obsolete */
1831 DEFSYMBOL (Qvalue_weak); /* obsolete */ 1847 DEFSYMBOL (Qvalue_weak); /* obsolete */
1832 DEFSYMBOL (Qnon_weak); /* obsolete */ 1848 DEFSYMBOL (Qnon_weak); /* obsolete */
1833 1849
1850 DEFKEYWORD (Q_data);
1834 DEFKEYWORD (Q_test); 1851 DEFKEYWORD (Q_test);
1835 DEFKEYWORD (Q_size); 1852 DEFKEYWORD (Q_size);
1836 DEFKEYWORD (Q_rehash_size); 1853 DEFKEYWORD (Q_rehash_size);
1837 DEFKEYWORD (Q_rehash_threshold); 1854 DEFKEYWORD (Q_rehash_threshold);
1838 DEFKEYWORD (Q_weakness); 1855 DEFKEYWORD (Q_weakness);