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

   1 /* -*-c-*-
   2  *
   3  * $Id$
   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 /*----- 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, (/*unconst */char *)Tcl_GetCommandName(ti, v->c),
 371                 TCL_STATIC);
 372   rc = TCL_OK;
 373
 374 fail:
 375   if (dim) Tcl_Free((void *)dim);
 376   if (init) Tcl_DecrRefCount(init);
 377   return (rc);
 378 }
 379
 380 /* --- Initialization --- */
 381
 382 int Vec_SafeInit(Tcl_Interp *ti)
 383 {
 384   Tcl_CreateObjCommand(ti, "vector", vec_new, 0, 0);
 385   if (Tcl_PkgProvide(ti, "vector", "1.0.0"))
 386     return (TCL_ERROR);
 387   return (TCL_OK);
 388 }
 389
 390 int Vec_Init(Tcl_Interp *ti)
 391 {
 392   return (Vec_SafeInit(ti));
 393 }
 394
 395 /*----- That's all, folks -------------------------------------------------*/