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

   1 /* -*-c-*-
   2  *
   3  * Vectors and arrays in Tcl
   4  *
   5  * (c) 2003 Mark Wooding
   6  */
   7
   8 /*----- Licensing notice --------------------------------------------------*
   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.
  14  *
  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.
  19  *
  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
  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;
 368   Tcl_SetResult(ti, Tcl_GetCommandName(ti, v->c), TCL_STATIC);
 369   rc = TCL_OK;
 370
 371 fail:
 372   if (dim) Tcl_Free((void *)dim);
 373   if (init) Tcl_DecrRefCount(init);
 374   return (rc);
 375 }
 376
 377 /* --- Initialization --- */
 378
 379 int Vec_SafeInit(Tcl_Interp *ti)
 380 {
 381   Tcl_CreateObjCommand(ti, "vector", vec_new, 0, 0);
 382   if (Tcl_PkgProvide(ti, "vector", "1.0.0"))
 383     return (TCL_ERROR);
 384   return (TCL_OK);
 385 }
 386
 387 int Vec_Init(Tcl_Interp *ti)
 388 {
 389   return (Vec_SafeInit(ti));
 390 }
 391
 392 /*----- That's all, folks -------------------------------------------------*/