From: mdw Date: Fri, 7 Mar 2003 00:45:35 +0000 (+0000) Subject: A multidimensional vector/matrix type which is updateable in place. X-Git-Tag: 1.1.0~3 X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/rocl/commitdiff_plain/92d4e32147b82130582be1f20c5e97fcc48805ec?hp=6f7ff7517fc2b5d67138ddd1055020385bf6baa7 A multidimensional vector/matrix type which is updateable in place. --- diff --git a/vec.c b/vec.c new file mode 100644 index 0000000..c2aef2e --- /dev/null +++ b/vec.c @@ -0,0 +1,402 @@ +/* -*-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 +#include +#include +#include + +#include + +#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 -------------------------------------------------*/