[rocl] / vec.c

/* -*-c-*-
 *
 * $Id: vec.c,v 1.1 2003/03/07 00:45:35 mdw Exp $
 *
 * Vectors and arrays in Tcl
 *
 * (c) 2003 Mark Wooding
 */

/*----- Licensing notice --------------------------------------------------* 
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software Foundation,
 * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 */

/*----- Revision history --------------------------------------------------* 
 *
 * $Log: vec.c,v $
 * Revision 1.1  2003/03/07 00:45:35  mdw
 * A multidimensional vector/matrix type which is updateable in place.
 *
 */

/*----- Header files ------------------------------------------------------*/

#include <assert.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>

#include <tcl.h>

#include "vec.h"

/*----- Static variables --------------------------------------------------*/

static unsigned seq = 0;

/*----- Underlying excitement ---------------------------------------------*/

static Tcl_ObjCmdProc vec_command;

static int err(Tcl_Interp *ti, /*const*/ char *p)
{
  Tcl_SetResult(ti, p, TCL_STATIC);
  return (TCL_ERROR);
}

/* --- @vec_find@ --- *
 *
 * Arguments:	@Tcl_Interp *ti@ = interpreter vector exists in
 *		@Tcl_Obj *o@ = object containing the command name
 *
 * Returns:	A pointer to the vector, or null.
 *
 * Use:		Finds the vector with a given name.
 */

vec *vec_find(Tcl_Interp *ti, Tcl_Obj *o)
{
  Tcl_CmdInfo ci;
  int len;
  const char *p = Tcl_GetStringFromObj(o, &len);

  if (strncmp(p, "vec@", 4) != 0) {
    err(ti, "unknown vector");
    return (0);
  }
  if (!Tcl_GetCommandInfo(ti, p, &ci)) {
    err(ti, "unknown vector");
    return (0);
  }
  return ((vec *)ci.objClientData);
}

/* --- @vec_index@ --- *
 *
 * Arguments:	@Tcl_Interp *ti@ = interpreter to put errors in
 *		@vec *v@ = the vector
 *		@int objc@ = number of indices provided
 *		@Tcl_Obj *const *objv@ = vector of objects
 *
 * Returns:	Address of the object pointer, or null.
 *
 * Use:		Looks up an index in a vector.
 */

Tcl_Obj **vec_index(Tcl_Interp *ti, vec *v, int objc, Tcl_Obj *const *objv)
{
  size_t i;
  size_t n;

  if (objc != v->ndim) {
    err(ti, "dimension mismatch");
    return (0);
  }
  n = 0;
  for (i = 0; i < objc; i++) {
    long l;
    if (Tcl_GetLongFromObj(ti, objv[i], &l) != TCL_OK)
      return (0);
    if (l < v->dim[i].lo || l >= v->dim[i].hi) {
      err(ti, "index out of range");
      return (0);
    }
    n = n * (v->dim[i].hi - v->dim[i].lo) + (l - v->dim[i].lo);
  }
  assert(n < v->n);
  return (&v->v[n]);
}

/* --- @vec_delete@ --- *
 *
 * Arguments:	@ClientData cd@ = vector pointer
 *
 * Returns:	---
 *
 * Use:		Destroys a vector.
 */

static void vec_delete(ClientData cd)
{
  vec *v = (vec *)cd;
  size_t i;

  if (v->n) {
    for (i = 0; i < v->n; i++)
      Tcl_DecrRefCount(v->v[i]);
    Tcl_Free((void *)v->v);
  }
  if (v->ndim)
    Tcl_Free((void *)v->dim);
  Tcl_Free((void *)v);
}

/* --- @vec_destroy@ --- *
 *
 * Arguments:	@Tcl_Interp *ti@ = owning interpreter
 *		@vec *v@ = vector pointer
 *
 * Returns:	---
 *
 * Use:		Destroys a vector.
 */

void vec_destroy(Tcl_Interp *ti, vec *v)
{
  Tcl_DeleteCommandFromToken(ti, v->c);
}

/* --- @vec_command@ --- *
 *
 * Arguments:	@ClientData cd@ = vector pointer
 *		@Tcl_Interp *ti@ = interpreter
 *		@int objc@ = number of arguments
 *		@Tcl_Obj *const *objv@ = vector of arguments
 *
 * Returns:	A Tcl return code.
 *
 * Use:		Various things.
 */

static int vec_command(ClientData cd, Tcl_Interp *ti,
		       int objc, Tcl_Obj *const *objv)
{
  char *sub;
  vec *v = (vec *)cd;

  if (objc < 2)
    return (err(ti, "usage: VECTOR SUBCOMMAND ARGS..."));
  sub = Tcl_GetStringFromObj(objv[1], 0);
  if (strcmp(sub, "destroy") == 0)
    Tcl_DeleteCommandFromToken(ti, v->c);
  else if (strcmp(sub, "get") == 0) {
    Tcl_Obj **o;
    if (objc != v->ndim + 2)
      return (err(ti, "usage: VECTOR get INDEX ..."));
    if ((o = vec_index(ti, v, objc - 2, objv + 2)) == 0)
      return (TCL_ERROR);
    Tcl_SetObjResult(ti, *o);
  } else if (strcmp(sub, "lget") == 0) {
    int lc;
    Tcl_Obj **lv;
    Tcl_Obj **o;
    if (objc != 3)
      return (err(ti, "usage: VECTOR lget LIST"));
    if (Tcl_ListObjGetElements(ti, objv[2], &lc, &lv) != TCL_OK)
      return (TCL_ERROR);
    if ((o = vec_index(ti, v, lc, lv)) == 0)
      return (TCL_ERROR);
    Tcl_SetObjResult(ti, *o);
  } else if (strcmp(sub, "rget") == 0) {
    long n;
    if (objc != 3)
      return (err(ti, "usage: VECTOR rget INDEX"));
    if (Tcl_GetLongFromObj(ti, objv[2], &n) != TCL_OK)
      return (TCL_ERROR);
    if (n < 0 || n >= v->n)
      return (err(ti, "raw index out of range"));
    Tcl_SetObjResult(ti, v->v[n]);
  } else if (strcmp(sub, "set") == 0) {
    Tcl_Obj **o;
    if (objc != v->ndim + 3)
      return (err(ti, "usage: VECTOR set INDEX ... VALUE"));
    if ((o = vec_index(ti, v, objc - 3, objv + 2)) == 0)
      return (TCL_ERROR);
    Tcl_DecrRefCount(*o);
    *o = objv[objc - 1];
    Tcl_IncrRefCount(*o);
  } else if (strcmp(sub, "lset") == 0) {
    int lc;
    Tcl_Obj **lv;
    Tcl_Obj **o;
    if (objc != 4)
      return (err(ti, "usage: VECTOR lset LIST VALUE"));
    if (Tcl_ListObjGetElements(ti, objv[2], &lc, &lv) != TCL_OK)
      return (TCL_ERROR);
    if ((o = vec_index(ti, v, lc, lv)) == 0)
      return (TCL_ERROR);
    Tcl_DecrRefCount(*o);
    *o = objv[3];
    Tcl_IncrRefCount(*o);
  } else if (strcmp(sub, "rset") == 0) {
    long n;
    if (objc != 4)
      return (err(ti, "usage: VECTOR rset INDEX VALUE"));
    if (Tcl_GetLongFromObj(ti, objv[2], &n) != TCL_OK)
      return (TCL_ERROR);
    if (n < 0 || n >= v->n)
      return (err(ti, "raw index out of range"));
    Tcl_DecrRefCount(v->v[n]);
    v->v[n] = objv[3];
    Tcl_IncrRefCount(v->v[n]);
  } else if (strcmp(sub, "bounds") == 0) {
    Tcl_Obj *l = Tcl_NewListObj(0, 0);
    size_t i;
    for (i = 0; i < v->ndim; i++) {
      Tcl_Obj *b = Tcl_NewListObj(0, 0);
      Tcl_ListObjAppendElement(ti, b, Tcl_NewLongObj(v->dim[i].lo));
      Tcl_ListObjAppendElement(ti, b, Tcl_NewLongObj(v->dim[i].hi));
      Tcl_ListObjAppendElement(ti, l, b);
    }
    Tcl_SetObjResult(ti, l);
  } else if (strcmp(sub, "size") == 0) {
    Tcl_SetObjResult(ti, Tcl_NewLongObj(v->n));
  } else
    return (err(ti, "unknown vector subcommand"));
  return (TCL_OK);
}

/* --- @vec_create@ --- *
 *
 * Arguments:	@Tcl_Interp *ti@ = interpreter to create vector in
 *		@size_t ndim@ = number of dimensions
 *		@const vec_bound *dim@ = the actual dimensions
 *		@Tcl_Obj *init@ = initial value
 *
 * Returns:	A pointer to the vector, or null if it failed.
 *
 * Use:		Creates a new vector object.
 */

vec *vec_create(Tcl_Interp *ti, size_t ndim, const vec_bound *dim,
		Tcl_Obj *init)
{
  vec *v = (void *)Tcl_Alloc(sizeof(*v));
  size_t i, n;
  char buf[32];

  n = 1;
  for (i = 0; i < ndim; i++) {
    if (dim[i].lo > dim[i].hi) {
      Tcl_Free((void *)v);
      err(ti, "bad vector index bounds");
      return (0);
    }
    n *= dim[i].hi - dim[i].lo;
  }

  sprintf(buf, "vec@%u", seq++);
  if ((v->c = Tcl_CreateObjCommand(ti, buf, vec_command,
				   (ClientData)v, vec_delete)) == 0) {
    Tcl_Free((void *)v);
    return (0);
  }

  v->ndim = ndim;
  if (!ndim)
    v->dim = 0;
  else {
    v->dim = (void *)Tcl_Alloc(ndim * sizeof(*v->dim));
    memcpy(v->dim, dim, ndim * sizeof(*v->dim));
  }
  v->n = n;
  if (!n)
    v->v = 0;
  else {
    v->v = (void *)Tcl_Alloc(n * sizeof(Tcl_Obj *));
    for (i = 0; i < n; i++) {
      v->v[i] = init;
      if (init)
	Tcl_IncrRefCount(v->v[i]);
    }
  }
  return (v);
}

/* --- @vec_new@ --- *
 *
 * Arguments:	@ClientData cd@ = vector pointer
 *		@Tcl_Interp *ti@ = interpreter
 *		@int objc@ = number of arguments
 *		@Tcl_Obj *const *objv@ = vector of arguments
 *
 * Returns:	A Tcl return code.
 *
 * Use:		Tcl command for making a new vector.
 */

static int vec_new(ClientData cd, Tcl_Interp *ti,
		   int objc, Tcl_Obj *const *objv)
{
  size_t i;
  size_t ndim;
  vec_bound *dim = 0;
  int lc, bc;
  Tcl_Obj **lv, **bv;
  Tcl_Obj *init = 0;
  vec *v;
  int rc = TCL_ERROR;

  if (objc < 2 || objc > 3)
    return (err(ti, "usage: vector LIST [INIT]"));
  if (Tcl_ListObjGetElements(ti, objv[1], &lc, &lv) != TCL_OK)
    return (TCL_ERROR);
  ndim = lc;
  if (ndim) {
    dim = (void *)Tcl_Alloc(ndim * sizeof(*dim));
    for (i = 0; i < ndim; i++) {
      if (Tcl_ListObjGetElements(ti, lv[i], &bc, &bv) != TCL_OK)
	return (TCL_ERROR);
      if (bc == 1) {
	dim[i].lo = 0;
	if (Tcl_GetLongFromObj(ti, bv[0], &dim[i].hi) != TCL_OK)
	  goto fail;
      } else if (bc == 2) {
	if (Tcl_GetLongFromObj(ti, bv[0], &dim[i].lo) != TCL_OK ||
	    Tcl_GetLongFromObj(ti, bv[1], &dim[i].hi) != TCL_OK)
	  goto fail;
      } else {
	err(ti, "bad bounds spec");
	goto fail;
      }
      if (dim[i].lo > dim[i].hi) {
	err(ti, "bad bounds spec");
	goto fail;
      }
    }
  }
  if (objc >= 3)
    init = objv[2];
  else
    init = Tcl_NewObj();
  Tcl_IncrRefCount(init);
  if ((v = vec_create(ti, ndim, dim, init)) == 0)
    goto fail;
  Tcl_SetResult(ti, Tcl_GetCommandName(ti, v->c), TCL_STATIC);
  rc = TCL_OK;

fail:
  if (dim) Tcl_Free((void *)dim);
  if (init) Tcl_DecrRefCount(init);
  return (rc);
}

/* --- Initialization --- */

int Vec_SafeInit(Tcl_Interp *ti)
{
  Tcl_CreateObjCommand(ti, "vector", vec_new, 0, 0);
  if (Tcl_PkgProvide(ti, "vector", "1.0.0"))
    return (TCL_ERROR);
  return (TCL_OK);
}

int Vec_Init(Tcl_Interp *ti)
{
  return (Vec_SafeInit(ti));
}

/*----- That's all, folks -------------------------------------------------*/
Commit	Line	Data
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
	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 -------------------------------------------------/