5 * Vectors and arrays in Tcl
7 * (c) 2003 Mark Wooding
10 /*----- Licensing notice --------------------------------------------------*
12 * This program is free software; you can redistribute it and/or modify
13 * it under the terms of the GNU General Public License as published by
14 * the Free Software Foundation; either version 2 of the License, or
15 * (at your option) any later version.
17 * This program is distributed in the hope that it will be useful,
18 * but WITHOUT ANY WARRANTY; without even the implied warranty of
19 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 * GNU General Public License for more details.
22 * You should have received a copy of the GNU General Public License
23 * along with this program; if not, write to the Free Software Foundation,
24 * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
27 /*----- Header files ------------------------------------------------------*/
38 /*----- Static variables --------------------------------------------------*/
40 static unsigned seq = 0;
42 /*----- Underlying excitement ---------------------------------------------*/
44 static Tcl_ObjCmdProc vec_command;
46 static int err(Tcl_Interp *ti, /*const*/ char *p)
48 Tcl_SetResult(ti, p, TCL_STATIC);
52 /* --- @vec_find@ --- *
54 * Arguments: @Tcl_Interp *ti@ = interpreter vector exists in
55 * @Tcl_Obj *o@ = object containing the command name
57 * Returns: A pointer to the vector, or null.
59 * Use: Finds the vector with a given name.
62 vec *vec_find(Tcl_Interp *ti, Tcl_Obj *o)
66 const char *p = Tcl_GetStringFromObj(o, &len);
68 if (strncmp(p, "vec@", 4) != 0) {
69 err(ti, "unknown vector");
72 if (!Tcl_GetCommandInfo(ti, p, &ci)) {
73 err(ti, "unknown vector");
76 return ((vec *)ci.objClientData);
79 /* --- @vec_index@ --- *
81 * Arguments: @Tcl_Interp *ti@ = interpreter to put errors in
82 * @vec *v@ = the vector
83 * @int objc@ = number of indices provided
84 * @Tcl_Obj *const *objv@ = vector of objects
86 * Returns: Address of the object pointer, or null.
88 * Use: Looks up an index in a vector.
91 Tcl_Obj **vec_index(Tcl_Interp *ti, vec *v, int objc, Tcl_Obj *const *objv)
96 if (objc != v->ndim) {
97 err(ti, "dimension mismatch");
101 for (i = 0; i < objc; i++) {
103 if (Tcl_GetLongFromObj(ti, objv[i], &l) != TCL_OK)
105 if (l < v->dim[i].lo || l >= v->dim[i].hi) {
106 err(ti, "index out of range");
109 n = n * (v->dim[i].hi - v->dim[i].lo) + (l - v->dim[i].lo);
115 /* --- @vec_delete@ --- *
117 * Arguments: @ClientData cd@ = vector pointer
121 * Use: Destroys a vector.
124 static void vec_delete(ClientData cd)
130 for (i = 0; i < v->n; i++)
131 Tcl_DecrRefCount(v->v[i]);
132 Tcl_Free((void *)v->v);
135 Tcl_Free((void *)v->dim);
139 /* --- @vec_destroy@ --- *
141 * Arguments: @Tcl_Interp *ti@ = owning interpreter
142 * @vec *v@ = vector pointer
146 * Use: Destroys a vector.
149 void vec_destroy(Tcl_Interp *ti, vec *v)
151 Tcl_DeleteCommandFromToken(ti, v->c);
154 /* --- @vec_command@ --- *
156 * Arguments: @ClientData cd@ = vector pointer
157 * @Tcl_Interp *ti@ = interpreter
158 * @int objc@ = number of arguments
159 * @Tcl_Obj *const *objv@ = vector of arguments
161 * Returns: A Tcl return code.
163 * Use: Various things.
166 static int vec_command(ClientData cd, Tcl_Interp *ti,
167 int objc, Tcl_Obj *const *objv)
173 return (err(ti, "usage: VECTOR SUBCOMMAND ARGS..."));
174 sub = Tcl_GetStringFromObj(objv[1], 0);
175 if (strcmp(sub, "destroy") == 0)
176 Tcl_DeleteCommandFromToken(ti, v->c);
177 else if (strcmp(sub, "get") == 0) {
179 if (objc != v->ndim + 2)
180 return (err(ti, "usage: VECTOR get INDEX ..."));
181 if ((o = vec_index(ti, v, objc - 2, objv + 2)) == 0)
183 Tcl_SetObjResult(ti, *o);
184 } else if (strcmp(sub, "lget") == 0) {
189 return (err(ti, "usage: VECTOR lget LIST"));
190 if (Tcl_ListObjGetElements(ti, objv[2], &lc, &lv) != TCL_OK)
192 if ((o = vec_index(ti, v, lc, lv)) == 0)
194 Tcl_SetObjResult(ti, *o);
195 } else if (strcmp(sub, "rget") == 0) {
198 return (err(ti, "usage: VECTOR rget INDEX"));
199 if (Tcl_GetLongFromObj(ti, objv[2], &n) != TCL_OK)
201 if (n < 0 || n >= v->n)
202 return (err(ti, "raw index out of range"));
203 Tcl_SetObjResult(ti, v->v[n]);
204 } else if (strcmp(sub, "set") == 0) {
206 if (objc != v->ndim + 3)
207 return (err(ti, "usage: VECTOR set INDEX ... VALUE"));
208 if ((o = vec_index(ti, v, objc - 3, objv + 2)) == 0)
210 Tcl_DecrRefCount(*o);
212 Tcl_IncrRefCount(*o);
213 } else if (strcmp(sub, "lset") == 0) {
218 return (err(ti, "usage: VECTOR lset LIST VALUE"));
219 if (Tcl_ListObjGetElements(ti, objv[2], &lc, &lv) != TCL_OK)
221 if ((o = vec_index(ti, v, lc, lv)) == 0)
223 Tcl_DecrRefCount(*o);
225 Tcl_IncrRefCount(*o);
226 } else if (strcmp(sub, "rset") == 0) {
229 return (err(ti, "usage: VECTOR rset INDEX VALUE"));
230 if (Tcl_GetLongFromObj(ti, objv[2], &n) != TCL_OK)
232 if (n < 0 || n >= v->n)
233 return (err(ti, "raw index out of range"));
234 Tcl_DecrRefCount(v->v[n]);
236 Tcl_IncrRefCount(v->v[n]);
237 } else if (strcmp(sub, "bounds") == 0) {
238 Tcl_Obj *l = Tcl_NewListObj(0, 0);
240 for (i = 0; i < v->ndim; i++) {
241 Tcl_Obj *b = Tcl_NewListObj(0, 0);
242 Tcl_ListObjAppendElement(ti, b, Tcl_NewLongObj(v->dim[i].lo));
243 Tcl_ListObjAppendElement(ti, b, Tcl_NewLongObj(v->dim[i].hi));
244 Tcl_ListObjAppendElement(ti, l, b);
246 Tcl_SetObjResult(ti, l);
247 } else if (strcmp(sub, "size") == 0) {
248 Tcl_SetObjResult(ti, Tcl_NewLongObj(v->n));
250 return (err(ti, "unknown vector subcommand"));
254 /* --- @vec_create@ --- *
256 * Arguments: @Tcl_Interp *ti@ = interpreter to create vector in
257 * @size_t ndim@ = number of dimensions
258 * @const vec_bound *dim@ = the actual dimensions
259 * @Tcl_Obj *init@ = initial value
261 * Returns: A pointer to the vector, or null if it failed.
263 * Use: Creates a new vector object.
266 vec *vec_create(Tcl_Interp *ti, size_t ndim, const vec_bound *dim,
269 vec *v = (void *)Tcl_Alloc(sizeof(*v));
274 for (i = 0; i < ndim; i++) {
275 if (dim[i].lo > dim[i].hi) {
277 err(ti, "bad vector index bounds");
280 n *= dim[i].hi - dim[i].lo;
283 sprintf(buf, "vec@%u", seq++);
284 if ((v->c = Tcl_CreateObjCommand(ti, buf, vec_command,
285 (ClientData)v, vec_delete)) == 0) {
294 v->dim = (void *)Tcl_Alloc(ndim * sizeof(*v->dim));
295 memcpy(v->dim, dim, ndim * sizeof(*v->dim));
301 v->v = (void *)Tcl_Alloc(n * sizeof(Tcl_Obj *));
302 for (i = 0; i < n; i++) {
305 Tcl_IncrRefCount(v->v[i]);
311 /* --- @vec_new@ --- *
313 * Arguments: @ClientData cd@ = vector pointer
314 * @Tcl_Interp *ti@ = interpreter
315 * @int objc@ = number of arguments
316 * @Tcl_Obj *const *objv@ = vector of arguments
318 * Returns: A Tcl return code.
320 * Use: Tcl command for making a new vector.
323 static int vec_new(ClientData cd, Tcl_Interp *ti,
324 int objc, Tcl_Obj *const *objv)
335 if (objc < 2 || objc > 3)
336 return (err(ti, "usage: vector LIST [INIT]"));
337 if (Tcl_ListObjGetElements(ti, objv[1], &lc, &lv) != TCL_OK)
341 dim = (void *)Tcl_Alloc(ndim * sizeof(*dim));
342 for (i = 0; i < ndim; i++) {
343 if (Tcl_ListObjGetElements(ti, lv[i], &bc, &bv) != TCL_OK)
347 if (Tcl_GetLongFromObj(ti, bv[0], &dim[i].hi) != TCL_OK)
349 } else if (bc == 2) {
350 if (Tcl_GetLongFromObj(ti, bv[0], &dim[i].lo) != TCL_OK ||
351 Tcl_GetLongFromObj(ti, bv[1], &dim[i].hi) != TCL_OK)
354 err(ti, "bad bounds spec");
357 if (dim[i].lo > dim[i].hi) {
358 err(ti, "bad bounds spec");
367 Tcl_IncrRefCount(init);
368 if ((v = vec_create(ti, ndim, dim, init)) == 0)
370 Tcl_SetResult(ti, Tcl_GetCommandName(ti, v->c), TCL_STATIC);
374 if (dim) Tcl_Free((void *)dim);
375 if (init) Tcl_DecrRefCount(init);
379 /* --- Initialization --- */
381 int Vec_SafeInit(Tcl_Interp *ti)
383 Tcl_CreateObjCommand(ti, "vector", vec_new, 0, 0);
384 if (Tcl_PkgProvide(ti, "vector", "1.0.0"))
389 int Vec_Init(Tcl_Interp *ti)
391 return (Vec_SafeInit(ti));
394 /*----- That's all, folks -------------------------------------------------*/