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