1/* struct::set - critcl - layer 0 declarations 2 * Tcl_ObjType 'set'. 3 */ 4 5#include <string.h> 6#include "s.h" 7 8/* .................................................. */ 9 10static void free_rep (Tcl_Obj* obj); 11static void dup_rep (Tcl_Obj* obj, Tcl_Obj* dup); 12static void string_rep (Tcl_Obj* obj); 13static int from_any (Tcl_Interp* ip, Tcl_Obj* obj); 14 15static 16Tcl_ObjType s_type = { 17 "tcllib::struct::set/critcl::set", 18 free_rep, 19 dup_rep, 20 string_rep, 21 from_any 22}; 23 24/* .................................................. */ 25 26int 27s_get (Tcl_Interp* interp, Tcl_Obj* o, SPtr* sStar) 28{ 29 if (o->typePtr != &s_type) { 30 int res = from_any (interp, o); 31 if (res != TCL_OK) { 32 return res; 33 } 34 } 35 36 *sStar = (SPtr) o->internalRep.otherValuePtr; 37 return TCL_OK; 38} 39 40Tcl_Obj* 41s_new (SPtr s) 42{ 43 Tcl_Obj* o = Tcl_NewObj(); 44 Tcl_InvalidateStringRep(o); 45 46 o->internalRep.otherValuePtr = s; 47 o->typePtr = &s_type; 48 return o; 49} 50 51Tcl_ObjType* 52s_stype (void) 53{ 54 return &s_type; 55} 56 57Tcl_ObjType* 58s_ltype (void) 59{ 60 static Tcl_ObjType* l; 61 if (l == NULL) { 62 l = Tcl_GetObjType ("list"); 63 } 64 return l; 65} 66 67/* .................................................. */ 68 69static void 70free_rep (Tcl_Obj* o) 71{ 72 s_free ((SPtr) o->internalRep.otherValuePtr); 73 o->internalRep.otherValuePtr = NULL; 74} 75 76static void 77dup_rep (Tcl_Obj* obj, Tcl_Obj* dup) 78{ 79 SPtr s = s_dup ((SPtr) obj->internalRep.otherValuePtr); 80 81 dup->internalRep.otherValuePtr = s; 82 dup->typePtr = &s_type; 83} 84 85static void 86string_rep (Tcl_Obj* obj) 87{ 88 SPtr s = (SPtr) obj->internalRep.otherValuePtr; 89 int numElems = s->el.numEntries; 90 91 /* iterate hash table and generate list-like string rep */ 92 93# define LOCAL_SIZE 20 94 int localFlags[LOCAL_SIZE], *flagPtr; 95 int localLen [LOCAL_SIZE], *lenPtr; 96 register int i; 97 char *elem, *dst; 98 int length; 99 100 Tcl_HashSearch hs; 101 Tcl_HashEntry* he; 102 103 /* 104 * Convert each key of the hash to string form and then convert it to 105 * proper list element form, adding it to the result buffer. */ 106 107 /* 108 * Pass 1: estimate space, gather flags. 109 */ 110 111 if (numElems <= LOCAL_SIZE) { 112 flagPtr = localFlags; 113 lenPtr = localLen; 114 } else { 115 flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); 116 lenPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); 117 } 118 obj->length = 1; 119 120 for(i = 0, he = Tcl_FirstHashEntry(&s->el, &hs); 121 he != NULL; 122 he = Tcl_NextHashEntry(&hs), i++) { 123 124 elem = Tcl_GetHashKey (&s->el, he); 125 lenPtr [i] = strlen (elem); 126 127 obj->length += Tcl_ScanCountedElement(elem, lenPtr[i], 128 &flagPtr[i]) + 1; 129 } 130 131 /* 132 * Pass 2: copy into string rep buffer. 133 */ 134 135 obj->bytes = ckalloc((unsigned) obj->length); 136 dst = obj->bytes; 137 138 for(i = 0, he = Tcl_FirstHashEntry(&s->el, &hs); 139 he != NULL; 140 he = Tcl_NextHashEntry(&hs), i++) { 141 142 elem = Tcl_GetHashKey (&s->el, he); 143 144 dst += Tcl_ConvertCountedElement(elem, lenPtr[i], 145 dst, flagPtr[i]); 146 *dst = ' '; 147 dst++; 148 } 149 if (flagPtr != localFlags) { 150 ckfree((char *) flagPtr); 151 ckfree((char *) lenPtr); 152 } 153 if (dst == obj->bytes) { 154 *dst = 0; 155 } else { 156 dst--; 157 *dst = 0; 158 } 159 obj->length = dst - obj->bytes; 160} 161 162static int 163from_any (Tcl_Interp* ip, Tcl_Obj* obj) 164{ 165 /* Go through an intermediate list rep. 166 */ 167 168 int lc, i, new; 169 Tcl_Obj** lv; 170 Tcl_ObjType* oldTypePtr; 171 SPtr s; 172 173 if (Tcl_ListObjGetElements (ip, obj, &lc, &lv) != TCL_OK) { 174 return TCL_ERROR; 175 } 176 177 /* 178 * Remember the old type after the conversion to list, or we will try to 179 * free a list intrep using the free-proc of whatever type the word had 180 * before. For example 'parsedvarname'. That would be bad. Segfault like 181 * bad. 182 */ 183 184 oldTypePtr = obj->typePtr; 185 186 /* Now, if the value was pure we forcibly generate the string-rep, to 187 * capture the existing semantics of the value. Because we now enter the 188 * realm of unordered, and the actual value may not be. If so, then not 189 * having the string-rep will later cause the generation of an arbitrarily 190 * ordered string-rep when the value is shimmered to some other type. This 191 * is most visible for lists, which are ordered. A shimmer list->set->list 192 * may reorder the elements if we do not capture their order in the 193 * string-rep. 194 * 195 * See test case -15.0 in sets.testsuite demonstrating this. 196 * Disable the Tcl_GetString below and see the test fail. 197 */ 198 199 Tcl_GetString (obj); 200 201 /* Gen hash table from list */ 202 203 s = (SPtr) ckalloc (sizeof (S)); 204 Tcl_InitHashTable(&s->el, TCL_STRING_KEYS); 205 206 for (i=0; i < lc; i++) { 207 (void) Tcl_CreateHashEntry(&s->el, 208 Tcl_GetString (lv[i]), &new); 209 } 210 211 /* 212 * Free the old internalRep before setting the new one. We do this as 213 * late as possible to allow the conversion code, in particular 214 * Tcl_ListObjGetElements, to use that old internalRep. 215 */ 216 217 if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { 218 oldTypePtr->freeIntRepProc(obj); 219 } 220 221 obj->internalRep.otherValuePtr = s; 222 obj->typePtr = &s_type; 223 return TCL_OK; 224} 225 226/* .................................................. */ 227 228int 229s_size (SPtr a) 230{ 231 return a->el.numEntries; 232} 233 234int 235s_empty (SPtr a) 236{ 237 return (a->el.numEntries == 0); 238} 239 240void 241s_free (SPtr a) 242{ 243 Tcl_DeleteHashTable(&a->el); 244 ckfree ((char*) a); 245} 246 247SPtr 248s_dup (SPtr a) 249{ 250 SPtr s = (SPtr) ckalloc (sizeof (S)); 251 Tcl_InitHashTable(&s->el, TCL_STRING_KEYS); 252 253 if (!a) return s; 254 s_add (s, a, NULL); 255 return s; 256} 257 258int 259s_contains (SPtr a, const char* item) 260{ 261 return Tcl_FindHashEntry (&a->el, item) != NULL; 262} 263 264SPtr 265s_difference (SPtr a, SPtr b) 266{ 267 int new; 268 Tcl_HashSearch hs; 269 Tcl_HashEntry* he; 270 CONST char* key; 271 SPtr s; 272 273 /* a - nothing = a. Just duplicate */ 274 275 if (!b->el.numEntries) { 276 return s_dup (a); 277 } 278 279 s = (SPtr) ckalloc (sizeof (S)); 280 Tcl_InitHashTable(&s->el, TCL_STRING_KEYS); 281 282 /* nothing - b = nothing */ 283 284 if (!a->el.numEntries) return s; 285 286 /* Have to get it the hard way, no shortcut */ 287 288 for(he = Tcl_FirstHashEntry(&a->el, &hs); 289 he != NULL; 290 he = Tcl_NextHashEntry(&hs)) { 291 key = Tcl_GetHashKey (&a->el, he); 292 293 if (Tcl_FindHashEntry (&b->el, key) != NULL) continue; 294 /* key is in a, not in b <=> in (a-b) */ 295 296 (void*) Tcl_CreateHashEntry(&s->el, key, &new); 297 } 298 299 return s; 300} 301 302SPtr 303s_intersect (SPtr a, SPtr b) 304{ 305 int new; 306 Tcl_HashSearch hs; 307 Tcl_HashEntry* he; 308 CONST char* key; 309 310 SPtr s = (SPtr) ckalloc (sizeof (S)); 311 Tcl_InitHashTable(&s->el, TCL_STRING_KEYS); 312 313 /* Shortcut when we know that the result is empty */ 314 315 if (!a->el.numEntries) return s; 316 if (!b->el.numEntries) return s; 317 318 /* Ensure that we iterate over the smaller of the two sets */ 319 320 if (b->el.numEntries < a->el.numEntries) { 321 SPtr t = a ; a = b ; b = t; 322 } 323 324 for(he = Tcl_FirstHashEntry(&a->el, &hs); 325 he != NULL; 326 he = Tcl_NextHashEntry(&hs)) { 327 key = Tcl_GetHashKey (&a->el, he); 328 329 if (Tcl_FindHashEntry (&b->el, key) == NULL) continue; 330 /* key is in a, in b <=> in (a*b) */ 331 332 (void*) Tcl_CreateHashEntry(&s->el, key, &new); 333 } 334 335 return s; 336} 337 338SPtr 339s_union (SPtr a, SPtr b) 340{ 341 int new; 342 Tcl_HashSearch hs; 343 Tcl_HashEntry* he; 344 CONST char* key; 345 346 SPtr s = (SPtr) ckalloc (sizeof (S)); 347 Tcl_InitHashTable(&s->el, TCL_STRING_KEYS); 348 349 s_add (s, a, NULL); 350 s_add (s, b, NULL); 351 352 return s; 353} 354 355void 356s_add (SPtr a, SPtr b, int* newPtr) 357{ 358 int new, nx = 0; 359 Tcl_HashSearch hs; 360 Tcl_HashEntry* he; 361 CONST char* key; 362 363 if (b->el.numEntries) { 364 for(he = Tcl_FirstHashEntry(&b->el, &hs); 365 he != NULL; 366 he = Tcl_NextHashEntry(&hs)) { 367 key = Tcl_GetHashKey (&b->el, he); 368 (void*) Tcl_CreateHashEntry(&a->el, key, &new); 369 if (new) {nx = 1;} 370 } 371 } 372 if(newPtr) {*newPtr = nx;} 373} 374 375void 376s_add1 (SPtr a, const char* item) 377{ 378 int new; 379 380 (void*) Tcl_CreateHashEntry(&a->el, item, &new); 381} 382 383void 384s_subtract (SPtr a, SPtr b, int* delPtr) 385{ 386 int new; 387 Tcl_HashSearch hs; 388 Tcl_HashEntry* he, *dhe; 389 CONST char* key; 390 int dx = 0; 391 392 if (b->el.numEntries) { 393 for(he = Tcl_FirstHashEntry(&b->el, &hs); 394 he != NULL; 395 he = Tcl_NextHashEntry(&hs)) { 396 key = Tcl_GetHashKey (&b->el, he); 397 dhe = Tcl_FindHashEntry(&a->el, key); 398 if (!dhe) continue; 399 /* Key is known, to be removed */ 400 dx = 1; 401 Tcl_DeleteHashEntry (dhe); 402 } 403 } 404 if(delPtr) {*delPtr = dx;} 405} 406 407void 408s_subtract1 (SPtr a, const char* item) 409{ 410 Tcl_HashEntry* he; 411 412 he = Tcl_FindHashEntry(&a->el, item); 413 if (!he) return; 414 Tcl_DeleteHashEntry (he); 415} 416 417int 418s_equal (SPtr a, SPtr b) 419{ 420 /* (a == b) <=> (|a| == |b| && (a-b) = {}) 421 */ 422 423 int res = 0; 424 425 if (s_size (a) == s_size(b)) { 426 SPtr t = s_difference (a, b); 427 res = s_empty (t); 428 s_free (t); 429 } 430 return res; 431} 432 433int 434s_subsetof (SPtr a, SPtr b) 435{ 436 /* (a <= b) <=> (|a| <= |b| && (a-b) = {}) 437 */ 438 439 int res = 0; 440 441 if (s_size (a) <= s_size(b)) { 442 SPtr t = s_difference (a, b); 443 res = s_empty (t); 444 s_free (t); 445 } 446 return res; 447} 448 449/* .................................................. */ 450 451 452/* 453 * Local Variables: 454 * mode: c 455 * c-basic-offset: 4 456 * fill-column: 78 457 * End: 458 */ 459