[rocl] / vec.c

/* -*-c-*-
 *
 * $Id$
 *
 * 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.
 */

/*----- 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--
92d4e321	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
	40	static unsigned seq = 0;
	41
	42	/----- Underlying excitement ---------------------------------------------/
	43
	44	static Tcl_ObjCmdProc vec_command;
	45
	46	static 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
	62	vec 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
91	Tcl_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
124	static 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
149	void 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
166	static 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
266	vec 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
323	static 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
373	fail:
374	if (dim) Tcl_Free((void *)dim);
375	if (init) Tcl_DecrRefCount(init);
376	return (rc);
377	}
378
379	/* --- Initialization --- */
380
381	int 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
389	int Vec_Init(Tcl_Interp *ti)
390	{
391	return (Vec_SafeInit(ti));
392	}
393
394	/----- That's all, folks -------------------------------------------------/