3 * Vectors and arrays in Tcl
5 * (c) 2003 Mark Wooding
8 /*----- Licensing notice --------------------------------------------------*
10 * This program is free software; you can redistribute it and/or modify
11 * it under the terms of the GNU General Public License as published by
12 * the Free Software Foundation; either version 2 of the License, or
13 * (at your option) any later version.
15 * This program is distributed in the hope that it will be useful,
16 * but WITHOUT ANY WARRANTY; without even the implied warranty of
17 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 * GNU General Public License for more details.
20 * You should have received a copy of the GNU General Public License
21 * along with this program; if not, write to the Free Software Foundation,
22 * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
25 /*----- Header files ------------------------------------------------------*/
36 /*----- Static variables --------------------------------------------------*/
38 static unsigned seq
= 0;
40 /*----- Underlying excitement ---------------------------------------------*/
42 static Tcl_ObjCmdProc vec_command
;
44 static int err(Tcl_Interp
*ti
, /*const*/ char *p
)
46 Tcl_SetResult(ti
, p
, TCL_STATIC
);
50 /* --- @vec_find@ --- *
52 * Arguments: @Tcl_Interp *ti@ = interpreter vector exists in
53 * @Tcl_Obj *o@ = object containing the command name
55 * Returns: A pointer to the vector, or null.
57 * Use: Finds the vector with a given name.
60 vec
*vec_find(Tcl_Interp
*ti
, Tcl_Obj
*o
)
64 const char *p
= Tcl_GetStringFromObj(o
, &len
);
66 if (strncmp(p
, "vec@", 4) != 0) {
67 err(ti
, "unknown vector");
70 if (!Tcl_GetCommandInfo(ti
, p
, &ci
)) {
71 err(ti
, "unknown vector");
74 return ((vec
*)ci
.objClientData
);
77 /* --- @vec_index@ --- *
79 * Arguments: @Tcl_Interp *ti@ = interpreter to put errors in
80 * @vec *v@ = the vector
81 * @int objc@ = number of indices provided
82 * @Tcl_Obj *const *objv@ = vector of objects
84 * Returns: Address of the object pointer, or null.
86 * Use: Looks up an index in a vector.
89 Tcl_Obj
**vec_index(Tcl_Interp
*ti
, vec
*v
, int objc
, Tcl_Obj
*const *objv
)
94 if (objc
!= v
->ndim
) {
95 err(ti
, "dimension mismatch");
99 for (i
= 0; i
< objc
; i
++) {
101 if (Tcl_GetLongFromObj(ti
, objv
[i
], &l
) != TCL_OK
)
103 if (l
< v
->dim
[i
].lo
|| l
>= v
->dim
[i
].hi
) {
104 err(ti
, "index out of range");
107 n
= n
* (v
->dim
[i
].hi
- v
->dim
[i
].lo
) + (l
- v
->dim
[i
].lo
);
113 /* --- @vec_delete@ --- *
115 * Arguments: @ClientData cd@ = vector pointer
119 * Use: Destroys a vector.
122 static void vec_delete(ClientData cd
)
128 for (i
= 0; i
< v
->n
; i
++)
129 Tcl_DecrRefCount(v
->v
[i
]);
130 Tcl_Free((void *)v
->v
);
133 Tcl_Free((void *)v
->dim
);
137 /* --- @vec_destroy@ --- *
139 * Arguments: @Tcl_Interp *ti@ = owning interpreter
140 * @vec *v@ = vector pointer
144 * Use: Destroys a vector.
147 void vec_destroy(Tcl_Interp
*ti
, vec
*v
)
149 Tcl_DeleteCommandFromToken(ti
, v
->c
);
152 /* --- @vec_command@ --- *
154 * Arguments: @ClientData cd@ = vector pointer
155 * @Tcl_Interp *ti@ = interpreter
156 * @int objc@ = number of arguments
157 * @Tcl_Obj *const *objv@ = vector of arguments
159 * Returns: A Tcl return code.
161 * Use: Various things.
164 static int vec_command(ClientData cd
, Tcl_Interp
*ti
,
165 int objc
, Tcl_Obj
*const *objv
)
171 return (err(ti
, "usage: VECTOR SUBCOMMAND ARGS..."));
172 sub
= Tcl_GetStringFromObj(objv
[1], 0);
173 if (strcmp(sub
, "destroy") == 0)
174 Tcl_DeleteCommandFromToken(ti
, v
->c
);
175 else if (strcmp(sub
, "get") == 0) {
177 if (objc
!= v
->ndim
+ 2)
178 return (err(ti
, "usage: VECTOR get INDEX ..."));
179 if ((o
= vec_index(ti
, v
, objc
- 2, objv
+ 2)) == 0)
181 Tcl_SetObjResult(ti
, *o
);
182 } else if (strcmp(sub
, "lget") == 0) {
187 return (err(ti
, "usage: VECTOR lget LIST"));
188 if (Tcl_ListObjGetElements(ti
, objv
[2], &lc
, &lv
) != TCL_OK
)
190 if ((o
= vec_index(ti
, v
, lc
, lv
)) == 0)
192 Tcl_SetObjResult(ti
, *o
);
193 } else if (strcmp(sub
, "rget") == 0) {
196 return (err(ti
, "usage: VECTOR rget INDEX"));
197 if (Tcl_GetLongFromObj(ti
, objv
[2], &n
) != TCL_OK
)
199 if (n
< 0 || n
>= v
->n
)
200 return (err(ti
, "raw index out of range"));
201 Tcl_SetObjResult(ti
, v
->v
[n
]);
202 } else if (strcmp(sub
, "set") == 0) {
204 if (objc
!= v
->ndim
+ 3)
205 return (err(ti
, "usage: VECTOR set INDEX ... VALUE"));
206 if ((o
= vec_index(ti
, v
, objc
- 3, objv
+ 2)) == 0)
208 Tcl_DecrRefCount(*o
);
210 Tcl_IncrRefCount(*o
);
211 } else if (strcmp(sub
, "lset") == 0) {
216 return (err(ti
, "usage: VECTOR lset LIST VALUE"));
217 if (Tcl_ListObjGetElements(ti
, objv
[2], &lc
, &lv
) != TCL_OK
)
219 if ((o
= vec_index(ti
, v
, lc
, lv
)) == 0)
221 Tcl_DecrRefCount(*o
);
223 Tcl_IncrRefCount(*o
);
224 } else if (strcmp(sub
, "rset") == 0) {
227 return (err(ti
, "usage: VECTOR rset INDEX VALUE"));
228 if (Tcl_GetLongFromObj(ti
, objv
[2], &n
) != TCL_OK
)
230 if (n
< 0 || n
>= v
->n
)
231 return (err(ti
, "raw index out of range"));
232 Tcl_DecrRefCount(v
->v
[n
]);
234 Tcl_IncrRefCount(v
->v
[n
]);
235 } else if (strcmp(sub
, "bounds") == 0) {
236 Tcl_Obj
*l
= Tcl_NewListObj(0, 0);
238 for (i
= 0; i
< v
->ndim
; i
++) {
239 Tcl_Obj
*b
= Tcl_NewListObj(0, 0);
240 Tcl_ListObjAppendElement(ti
, b
, Tcl_NewLongObj(v
->dim
[i
].lo
));
241 Tcl_ListObjAppendElement(ti
, b
, Tcl_NewLongObj(v
->dim
[i
].hi
));
242 Tcl_ListObjAppendElement(ti
, l
, b
);
244 Tcl_SetObjResult(ti
, l
);
245 } else if (strcmp(sub
, "size") == 0) {
246 Tcl_SetObjResult(ti
, Tcl_NewLongObj(v
->n
));
248 return (err(ti
, "unknown vector subcommand"));
252 /* --- @vec_create@ --- *
254 * Arguments: @Tcl_Interp *ti@ = interpreter to create vector in
255 * @size_t ndim@ = number of dimensions
256 * @const vec_bound *dim@ = the actual dimensions
257 * @Tcl_Obj *init@ = initial value
259 * Returns: A pointer to the vector, or null if it failed.
261 * Use: Creates a new vector object.
264 vec
*vec_create(Tcl_Interp
*ti
, size_t ndim
, const vec_bound
*dim
,
267 vec
*v
= (void *)Tcl_Alloc(sizeof(*v
));
272 for (i
= 0; i
< ndim
; i
++) {
273 if (dim
[i
].lo
> dim
[i
].hi
) {
275 err(ti
, "bad vector index bounds");
278 n
*= dim
[i
].hi
- dim
[i
].lo
;
281 sprintf(buf
, "vec@%u", seq
++);
282 if ((v
->c
= Tcl_CreateObjCommand(ti
, buf
, vec_command
,
283 (ClientData
)v
, vec_delete
)) == 0) {
292 v
->dim
= (void *)Tcl_Alloc(ndim
* sizeof(*v
->dim
));
293 memcpy(v
->dim
, dim
, ndim
* sizeof(*v
->dim
));
299 v
->v
= (void *)Tcl_Alloc(n
* sizeof(Tcl_Obj
*));
300 for (i
= 0; i
< n
; i
++) {
303 Tcl_IncrRefCount(v
->v
[i
]);
309 /* --- @vec_new@ --- *
311 * Arguments: @ClientData cd@ = vector pointer
312 * @Tcl_Interp *ti@ = interpreter
313 * @int objc@ = number of arguments
314 * @Tcl_Obj *const *objv@ = vector of arguments
316 * Returns: A Tcl return code.
318 * Use: Tcl command for making a new vector.
321 static int vec_new(ClientData cd
, Tcl_Interp
*ti
,
322 int objc
, Tcl_Obj
*const *objv
)
333 if (objc
< 2 || objc
> 3)
334 return (err(ti
, "usage: vector LIST [INIT]"));
335 if (Tcl_ListObjGetElements(ti
, objv
[1], &lc
, &lv
) != TCL_OK
)
339 dim
= (void *)Tcl_Alloc(ndim
* sizeof(*dim
));
340 for (i
= 0; i
< ndim
; i
++) {
341 if (Tcl_ListObjGetElements(ti
, lv
[i
], &bc
, &bv
) != TCL_OK
)
345 if (Tcl_GetLongFromObj(ti
, bv
[0], &dim
[i
].hi
) != TCL_OK
)
347 } else if (bc
== 2) {
348 if (Tcl_GetLongFromObj(ti
, bv
[0], &dim
[i
].lo
) != TCL_OK
||
349 Tcl_GetLongFromObj(ti
, bv
[1], &dim
[i
].hi
) != TCL_OK
)
352 err(ti
, "bad bounds spec");
355 if (dim
[i
].lo
> dim
[i
].hi
) {
356 err(ti
, "bad bounds spec");
365 Tcl_IncrRefCount(init
);
366 if ((v
= vec_create(ti
, ndim
, dim
, init
)) == 0)
368 Tcl_SetResult(ti
, (/*unconst */char *)Tcl_GetCommandName(ti
, v
->c
),
373 if (dim
) Tcl_Free((void *)dim
);
374 if (init
) Tcl_DecrRefCount(init
);
378 /* --- Initialization --- */
380 int Vec_SafeInit(Tcl_Interp
*ti
)
382 Tcl_CreateObjCommand(ti
, "vector", vec_new
, 0, 0);
383 if (Tcl_PkgProvide(ti
, "vector", "1.0.0"))
388 int Vec_Init(Tcl_Interp
*ti
)
390 return (Vec_SafeInit(ti
));
393 /*----- That's all, folks -------------------------------------------------*/