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