chiark / gitweb /
Release 1.1.6.
[rocl] / vec.c
CommitLineData
92d4e321 1/* -*-c-*-
2 *
92d4e321 3 * Vectors and arrays in Tcl
4 *
5 * (c) 2003 Mark Wooding
6 */
7
5a74fac2 8/*----- Licensing notice --------------------------------------------------*
92d4e321 9 *
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.
5a74fac2 14 *
92d4e321 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.
5a74fac2 19 *
92d4e321 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.
23 */
24
92d4e321 25/*----- Header files ------------------------------------------------------*/
26
27#include <assert.h>
28#include <stdio.h>
29#include <stdlib.h>
30#include <string.h>
31
32#include <tcl.h>
33
34#include "vec.h"
35
36/*----- Static variables --------------------------------------------------*/
37
38static unsigned seq = 0;
39
40/*----- Underlying excitement ---------------------------------------------*/
41
42static Tcl_ObjCmdProc vec_command;
43
44static int err(Tcl_Interp *ti, /*const*/ char *p)
45{
46 Tcl_SetResult(ti, p, TCL_STATIC);
47 return (TCL_ERROR);
48}
49
50/* --- @vec_find@ --- *
51 *
52 * Arguments: @Tcl_Interp *ti@ = interpreter vector exists in
53 * @Tcl_Obj *o@ = object containing the command name
54 *
55 * Returns: A pointer to the vector, or null.
56 *
57 * Use: Finds the vector with a given name.
58 */
59
60vec *vec_find(Tcl_Interp *ti, Tcl_Obj *o)
61{
62 Tcl_CmdInfo ci;
63 int len;
64 const char *p = Tcl_GetStringFromObj(o, &len);
65
66 if (strncmp(p, "vec@", 4) != 0) {
67 err(ti, "unknown vector");
68 return (0);
69 }
70 if (!Tcl_GetCommandInfo(ti, p, &ci)) {
71 err(ti, "unknown vector");
72 return (0);
73 }
74 return ((vec *)ci.objClientData);
75}
76
77/* --- @vec_index@ --- *
78 *
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
83 *
84 * Returns: Address of the object pointer, or null.
85 *
86 * Use: Looks up an index in a vector.
87 */
88
89Tcl_Obj **vec_index(Tcl_Interp *ti, vec *v, int objc, Tcl_Obj *const *objv)
90{
91 size_t i;
92 size_t n;
93
94 if (objc != v->ndim) {
95 err(ti, "dimension mismatch");
96 return (0);
97 }
98 n = 0;
99 for (i = 0; i < objc; i++) {
100 long l;
101 if (Tcl_GetLongFromObj(ti, objv[i], &l) != TCL_OK)
102 return (0);
103 if (l < v->dim[i].lo || l >= v->dim[i].hi) {
104 err(ti, "index out of range");
105 return (0);
106 }
107 n = n * (v->dim[i].hi - v->dim[i].lo) + (l - v->dim[i].lo);
108 }
109 assert(n < v->n);
110 return (&v->v[n]);
111}
112
113/* --- @vec_delete@ --- *
114 *
115 * Arguments: @ClientData cd@ = vector pointer
116 *
117 * Returns: ---
118 *
119 * Use: Destroys a vector.
120 */
121
122static void vec_delete(ClientData cd)
123{
124 vec *v = (vec *)cd;
125 size_t i;
126
127 if (v->n) {
128 for (i = 0; i < v->n; i++)
129 Tcl_DecrRefCount(v->v[i]);
130 Tcl_Free((void *)v->v);
131 }
132 if (v->ndim)
133 Tcl_Free((void *)v->dim);
134 Tcl_Free((void *)v);
135}
136
137/* --- @vec_destroy@ --- *
138 *
139 * Arguments: @Tcl_Interp *ti@ = owning interpreter
140 * @vec *v@ = vector pointer
141 *
142 * Returns: ---
143 *
144 * Use: Destroys a vector.
145 */
146
147void vec_destroy(Tcl_Interp *ti, vec *v)
148{
149 Tcl_DeleteCommandFromToken(ti, v->c);
150}
151
152/* --- @vec_command@ --- *
153 *
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
158 *
159 * Returns: A Tcl return code.
160 *
161 * Use: Various things.
162 */
163
164static int vec_command(ClientData cd, Tcl_Interp *ti,
165 int objc, Tcl_Obj *const *objv)
166{
167 char *sub;
168 vec *v = (vec *)cd;
169
170 if (objc < 2)
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) {
176 Tcl_Obj **o;
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)
180 return (TCL_ERROR);
181 Tcl_SetObjResult(ti, *o);
182 } else if (strcmp(sub, "lget") == 0) {
183 int lc;
184 Tcl_Obj **lv;
185 Tcl_Obj **o;
186 if (objc != 3)
187 return (err(ti, "usage: VECTOR lget LIST"));
188 if (Tcl_ListObjGetElements(ti, objv[2], &lc, &lv) != TCL_OK)
189 return (TCL_ERROR);
190 if ((o = vec_index(ti, v, lc, lv)) == 0)
191 return (TCL_ERROR);
192 Tcl_SetObjResult(ti, *o);
193 } else if (strcmp(sub, "rget") == 0) {
194 long n;
195 if (objc != 3)
196 return (err(ti, "usage: VECTOR rget INDEX"));
197 if (Tcl_GetLongFromObj(ti, objv[2], &n) != TCL_OK)
198 return (TCL_ERROR);
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) {
203 Tcl_Obj **o;
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)
207 return (TCL_ERROR);
208 Tcl_DecrRefCount(*o);
209 *o = objv[objc - 1];
210 Tcl_IncrRefCount(*o);
211 } else if (strcmp(sub, "lset") == 0) {
212 int lc;
213 Tcl_Obj **lv;
214 Tcl_Obj **o;
215 if (objc != 4)
216 return (err(ti, "usage: VECTOR lset LIST VALUE"));
217 if (Tcl_ListObjGetElements(ti, objv[2], &lc, &lv) != TCL_OK)
218 return (TCL_ERROR);
219 if ((o = vec_index(ti, v, lc, lv)) == 0)
220 return (TCL_ERROR);
221 Tcl_DecrRefCount(*o);
222 *o = objv[3];
223 Tcl_IncrRefCount(*o);
224 } else if (strcmp(sub, "rset") == 0) {
225 long n;
226 if (objc != 4)
227 return (err(ti, "usage: VECTOR rset INDEX VALUE"));
228 if (Tcl_GetLongFromObj(ti, objv[2], &n) != TCL_OK)
229 return (TCL_ERROR);
230 if (n < 0 || n >= v->n)
231 return (err(ti, "raw index out of range"));
232 Tcl_DecrRefCount(v->v[n]);
233 v->v[n] = objv[3];
234 Tcl_IncrRefCount(v->v[n]);
235 } else if (strcmp(sub, "bounds") == 0) {
236 Tcl_Obj *l = Tcl_NewListObj(0, 0);
237 size_t i;
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);
243 }
244 Tcl_SetObjResult(ti, l);
245 } else if (strcmp(sub, "size") == 0) {
246 Tcl_SetObjResult(ti, Tcl_NewLongObj(v->n));
247 } else
248 return (err(ti, "unknown vector subcommand"));
249 return (TCL_OK);
250}
251
252/* --- @vec_create@ --- *
253 *
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
258 *
259 * Returns: A pointer to the vector, or null if it failed.
260 *
261 * Use: Creates a new vector object.
262 */
263
264vec *vec_create(Tcl_Interp *ti, size_t ndim, const vec_bound *dim,
265 Tcl_Obj *init)
266{
267 vec *v = (void *)Tcl_Alloc(sizeof(*v));
268 size_t i, n;
269 char buf[32];
270
271 n = 1;
272 for (i = 0; i < ndim; i++) {
273 if (dim[i].lo > dim[i].hi) {
274 Tcl_Free((void *)v);
275 err(ti, "bad vector index bounds");
276 return (0);
277 }
278 n *= dim[i].hi - dim[i].lo;
279 }
280
281 sprintf(buf, "vec@%u", seq++);
282 if ((v->c = Tcl_CreateObjCommand(ti, buf, vec_command,
283 (ClientData)v, vec_delete)) == 0) {
284 Tcl_Free((void *)v);
285 return (0);
286 }
287
288 v->ndim = ndim;
289 if (!ndim)
290 v->dim = 0;
291 else {
292 v->dim = (void *)Tcl_Alloc(ndim * sizeof(*v->dim));
293 memcpy(v->dim, dim, ndim * sizeof(*v->dim));
294 }
295 v->n = n;
296 if (!n)
297 v->v = 0;
298 else {
299 v->v = (void *)Tcl_Alloc(n * sizeof(Tcl_Obj *));
300 for (i = 0; i < n; i++) {
301 v->v[i] = init;
302 if (init)
303 Tcl_IncrRefCount(v->v[i]);
304 }
305 }
306 return (v);
307}
308
309/* --- @vec_new@ --- *
310 *
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
315 *
316 * Returns: A Tcl return code.
317 *
318 * Use: Tcl command for making a new vector.
319 */
320
321static int vec_new(ClientData cd, Tcl_Interp *ti,
322 int objc, Tcl_Obj *const *objv)
323{
324 size_t i;
325 size_t ndim;
326 vec_bound *dim = 0;
327 int lc, bc;
328 Tcl_Obj **lv, **bv;
329 Tcl_Obj *init = 0;
330 vec *v;
331 int rc = TCL_ERROR;
332
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)
336 return (TCL_ERROR);
337 ndim = lc;
338 if (ndim) {
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)
342 return (TCL_ERROR);
343 if (bc == 1) {
344 dim[i].lo = 0;
345 if (Tcl_GetLongFromObj(ti, bv[0], &dim[i].hi) != TCL_OK)
346 goto fail;
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)
350 goto fail;
351 } else {
352 err(ti, "bad bounds spec");
353 goto fail;
354 }
355 if (dim[i].lo > dim[i].hi) {
356 err(ti, "bad bounds spec");
357 goto fail;
358 }
359 }
360 }
361 if (objc >= 3)
362 init = objv[2];
363 else
364 init = Tcl_NewObj();
365 Tcl_IncrRefCount(init);
366 if ((v = vec_create(ti, ndim, dim, init)) == 0)
367 goto fail;
44649ec5
MW
368 Tcl_SetResult(ti, (/*unconst */char *)Tcl_GetCommandName(ti, v->c),
369 TCL_STATIC);
92d4e321 370 rc = TCL_OK;
371
372fail:
373 if (dim) Tcl_Free((void *)dim);
374 if (init) Tcl_DecrRefCount(init);
375 return (rc);
376}
377
378/* --- Initialization --- */
379
380int Vec_SafeInit(Tcl_Interp *ti)
381{
382 Tcl_CreateObjCommand(ti, "vector", vec_new, 0, 0);
383 if (Tcl_PkgProvide(ti, "vector", "1.0.0"))
384 return (TCL_ERROR);
385 return (TCL_OK);
386}
387
388int Vec_Init(Tcl_Interp *ti)
389{
390 return (Vec_SafeInit(ti));
391}
392
393/*----- That's all, folks -------------------------------------------------*/