1/* struct::queue - critcl - layer 3 definitions. 2 * 3 * -> Method functions. 4 * Implementations for all queue methods. 5 */ 6 7#include "util.h" 8#include "m.h" 9#include "q.h" 10#include "ms.h" 11 12static int qsize (Q* q, int* u, int* r, int* a); 13static void qshift (Q* q); 14 15#undef QUEUE_DUMP 16/*#define QUEUE_DUMP 1*/ 17 18#if QUEUE_DUMP 19static void qdump (Q* q); 20#else 21#define qdump(q) /* Ignore */ 22#endif 23 24/* .................................................. */ 25 26/* 27 *--------------------------------------------------------------------------- 28 * 29 * qum_CLEAR -- 30 * 31 * Removes all elements currently on the queue. I.e empties the queue. 32 * 33 * Results: 34 * A standard Tcl result code. 35 * 36 * Side effects: 37 * Only internal, memory allocation changes ... 38 * 39 *--------------------------------------------------------------------------- 40 */ 41 42int 43qum_CLEAR (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 44{ 45 /* Syntax: queue clear 46 * [0] [1] 47 */ 48 49 if (objc != 2) { 50 Tcl_WrongNumArgs (interp, 2, objv, NULL); 51 return TCL_ERROR; 52 } 53 54 /* 55 * Delete and recreate the queue memory. A combination of delete/new, 56 * except the main structure is left unchanged 57 */ 58 59 Tcl_DecrRefCount (q->unget); 60 Tcl_DecrRefCount (q->queue); 61 Tcl_DecrRefCount (q->append); 62 63 q->at = 0; 64 q->unget = Tcl_NewListObj (0,NULL); 65 q->queue = Tcl_NewListObj (0,NULL); 66 q->append = Tcl_NewListObj (0,NULL); 67 68 Tcl_IncrRefCount (q->unget); 69 Tcl_IncrRefCount (q->queue); 70 Tcl_IncrRefCount (q->append); 71 72 return TCL_OK; 73} 74 75/* 76 *--------------------------------------------------------------------------- 77 * 78 * qum_DESTROY -- 79 * 80 * Destroys the whole queue object. 81 * 82 * Results: 83 * A standard Tcl result code. 84 * 85 * Side effects: 86 * Releases memory. 87 * 88 *--------------------------------------------------------------------------- 89 */ 90 91int 92qum_DESTROY (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 93{ 94 /* Syntax: queue destroy 95 * [0] [1] 96 */ 97 98 if (objc != 2) { 99 Tcl_WrongNumArgs (interp, 2, objv, NULL); 100 return TCL_ERROR; 101 } 102 103 Tcl_DeleteCommandFromToken(interp, q->cmd); 104 return TCL_OK; 105} 106 107/* 108 *--------------------------------------------------------------------------- 109 * 110 * qum_PEEK/GET -- 111 * 112 * (Non-)destructively retrieves one or more elements from the top of the 113 * queue. 114 * 115 * Results: 116 * A standard Tcl result code. 117 * 118 * Side effects: 119 * Only internal, memory allocation changes ... 120 * 121 *--------------------------------------------------------------------------- 122 */ 123 124int 125qum_PEEK (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv, int get) 126{ 127 /* Syntax: queue peek|get ?n? 128 * [0] [1] [2] 129 */ 130 131 int listc = 0; 132 Tcl_Obj** listv; 133 Tcl_Obj* r; 134 int n = 1; 135 int ungetc; 136 int queuec; 137 int appendc; 138 139 if ((objc != 2) && (objc != 3)) { 140 Tcl_WrongNumArgs (interp, 2, objv, "?n?"); 141 return TCL_ERROR; 142 } 143 144 if (objc == 3) { 145 if (Tcl_GetIntFromObj(interp, objv[2], &n) != TCL_OK) { 146 return TCL_ERROR; 147 } else if (n < 1) { 148 Tcl_AppendResult (interp, "invalid item count ", 149 Tcl_GetString (objv[2]), 150 NULL); 151 return TCL_ERROR; 152 } 153 } 154 155 if (n > qsize(q, &ungetc, &queuec, &appendc)) { 156 Tcl_AppendResult (interp, 157 "insufficient items in queue to fill request", 158 NULL); 159 return TCL_ERROR; 160 } 161 162 /* 1. We have item on the unget stack 163 * a. Enough to satisfy request. 164 * b. Not enough. 165 * 2. We have items in the return buffer. 166 * a. Enough to satisfy request. 167 * b. Not enough. 168 * 3. We have items in the append buffer. 169 * a. Enough to satisfy request. 170 * b. Not enough. 171 * 172 * Case 3. can assume 2b, because an empty return buffer will be filled 173 * from the append buffer before looking at either. Case 3. cannot happen 174 * for n==1, the return buffer will contain at least one element. 175 * 176 * We distinguish between single and multi-element requests. 177 * 178 * XXX AK optimizations - If we can return everything from a single 179 * buffer, be it queue, or append, just return the buffer object, do not 180 * create something new. 181 */ 182 183 if (n == 1) { 184 if (ungetc) { 185 /* Pull from unget stack */ 186 Tcl_ListObjGetElements (interp, q->unget, &listc, &listv); 187 r = listv [listc-1]; 188 Tcl_SetObjResult (interp, r); 189 if (get) { 190 /* XXX AK : Should maintain max size info, and proper index, for discard. */ 191 Tcl_ListObjReplace (interp, q->unget, listc-1, 1, 0, NULL); 192 } 193 } else { 194 qshift (q); 195 Tcl_ListObjGetElements (interp, q->queue, &listc, &listv); 196 ASSERT_BOUNDS(q->at,listc); 197 r = listv [q->at]; 198 Tcl_SetObjResult (interp, r); 199 /* 200 * Note: Doing the SetObj now is important. It increments the 201 * refcount of 'r', allowing it to survive if the 'qshift' below 202 * kills the internal list (q->queue) holding it. 203 */ 204 if (get) { 205 q->at ++; 206 qshift (q); 207 } 208 } 209 } else { 210 /* 211 * Allocate buffer for result, then fill it using the various data 212 * sources. 213 */ 214 215 int i = 0, j; 216 Tcl_Obj** resv = NALLOC(n,Tcl_Obj*); 217 218 if (ungetc) { 219 Tcl_ListObjGetElements (interp, q->unget, &listc, &listv); 220 /* 221 * Note how we are iterating backward in listv. unget is managed 222 * as a stack, avoiding mem-copy operations and both push and pop. 223 */ 224 for (j = listc-1; 225 j >= 0 && i < n; 226 j--, i++) { 227 ASSERT_BOUNDS(i,n); 228 ASSERT_BOUNDS(j,listc); 229 resv[i] = listv[j]; 230 Tcl_IncrRefCount (resv[i]); 231 } 232 if (get) { 233 /* XXX AK : Should maintain max size info, and proper index, for discard. */ 234 Tcl_ListObjReplace (interp, q->unget, j, i, 0, NULL); 235 /* XXX CHECK index calcs. */ 236 } 237 } 238 if (i < n) { 239 qshift (q); 240 Tcl_ListObjGetElements (interp, q->queue, &listc, &listv); 241 for (j = q->at; 242 j < listc && i < n; 243 j++, i++) { 244 ASSERT_BOUNDS(i,n); 245 ASSERT_BOUNDS(j,listc); 246 resv[i] = listv[j]; 247 Tcl_IncrRefCount (resv[i]); 248 } 249 250 if (get) { 251 q->at = j; 252 qshift (q); 253 } else if (i < n) { 254 /* XX */ 255 Tcl_ListObjGetElements (interp, q->append, &listc, &listv); 256 for (j = 0; 257 j < listc && i < n; 258 j++, i++) { 259 ASSERT_BOUNDS(i,n); 260 ASSERT_BOUNDS(j,listc); 261 resv[i] = listv[j]; 262 Tcl_IncrRefCount (resv[i]); 263 } 264 } 265 } 266 267 /* 268 * This can happend if and only if we have to pull data from append, 269 * and get is set. Without get XX would have run and filled the result 270 * to completion. 271 */ 272 273 if (i < n) { 274 ASSERT(get,"Impossible 2nd return pull witohut get"); 275 qshift (q); 276 Tcl_ListObjGetElements (interp, q->queue, &listc, &listv); 277 for (j = q->at; 278 j < listc && i < n; 279 j++, i++) { 280 ASSERT_BOUNDS(i,n); 281 ASSERT_BOUNDS(j,listc); 282 resv[i] = listv[j]; 283 Tcl_IncrRefCount (resv[i]); 284 } 285 q->at = j; 286 qshift (q); 287 } 288 289 r = Tcl_NewListObj (n, resv); 290 Tcl_SetObjResult (interp, r); 291 292 for (i=0;i<n;i++) { 293 Tcl_DecrRefCount (resv[i]); 294 } 295 ckfree((char*)resv); 296 } 297 298 return TCL_OK; 299} 300 301/* 302 *--------------------------------------------------------------------------- 303 * 304 * qum_PUT -- 305 * 306 * Adds one or more elements to the queue. 307 * 308 * Results: 309 * A standard Tcl result code. 310 * 311 * Side effects: 312 * May release and allocate memory. 313 * 314 *--------------------------------------------------------------------------- 315 */ 316 317int 318qum_PUT (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 319{ 320 /* Syntax: queue push item... 321 * [0] [1] [2] 322 */ 323 324 int i; 325 326 if (objc < 3) { 327 Tcl_WrongNumArgs (interp, 2, objv, "item ?item ...?"); 328 return TCL_ERROR; 329 } 330 331 for (i = 2; i < objc; i++) { 332 Tcl_ListObjAppendElement (interp, q->append, objv[i]); 333 } 334 335 return TCL_OK; 336} 337 338/* 339 *--------------------------------------------------------------------------- 340 * 341 * qum_UNGET -- 342 * 343 * Pushes an element back into the queue. 344 * 345 * Results: 346 * A standard Tcl result code. 347 * 348 * Side effects: 349 * May release and allocate memory. 350 * 351 *--------------------------------------------------------------------------- 352 */ 353 354int 355qum_UNGET (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 356{ 357 /* Syntax: queue unget item 358 * [0] [1] [2] 359 */ 360 361 if (objc != 3) { 362 Tcl_WrongNumArgs (interp, 2, objv, "item"); 363 return TCL_ERROR; 364 } 365 366 if (q->at == 0) { 367 /* Need the unget stack */ 368 Tcl_ListObjAppendElement (interp, q->unget, objv[2]); 369 } else { 370 /* 371 * We have room in the return buffer, so splice directly instead of 372 * using the unget stack. 373 */ 374 375 int queuec = 0; 376 Tcl_ListObjLength (NULL, q->queue, &queuec); 377 378 q->at --; 379 ASSERT_BOUNDS(q->at,queuec); 380 Tcl_ListObjReplace (interp, q->queue, q->at, 1, 1, &objv[2]); 381 } 382 383 return TCL_OK; 384} 385 386/* 387 *--------------------------------------------------------------------------- 388 * 389 * qum_SIZE -- 390 * 391 * Returns the number of elements currently held by the queue. 392 * 393 * Results: 394 * A standard Tcl result code. 395 * 396 * Side effects: 397 * None. 398 * 399 *--------------------------------------------------------------------------- 400 */ 401 402int 403qum_SIZE (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 404{ 405 /* Syntax: queue size 406 * [0] [1] 407 */ 408 409 if ((objc != 2)) { 410 Tcl_WrongNumArgs (interp, 2, objv, NULL); 411 return TCL_ERROR; 412 } 413 414 Tcl_SetObjResult (interp, Tcl_NewIntObj (qsize (q, NULL, NULL, NULL))); 415 return TCL_OK; 416} 417 418 419static int 420qsize (Q* q, int* u, int* r, int* a) 421{ 422 int ungetc = 0; 423 int queuec = 0; 424 int appendc = 0; 425 426 Tcl_ListObjLength (NULL, q->unget, &ungetc); 427 Tcl_ListObjLength (NULL, q->queue, &queuec); 428 Tcl_ListObjLength (NULL, q->append, &appendc); 429 430 if (u) *u = ungetc; 431 if (r) *r = queuec; 432 if (a) *a = appendc; 433 434 return ungetc + queuec + appendc - q->at; 435} 436 437static void 438qshift (Q* q) 439{ 440 int queuec = 0; 441 int appendc = 0; 442 443 qdump (q); 444 445 /* The queue is not done yet, no shift */ 446 Tcl_ListObjLength (NULL, q->queue, &queuec); 447 if (q->at < queuec) return; 448 449 /* The queue is done, however there is nothing 450 * to shift into it, so we don't 451 */ 452 Tcl_ListObjLength (NULL, q->append, &appendc); 453 if (!appendc) return; 454 455 q->at = 0; 456 Tcl_DecrRefCount (q->queue); 457 q->queue = q->append; 458 q->append = Tcl_NewListObj (0,NULL); 459 Tcl_IncrRefCount (q->append); 460 461 qdump (q); 462} 463 464#ifdef QUEUE_DUMP 465static void 466qdump (Q* q) 467{ 468 int k; 469 int listc = 0; 470 Tcl_Obj** listv; 471 472 fprintf(stderr,"qdump (%p, @%d)\n", q, q->at);fflush(stderr); 473 474 fprintf(stderr,"\tunget %p\n", q->unget);fflush(stderr); 475 Tcl_ListObjGetElements (NULL, q->unget, &listc, &listv); 476 for (k=0; k < listc; k++) { 477 fprintf(stderr,"\tunget %p [%d] = %p '%s' /%d\n", q->unget, k, listv[k], Tcl_GetString(listv[k]), listv[k]->refCount);fflush(stderr); 478 } 479 480 fprintf(stderr,"\tqueue %p\n", q->queue);fflush(stderr); 481 Tcl_ListObjGetElements (NULL, q->queue, &listc, &listv); 482 for (k=0; k < listc; k++) { 483 fprintf(stderr,"\tqueue %p [%d] = %p '%s' /%d\n", q->queue, k, listv[k], Tcl_GetString(listv[k]), listv[k]->refCount);fflush(stderr); 484 } 485 486 fprintf(stderr,"\tapp.. %p\n", q->append);fflush(stderr); 487 Tcl_ListObjGetElements (NULL, q->append, &listc, &listv); 488 for (k=0; k < listc; k++) { 489 fprintf(stderr,"\tapp.. %p [%d] = %p '%s' /%d\n", q->append, k, listv[k], Tcl_GetString(listv[k]), listv[k]->refCount);fflush(stderr); 490 } 491 492 fprintf(stderr,"qdump/ ___________________\n");fflush(stderr); 493} 494#endif 495 496/* 497 * Local Variables: 498 * mode: c 499 * c-basic-offset: 4 500 * fill-column: 78 501 * End: 502 */ 503