[rocl] / vec.c

/* -*-c-*-
 *
 * 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, (/*unconst */char *)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	*
	3	* Vectors and arrays in Tcl
	4	*
	5	* (c) 2003 Mark Wooding
	6	*/
	7
5a74fac2	8	/----- Licensing notice --------------------------------------------------
92d4e321	9	*
	10	* This program is free software; you can redistribute it and/or modify
	11	* it under the terms of the GNU General Public License as published by
	12	* the Free Software Foundation; either version 2 of the License, or
	13	* (at your option) any later version.
5a74fac2	14	*
92d4e321	15	* This program is distributed in the hope that it will be useful,
	16	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	17	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	* GNU General Public License for more details.
5a74fac2	19	*
92d4e321	20	* You should have received a copy of the GNU General Public License
	21	* along with this program; if not, write to the Free Software Foundation,
	22	* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
	23	*/
	24
92d4e321	25	/----- Header files ------------------------------------------------------/
	26
	27	#include <assert.h>
	28	#include <stdio.h>
	29	#include <stdlib.h>
	30	#include <string.h>
	31
	32	#include <tcl.h>
	33
	34	#include "vec.h"
	35
	36	/----- Static variables --------------------------------------------------/
	37
	38	static unsigned seq = 0;
	39
	40	/----- Underlying excitement ---------------------------------------------/
	41
	42	static Tcl_ObjCmdProc vec_command;
	43
	44	static int err(Tcl_Interp ti, /const/ char p)
	45	{
	46	Tcl_SetResult(ti, p, TCL_STATIC);
	47	return (TCL_ERROR);
	48	}
	49
	50	/* --- @vec_find@ --- *
	51	*
	52	* Arguments: @Tcl_Interp *ti@ = interpreter vector exists in
	53	* @Tcl_Obj *o@ = object containing the command name
	54	*
	55	* Returns: A pointer to the vector, or null.
	56	*
	57	* Use: Finds the vector with a given name.
	58	*/
	59
	60	vec vec_find(Tcl_Interp ti, Tcl_Obj *o)
	61	{
	62	Tcl_CmdInfo ci;
	63	int len;
	64	const char *p = Tcl_GetStringFromObj(o, &len);
	65
	66	if (strncmp(p, "vec@", 4) != 0) {
	67	err(ti, "unknown vector");
	68	return (0);
	69	}
	70	if (!Tcl_GetCommandInfo(ti, p, &ci)) {
	71	err(ti, "unknown vector");
	72	return (0);
	73	}
	74	return ((vec *)ci.objClientData);
	75	}
	76
	77	/* --- @vec_index@ --- *
	78	*
	79	* Arguments: @Tcl_Interp *ti@ = interpreter to put errors in
	80	* @vec *v@ = the vector
	81	* @int objc@ = number of indices provided
	82	* @Tcl_Obj const objv@ = vector of objects
	83	*
	84	* Returns: Address of the object pointer, or null.
	85	*
	86	* Use: Looks up an index in a vector.
	87	*/
	88
89	Tcl_Obj *vec_index(Tcl_Interp ti, vec v, int objc, Tcl_Obj const *objv)
90	{
91	size_t i;
92	size_t n;
93
94	if (objc != v->ndim) {
95	err(ti, "dimension mismatch");
96	return (0);
97	}
98	n = 0;
99	for (i = 0; i < objc; i++) {
100	long l;
101	if (Tcl_GetLongFromObj(ti, objv[i], &l) != TCL_OK)
102	return (0);
103	if (l < v->dim[i].lo \|\| l >= v->dim[i].hi) {
104	err(ti, "index out of range");
105	return (0);
106	}
107	n = n * (v->dim[i].hi - v->dim[i].lo) + (l - v->dim[i].lo);
108	}
109	assert(n < v->n);
110	return (&v->v[n]);
111	}
112
113	/* --- @vec_delete@ --- *
114	*
115	* Arguments: @ClientData cd@ = vector pointer
116	*
117	* Returns: ---
118	*
119	* Use: Destroys a vector.
120	*/
121
122	static void vec_delete(ClientData cd)
123	{
124	vec v = (vec )cd;
125	size_t i;
126
127	if (v->n) {
128	for (i = 0; i < v->n; i++)
129	Tcl_DecrRefCount(v->v[i]);
130	Tcl_Free((void *)v->v);
131	}
132	if (v->ndim)
133	Tcl_Free((void *)v->dim);
134	Tcl_Free((void *)v);
135	}
136
137	/* --- @vec_destroy@ --- *
138	*
139	* Arguments: @Tcl_Interp *ti@ = owning interpreter
140	* @vec *v@ = vector pointer
141	*
142	* Returns: ---
143	*
144	* Use: Destroys a vector.
145	*/
146
147	void vec_destroy(Tcl_Interp ti, vec v)
148	{
149	Tcl_DeleteCommandFromToken(ti, v->c);
150	}
151
152	/* --- @vec_command@ --- *
153	*
154	* Arguments: @ClientData cd@ = vector pointer
155	* @Tcl_Interp *ti@ = interpreter
156	* @int objc@ = number of arguments
157	* @Tcl_Obj const objv@ = vector of arguments
158	*
159	* Returns: A Tcl return code.
160	*
161	* Use: Various things.
162	*/
163
164	static int vec_command(ClientData cd, Tcl_Interp *ti,
165	int objc, Tcl_Obj const objv)
166	{
167	char *sub;
168	vec v = (vec )cd;
169
170	if (objc < 2)
171	return (err(ti, "usage: VECTOR SUBCOMMAND ARGS..."));
172	sub = Tcl_GetStringFromObj(objv[1], 0);
173	if (strcmp(sub, "destroy") == 0)
174	Tcl_DeleteCommandFromToken(ti, v->c);
175	else if (strcmp(sub, "get") == 0) {
176	Tcl_Obj **o;
177	if (objc != v->ndim + 2)
178	return (err(ti, "usage: VECTOR get INDEX ..."));
179	if ((o = vec_index(ti, v, objc - 2, objv + 2)) == 0)
180	return (TCL_ERROR);
181	Tcl_SetObjResult(ti, *o);
182	} else if (strcmp(sub, "lget") == 0) {
183	int lc;
184	Tcl_Obj **lv;
185	Tcl_Obj **o;
186	if (objc != 3)
187	return (err(ti, "usage: VECTOR lget LIST"));
188	if (Tcl_ListObjGetElements(ti, objv[2], &lc, &lv) != TCL_OK)
189	return (TCL_ERROR);
190	if ((o = vec_index(ti, v, lc, lv)) == 0)
191	return (TCL_ERROR);
192	Tcl_SetObjResult(ti, *o);
193	} else if (strcmp(sub, "rget") == 0) {
194	long n;
195	if (objc != 3)
196	return (err(ti, "usage: VECTOR rget INDEX"));
197	if (Tcl_GetLongFromObj(ti, objv[2], &n) != TCL_OK)
198	return (TCL_ERROR);
199	if (n < 0 \|\| n >= v->n)
200	return (err(ti, "raw index out of range"));
201	Tcl_SetObjResult(ti, v->v[n]);
202	} else if (strcmp(sub, "set") == 0) {
203	Tcl_Obj **o;
204	if (objc != v->ndim + 3)
205	return (err(ti, "usage: VECTOR set INDEX ... VALUE"));
206	if ((o = vec_index(ti, v, objc - 3, objv + 2)) == 0)
207	return (TCL_ERROR);
208	Tcl_DecrRefCount(*o);
209	*o = objv[objc - 1];
210	Tcl_IncrRefCount(*o);
211	} else if (strcmp(sub, "lset") == 0) {
212	int lc;
213	Tcl_Obj **lv;
214	Tcl_Obj **o;
215	if (objc != 4)
216	return (err(ti, "usage: VECTOR lset LIST VALUE"));
217	if (Tcl_ListObjGetElements(ti, objv[2], &lc, &lv) != TCL_OK)
218	return (TCL_ERROR);
219	if ((o = vec_index(ti, v, lc, lv)) == 0)
220	return (TCL_ERROR);
221	Tcl_DecrRefCount(*o);
222	*o = objv[3];
223	Tcl_IncrRefCount(*o);
224	} else if (strcmp(sub, "rset") == 0) {
225	long n;
226	if (objc != 4)
227	return (err(ti, "usage: VECTOR rset INDEX VALUE"));
228	if (Tcl_GetLongFromObj(ti, objv[2], &n) != TCL_OK)
229	return (TCL_ERROR);
230	if (n < 0 \|\| n >= v->n)
231	return (err(ti, "raw index out of range"));
232	Tcl_DecrRefCount(v->v[n]);
233	v->v[n] = objv[3];
234	Tcl_IncrRefCount(v->v[n]);
235	} else if (strcmp(sub, "bounds") == 0) {
236	Tcl_Obj *l = Tcl_NewListObj(0, 0);
237	size_t i;
238	for (i = 0; i < v->ndim; i++) {
239	Tcl_Obj *b = Tcl_NewListObj(0, 0);
240	Tcl_ListObjAppendElement(ti, b, Tcl_NewLongObj(v->dim[i].lo));
241	Tcl_ListObjAppendElement(ti, b, Tcl_NewLongObj(v->dim[i].hi));
242	Tcl_ListObjAppendElement(ti, l, b);
243	}
244	Tcl_SetObjResult(ti, l);
245	} else if (strcmp(sub, "size") == 0) {
246	Tcl_SetObjResult(ti, Tcl_NewLongObj(v->n));
247	} else
248	return (err(ti, "unknown vector subcommand"));
249	return (TCL_OK);
250	}
251
252	/* --- @vec_create@ --- *
253	*
254	* Arguments: @Tcl_Interp *ti@ = interpreter to create vector in
255	* @size_t ndim@ = number of dimensions
256	* @const vec_bound *dim@ = the actual dimensions
257	* @Tcl_Obj *init@ = initial value
258	*
259	* Returns: A pointer to the vector, or null if it failed.
260	*
261	* Use: Creates a new vector object.
262	*/
263
264	vec vec_create(Tcl_Interp ti, size_t ndim, const vec_bound *dim,
265	Tcl_Obj *init)
266	{
267	vec v = (void )Tcl_Alloc(sizeof(*v));
268	size_t i, n;
269	char buf[32];
270
271	n = 1;
272	for (i = 0; i < ndim; i++) {
273	if (dim[i].lo > dim[i].hi) {
274	Tcl_Free((void *)v);
275	err(ti, "bad vector index bounds");
276	return (0);
277	}
278	n *= dim[i].hi - dim[i].lo;
279	}
280
281	sprintf(buf, "vec@%u", seq++);
282	if ((v->c = Tcl_CreateObjCommand(ti, buf, vec_command,
283	(ClientData)v, vec_delete)) == 0) {
284	Tcl_Free((void *)v);
285	return (0);
286	}
287
288	v->ndim = ndim;
289	if (!ndim)
290	v->dim = 0;
291	else {
292	v->dim = (void )Tcl_Alloc(ndim sizeof(*v->dim));
293	memcpy(v->dim, dim, ndim * sizeof(*v->dim));
294	}
295	v->n = n;
296	if (!n)
297	v->v = 0;
298	else {
299	v->v = (void )Tcl_Alloc(n sizeof(Tcl_Obj *));
300	for (i = 0; i < n; i++) {
301	v->v[i] = init;
302	if (init)
303	Tcl_IncrRefCount(v->v[i]);
304	}
305	}
306	return (v);
307	}
308
309	/* --- @vec_new@ --- *
310	*
311	* Arguments: @ClientData cd@ = vector pointer
312	* @Tcl_Interp *ti@ = interpreter
313	* @int objc@ = number of arguments
314	* @Tcl_Obj const objv@ = vector of arguments
315	*
316	* Returns: A Tcl return code.
317	*
318	* Use: Tcl command for making a new vector.
319	*/
320
321	static int vec_new(ClientData cd, Tcl_Interp *ti,
322	int objc, Tcl_Obj const objv)
323	{
324	size_t i;
325	size_t ndim;
326	vec_bound *dim = 0;
327	int lc, bc;
328	Tcl_Obj lv, bv;
329	Tcl_Obj *init = 0;
330	vec *v;
331	int rc = TCL_ERROR;
332
333	if (objc < 2 \|\| objc > 3)
334	return (err(ti, "usage: vector LIST [INIT]"));
335	if (Tcl_ListObjGetElements(ti, objv[1], &lc, &lv) != TCL_OK)
336	return (TCL_ERROR);
337	ndim = lc;
338	if (ndim) {
339	dim = (void )Tcl_Alloc(ndim sizeof(*dim));
340	for (i = 0; i < ndim; i++) {
341	if (Tcl_ListObjGetElements(ti, lv[i], &bc, &bv) != TCL_OK)
342	return (TCL_ERROR);
343	if (bc == 1) {
344	dim[i].lo = 0;
345	if (Tcl_GetLongFromObj(ti, bv[0], &dim[i].hi) != TCL_OK)
346	goto fail;
347	} else if (bc == 2) {
348	if (Tcl_GetLongFromObj(ti, bv[0], &dim[i].lo) != TCL_OK \|\|
349	Tcl_GetLongFromObj(ti, bv[1], &dim[i].hi) != TCL_OK)
350	goto fail;
351	} else {
352	err(ti, "bad bounds spec");
353	goto fail;
354	}
355	if (dim[i].lo > dim[i].hi) {
356	err(ti, "bad bounds spec");
357	goto fail;
358	}
359	}
360	}
361	if (objc >= 3)
362	init = objv[2];
363	else
364	init = Tcl_NewObj();
365	Tcl_IncrRefCount(init);
366	if ((v = vec_create(ti, ndim, dim, init)) == 0)
367	goto fail;
44649ec5 MW	368	Tcl_SetResult(ti, (/unconst /char *)Tcl_GetCommandName(ti, v->c),
44649ec5 MW	369	TCL_STATIC);
92d4e321	370	rc = TCL_OK;
	371
	372	fail:
	373	if (dim) Tcl_Free((void *)dim);
	374	if (init) Tcl_DecrRefCount(init);
	375	return (rc);
	376	}
	377
	378	/* --- Initialization --- */
	379
	380	int Vec_SafeInit(Tcl_Interp *ti)
	381	{
	382	Tcl_CreateObjCommand(ti, "vector", vec_new, 0, 0);
	383	if (Tcl_PkgProvide(ti, "vector", "1.0.0"))
	384	return (TCL_ERROR);
	385	return (TCL_OK);
	386	}
	387
	388	int Vec_Init(Tcl_Interp *ti)
	389	{
	390	return (Vec_SafeInit(ti));
	391	}
	392
	393	/----- That's all, folks -------------------------------------------------/