Mercurial > hg > xemacs-beta

comparison src/elhash.c @ 185:3d6bfa290dbd r20-3b19

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b19
author cvs
date Mon, 13 Aug 2007 09:55:28 +0200
parents 8eaf7971accc
children b405438285a2
comparison
equal deleted inserted replaced
184:bcd2674570bf 185:3d6bfa290dbd
29 29
30 Lisp_Object Qhashtablep; 30 Lisp_Object Qhashtablep;
31 31
32 #define LISP_OBJECTS_PER_HENTRY (sizeof (hentry) / sizeof (Lisp_Object))/* 2 */ 32 #define LISP_OBJECTS_PER_HENTRY (sizeof (hentry) / sizeof (Lisp_Object))/* 2 */
33 33
34 struct hashtable_struct 34 struct hashtable
35 { 35 {
36 struct lcrecord_header header; 36 struct lcrecord_header header;
37 unsigned int fullness; 37 unsigned int fullness;
38 unsigned long (*hash_function) (CONST void *); 38 unsigned long (*hash_function) (CONST void *);
39 int (*test_function) (CONST void *, CONST void *); 39 int (*test_function) (CONST void *, CONST void *);
48 48
49 static Lisp_Object mark_hashtable (Lisp_Object, void (*) (Lisp_Object)); 49 static Lisp_Object mark_hashtable (Lisp_Object, void (*) (Lisp_Object));
50 static void print_hashtable (Lisp_Object, Lisp_Object, int); 50 static void print_hashtable (Lisp_Object, Lisp_Object, int);
51 DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable, 51 DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable,
52 mark_hashtable, print_hashtable, 0, 0, 0, 52 mark_hashtable, print_hashtable, 0, 0, 0,
53 struct hashtable_struct); 53 struct hashtable);
54 54
55 static Lisp_Object 55 static Lisp_Object
56 mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object)) 56 mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object))
57 { 57 {
58 struct hashtable_struct *table = XHASHTABLE (obj); 58 struct hashtable *table = XHASHTABLE (obj);
59 59
60 if (table->type != HASHTABLE_NONWEAK) 60 if (table->type != HASHTABLE_NONWEAK)
61 { 61 {
62 /* If the table is weak, we don't want to mark the keys and values 62 /* If the table is weak, we don't want to mark the keys and values
63 (we scan over them after everything else has been marked, 63 (we scan over them after everything else has been marked,
67 return Qnil; 67 return Qnil;
68 } 68 }
69 ((markobj) (table->zero_entry)); 69 ((markobj) (table->zero_entry));
70 return table->harray; 70 return table->harray;
71 } 71 }
72 72
73 static void 73 static void
74 print_hashtable (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 74 print_hashtable (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
75 { 75 {
76 struct hashtable_struct *table = XHASHTABLE (obj); 76 struct hashtable *table = XHASHTABLE (obj);
77 char buf[200]; 77 char buf[200];
78 if (print_readably) 78 if (print_readably)
79 error ("printing unreadable object #<hashtable 0x%x>", 79 error ("printing unreadable object #<hashtable 0x%x>",
80 table->header.uid); 80 table->header.uid);
81 sprintf (buf, GETTEXT ("#<%shashtable %d/%ld 0x%x>"), 81 sprintf (buf, GETTEXT ("#<%shashtable %d/%ld 0x%x>"),
90 table->header.uid); 90 table->header.uid);
91 write_c_string (buf, printcharfun); 91 write_c_string (buf, printcharfun);
92 } 92 }
93 93
94 static void 94 static void
95 ht_copy_to_c (struct hashtable_struct *ht, 95 ht_copy_to_c (struct hashtable *ht, c_hashtable c_table)
96 c_hashtable c_table)
97 { 96 {
98 int len = XVECTOR_LENGTH (ht->harray); 97 int len = XVECTOR_LENGTH (ht->harray);
99 98
100 c_table->harray = (void *) XVECTOR_DATA (ht->harray); 99 c_table->harray = (hentry *) XVECTOR_DATA (ht->harray);
101 c_table->zero_set = (!GC_UNBOUNDP (ht->zero_entry)); 100 c_table->zero_set = (!GC_UNBOUNDP (ht->zero_entry));
102 c_table->zero_entry = LISP_TO_VOID (ht->zero_entry); 101 c_table->zero_entry = LISP_TO_VOID (ht->zero_entry);
103 if (len < 0) 102 if (len < 0)
104 { 103 {
105 /* #### if alloc.c mark_object() changes, this must change too. */ 104 /* #### if alloc.c mark_object() changes, this must change too. */
116 c_table->test_function = ht->test_function; 115 c_table->test_function = ht->test_function;
117 XSETHASHTABLE (c_table->elisp_table, ht); 116 XSETHASHTABLE (c_table->elisp_table, ht);
118 } 117 }
119 118
120 static void 119 static void
121 ht_copy_from_c (c_hashtable c_table, 120 ht_copy_from_c (c_hashtable c_table, struct hashtable *ht)
122 struct hashtable_struct *ht)
123 { 121 {
124 struct Lisp_Vector dummy; 122 struct Lisp_Vector dummy;
125 /* C is truly hateful */ 123 /* C is truly hateful */
126 void *vec_addr 124 void *vec_addr
127 = ((char *) c_table->harray 125 = ((char *) c_table->harray
128 - ((char *) &(dummy.contents[0]) - (char *) &dummy)); 126 - ((char *) &(dummy.contents[0]) - (char *) &dummy));
129 127
130 XSETVECTOR (ht->harray, vec_addr); 128 XSETVECTOR (ht->harray, vec_addr);
131 if (c_table->zero_set) 129 if (c_table->zero_set)
132 VOID_TO_LISP (ht->zero_entry, c_table->zero_entry); 130 VOID_TO_LISP (ht->zero_entry, c_table->zero_entry);
134 ht->zero_entry = Qunbound; 132 ht->zero_entry = Qunbound;
135 ht->fullness = c_table->fullness; 133 ht->fullness = c_table->fullness;
136 } 134 }
137 135
138 136
139 static struct hashtable_struct * 137 static struct hashtable *
140 allocate_hashtable (void) 138 allocate_hashtable (void)
141 { 139 {
142 struct hashtable_struct *table 140 struct hashtable *table =
143 = alloc_lcrecord (sizeof (struct hashtable_struct), lrecord_hashtable); 141 alloc_lcrecord_type (struct hashtable, lrecord_hashtable);
144 table->harray = Qnil; 142 table->harray = Qnil;
145 table->zero_entry = Qunbound; 143 table->zero_entry = Qunbound;
146 table->fullness = 0; 144 table->fullness = 0;
147 table->hash_function = 0; 145 table->hash_function = 0;
148 table->test_function = 0; 146 table->test_function = 0;
151 149
152 void * 150 void *
153 elisp_hvector_malloc (unsigned int bytes, Lisp_Object table) 151 elisp_hvector_malloc (unsigned int bytes, Lisp_Object table)
154 { 152 {
155 Lisp_Object new_vector; 153 Lisp_Object new_vector;
156 struct hashtable_struct *ht; 154 struct hashtable *ht = XHASHTABLE (table);
157 155
158 ht = XHASHTABLE (table);
159 assert (bytes > XVECTOR_LENGTH (ht->harray) * sizeof (Lisp_Object)); 156 assert (bytes > XVECTOR_LENGTH (ht->harray) * sizeof (Lisp_Object));
160 new_vector = make_vector ((bytes / sizeof (Lisp_Object)), Qzero); 157 new_vector = make_vector ((bytes / sizeof (Lisp_Object)), Qzero);
161 return (void *) XVECTOR_DATA (new_vector); 158 return (void *) XVECTOR_DATA (new_vector);
162 } 159 }
163 160
164 void 161 void
165 elisp_hvector_free (void *ptr, Lisp_Object table) 162 elisp_hvector_free (void *ptr, Lisp_Object table)
166 { 163 {
167 struct hashtable_struct *ht = XHASHTABLE (table); 164 struct hashtable *ht = XHASHTABLE (table);
168 #if defined (USE_ASSERTIONS) || defined (DEBUG_XEMACS) 165 #if defined (USE_ASSERTIONS) || defined (DEBUG_XEMACS)
169 Lisp_Object current_vector = ht->harray; 166 Lisp_Object current_vector = ht->harray;
170 #endif 167 #endif
171 168
172 assert (((void *) XVECTOR_DATA (current_vector)) == ptr); 169 assert (((void *) XVECTOR_DATA (current_vector)) == ptr);
250 make_lisp_hashtable (int size, 247 make_lisp_hashtable (int size,
251 enum hashtable_type type, 248 enum hashtable_type type,
252 enum hashtable_test_fun test) 249 enum hashtable_test_fun test)
253 { 250 {
254 Lisp_Object result; 251 Lisp_Object result;
255 struct hashtable_struct *table = allocate_hashtable (); 252 struct hashtable *table = allocate_hashtable ();
256 253
257 table->harray = make_vector ((compute_harray_size (size) 254 table->harray = make_vector ((compute_harray_size (size)
258 * LISP_OBJECTS_PER_HENTRY), 255 * LISP_OBJECTS_PER_HENTRY),
259 Qzero); 256 Qzero);
260 switch (test) 257 switch (test)
301 CHECK_SYMBOL (sym); 298 CHECK_SYMBOL (sym);
302 299
303 if (EQ (sym, Qeq)) return HASHTABLE_EQ; 300 if (EQ (sym, Qeq)) return HASHTABLE_EQ;
304 if (EQ (sym, Qequal)) return HASHTABLE_EQUAL; 301 if (EQ (sym, Qequal)) return HASHTABLE_EQUAL;
305 if (EQ (sym, Qeql)) return HASHTABLE_EQL; 302 if (EQ (sym, Qeql)) return HASHTABLE_EQL;
306 303
307 signal_simple_error ("Invalid hashtable test fun", sym); 304 signal_simple_error ("Invalid hashtable test fun", sym);
308 return HASHTABLE_EQ; /* not reached */ 305 return HASHTABLE_EQ; /* not reached */
309 } 306 }
310 307
311 DEFUN ("make-hashtable", Fmake_hashtable, 1, 2, 0, /* 308 DEFUN ("make-hashtable", Fmake_hashtable, 1, 2, 0, /*
331 */ 328 */
332 (old_table)) 329 (old_table))
333 { 330 {
334 struct _C_hashtable old_htbl; 331 struct _C_hashtable old_htbl;
335 struct _C_hashtable new_htbl; 332 struct _C_hashtable new_htbl;
336 struct hashtable_struct *old_ht; 333 struct hashtable *old_ht;
337 struct hashtable_struct *new_ht; 334 struct hashtable *new_ht;
338 Lisp_Object result; 335 Lisp_Object result;
339 336
340 CHECK_HASHTABLE (old_table); 337 CHECK_HASHTABLE (old_table);
341 old_ht = XHASHTABLE (old_table); 338 old_ht = XHASHTABLE (old_table);
342 ht_copy_to_c (old_ht, &old_htbl); 339 ht_copy_to_c (old_ht, &old_htbl);
383 { 380 {
384 Lisp_Object val; 381 Lisp_Object val;
385 CVOID_TO_LISP (val, vval); 382 CVOID_TO_LISP (val, vval);
386 return val; 383 return val;
387 } 384 }
388 else 385 else
389 return default_; 386 return default_;
390 } 387 }
391 388
392 389
393 DEFUN ("remhash", Fremhash, 2, 2, 0, /* 390 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
408 DEFUN ("puthash", Fputhash, 3, 3, 0, /* 405 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
409 Hash KEY to VAL in TABLE. 406 Hash KEY to VAL in TABLE.
410 */ 407 */
411 (key, val, table)) 408 (key, val, table))
412 { 409 {
413 struct hashtable_struct *ht; 410 struct hashtable *ht;
414 void *vkey = LISP_TO_VOID (key); 411 void *vkey = LISP_TO_VOID (key);
415 412
416 CHECK_HASHTABLE (table); 413 CHECK_HASHTABLE (table);
417 ht = XHASHTABLE (table); 414 ht = XHASHTABLE (table);
418 if (!vkey) 415 if (!vkey)
469 if (SUBRP (function) || COMPILED_FUNCTIONP (function)) 466 if (SUBRP (function) || COMPILED_FUNCTIONP (function))
470 return; 467 return;
471 else if (CONSP (function)) 468 else if (CONSP (function))
472 { 469 {
473 Lisp_Object funcar = Fcar (function); 470 Lisp_Object funcar = Fcar (function);
474 if ((SYMBOLP (funcar)) 471 if ((SYMBOLP (funcar))
475 && (EQ (funcar, Qlambda) 472 && (EQ (funcar, Qlambda)
476 || EQ (funcar, Qautoload))) 473 || EQ (funcar, Qautoload)))
477 return; 474 return;
478 } 475 }
479 signal_error (Qinvalid_function, list1 (function)); 476 signal_error (Qinvalid_function, list1 (function));
480 } 477 }
619 616
620 /* This function is called over each pair in the hashtable. 617 /* This function is called over each pair in the hashtable.
621 We complete the marking for semi-weak hashtables. */ 618 We complete the marking for semi-weak hashtables. */
622 CVOID_TO_LISP (keytem, key); 619 CVOID_TO_LISP (keytem, key);
623 CVOID_TO_LISP (valuetem, contents); 620 CVOID_TO_LISP (valuetem, contents);
624 621
625 switch (fmh->type) 622 switch (fmh->type)
626 { 623 {
627 case HASHTABLE_KEY_WEAK: 624 case HASHTABLE_KEY_WEAK:
628 if ((fmh->obj_marked_p) (keytem) && 625 if ((fmh->obj_marked_p) (keytem) &&
629 !(fmh->obj_marked_p) (valuetem)) 626 !(fmh->obj_marked_p) (valuetem))
675 break; 672 break;
676 673
677 default: 674 default:
678 abort (); /* Huh? */ 675 abort (); /* Huh? */
679 } 676 }
680 677
681 return; 678 return;
682 } 679 }
683 680
684 int 681 int
685 finish_marking_weak_hashtables (int (*obj_marked_p) (Lisp_Object), 682 finish_marking_weak_hashtables (int (*obj_marked_p) (Lisp_Object),
745 742
746 static int 743 static int
747 pruning_mapper (CONST void *key, CONST void *contents, void *closure) 744 pruning_mapper (CONST void *key, CONST void *contents, void *closure)
748 { 745 {
749 Lisp_Object keytem, valuetem; 746 Lisp_Object keytem, valuetem;
750 struct pruning_closure *fmh = 747 struct pruning_closure *fmh = (struct pruning_closure *) closure;
751 (struct pruning_closure *) closure;
752 748
753 /* This function is called over each pair in the hashtable. 749 /* This function is called over each pair in the hashtable.
754 We remove the pairs that aren't completely marked (everything 750 We remove the pairs that aren't completely marked (everything
755 that is going to stay ought to have been marked already 751 that is going to stay ought to have been marked already
756 by the finish_marking stage). */ 752 by the finish_marking stage). */
802 { 798 {
803 for (i = 0; i < size; i++) 799 for (i = 0; i < size; i++)
804 hash = HASH2 (hash, internal_hash (arr[i], depth + 1)); 800 hash = HASH2 (hash, internal_hash (arr[i], depth + 1));
805 return hash; 801 return hash;
806 } 802 }
807 803
808 /* just pick five elements scattered throughout the array. 804 /* just pick five elements scattered throughout the array.
809 A slightly better approach would be to offset by some 805 A slightly better approach would be to offset by some
810 noise factor from the points chosen below. */ 806 noise factor from the points chosen below. */
811 for (i = 0; i < 5; i++) 807 for (i = 0; i < 5; i++)
812 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth + 1)); 808 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth + 1));
813 809
814 return hash; 810 return hash;
815 } 811 }
816 812
817 /* Return a hash value for a Lisp_Object. This is for use when hashing 813 /* Return a hash value for a Lisp_Object. This is for use when hashing
818 objects with the comparison being `equal' (for `eq', you can just 814 objects with the comparison being `equal' (for `eq', you can just