chiark / gitweb /
And then screwed the code over...
[rocl] / vec.c
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
48 static unsigned seq = 0;
49
50 /*----- Underlying excitement ---------------------------------------------*/
51
52 static Tcl_ObjCmdProc vec_command;
53
54 static 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
70 vec *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
99 Tcl_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
132 static 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
157 void 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
174 static 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
274 vec *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
331 static 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
381 fail:
382   if (dim) Tcl_Free((void *)dim);
383   if (init) Tcl_DecrRefCount(init);
384   return (rc);
385 }
386
387 /* --- Initialization --- */
388
389 int 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
397 int Vec_Init(Tcl_Interp *ti)
398 {
399   return (Vec_SafeInit(ti));
400 }
401
402 /*----- That's all, folks -------------------------------------------------*/