3
# Implementation of a queue data structure for Tcl.
4
# This code based on critcl v3.1, API compatible to the PTI [x].
5
# [x] Pure Tcl Implementation.
7
# Mainly demonstrates the utility package for the creation of classes
8
# and objects in C, with both claaes and their instances represented
9
# as Tcl commands. In contrast to the stackc demo this does not use a
10
# separate data structure package, nor separately written method
13
# Copyright (c) 2012 Andreas Kupries <andreas_kupries@users.sourceforge.net>
15
# See the file "license.terms" for information on usage and redistribution
16
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
18
# RCS: @(#) $Id: queuec.tcl,v 1.1 2008/06/19 23:03:35 andreas_kupries Exp $
20
package require Tcl 8.4
21
package require critcl 3.1
23
critcl::buildrequirement {
24
package require critcl::class ; # DSL, easy spec of Tcl class/object commands.
27
# # ## ### ##### ######## ############# #####################
30
critcl::license {Andreas Kupries} {BSD licensed}
32
critcl::summary {Queue objects for Tcl.}
35
This package implements queue objects
40
critcl::subject {data structure}
41
critcl::subject structure
42
critcl::subject {abstract data structure}
43
critcl::subject {generic data structure}
45
# # ## ### ##### ######## ############# #####################
46
## Configuration and implementation.
48
critcl::cheaders util.h
50
critcl::class::define ::queuec {
55
Tcl_AppendResult (interp, "wrong\#args for constructor, expected none", NULL);
62
# # ## ### ##### ######## ############# #####################
63
insvariable Tcl_Obj* unget {
64
List object holding unget'ted elements.
66
instance->unget = Tcl_NewListObj (0,NULL);
67
Tcl_IncrRefCount (instance->unget);
69
Tcl_DecrRefCount (instance->unget);
72
# # ## ### ##### ######## ############# #####################
73
insvariable Tcl_Obj* queue {
74
List object holding the main queue.
76
instance->queue = Tcl_NewListObj (0,NULL);
77
Tcl_IncrRefCount (instance->queue);
79
Tcl_DecrRefCount (instance->queue);
82
# # ## ### ##### ######## ############# #####################
83
insvariable Tcl_Obj* append {
84
List object holding new elements
86
instance->append = Tcl_NewListObj (0,NULL);
87
Tcl_IncrRefCount (instance->append);
89
Tcl_DecrRefCount (instance->append);
92
# # ## ### ##### ######## ############# #####################
94
Index of next element to return from the main queue.
98
} ; # no need for a destructor
100
# # ## ### ##### ######## ############# #####################
101
method clear proc {} void {
103
* Delete and recreate the queue memory. A combination of delete/new,
104
* except the main structure is left unchanged
107
Tcl_DecrRefCount (instance->unget);
108
Tcl_DecrRefCount (instance->queue);
109
Tcl_DecrRefCount (instance->append);
112
instance->unget = Tcl_NewListObj (0,NULL);
113
instance->queue = Tcl_NewListObj (0,NULL);
114
instance->append = Tcl_NewListObj (0,NULL);
116
Tcl_IncrRefCount (instance->unget);
117
Tcl_IncrRefCount (instance->queue);
118
Tcl_IncrRefCount (instance->append);
121
# # ## ### ##### ######## ############# #####################
122
method get as QueueRetrieve 1
123
method peek as QueueRetrieve 0
125
# # ## ### ##### ######## ############# #####################
132
Tcl_WrongNumArgs (interp, 2, objv, "item ?item ...?");
136
for (i = 2; i < objc; i++) {
137
Tcl_ListObjAppendElement (interp, instance->append, objv[i]);
143
# # ## ### ##### ######## ############# #####################
144
method size proc {} int {
145
return QueueSize (instance, NULL, NULL, NULL);
148
# # ## ### ##### ######## ############# #####################
149
method unget proc {Tcl_Obj* item} ok {
150
if (instance->at == 0) {
151
/* Need the unget stack */
152
Tcl_ListObjAppendElement (interp, instance->unget, item);
155
* We have room in the return buffer, so splice directly instead of
156
* using the unget stack.
160
Tcl_ListObjLength (NULL, instance->queue, &queuec);
163
ASSERT_BOUNDS(instance->at,queuec);
164
Tcl_ListObjReplace (interp, instance->queue, instance->at, 1, 1, &item);
170
# # ## ### ##### ######## ############# #####################
173
QueueSize (@instancetype@ q, int* u, int* r, int* a)
179
Tcl_ListObjLength (NULL, q->unget, &ungetc);
180
Tcl_ListObjLength (NULL, q->queue, &queuec);
181
Tcl_ListObjLength (NULL, q->append, &appendc);
187
return ungetc + queuec + appendc - q->at;
191
QueueShift (@instancetype@ q)
196
/* The queue is not done yet, no shift */
197
Tcl_ListObjLength (NULL, q->queue, &queuec);
198
if (q->at < queuec) return;
200
/* The queue is done, however there is nothing
201
* to shift into it, so we don't
203
Tcl_ListObjLength (NULL, q->append, &appendc);
204
if (!appendc) return;
207
Tcl_DecrRefCount (q->queue);
208
q->queue = q->append;
209
q->append = Tcl_NewListObj (0,NULL);
210
Tcl_IncrRefCount (q->append);
214
QueueRetrieve (@instancetype@ instance,
217
Tcl_Obj* CONST* objv,
220
/* Syntax: queue peek|get ?n?
232
if ((objc != 2) && (objc != 3)) {
233
Tcl_WrongNumArgs (interp, 2, objv, "?n?");
238
if (Tcl_GetIntFromObj(interp, objv[2], &n) != TCL_OK) {
241
Tcl_AppendResult (interp, "invalid item count ",
242
Tcl_GetString (objv[2]),
248
if (n > QueueSize(instance, &ungetc, &queuec, &appendc)) {
249
Tcl_AppendResult (interp,
250
"insufficient items in queue to fill request",
255
/* 1. We have item on the unget stack
256
* a. Enough to satisfy request.
258
* 2. We have items in the return buffer.
259
* a. Enough to satisfy request.
261
* 3. We have items in the append buffer.
262
* a. Enough to satisfy request.
265
* Case 3. can assume 2b, because an empty return buffer will be filled
266
* from the append buffer before looking at either. Case 3. cannot happen
267
* for n==1, the return buffer will contain at least one element.
269
* We distinguish between single and multi-element requests.
271
* XXX AK optimizations - If we can return everything from a single
272
* buffer, be it queue, or append, just return the buffer object, do not
273
* create something new.
278
/* Pull from unget stack */
279
Tcl_ListObjGetElements (interp, instance->unget, &listc, &listv);
281
Tcl_SetObjResult (interp, r);
283
/* XXX AK : Should maintain max size info, and proper index, for discard. */
284
Tcl_ListObjReplace (interp, instance->unget, listc-1, 1, 0, NULL);
287
QueueShift (instance);
288
Tcl_ListObjGetElements (interp, instance->queue, &listc, &listv);
289
ASSERT_BOUNDS(instance->at,listc);
290
r = listv [instance->at];
291
Tcl_SetObjResult (interp, r);
293
* Note: Doing the SetObj now is important. It increments the
294
* refcount of 'r', allowing it to survive if the 'QueueShift' below
295
* kills the internal list (instance->queue) holding it.
299
QueueShift (instance);
304
* Allocate buffer for result, then fill it using the various data
309
Tcl_Obj** resv = NALLOC(n,Tcl_Obj*);
312
Tcl_ListObjGetElements (interp, instance->unget, &listc, &listv);
314
* Note how we are iterating backward in listv. unget is managed
315
* as a stack, avoiding mem-copy operations and both push and pop.
321
ASSERT_BOUNDS(j,listc);
323
Tcl_IncrRefCount (resv[i]);
326
/* XXX AK : Should maintain max size info, and proper index, for discard. */
327
Tcl_ListObjReplace (interp, instance->unget, j, i, 0, NULL);
328
/* XXX CHECK index calcs. */
332
QueueShift (instance);
333
Tcl_ListObjGetElements (interp, instance->queue, &listc, &listv);
334
for (j = instance->at;
338
ASSERT_BOUNDS(j,listc);
340
Tcl_IncrRefCount (resv[i]);
345
QueueShift (instance);
348
Tcl_ListObjGetElements (interp, instance->append, &listc, &listv);
353
ASSERT_BOUNDS(j,listc);
355
Tcl_IncrRefCount (resv[i]);
361
* This can happen if and only if we have to pull data from append,
362
* and get is set. Without get XX would have run and filled the result
367
ASSERT(get,"Impossible 2nd return pull witohut get");
368
QueueShift (instance);
369
Tcl_ListObjGetElements (interp, instance->queue, &listc, &listv);
370
for (j = instance->at;
374
ASSERT_BOUNDS(j,listc);
376
Tcl_IncrRefCount (resv[i]);
379
QueueShift (instance);
382
r = Tcl_NewListObj (n, resv);
383
Tcl_SetObjResult (interp, r);
386
Tcl_DecrRefCount (resv[i]);
396
# ### ### ### ######### ######### #########
398
package provide queuec 1
added
removed
examples/queue/queuec.tcl
