--- /dev/null
+/* -*-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 -------------------------------------------------*/
~mdw / rocl / commitdiff