chiark - git - mdw - rocl/blob - vec.c

   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 -------------------------------------------------*/