chiark / gitweb /
Print seed -- it's useful.
[rocl] / vec.c
CommitLineData
92d4e321 1/* -*-c-*-
2 *
3 * $Id: vec.c,v 1.1 2003/03/07 00:45:35 mdw Exp $
4 *
5 * Vectors and arrays in Tcl
6 *
7 * (c) 2003 Mark Wooding
8 */
9
10/*----- Licensing notice --------------------------------------------------*
11 *
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.
16 *
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.
21 *
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.
25 */
26
27/*----- Revision history --------------------------------------------------*
28 *
29 * $Log: vec.c,v $
30 * Revision 1.1 2003/03/07 00:45:35 mdw
31 * A multidimensional vector/matrix type which is updateable in place.
32 *
33 */
34
35/*----- Header files ------------------------------------------------------*/
36
37#include <assert.h>
38#include <stdio.h>
39#include <stdlib.h>
40#include <string.h>
41
42#include <tcl.h>
43
44#include "vec.h"
45
46/*----- Static variables --------------------------------------------------*/
47
48static unsigned seq = 0;
49
50/*----- Underlying excitement ---------------------------------------------*/
51
52static Tcl_ObjCmdProc vec_command;
53
54static int err(Tcl_Interp *ti, /*const*/ char *p)
55{
56 Tcl_SetResult(ti, p, TCL_STATIC);
57 return (TCL_ERROR);
58}
59
60/* --- @vec_find@ --- *
61 *
62 * Arguments: @Tcl_Interp *ti@ = interpreter vector exists in
63 * @Tcl_Obj *o@ = object containing the command name
64 *
65 * Returns: A pointer to the vector, or null.
66 *
67 * Use: Finds the vector with a given name.
68 */
69
70vec *vec_find(Tcl_Interp *ti, Tcl_Obj *o)
71{
72 Tcl_CmdInfo ci;
73 int len;
74 const char *p = Tcl_GetStringFromObj(o, &len);
75
76 if (strncmp(p, "vec@", 4) != 0) {
77 err(ti, "unknown vector");
78 return (0);
79 }
80 if (!Tcl_GetCommandInfo(ti, p, &ci)) {
81 err(ti, "unknown vector");
82 return (0);
83 }
84 return ((vec *)ci.objClientData);
85}
86
87/* --- @vec_index@ --- *
88 *
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
93 *
94 * Returns: Address of the object pointer, or null.
95 *
96 * Use: Looks up an index in a vector.
97 */
98
99Tcl_Obj **vec_index(Tcl_Interp *ti, vec *v, int objc, Tcl_Obj *const *objv)
100{
101 size_t i;
102 size_t n;
103
104 if (objc != v->ndim) {
105 err(ti, "dimension mismatch");
106 return (0);
107 }
108 n = 0;
109 for (i = 0; i < objc; i++) {
110 long l;
111 if (Tcl_GetLongFromObj(ti, objv[i], &l) != TCL_OK)
112 return (0);
113 if (l < v->dim[i].lo || l >= v->dim[i].hi) {
114 err(ti, "index out of range");
115 return (0);
116 }
117 n = n * (v->dim[i].hi - v->dim[i].lo) + (l - v->dim[i].lo);
118 }
119 assert(n < v->n);
120 return (&v->v[n]);
121}
122
123/* --- @vec_delete@ --- *
124 *
125 * Arguments: @ClientData cd@ = vector pointer
126 *
127 * Returns: ---
128 *
129 * Use: Destroys a vector.
130 */
131
132static void vec_delete(ClientData cd)
133{
134 vec *v = (vec *)cd;
135 size_t i;
136
137 if (v->n) {
138 for (i = 0; i < v->n; i++)
139 Tcl_DecrRefCount(v->v[i]);
140 Tcl_Free((void *)v->v);
141 }
142 if (v->ndim)
143 Tcl_Free((void *)v->dim);
144 Tcl_Free((void *)v);
145}
146
147/* --- @vec_destroy@ --- *
148 *
149 * Arguments: @Tcl_Interp *ti@ = owning interpreter
150 * @vec *v@ = vector pointer
151 *
152 * Returns: ---
153 *
154 * Use: Destroys a vector.
155 */
156
157void vec_destroy(Tcl_Interp *ti, vec *v)
158{
159 Tcl_DeleteCommandFromToken(ti, v->c);
160}
161
162/* --- @vec_command@ --- *
163 *
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
168 *
169 * Returns: A Tcl return code.
170 *
171 * Use: Various things.
172 */
173
174static int vec_command(ClientData cd, Tcl_Interp *ti,
175 int objc, Tcl_Obj *const *objv)
176{
177 char *sub;
178 vec *v = (vec *)cd;
179
180 if (objc < 2)
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) {
186 Tcl_Obj **o;
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)
190 return (TCL_ERROR);
191 Tcl_SetObjResult(ti, *o);
192 } else if (strcmp(sub, "lget") == 0) {
193 int lc;
194 Tcl_Obj **lv;
195 Tcl_Obj **o;
196 if (objc != 3)
197 return (err(ti, "usage: VECTOR lget LIST"));
198 if (Tcl_ListObjGetElements(ti, objv[2], &lc, &lv) != TCL_OK)
199 return (TCL_ERROR);
200 if ((o = vec_index(ti, v, lc, lv)) == 0)
201 return (TCL_ERROR);
202 Tcl_SetObjResult(ti, *o);
203 } else if (strcmp(sub, "rget") == 0) {
204 long n;
205 if (objc != 3)
206 return (err(ti, "usage: VECTOR rget INDEX"));
207 if (Tcl_GetLongFromObj(ti, objv[2], &n) != TCL_OK)
208 return (TCL_ERROR);
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) {
213 Tcl_Obj **o;
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)
217 return (TCL_ERROR);
218 Tcl_DecrRefCount(*o);
219 *o = objv[objc - 1];
220 Tcl_IncrRefCount(*o);
221 } else if (strcmp(sub, "lset") == 0) {
222 int lc;
223 Tcl_Obj **lv;
224 Tcl_Obj **o;
225 if (objc != 4)
226 return (err(ti, "usage: VECTOR lset LIST VALUE"));
227 if (Tcl_ListObjGetElements(ti, objv[2], &lc, &lv) != TCL_OK)
228 return (TCL_ERROR);
229 if ((o = vec_index(ti, v, lc, lv)) == 0)
230 return (TCL_ERROR);
231 Tcl_DecrRefCount(*o);
232 *o = objv[3];
233 Tcl_IncrRefCount(*o);
234 } else if (strcmp(sub, "rset") == 0) {
235 long n;
236 if (objc != 4)
237 return (err(ti, "usage: VECTOR rset INDEX VALUE"));
238 if (Tcl_GetLongFromObj(ti, objv[2], &n) != TCL_OK)
239 return (TCL_ERROR);
240 if (n < 0 || n >= v->n)
241 return (err(ti, "raw index out of range"));
242 Tcl_DecrRefCount(v->v[n]);
243 v->v[n] = objv[3];
244 Tcl_IncrRefCount(v->v[n]);
245 } else if (strcmp(sub, "bounds") == 0) {
246 Tcl_Obj *l = Tcl_NewListObj(0, 0);
247 size_t i;
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);
253 }
254 Tcl_SetObjResult(ti, l);
255 } else if (strcmp(sub, "size") == 0) {
256 Tcl_SetObjResult(ti, Tcl_NewLongObj(v->n));
257 } else
258 return (err(ti, "unknown vector subcommand"));
259 return (TCL_OK);
260}
261
262/* --- @vec_create@ --- *
263 *
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
268 *
269 * Returns: A pointer to the vector, or null if it failed.
270 *
271 * Use: Creates a new vector object.
272 */
273
274vec *vec_create(Tcl_Interp *ti, size_t ndim, const vec_bound *dim,
275 Tcl_Obj *init)
276{
277 vec *v = (void *)Tcl_Alloc(sizeof(*v));
278 size_t i, n;
279 char buf[32];
280
281 n = 1;
282 for (i = 0; i < ndim; i++) {
283 if (dim[i].lo > dim[i].hi) {
284 Tcl_Free((void *)v);
285 err(ti, "bad vector index bounds");
286 return (0);
287 }
288 n *= dim[i].hi - dim[i].lo;
289 }
290
291 sprintf(buf, "vec@%u", seq++);
292 if ((v->c = Tcl_CreateObjCommand(ti, buf, vec_command,
293 (ClientData)v, vec_delete)) == 0) {
294 Tcl_Free((void *)v);
295 return (0);
296 }
297
298 v->ndim = ndim;
299 if (!ndim)
300 v->dim = 0;
301 else {
302 v->dim = (void *)Tcl_Alloc(ndim * sizeof(*v->dim));
303 memcpy(v->dim, dim, ndim * sizeof(*v->dim));
304 }
305 v->n = n;
306 if (!n)
307 v->v = 0;
308 else {
309 v->v = (void *)Tcl_Alloc(n * sizeof(Tcl_Obj *));
310 for (i = 0; i < n; i++) {
311 v->v[i] = init;
312 if (init)
313 Tcl_IncrRefCount(v->v[i]);
314 }
315 }
316 return (v);
317}
318
319/* --- @vec_new@ --- *
320 *
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
325 *
326 * Returns: A Tcl return code.
327 *
328 * Use: Tcl command for making a new vector.
329 */
330
331static int vec_new(ClientData cd, Tcl_Interp *ti,
332 int objc, Tcl_Obj *const *objv)
333{
334 size_t i;
335 size_t ndim;
336 vec_bound *dim = 0;
337 int lc, bc;
338 Tcl_Obj **lv, **bv;
339 Tcl_Obj *init = 0;
340 vec *v;
341 int rc = TCL_ERROR;
342
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)
346 return (TCL_ERROR);
347 ndim = lc;
348 if (ndim) {
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)
352 return (TCL_ERROR);
353 if (bc == 1) {
354 dim[i].lo = 0;
355 if (Tcl_GetLongFromObj(ti, bv[0], &dim[i].hi) != TCL_OK)
356 goto fail;
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)
360 goto fail;
361 } else {
362 err(ti, "bad bounds spec");
363 goto fail;
364 }
365 if (dim[i].lo > dim[i].hi) {
366 err(ti, "bad bounds spec");
367 goto fail;
368 }
369 }
370 }
371 if (objc >= 3)
372 init = objv[2];
373 else
374 init = Tcl_NewObj();
375 Tcl_IncrRefCount(init);
376 if ((v = vec_create(ti, ndim, dim, init)) == 0)
377 goto fail;
378 Tcl_SetResult(ti, Tcl_GetCommandName(ti, v->c), TCL_STATIC);
379 rc = TCL_OK;
380
381fail:
382 if (dim) Tcl_Free((void *)dim);
383 if (init) Tcl_DecrRefCount(init);
384 return (rc);
385}
386
387/* --- Initialization --- */
388
389int Vec_SafeInit(Tcl_Interp *ti)
390{
391 Tcl_CreateObjCommand(ti, "vector", vec_new, 0, 0);
392 if (Tcl_PkgProvide(ti, "vector", "1.0.0"))
393 return (TCL_ERROR);
394 return (TCL_OK);
395}
396
397int Vec_Init(Tcl_Interp *ti)
398{
399 return (Vec_SafeInit(ti));
400}
401
402/*----- That's all, folks -------------------------------------------------*/