Mercurial > hg > xemacs-beta

comparison src/elhash.c @ 231:557eaa0339bf r20-5b14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b14
author cvs
date Mon, 13 Aug 2007 10:13:48 +0200
parents 2c611d1463a6
children f955c73f5258
comparison
equal deleted inserted replaced
230:39ed1d2bdd9d 231:557eaa0339bf
48 48
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 DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable, 54 DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable,
54 mark_hashtable, print_hashtable, 0, 0, 0, 55 mark_hashtable, print_hashtable, 0,
55 struct hashtable); 56 hashtable_equal, 0, struct hashtable);
56 57
57 static Lisp_Object 58 static Lisp_Object
58 mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object)) 59 mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object))
59 { 60 {
60 struct hashtable *table = XHASHTABLE (obj); 61 struct hashtable *table = XHASHTABLE (obj);
70 } 71 }
71 ((markobj) (table->zero_entry)); 72 ((markobj) (table->zero_entry));
72 return table->harray; 73 return table->harray;
73 } 74 }
74 75
76 /* Equality of hashtables. Two hashtables are equal when they are of
77 the same type and test function, they have the same number of
78 elements, and for each key in hashtable, the values are `equal'.
79
80 This is similar to Common Lisp `equalp' of hashtables, with the
81 difference that CL requires the keys to be compared using the
82 `:test' function, which we don't do. Doing that would require
83 consing, and consing is bad idea in `equal'. Anyway, our method
84 should provide the same result -- if the keys are not equal
85 according to `:test', then Fgethash() in hashtable_equal_mapper()
86 will fail. */
87 struct hashtable_equal_closure
88 {
89 int depth;
90 int equal_so_far;
91 Lisp_Object other_table;
92 };
93
94 static void
95 hashtable_equal_mapper (void *key, void *contents, void *arg)
96 {
97 struct hashtable_equal_closure *closure =
98 (struct hashtable_equal_closure *)arg;
99 Lisp_Object keytem, valuetem;
100
101 /* It would be beautiful if maphash() allowed us to bail out when C
102 function returns non-zero, a la map_extents() et al. #### Make
103 it so! */
104 if (closure->equal_so_far)
105 {
106 Lisp_Object value_in_other;
107 CVOID_TO_LISP (keytem, key);
108 CVOID_TO_LISP (valuetem, contents);
109 /* Look up the key in the other hashtable, and compare the
110 values. */
111 value_in_other = Fgethash (keytem, closure->other_table, Qunbound);
112 if (UNBOUNDP (value_in_other)
113 || !internal_equal (valuetem, value_in_other, closure->depth))
114 closure->equal_so_far = 0;
115 /* return 1; */
116 }
117 /* return 0; */
118 }
119
120 static int
121 hashtable_equal (Lisp_Object t1, Lisp_Object t2, int depth)
122 {
123 struct hashtable_equal_closure closure;
124 struct hashtable *table1 = XHASHTABLE (t1);
125 struct hashtable *table2 = XHASHTABLE (t2);
126
127 /* The objects are `equal' if they are of the same type, so return 0
128 if types or test functions are not the same. Obviously, the
129 number of elements must be equal, too. */
130 if ((table1->test_function != table2->test_function)
131 || (table1->type != table2->type)
132 || (table1->fullness != table2->fullness))
133 return 0;
134
135 closure.depth = depth + 1;
136 closure.equal_so_far = 1;
137 closure.other_table = t2;
138 elisp_maphash (hashtable_equal_mapper, t1, &closure);
139 return closure.equal_so_far;
140 }
141
75 /* Printing hashtables. 142 /* Printing hashtables.
76 143
77 This is non-trivial, because we use a readable structure-style 144 This is non-trivial, because we use a readable structure-style
78 syntax for hashtables. This means that a typical hashtable will be 145 syntax for hashtables. This means that a typical hashtable will be
79 readably printed in the form of: 146 readably printed in the form of:
90 #<hashtable size 2/13 data (key1 value1 key2 value2) 0x874d> 157 #<hashtable size 2/13 data (key1 value1 key2 value2) 0x874d>
91 158
92 The data is truncated to four pairs, and the rest is shown with 159 The data is truncated to four pairs, and the rest is shown with
93 `...'. The actual printer is non-consing. */ 160 `...'. The actual printer is non-consing. */
94 161
95 struct print_mapper_arg { 162 struct print_hashtable_data_closure
96 EMACS_INT count; /* Used to implement the truncation 163 {
97 for non-readable printing, as well 164 EMACS_INT count; /* Used to implement truncation for
98 as to avoid the unnecessary space 165 non-readable printing, as well as
99 at the beginning. */ 166 to avoid the unnecessary space at
167 the beginning. */
100 Lisp_Object printcharfun; 168 Lisp_Object printcharfun;
101 }; 169 };
102 170
103 static void 171 static void
104 print_hashtable_data_mapper (void *key, void *contents, void *arg) 172 print_hashtable_data_mapper (void *key, void *contents, void *arg)
105 { 173 {
106 Lisp_Object keytem, valuetem; 174 Lisp_Object keytem, valuetem;
107 struct print_mapper_arg *closure = (struct print_mapper_arg *)arg; 175 struct print_hashtable_data_closure *closure =
176 (struct print_hashtable_data_closure *)arg;
108 177
109 if (closure->count < 4 || print_readably) 178 if (closure->count < 4 || print_readably)
110 { 179 {
111 CVOID_TO_LISP (keytem, key); 180 CVOID_TO_LISP (keytem, key);
112 CVOID_TO_LISP (valuetem, contents); 181 CVOID_TO_LISP (valuetem, contents);
124 /* Print the data of the hashtable. This maps through a Lisp 193 /* Print the data of the hashtable. This maps through a Lisp
125 hashtable and prints key/value pairs using PRINTCHARFUN. */ 194 hashtable and prints key/value pairs using PRINTCHARFUN. */
126 static void 195 static void
127 print_hashtable_data (Lisp_Object hashtable, Lisp_Object printcharfun) 196 print_hashtable_data (Lisp_Object hashtable, Lisp_Object printcharfun)
128 { 197 {
129 struct print_mapper_arg closure; 198 struct print_hashtable_data_closure closure;
130 closure.count = 0; 199 closure.count = 0;
131 closure.printcharfun = printcharfun; 200 closure.printcharfun = printcharfun;
132 201
133 write_c_string (" data (", printcharfun); 202 write_c_string (" data (", printcharfun);
134 elisp_maphash (print_hashtable_data_mapper, hashtable, &closure); 203 elisp_maphash (print_hashtable_data_mapper, hashtable, &closure);
161 if (table->test_function == NULL) 230 if (table->test_function == NULL)
162 write_c_string (" test eq", printcharfun); 231 write_c_string (" test eq", printcharfun);
163 else if (table->test_function == lisp_object_equal_equal) 232 else if (table->test_function == lisp_object_equal_equal)
164 write_c_string (" test equal", printcharfun); 233 write_c_string (" test equal", printcharfun);
165 else if (table->test_function == lisp_object_eql_equal) 234 else if (table->test_function == lisp_object_eql_equal)
166 ; 235 DO_NOTHING;
167 else 236 else
168 abort (); 237 abort ();
169 if (table->fullness || !print_readably) 238 if (table->fullness || !print_readably)
170 { 239 {
171 if (print_readably) 240 if (print_readably)
172 sprintf (buf, " size %d", table->fullness); 241 sprintf (buf, " size %u", table->fullness);
173 else 242 else
174 sprintf (buf, " size %u/%ld", table->fullness, 243 sprintf (buf, " size %u/%ld", table->fullness,
175 XVECTOR_LENGTH (table->harray) / LISP_OBJECTS_PER_HENTRY); 244 XVECTOR_LENGTH (table->harray) / LISP_OBJECTS_PER_HENTRY);
176 write_c_string (buf, printcharfun); 245 write_c_string (buf, printcharfun);
177 } 246 }
557 if (NILP (sym)) return HASHTABLE_EQL; 626 if (NILP (sym)) return HASHTABLE_EQL;
558 if (EQ (sym, Qeq)) return HASHTABLE_EQ; 627 if (EQ (sym, Qeq)) return HASHTABLE_EQ;
559 if (EQ (sym, Qequal)) return HASHTABLE_EQUAL; 628 if (EQ (sym, Qequal)) return HASHTABLE_EQUAL;
560 if (EQ (sym, Qeql)) return HASHTABLE_EQL; 629 if (EQ (sym, Qeql)) return HASHTABLE_EQL;
561 630
562 signal_simple_error ("Invalid hashtable test fun", sym); 631 signal_simple_error ("Invalid hashtable test function", sym);
563 return HASHTABLE_EQ; /* not reached */ 632 return HASHTABLE_EQ; /* not reached */
564 } 633 }
565 634
566 DEFUN ("make-hashtable", Fmake_hashtable, 1, 2, 0, /* 635 DEFUN ("make-hashtable", Fmake_hashtable, 1, 2, 0, /*
567 Make a hashtable of initial size SIZE. 636 Make a hashtable of initial size SIZE.