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