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