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
, (/*unconst */char *)Tcl_GetCommandName(ti
, v
->c
),
375 if (dim
) Tcl_Free((void *)dim
);
376 if (init
) Tcl_DecrRefCount(init
);
380 /* --- Initialization --- */
382 int Vec_SafeInit(Tcl_Interp
*ti
)
384 Tcl_CreateObjCommand(ti
, "vector", vec_new
, 0, 0);
385 if (Tcl_PkgProvide(ti
, "vector", "1.0.0"))
390 int Vec_Init(Tcl_Interp
*ti
)
392 return (Vec_SafeInit(ti
));
395 /*----- That's all, folks -------------------------------------------------*/