3 * $Id: vec.c,v 1.1 2003/03/07 00:45:35 mdw Exp $
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 /*----- Revision history --------------------------------------------------*
30 * Revision 1.1 2003/03/07 00:45:35 mdw
31 * A multidimensional vector/matrix type which is updateable in place.
35 /*----- Header files ------------------------------------------------------*/
46 /*----- Static variables --------------------------------------------------*/
48 static unsigned seq
= 0;
50 /*----- Underlying excitement ---------------------------------------------*/
52 static Tcl_ObjCmdProc vec_command
;
54 static int err(Tcl_Interp
*ti
, /*const*/ char *p
)
56 Tcl_SetResult(ti
, p
, TCL_STATIC
);
60 /* --- @vec_find@ --- *
62 * Arguments: @Tcl_Interp *ti@ = interpreter vector exists in
63 * @Tcl_Obj *o@ = object containing the command name
65 * Returns: A pointer to the vector, or null.
67 * Use: Finds the vector with a given name.
70 vec
*vec_find(Tcl_Interp
*ti
, Tcl_Obj
*o
)
74 const char *p
= Tcl_GetStringFromObj(o
, &len
);
76 if (strncmp(p
, "vec@", 4) != 0) {
77 err(ti
, "unknown vector");
80 if (!Tcl_GetCommandInfo(ti
, p
, &ci
)) {
81 err(ti
, "unknown vector");
84 return ((vec
*)ci
.objClientData
);
87 /* --- @vec_index@ --- *
89 * Arguments: @Tcl_Interp *ti@ = interpreter to put errors in
90 * @vec *v@ = the vector
91 * @int objc@ = number of indices provided
92 * @Tcl_Obj *const *objv@ = vector of objects
94 * Returns: Address of the object pointer, or null.
96 * Use: Looks up an index in a vector.
99 Tcl_Obj
**vec_index(Tcl_Interp
*ti
, vec
*v
, int objc
, Tcl_Obj
*const *objv
)
104 if (objc
!= v
->ndim
) {
105 err(ti
, "dimension mismatch");
109 for (i
= 0; i
< objc
; i
++) {
111 if (Tcl_GetLongFromObj(ti
, objv
[i
], &l
) != TCL_OK
)
113 if (l
< v
->dim
[i
].lo
|| l
>= v
->dim
[i
].hi
) {
114 err(ti
, "index out of range");
117 n
= n
* (v
->dim
[i
].hi
- v
->dim
[i
].lo
) + (l
- v
->dim
[i
].lo
);
123 /* --- @vec_delete@ --- *
125 * Arguments: @ClientData cd@ = vector pointer
129 * Use: Destroys a vector.
132 static void vec_delete(ClientData cd
)
138 for (i
= 0; i
< v
->n
; i
++)
139 Tcl_DecrRefCount(v
->v
[i
]);
140 Tcl_Free((void *)v
->v
);
143 Tcl_Free((void *)v
->dim
);
147 /* --- @vec_destroy@ --- *
149 * Arguments: @Tcl_Interp *ti@ = owning interpreter
150 * @vec *v@ = vector pointer
154 * Use: Destroys a vector.
157 void vec_destroy(Tcl_Interp
*ti
, vec
*v
)
159 Tcl_DeleteCommandFromToken(ti
, v
->c
);
162 /* --- @vec_command@ --- *
164 * Arguments: @ClientData cd@ = vector pointer
165 * @Tcl_Interp *ti@ = interpreter
166 * @int objc@ = number of arguments
167 * @Tcl_Obj *const *objv@ = vector of arguments
169 * Returns: A Tcl return code.
171 * Use: Various things.
174 static int vec_command(ClientData cd
, Tcl_Interp
*ti
,
175 int objc
, Tcl_Obj
*const *objv
)
181 return (err(ti
, "usage: VECTOR SUBCOMMAND ARGS..."));
182 sub
= Tcl_GetStringFromObj(objv
[1], 0);
183 if (strcmp(sub
, "destroy") == 0)
184 Tcl_DeleteCommandFromToken(ti
, v
->c
);
185 else if (strcmp(sub
, "get") == 0) {
187 if (objc
!= v
->ndim
+ 2)
188 return (err(ti
, "usage: VECTOR get INDEX ..."));
189 if ((o
= vec_index(ti
, v
, objc
- 2, objv
+ 2)) == 0)
191 Tcl_SetObjResult(ti
, *o
);
192 } else if (strcmp(sub
, "lget") == 0) {
197 return (err(ti
, "usage: VECTOR lget LIST"));
198 if (Tcl_ListObjGetElements(ti
, objv
[2], &lc
, &lv
) != TCL_OK
)
200 if ((o
= vec_index(ti
, v
, lc
, lv
)) == 0)
202 Tcl_SetObjResult(ti
, *o
);
203 } else if (strcmp(sub
, "rget") == 0) {
206 return (err(ti
, "usage: VECTOR rget INDEX"));
207 if (Tcl_GetLongFromObj(ti
, objv
[2], &n
) != TCL_OK
)
209 if (n
< 0 || n
>= v
->n
)
210 return (err(ti
, "raw index out of range"));
211 Tcl_SetObjResult(ti
, v
->v
[n
]);
212 } else if (strcmp(sub
, "set") == 0) {
214 if (objc
!= v
->ndim
+ 3)
215 return (err(ti
, "usage: VECTOR set INDEX ... VALUE"));
216 if ((o
= vec_index(ti
, v
, objc
- 3, objv
+ 2)) == 0)
218 Tcl_DecrRefCount(*o
);
220 Tcl_IncrRefCount(*o
);
221 } else if (strcmp(sub
, "lset") == 0) {
226 return (err(ti
, "usage: VECTOR lset LIST VALUE"));
227 if (Tcl_ListObjGetElements(ti
, objv
[2], &lc
, &lv
) != TCL_OK
)
229 if ((o
= vec_index(ti
, v
, lc
, lv
)) == 0)
231 Tcl_DecrRefCount(*o
);
233 Tcl_IncrRefCount(*o
);
234 } else if (strcmp(sub
, "rset") == 0) {
237 return (err(ti
, "usage: VECTOR rset INDEX VALUE"));
238 if (Tcl_GetLongFromObj(ti
, objv
[2], &n
) != TCL_OK
)
240 if (n
< 0 || n
>= v
->n
)
241 return (err(ti
, "raw index out of range"));
242 Tcl_DecrRefCount(v
->v
[n
]);
244 Tcl_IncrRefCount(v
->v
[n
]);
245 } else if (strcmp(sub
, "bounds") == 0) {
246 Tcl_Obj
*l
= Tcl_NewListObj(0, 0);
248 for (i
= 0; i
< v
->ndim
; i
++) {
249 Tcl_Obj
*b
= Tcl_NewListObj(0, 0);
250 Tcl_ListObjAppendElement(ti
, b
, Tcl_NewLongObj(v
->dim
[i
].lo
));
251 Tcl_ListObjAppendElement(ti
, b
, Tcl_NewLongObj(v
->dim
[i
].hi
));
252 Tcl_ListObjAppendElement(ti
, l
, b
);
254 Tcl_SetObjResult(ti
, l
);
255 } else if (strcmp(sub
, "size") == 0) {
256 Tcl_SetObjResult(ti
, Tcl_NewLongObj(v
->n
));
258 return (err(ti
, "unknown vector subcommand"));
262 /* --- @vec_create@ --- *
264 * Arguments: @Tcl_Interp *ti@ = interpreter to create vector in
265 * @size_t ndim@ = number of dimensions
266 * @const vec_bound *dim@ = the actual dimensions
267 * @Tcl_Obj *init@ = initial value
269 * Returns: A pointer to the vector, or null if it failed.
271 * Use: Creates a new vector object.
274 vec
*vec_create(Tcl_Interp
*ti
, size_t ndim
, const vec_bound
*dim
,
277 vec
*v
= (void *)Tcl_Alloc(sizeof(*v
));
282 for (i
= 0; i
< ndim
; i
++) {
283 if (dim
[i
].lo
> dim
[i
].hi
) {
285 err(ti
, "bad vector index bounds");
288 n
*= dim
[i
].hi
- dim
[i
].lo
;
291 sprintf(buf
, "vec@%u", seq
++);
292 if ((v
->c
= Tcl_CreateObjCommand(ti
, buf
, vec_command
,
293 (ClientData
)v
, vec_delete
)) == 0) {
302 v
->dim
= (void *)Tcl_Alloc(ndim
* sizeof(*v
->dim
));
303 memcpy(v
->dim
, dim
, ndim
* sizeof(*v
->dim
));
309 v
->v
= (void *)Tcl_Alloc(n
* sizeof(Tcl_Obj
*));
310 for (i
= 0; i
< n
; i
++) {
313 Tcl_IncrRefCount(v
->v
[i
]);
319 /* --- @vec_new@ --- *
321 * Arguments: @ClientData cd@ = vector pointer
322 * @Tcl_Interp *ti@ = interpreter
323 * @int objc@ = number of arguments
324 * @Tcl_Obj *const *objv@ = vector of arguments
326 * Returns: A Tcl return code.
328 * Use: Tcl command for making a new vector.
331 static int vec_new(ClientData cd
, Tcl_Interp
*ti
,
332 int objc
, Tcl_Obj
*const *objv
)
343 if (objc
< 2 || objc
> 3)
344 return (err(ti
, "usage: vector LIST [INIT]"));
345 if (Tcl_ListObjGetElements(ti
, objv
[1], &lc
, &lv
) != TCL_OK
)
349 dim
= (void *)Tcl_Alloc(ndim
* sizeof(*dim
));
350 for (i
= 0; i
< ndim
; i
++) {
351 if (Tcl_ListObjGetElements(ti
, lv
[i
], &bc
, &bv
) != TCL_OK
)
355 if (Tcl_GetLongFromObj(ti
, bv
[0], &dim
[i
].hi
) != TCL_OK
)
357 } else if (bc
== 2) {
358 if (Tcl_GetLongFromObj(ti
, bv
[0], &dim
[i
].lo
) != TCL_OK
||
359 Tcl_GetLongFromObj(ti
, bv
[1], &dim
[i
].hi
) != TCL_OK
)
362 err(ti
, "bad bounds spec");
365 if (dim
[i
].lo
> dim
[i
].hi
) {
366 err(ti
, "bad bounds spec");
375 Tcl_IncrRefCount(init
);
376 if ((v
= vec_create(ti
, ndim
, dim
, init
)) == 0)
378 Tcl_SetResult(ti
, Tcl_GetCommandName(ti
, v
->c
), TCL_STATIC
);
382 if (dim
) Tcl_Free((void *)dim
);
383 if (init
) Tcl_DecrRefCount(init
);
387 /* --- Initialization --- */
389 int Vec_SafeInit(Tcl_Interp
*ti
)
391 Tcl_CreateObjCommand(ti
, "vector", vec_new
, 0, 0);
392 if (Tcl_PkgProvide(ti
, "vector", "1.0.0"))
397 int Vec_Init(Tcl_Interp
*ti
)
399 return (Vec_SafeInit(ti
));
402 /*----- That's all, folks -------------------------------------------------*/