1 /*
2 * bltVector.c --
3 *
4 * This module implements vector data objects.
5 *
6 * Copyright 1995-1998 Lucent Technologies, Inc.
7 *
8 * Permission to use, copy, modify, and distribute this software and
9 * its documentation for any purpose and without fee is hereby
10 * granted, provided that the above copyright notice appear in all
11 * copies and that both that the copyright notice and warranty
12 * disclaimer appear in supporting documentation, and that the names
13 * of Lucent Technologies any of their entities not be used in
14 * advertising or publicity pertaining to distribution of the software
15 * without specific, written prior permission.
16 *
17 * Lucent Technologies disclaims all warranties with regard to this
18 * software, including all implied warranties of merchantability and
19 * fitness. In no event shall Lucent Technologies be liable for any
20 * special, indirect or consequential damages or any damages
21 * whatsoever resulting from loss of use, data or profits, whether in
22 * an action of contract, negligence or other tortuous action, arising
23 * out of or in connection with the use or performance of this
24 * software.
25 */
26
27 /*
28 * TODO:
29 * o Add H. Kirsch's vector binary read operation
30 * x binread file0
31 * x binread -file file0
32 *
33 * o Add ASCII/binary file reader
34 * x read fileName
35 *
36 * o Allow Tcl-based client notifications.
37 * vector x
38 * x notify call Display
39 * x notify delete Display
40 * x notify reorder #1 #2
41 */
42
43 #include "bltVecInt.h"
44 #include <bltMath.h>
45
46 #ifdef TIME_WITH_SYS_TIME
47 #include <sys/time.h>
48 #include <time.h>
49 #else
50 #ifdef HAVE_SYS_TIME_H
51 #include <sys/time.h>
52 #else
53 #include <time.h>
54 #endif /* HAVE_SYS_TIME_H */
55 #endif /* TIME_WITH_SYS_TIME */
56
57 #ifndef TCL_NAMESPACE_ONLY
58 #define TCL_NAMESPACE_ONLY TCL_GLOBAL_ONLY
59 #endif
60
61 #define DEF_ARRAY_SIZE 64
62 #define VECFLAGS(v) \
63 (((v)->varNsPtr != NULL) ? (TCL_NAMESPACE_ONLY | TCL_GLOBAL_ONLY) : 0);
64 #define TRACE_ALL (TCL_TRACE_WRITES | TCL_TRACE_READS | TCL_TRACE_UNSETS)
65
66
67 #define VECTOR_CHAR(c) ((isalnum(UCHAR(c))) || \
68 (c == '_') || (c == ':') || (c == '@') || (c == '.'))
69
70
71 /*
72 * VectorClient --
73 *
74 * A vector can be shared by several clients. Each client
75 * allocates this structure that acts as its key for using the
76 * vector. Clients can also designate a callback routine that is
77 * executed whenever the vector is updated or destroyed.
78 *
79 */
80 typedef struct {
81 unsigned int magic; /* Magic value designating whether this
82 * really is a vector token or not */
83
84 VectorObject *serverPtr; /* Pointer to the master record of the
85 * vector. If NULL, indicates that the
86 * vector has been destroyed but as of
87 * yet, this client hasn't recognized
88 * it. */
89
90 Blt_VectorChangedProc *proc;/* Routine to call when the contents
91 * of the vector change or the vector
92 * is deleted. */
93
94 ClientData clientData; /* Data passed whenever the vector
95 * change procedure is called. */
96
97 Blt_ChainLink *linkPtr; /* Used to quickly remove this entry from
98 * its server's client chain. */
99 } VectorClient;
100
101 static Tcl_CmdDeleteProc VectorInstDeleteProc;
102 static Tcl_InterpDeleteProc VectorInterpDeleteProc;
103
104 #if (TCL_MAJOR_VERSION == 7)
105 static Tcl_CmdProc VectorCmd;
106 #endif
107
108 #if defined(HAVE_SRAND48) && defined(NO_DECL_SRAND48)
109 extern void srand48 _ANSI_ARGS_((long int seed));
110 #endif
111
112 static VectorObject *
FindVectorInNamespace(dataPtr,nsPtr,vecName)113 FindVectorInNamespace(dataPtr, nsPtr, vecName)
114 VectorInterpData *dataPtr; /* Interpreter-specific data. */
115 Tcl_Namespace *nsPtr;
116 CONST char *vecName;
117 {
118 Tcl_DString dString;
119 CONST char *name;
120 Blt_HashEntry *hPtr;
121
122 name = Blt_GetQualifiedName(nsPtr, vecName, &dString);
123 hPtr = Blt_FindHashEntry(&(dataPtr->vectorTable), name);
124 Tcl_DStringFree(&dString);
125 if (hPtr != NULL) {
126 return (VectorObject *)Blt_GetHashValue(hPtr);
127 }
128 return NULL;
129 }
130
131 /*
132 * ----------------------------------------------------------------------
133 *
134 * GetVectorObject --
135 *
136 * Searches for the vector associated with the name given.
137 * Allow for a range specification.
138 *
139 * Results:
140 * Returns a pointer to the vector if found, otherwise NULL.
141 *
142 * ----------------------------------------------------------------------
143 */
144 static VectorObject *
GetVectorObject(dataPtr,name,flags)145 GetVectorObject(dataPtr, name, flags)
146 VectorInterpData *dataPtr; /* Interpreter-specific data. */
147 CONST char *name;
148 int flags;
149 {
150 CONST char *vecName;
151 Tcl_Namespace *nsPtr;
152 VectorObject *vPtr;
153
154 nsPtr = NULL;
155 vecName = name;
156 if (Blt_ParseQualifiedName(dataPtr->interp, name, &nsPtr, &vecName)
157 != TCL_OK) {
158 return NULL; /* Can't find namespace. */
159 }
160 vPtr = NULL;
161 if (nsPtr != NULL) {
162 vPtr = FindVectorInNamespace(dataPtr, nsPtr, vecName);
163 } else {
164 if (flags & NS_SEARCH_CURRENT) {
165 nsPtr = Tcl_GetCurrentNamespace(dataPtr->interp);
166 vPtr = FindVectorInNamespace(dataPtr, nsPtr, vecName);
167 }
168 if ((vPtr == NULL) && (flags & NS_SEARCH_GLOBAL)) {
169 nsPtr = Tcl_GetGlobalNamespace(dataPtr->interp);
170 vPtr = FindVectorInNamespace(dataPtr, nsPtr, vecName);
171 }
172 }
173 return vPtr;
174 }
175
176 void
Blt_VectorUpdateRange(vPtr)177 Blt_VectorUpdateRange(vPtr)
178 VectorObject *vPtr;
179 {
180 double min, max;
181 register int i;
182
183 min = DBL_MAX, max = -DBL_MAX;
184 for (i = 0; i < vPtr->length; i++) {
185 if (FINITE(vPtr->valueArr[i])) {
186 min = max = vPtr->valueArr[i];
187 break;
188 }
189 }
190 for (/* empty */; i < vPtr->length; i++) {
191 if (FINITE(vPtr->valueArr[i])) {
192 if (min > vPtr->valueArr[i]) {
193 min = vPtr->valueArr[i];
194 } else if (max < vPtr->valueArr[i]) {
195 max = vPtr->valueArr[i];
196 }
197 }
198 }
199 vPtr->min = min;
200 vPtr->max = max;
201 vPtr->notifyFlags &= ~UPDATE_RANGE;
202 }
203
204 static int
GetIntEnd(interp,string,iPtr,endVal)205 GetIntEnd(interp, string, iPtr, endVal)
206 Tcl_Interp *interp;
207 char *string;
208 int *iPtr;
209 int endVal;
210 {
211 char *cp = string;
212 int add = 0;
213
214 if (strncmp("end", cp, 3) == 0) {
215 if (*cp == 0) {
216 *iPtr = endVal;
217 return TCL_OK;
218 }
219 add = endVal;
220 cp += 3;
221 }
222 if (Tcl_GetInt(interp, cp, iPtr) != TCL_OK) {
223 long l;
224 Tcl_ResetResult(interp);
225 if (Tcl_ExprLong(interp, cp, &l) != TCL_OK) {
226 return TCL_ERROR;
227 }
228 *iPtr = (int)l;
229 }
230 *iPtr += add;
231 return TCL_OK;
232 }
233
234 /*
235 * ----------------------------------------------------------------------
236 *
237 * Blt_VectorGetIndex --
238 *
239 * Converts the string representing an index in the vector, to
240 * its numeric value. A valid index may be an numeric string of
241 * the string "end" (indicating the last element in the string).
242 *
243 * Results:
244 * A standard Tcl result. If the string is a valid index, TCL_OK
245 * is returned. Otherwise TCL_ERROR is returned and interp->result
246 * will contain an error message.
247 *
248 * ----------------------------------------------------------------------
249 */
250 int
Blt_VectorGetIndex(interp,vPtr,string,indexPtr,flags,procPtrPtr)251 Blt_VectorGetIndex(interp, vPtr, string, indexPtr, flags, procPtrPtr)
252 Tcl_Interp *interp;
253 VectorObject *vPtr;
254 CONST char *string;
255 int *indexPtr;
256 int flags;
257 Blt_VectorIndexProc **procPtrPtr;
258 {
259 char c;
260 int value = -1, value2 = -1, sz, result = TCL_OK;
261 char *comma, *zBuf;
262 char zStatic[201];
263
264 /* Need a static copy of index. */
265 sz = strlen(string);
266 if (sz>=200) {
267 zBuf = Blt_Malloc(sz+1);
268 strcpy(zBuf, string);
269 string = zBuf;
270 } else {
271 strcpy(zStatic, string);
272 string = zStatic;
273 }
274
275 c = string[0];
276
277 /* Treat the index "end" like a numeric index. */
278
279 if ((c == 'e') && (strcmp(string, "end") == 0)) {
280 if (vPtr->length < 1) {
281 if (interp != NULL) {
282 Tcl_AppendResult(interp, "bad index \"end\": vector is empty",
283 (char *)NULL);
284 }
285 result = TCL_ERROR;
286 goto cleanup;
287 }
288 *indexPtr = vPtr->length - 1;
289 goto cleanup;
290 } else if ((c == '+') && (strcmp(string, "++end") == 0)) {
291 *indexPtr = vPtr->length;
292 goto cleanup;
293 }
294 if (procPtrPtr != NULL) {
295 Blt_HashEntry *hPtr;
296
297 hPtr = Blt_FindHashEntry(&(vPtr->dataPtr->indexProcTable), string);
298 if (hPtr != NULL) {
299 *indexPtr = SPECIAL_INDEX;
300 *procPtrPtr = (Blt_VectorIndexProc *) Blt_GetHashValue(hPtr);
301 goto cleanup;
302 }
303 }
304 if ((comma=strchr(string, ','))) {
305 char *ccp;
306 *comma = 0;
307 ccp = (char*)comma+1;
308 if ((GetIntEnd(interp, ccp, &value2, vPtr->numcols-1) == TCL_OK) &&
309 (GetIntEnd(interp, (char *)string, &value, vPtr->numcols-1) ==
310 TCL_OK)) {
311 if (value2<0 || value<0) {
312 if (flags & INDEX_VAR_TRACE) {
313 *indexPtr = SPECIAL_INDEX;
314 if (procPtrPtr != NULL) {
315 *procPtrPtr = NULL;
316 }
317 goto cleanup;
318 } else {
319 Tcl_AppendResult(interp, "negative index not allowed", 0);
320 result = TCL_ERROR;
321 goto cleanup;
322 }
323 }
324 if (value2>=vPtr->numcols) {
325 Tcl_AppendResult(interp, "col index is > numcols", 0);
326 result = TCL_ERROR;
327 goto cleanup;
328 }
329 value = (value*vPtr->numcols)+value2;
330 *comma = ',';
331 } else {
332 *comma = ',';
333 result = TCL_ERROR;
334 goto cleanup;
335 }
336
337 } else if (Tcl_GetInt(interp, (char *)string, &value) != TCL_OK) {
338 long int lvalue;
339 /*
340 * Unlike Tcl_GetInt, Tcl_ExprLong needs a valid interpreter,
341 * but the interp passed in may be NULL. So we have to use
342 * vPtr->interp and then reset the result.
343 */
344 if (Tcl_ExprLong(vPtr->interp, (char *)string, &lvalue) != TCL_OK) {
345 Tcl_ResetResult(vPtr->interp);
346 if (interp != NULL) {
347 Tcl_AppendResult(interp, "bad index \"", string, "\"",
348 (char *)NULL);
349 }
350 result = TCL_ERROR;
351 goto cleanup;
352 }
353 value = lvalue;
354 }
355 /*
356 * Correct the index by the current value of the offset. This makes
357 * all the numeric indices non-negative, which is how we distinguish
358 * the special non-numeric indices.
359 */
360 value -= vPtr->offset;
361
362 if ((value < 0) || ((flags & INDEX_CHECK) && (value >= vPtr->length))) {
363 if (interp != NULL) {
364 Tcl_AppendResult(interp, "index \"", string, "\" is out of range",
365 (char *)NULL);
366 }
367 result = TCL_ERROR;
368 goto cleanup;
369 }
370 *indexPtr = (int)value;
371 cleanup:
372 if (string != zStatic) {
373 Blt_Free( (void *)string );
374 }
375 return result;
376 }
377
378 /*
379 * ----------------------------------------------------------------------
380 *
381 * Blt_VectorGetIndexRange --
382 *
383 * Converts the string representing an index in the vector, to
384 * its numeric value. A valid index may be an numeric string of
385 * the string "end" (indicating the last element in the string).
386 *
387 * Results:
388 * A standard Tcl result. If the string is a valid index, TCL_OK
389 * is returned. Otherwise TCL_ERROR is returned and interp->result
390 * will contain an error message.
391 *
392 * ----------------------------------------------------------------------
393 */
394 int
Blt_VectorGetIndexRange(interp,vPtr,string,flags,procPtrPtr)395 Blt_VectorGetIndexRange(interp, vPtr, string, flags, procPtrPtr)
396 Tcl_Interp *interp;
397 VectorObject *vPtr;
398 CONST char *string;
399 int flags;
400 Blt_VectorIndexProc **procPtrPtr;
401 {
402 int ielem;
403 char *colon;
404
405 colon = NULL;
406 if (flags & INDEX_COLON) {
407 colon = strchr(string, ':');
408 }
409 if (colon != NULL) {
410 if (string == colon) {
411 vPtr->first = 0; /* Default to the first index */
412 } else {
413 int result;
414
415 *colon = '\0';
416 result = Blt_VectorGetIndex(interp, vPtr, string, &ielem, flags,
417 (Blt_VectorIndexProc **) NULL);
418 *colon = ':';
419 if (result != TCL_OK) {
420 return TCL_ERROR;
421 }
422 vPtr->first = ielem;
423 }
424 if (*(colon + 1) == '\0') {
425 /* Default to the last index */
426 vPtr->last = (vPtr->length > 0) ? vPtr->length - 1 : 0;
427 } else {
428 if (Blt_VectorGetIndex(interp, vPtr, colon + 1, &ielem, flags,
429 (Blt_VectorIndexProc **) NULL) != TCL_OK) {
430 return TCL_ERROR;
431 }
432 vPtr->last = ielem;
433 }
434 if (vPtr->first > vPtr->last) {
435 if (interp != NULL) {
436 Tcl_AppendResult(interp, "bad range \"", string,
437 "\" (first > last)", (char *)NULL);
438 }
439 return TCL_ERROR;
440 }
441 } else {
442 if (Blt_VectorGetIndex(interp, vPtr, string, &ielem, flags,
443 procPtrPtr) != TCL_OK) {
444 return TCL_ERROR;
445 }
446 vPtr->last = vPtr->first = ielem;
447 }
448 return TCL_OK;
449 }
450
451 VectorObject *
Blt_VectorParseElement(interp,dataPtr,start,endPtr,flags)452 Blt_VectorParseElement(interp, dataPtr, start, endPtr, flags)
453 Tcl_Interp *interp;
454 VectorInterpData *dataPtr; /* Interpreter-specific data. */
455 CONST char *start;
456 char **endPtr;
457 int flags;
458 {
459 register char *p;
460 char saved;
461 VectorObject *vPtr;
462
463 p = (char *)start;
464 /* Find the end of the vector name */
465 while (VECTOR_CHAR(*p)) {
466 p++;
467 }
468 saved = *p;
469 *p = '\0';
470
471 vPtr = GetVectorObject(dataPtr, start, flags);
472 if (vPtr == NULL) {
473 if (interp != NULL) {
474 Tcl_AppendResult(interp, "can't find vector \"", start, "\"",
475 (char *)NULL);
476 }
477 *p = saved;
478 return NULL;
479 }
480 *p = saved;
481 vPtr->first = 0;
482 vPtr->last = vPtr->length - 1;
483 if (*p == '(') {
484 int count, result;
485
486 start = p + 1;
487 p++;
488
489 /* Find the matching right parenthesis */
490 count = 1;
491 while (*p != '\0') {
492 if (*p == ')') {
493 count--;
494 if (count == 0) {
495 break;
496 }
497 } else if (*p == '(') {
498 count++;
499 }
500 p++;
501 }
502 if (count > 0) {
503 if (interp != NULL) {
504 Tcl_AppendResult(interp, "unbalanced parentheses \"", start,
505 "\"", (char *)NULL);
506 }
507 return NULL;
508 }
509 *p = '\0';
510 result = Blt_VectorGetIndexRange(interp, vPtr, start,
511 (INDEX_COLON | INDEX_CHECK), (Blt_VectorIndexProc **) NULL);
512 *p = ')';
513 if (result != TCL_OK) {
514 return NULL;
515 }
516 p++;
517 }
518 if (endPtr != NULL) {
519 *endPtr = p;
520 }
521 return vPtr;
522 }
523
524
525 /*
526 * ----------------------------------------------------------------------
527 *
528 * Blt_VectorNotifyClients --
529 *
530 * Notifies each client of the vector that the vector has changed
531 * (updated or destroyed) by calling the provided function back.
532 * The function pointer may be NULL, in that case the client is
533 * not notified.
534 *
535 * Results:
536 * None.
537 *
538 * Side effects:
539 * The results depend upon what actions the client callbacks
540 * take.
541 *
542 * ----------------------------------------------------------------------
543 */
544 void
Blt_VectorNotifyClients(clientData)545 Blt_VectorNotifyClients(clientData)
546 ClientData clientData;
547 {
548 VectorObject *vPtr = clientData;
549 Blt_ChainLink *linkPtr;
550 VectorClient *clientPtr;
551 Blt_VectorNotify notify;
552
553 notify = (vPtr->notifyFlags & NOTIFY_DESTROYED)
554 ? BLT_VECTOR_NOTIFY_DESTROY : BLT_VECTOR_NOTIFY_UPDATE;
555 vPtr->notifyFlags &= ~(NOTIFY_UPDATED | NOTIFY_DESTROYED | NOTIFY_PENDING);
556
557 for (linkPtr = Blt_ChainFirstLink(vPtr->chainPtr); linkPtr != NULL;
558 linkPtr = Blt_ChainNextLink(linkPtr)) {
559 clientPtr = Blt_ChainGetValue(linkPtr);
560 if (clientPtr->proc != NULL) {
561 (*clientPtr->proc) (vPtr->interp, clientPtr->clientData, notify);
562 }
563 }
564 /*
565 * Some clients may not handle the "destroy" callback properly
566 * (they should call Blt_FreeVectorId to release the client
567 * identifier), so mark any remaining clients to indicate that
568 * vector's server has gone away.
569 */
570 if (notify == BLT_VECTOR_NOTIFY_DESTROY) {
571 for (linkPtr = Blt_ChainFirstLink(vPtr->chainPtr); linkPtr != NULL;
572 linkPtr = Blt_ChainNextLink(linkPtr)) {
573 clientPtr = Blt_ChainGetValue(linkPtr);
574 clientPtr->serverPtr = NULL;
575 }
576 }
577 if (vPtr->callback) {
578 Tcl_EvalObjEx( vPtr->interp, vPtr->callback, TCL_GLOBAL_ONLY);
579 }
580 }
581
582 /*
583 * ----------------------------------------------------------------------
584 *
585 * Blt_VectorUpdateClients --
586 *
587 * Notifies each client of the vector that the vector has changed
588 * (updated or destroyed) by calling the provided function back.
589 *
590 * Results:
591 * None.
592 *
593 * Side effects:
594 * The individual client callbacks are eventually invoked.
595 *
596 * ----------------------------------------------------------------------
597 */
598 void
Blt_VectorUpdateClients(vPtr)599 Blt_VectorUpdateClients(vPtr)
600 VectorObject *vPtr;
601 {
602 vPtr->dirty++;
603 vPtr->max = vPtr->min = bltNaN;
604 if (vPtr->notifyFlags & NOTIFY_NEVER) {
605 return;
606 }
607 vPtr->notifyFlags |= NOTIFY_UPDATED;
608 if (vPtr->notifyFlags & NOTIFY_ALWAYS) {
609 Blt_VectorNotifyClients(vPtr);
610 return;
611 }
612 if (!(vPtr->notifyFlags & NOTIFY_PENDING)) {
613 vPtr->notifyFlags |= NOTIFY_PENDING;
614 Tcl_DoWhenIdle(Blt_VectorNotifyClients, vPtr);
615 }
616 }
617
618 /*
619 * ----------------------------------------------------------------------
620 *
621 * Blt_VectorFlushCache --
622 *
623 * Unsets all the elements of the Tcl array variable associated
624 * with the vector, freeing memory associated with the variable.
625 * This includes both the hash table and the hash keys. The down
626 * side is that this effectively flushes the caching of vector
627 * elements in the array. This means that the subsequent reads
628 * of the array will require a decimal to string conversion.
629 *
630 * This is needed when the vector changes its values, making
631 * the array variable out-of-sync.
632 *
633 * Results:
634 * None.
635 *
636 * Side effects:
637 * All elements of array variable (except one) are unset, freeing
638 * the memory associated with the variable.
639 *
640 * ----------------------------------------------------------------------
641 */
642 void
Blt_VectorFlushCache(vPtr)643 Blt_VectorFlushCache(vPtr)
644 VectorObject *vPtr;
645 {
646 Tcl_CallFrame *framePtr;
647 Tcl_Interp *interp = vPtr->interp;
648
649 if (vPtr->arrayName == NULL) {
650 return; /* Doesn't use the variable API */
651 }
652 framePtr = NULL;
653 if (vPtr->varNsPtr != NULL) {
654 framePtr = Blt_EnterNamespace(interp, vPtr->varNsPtr);
655 }
656 /* Turn off the trace temporarily so that we can unset all the
657 * elements in the array. */
658
659 Tcl_UntraceVar2(interp, vPtr->arrayName, (char *)NULL,
660 TRACE_ALL | vPtr->varFlags, Blt_VectorVarTrace, vPtr);
661
662 if (vPtr->numcols>1) {
663 Tcl_Interp *i = vPtr->interp;
664 Tcl_Obj *o = Tcl_NewListObj(0,0);
665 /* Preserve non-numeric datat that Tktable stores. */
666
667 Tcl_ListObjAppendElement(i, o, Tcl_NewStringObj("::array",-1));
668 Tcl_ListObjAppendElement(i, o, Tcl_NewStringObj("unset",-1));
669 Tcl_ListObjAppendElement(i, o, Tcl_NewStringObj(vPtr->arrayName,-1));
670 Tcl_ListObjAppendElement(i, o, Tcl_NewStringObj("[0-9]*,[0-9]*",-1));
671 Tcl_IncrRefCount(o);
672 if (Tcl_EvalObjEx(i, o, 0) != TCL_OK) {
673 /* printf("FAIL: %s\n", Tcl_GetStringResult(interp)); */
674 }
675 Tcl_DecrRefCount(o);
676 } else {
677 /* Clear all the element entries from the entire array */
678 Tcl_UnsetVar2(interp, vPtr->arrayName, (char *)NULL, vPtr->varFlags);
679
680 /* Restore the "end" index by default and the trace on the entire array */
681 Tcl_SetVar2(interp, vPtr->arrayName, "end", "", vPtr->varFlags);
682 }
683
684 Tcl_TraceVar2(interp, vPtr->arrayName, (char *)NULL,
685 TRACE_ALL | vPtr->varFlags, Blt_VectorVarTrace, vPtr);
686
687 if ((vPtr->varNsPtr != NULL) && (framePtr != NULL)) {
688 Blt_LeaveNamespace(interp, framePtr); /* Go back to current */
689 }
690 }
691
692 /*
693 * ----------------------------------------------------------------------
694 *
695 * Blt_VectorLookupName --
696 *
697 * Searches for the vector associated with the name given. Allow
698 * for a range specification.
699 *
700 * Results:
701 * Returns a pointer to the vector if found, otherwise NULL.
702 * If the name is not associated with a vector and the
703 * TCL_LEAVE_ERR_MSG flag is set, and interp->result will contain
704 * an error message.
705 *
706 * ----------------------------------------------------------------------
707 */
708 int
Blt_VectorLookupName(dataPtr,vecName,vPtrPtr)709 Blt_VectorLookupName(dataPtr, vecName, vPtrPtr)
710 VectorInterpData *dataPtr; /* Interpreter-specific data. */
711 char *vecName;
712 VectorObject **vPtrPtr;
713 {
714 VectorObject *vPtr;
715 char *endPtr;
716
717 vPtr = Blt_VectorParseElement(dataPtr->interp, dataPtr, vecName, &endPtr,
718 NS_SEARCH_BOTH);
719 if (vPtr == NULL) {
720 return TCL_ERROR;
721 }
722 if (*endPtr != '\0') {
723 Tcl_AppendResult(dataPtr->interp,
724 "extra characters after vector name", (char *)NULL);
725 return TCL_ERROR;
726 }
727 *vPtrPtr = vPtr;
728 return TCL_OK;
729 }
730
731 /*
732 * ----------------------------------------------------------------------
733 *
734 * DeleteCommand --
735 *
736 * Deletes the Tcl command associated with the vector, without
737 * triggering a callback to "VectorInstDeleteProc".
738 *
739 * Results:
740 * None.
741 *
742 * ----------------------------------------------------------------------
743 */
744 static void
DeleteCommand(vPtr)745 DeleteCommand(vPtr)
746 VectorObject *vPtr; /* Vector associated with the Tcl command. */
747 {
748 Tcl_Interp *interp = vPtr->interp;
749 char *qualName; /* Name of Tcl command. */
750 Tcl_CmdInfo cmdInfo;
751 Tcl_DString dString;
752
753 Tcl_DStringInit(&dString);
754 qualName = Blt_GetQualifiedName(
755 Blt_GetCommandNamespace(interp, vPtr->cmdToken),
756 Tcl_GetCommandName(interp, vPtr->cmdToken), &dString);
757 if (Tcl_GetCommandInfo(interp, qualName, &cmdInfo)) {
758 cmdInfo.deleteProc = NULL; /* Disable the callback before
759 * deleting the Tcl command.*/
760 Tcl_SetCommandInfo(interp, qualName, &cmdInfo);
761 Tcl_DeleteCommandFromToken(interp, vPtr->cmdToken);
762 }
763 Tcl_DStringFree(&dString);
764 vPtr->cmdToken = 0;
765 }
766
767 /*
768 * ----------------------------------------------------------------------
769 *
770 * UnmapVariable --
771 *
772 * Destroys the trace on the current Tcl variable designated
773 * to access the vector.
774 *
775 * Results:
776 * None.
777 *
778 * ----------------------------------------------------------------------
779 */
780 static void
UnmapVariable(vPtr)781 UnmapVariable(vPtr)
782 VectorObject *vPtr;
783 {
784 Tcl_Interp *interp = vPtr->interp;
785 Tcl_CallFrame *framePtr;
786
787 framePtr = NULL;
788 if (vPtr->varNsPtr != NULL) { /* Activate namespace */
789 framePtr = Blt_EnterNamespace(interp, vPtr->varNsPtr);
790 }
791 /* Unset the entire array */
792 Tcl_UntraceVar2(interp, vPtr->arrayName, (char *)NULL,
793 (TRACE_ALL | vPtr->varFlags), Blt_VectorVarTrace, vPtr);
794 Tcl_UnsetVar2(interp, vPtr->arrayName, (char *)NULL, vPtr->varFlags);
795
796 if ((vPtr->varNsPtr != NULL) && (framePtr != NULL)) {
797 /* Go back to current namespace */
798 Blt_LeaveNamespace(interp, framePtr);
799 }
800 if (vPtr->arrayName != NULL) {
801 Blt_Free(vPtr->arrayName);
802 vPtr->arrayName = NULL;
803 }
804 vPtr->varNsPtr = NULL;
805 }
806
807 /*
808 * ----------------------------------------------------------------------
809 *
810 * Blt_VectorMapVariable --
811 *
812 * Sets up traces on a Tcl variable to access the vector.
813 *
814 * If another variable is already mapped, it's first untraced and
815 * removed. Don't do anything else for variables named "" (even
816 * though Tcl allows this pathology). Saves the name of the new
817 * array variable.
818 *
819 * Results:
820 * A standard Tcl result. If an error occurs setting the variable
821 * TCL_ERROR is returned and an error message is left in the
822 * interpreter.
823 *
824 * Side effects:
825 * Traces are set for the new variable. The new variable name is
826 * saved in a malloc'ed string in vPtr->arrayName. If this
827 * variable is non-NULL, it indicates that a Tcl variable has
828 * been mapped to this vector.
829 *
830 * ----------------------------------------------------------------------
831 */
832 int
Blt_VectorMapVariable(interp,vPtr,name)833 Blt_VectorMapVariable(interp, vPtr, name)
834 Tcl_Interp *interp;
835 VectorObject *vPtr;
836 CONST char *name;
837 {
838 Tcl_Namespace *nsPtr;
839 Tcl_CallFrame *framePtr;
840 CONST char *varName;
841 CONST char *result;
842
843 if (vPtr->arrayName != NULL) {
844 UnmapVariable(vPtr);
845 }
846 if ((name == NULL) || (name[0] == '\0')) {
847 return TCL_OK; /* If the variable name is the empty
848 * string, simply return after
849 * removing any existing variable. */
850 }
851 framePtr = NULL;
852
853 /* Get the variable name (without the namespace qualifier). */
854 if (Blt_ParseQualifiedName(interp, name, &nsPtr, &varName) != TCL_OK) {
855 Tcl_AppendResult(interp, "can't find namespace in \"", name, "\"",
856 (char *)NULL);
857 return TCL_ERROR;
858 }
859 /* We need to use fully qualified names. */
860 varName = name;
861 if (nsPtr != NULL) {
862 /* [incr Tcl] 2.x doesn't like qualifiers with variable names,
863 * so we need to enter the namespace if one was designated. */
864 framePtr = Blt_EnterNamespace(interp, nsPtr);
865 }
866 /*
867 * To play it safe, delete the variable first. This has
868 * side-effect of unmapping the variable from any vector that may
869 * be currently using it.
870 */
871 Tcl_UnsetVar2(interp, (char *)varName, (char *)NULL, 0);
872
873 /* Set the index "end" in the array. This will create the
874 * variable immediately so that we can check its namespace
875 * context. */
876 result = Tcl_SetVar2(interp, (char *)varName, "end", "", TCL_LEAVE_ERR_MSG);
877
878 /* Determine if the variable is global or not. If there wasn't a
879 * namespace qualifier, it still may be global. We need to look
880 * inside the Var structure to see what it's namespace field says.
881 * NULL indicates that it's local. */
882
883 vPtr->varNsPtr = Blt_GetVariableNamespace(interp, varName);
884 vPtr->varFlags = (vPtr->varNsPtr != NULL) ?
885 (TCL_NAMESPACE_ONLY | TCL_GLOBAL_ONLY) : 0;
886
887 if (result != NULL) {
888 /* Trace the array on reads, writes, and unsets */
889 Tcl_TraceVar2(interp, (char *)varName, (char *)NULL,
890 (TRACE_ALL | vPtr->varFlags), Blt_VectorVarTrace, vPtr);
891 }
892 if ((nsPtr != NULL) && (framePtr != NULL)) {
893 Blt_LeaveNamespace(interp, framePtr); /* Go back to current */
894 }
895 vPtr->arrayName = Blt_Strdup(varName);
896 return (result == NULL) ? TCL_ERROR : TCL_OK;
897 }
898
899 /*
900 * ----------------------------------------------------------------------
901 *
902 * Blt_VectorChangeLength --
903 *
904 * Resizes the vector to the new size.
905 *
906 * The new size of the vector is computed by doubling the
907 * size of the vector until it fits the number of slots needed
908 * (designated by *length*).
909 *
910 * If the new size is the same as the old, simply adjust the
911 * length of the vector. Otherwise we're copying the data from
912 * one memory location to another. The trailing elements of the
913 * vector need to be reset to zero.
914 *
915 * If the storage changed memory locations, free up the old
916 * location if it was dynamically allocated.
917 *
918 * Results:
919 * A standard Tcl result. If the reallocation is successful,
920 * TCL_OK is returned, otherwise TCL_ERROR.
921 *
922 * Side effects:
923 * Memory for the array is reallocated.
924 *
925 * ----------------------------------------------------------------------
926 */
927
928 int
Blt_VectorChangeLength(vPtr,length)929 Blt_VectorChangeLength(vPtr, length)
930 VectorObject *vPtr;
931 int length;
932 {
933 int newSize; /* Size of array in elements */
934 double *newArr;
935 Tcl_FreeProc *freeProc;
936 VectorInterpData *dataPtr = vPtr->dataPtr;
937
938
939 newArr = NULL;
940 newSize = 0;
941 freeProc = TCL_STATIC;
942
943 if (length > 0) {
944 int wanted, used;
945
946 if (vPtr->numcols>1 && length%vPtr->numcols) {
947 length += (vPtr->numcols-(length%vPtr->numcols));
948 }
949 if (dataPtr->bltMaxSize>0 && length>dataPtr->bltMaxSize) {
950 Tcl_AppendResult(vPtr->interp, "vector size too large",0);
951 return TCL_ERROR;
952 }
953 wanted = length;
954 used = vPtr->length;
955
956 /* Compute the new size by doubling old size until it's big enough */
957 newSize = DEF_ARRAY_SIZE;
958 if (wanted > DEF_ARRAY_SIZE) {
959 while (newSize < wanted) {
960 newSize += newSize;
961 }
962 }
963 freeProc = vPtr->freeProc;
964 if (newSize == vPtr->size) {
965 newArr = vPtr->valueArr; /* Same size, use current array. */
966 } else {
967 /* Dynamically allocate memory for the new array. */
968 newArr = Blt_Malloc(newSize * sizeof(double));
969 if (newArr == NULL) {
970 Tcl_AppendResult(vPtr->interp, "can't allocate ",
971 Blt_Itoa(newSize), " elements for vector \"", vPtr->name,
972 "\"", (char *)NULL); return TCL_ERROR;
973 }
974 if (used > wanted) {
975 used = wanted;
976 }
977 /* Copy any previous data */
978 if (used > 0) {
979 memcpy(newArr, vPtr->valueArr, used * sizeof(double));
980 }
981 freeProc = TCL_DYNAMIC;
982 }
983 /* Clear any new slots that we're now using in the array */
984 if (wanted > used) {
985 memset(newArr + used, 0, (wanted - used) * sizeof(double));
986 }
987 }
988 if ((newArr != vPtr->valueArr) && (vPtr->valueArr != NULL)) {
989 /*
990 * We're not using the old storage anymore, so free it if it's
991 * not static. It's static because the user previously reset
992 * the vector with a statically allocated array (setting freeProc
993 * to TCL_STATIC).
994 */
995 if (vPtr->freeProc != TCL_STATIC) {
996 if (vPtr->freeProc == TCL_DYNAMIC) {
997 Blt_Free(vPtr->valueArr);
998 } else {
999 (*vPtr->freeProc) ((char *)vPtr->valueArr);
1000 }
1001 }
1002 }
1003 vPtr->valueArr = newArr;
1004 vPtr->size = newSize;
1005 vPtr->length = length;
1006 vPtr->first = 0;
1007 vPtr->last = length - 1;
1008 vPtr->freeProc = freeProc; /* Set the type of the new storage */
1009 return TCL_OK;
1010 }
1011
1012 /*
1013 * -----------------------------------------------------------------------
1014 *
1015 * Blt_ResetVector --
1016 *
1017 * Resets the vector data. This is called by a client to
1018 * indicate that the vector data has changed. The vector does
1019 * not need to point to different memory. Any clients of the
1020 * vector will be notified of the change.
1021 *
1022 * Results:
1023 * A standard Tcl result. If the new array size is invalid,
1024 * TCL_ERROR is returned. Otherwise TCL_OK is returned and the
1025 * new vector data is recorded.
1026 *
1027 * Side Effects:
1028 * Any client designated callbacks will be posted. Memory may
1029 * be changed for the vector array.
1030 *
1031 * -----------------------------------------------------------------------
1032 */
1033 int
Blt_VectorReset(vPtr,valueArr,length,size,freeProc)1034 Blt_VectorReset(vPtr, valueArr, length, size, freeProc)
1035 VectorObject *vPtr;
1036 double *valueArr; /* Array containing the elements of the
1037 * vector. If NULL, indicates to reset the
1038 * vector.*/
1039 int length; /* The number of elements that the vector
1040 * currently holds. */
1041 int size; /* The maximum number of elements that the
1042 * array can hold. */
1043 Tcl_FreeProc *freeProc; /* Address of memory deallocation routine
1044 * for the array of values. Can also be
1045 * TCL_STATIC, TCL_DYNAMIC, or TCL_VOLATILE. */
1046 {
1047 if (vPtr->valueArr != valueArr) { /* New array of values resides
1048 * in different memory than
1049 * the current vector. */
1050 if ((valueArr == NULL) || (size == 0)) {
1051 /* Empty array. Set up default values */
1052 freeProc = TCL_STATIC;
1053 valueArr = NULL;
1054 size = length = 0;
1055 } else if (freeProc == TCL_VOLATILE) {
1056 double *newArr;
1057 /* Data is volatile. Make a copy of the value array. */
1058 newArr = Blt_Malloc(size * sizeof(double));
1059 if (newArr == NULL) {
1060 Tcl_AppendResult(vPtr->interp, "can't allocate ",
1061 Blt_Itoa(size), " elements for vector \"",
1062 vPtr->name, "\"", (char *)NULL);
1063 return TCL_ERROR;
1064 }
1065 memcpy((char *)newArr, (char *)valueArr,
1066 sizeof(double) * length);
1067 valueArr = newArr;
1068 freeProc = TCL_DYNAMIC;
1069 }
1070
1071 if (vPtr->freeProc != TCL_STATIC) {
1072 /* Old data was dynamically allocated. Free it before
1073 * attaching new data. */
1074 if (vPtr->freeProc == TCL_DYNAMIC) {
1075 Blt_Free(vPtr->valueArr);
1076 } else {
1077 (*freeProc) ((char *)vPtr->valueArr);
1078 }
1079 }
1080 vPtr->freeProc = freeProc;
1081 vPtr->valueArr = valueArr;
1082 vPtr->size = size;
1083 }
1084
1085 vPtr->length = length;
1086 if (vPtr->flush) {
1087 Blt_VectorFlushCache(vPtr);
1088 }
1089 Blt_VectorUpdateClients(vPtr);
1090 return TCL_OK;
1091 }
1092
1093 VectorObject *
Blt_VectorNew(dataPtr)1094 Blt_VectorNew(dataPtr)
1095 VectorInterpData *dataPtr; /* Interpreter-specific data. */
1096 {
1097 VectorObject *vPtr;
1098
1099 vPtr = Blt_Calloc(1, sizeof(VectorObject));
1100 assert(vPtr);
1101 vPtr->notifyFlags = NOTIFY_WHENIDLE;
1102 vPtr->freeProc = TCL_STATIC;
1103 vPtr->dataPtr = dataPtr;
1104 vPtr->valueArr = NULL;
1105 vPtr->length = vPtr->size = 0;
1106 vPtr->interp = dataPtr->interp;
1107 vPtr->hashPtr = NULL;
1108 vPtr->chainPtr = Blt_ChainCreate();
1109 vPtr->flush = FALSE;
1110 vPtr->numcols = 1;
1111 vPtr->min = vPtr->max = bltNaN;
1112 return vPtr;
1113 }
1114
1115 /*
1116 * ----------------------------------------------------------------------
1117 *
1118 * Blt_VectorFree --
1119 *
1120 * Removes the memory and frees resources associated with the
1121 * vector.
1122 *
1123 * o Removes the trace and the Tcl array variable and unsets
1124 * the variable.
1125 * o Notifies clients of the vector that the vector is being
1126 * destroyed.
1127 * o Removes any clients that are left after notification.
1128 * o Frees the memory (if necessary) allocated for the array.
1129 * o Removes the entry from the hash table of vectors.
1130 * o Frees the memory allocated for the name.
1131 *
1132 * Results:
1133 * None.
1134 *
1135 * Side effects:
1136 *
1137 * ----------------------------------------------------------------------
1138 */
1139 void
Blt_VectorFree(vPtr)1140 Blt_VectorFree(vPtr)
1141 VectorObject *vPtr;
1142 {
1143 Blt_ChainLink *linkPtr;
1144 VectorClient *clientPtr;
1145
1146 if (vPtr->cmdToken != 0) {
1147 DeleteCommand(vPtr);
1148 }
1149 if (vPtr->arrayName != NULL) {
1150 UnmapVariable(vPtr);
1151 }
1152 vPtr->length = 0;
1153
1154 /* Immediately notify clients that vector is going away */
1155 if (vPtr->notifyFlags & NOTIFY_PENDING) {
1156 vPtr->notifyFlags &= ~NOTIFY_PENDING;
1157 Tcl_CancelIdleCall(Blt_VectorNotifyClients, vPtr);
1158 }
1159 vPtr->notifyFlags |= NOTIFY_DESTROYED;
1160 Blt_VectorNotifyClients(vPtr);
1161
1162 for (linkPtr = Blt_ChainFirstLink(vPtr->chainPtr); linkPtr != NULL;
1163 linkPtr = Blt_ChainNextLink(linkPtr)) {
1164 clientPtr = Blt_ChainGetValue(linkPtr);
1165 Blt_Free(clientPtr);
1166 }
1167 Blt_ChainDestroy(vPtr->chainPtr);
1168 if ((vPtr->valueArr != NULL) && (vPtr->freeProc != TCL_STATIC)) {
1169 if (vPtr->freeProc == TCL_DYNAMIC) {
1170 Blt_Free(vPtr->valueArr);
1171 } else {
1172 (*vPtr->freeProc) ((char *)vPtr->valueArr);
1173 }
1174 }
1175 if (vPtr->hashPtr != NULL) {
1176 Blt_DeleteHashEntry(&(vPtr->dataPtr->vectorTable), vPtr->hashPtr);
1177 }
1178 #ifdef NAMESPACE_DELETE_NOTIFY
1179 if (vPtr->nsPtr != NULL) {
1180 Blt_DestroyNsDeleteNotify(vPtr->interp, vPtr->nsPtr, vPtr);
1181 }
1182 #endif /* NAMESPACE_DELETE_NOTIFY */
1183 Blt_Free(vPtr);
1184 }
1185
1186 /*
1187 * ----------------------------------------------------------------------
1188 *
1189 * VectorInstDeleteProc --
1190 *
1191 * Deletes the command associated with the vector. This is
1192 * called only when the command associated with the vector is
1193 * destroyed.
1194 *
1195 * Results:
1196 * None.
1197 *
1198 * ----------------------------------------------------------------------
1199 */
1200 static void
VectorInstDeleteProc(clientData)1201 VectorInstDeleteProc(clientData)
1202 ClientData clientData;
1203 {
1204 VectorObject *vPtr = clientData;
1205
1206 vPtr->cmdToken = 0;
1207 Blt_VectorFree(vPtr);
1208 }
1209
1210 /*
1211 * ----------------------------------------------------------------------
1212 *
1213 * Blt_VectorCreate --
1214 *
1215 * Creates a vector structure and the following items:
1216 *
1217 * o Tcl command
1218 * o Tcl array variable and establishes traces on the variable
1219 * o Adds a new entry in the vector hash table
1220 *
1221 * Results:
1222 * A pointer to the new vector structure. If an error occurred
1223 * NULL is returned and an error message is left in
1224 * interp->result.
1225 *
1226 * Side effects:
1227 * A new Tcl command and array variable is added to the
1228 * interpreter.
1229 *
1230 * ---------------------------------------------------------------------- */
1231 VectorObject *
Blt_VectorCreate(dataPtr,vecName,cmdName,varName,newPtr)1232 Blt_VectorCreate(dataPtr, vecName, cmdName, varName, newPtr)
1233 VectorInterpData *dataPtr; /* Interpreter-specific data. */
1234 CONST char *vecName; /* Namespace-qualified name of the vector */
1235 CONST char *cmdName; /* Name of the Tcl command mapped to
1236 * the vector */
1237 CONST char *varName; /* Name of the Tcl array mapped to the
1238 * vector */
1239 int *newPtr;
1240 {
1241 Tcl_DString dString;
1242 VectorObject *vPtr;
1243 int isNew;
1244 CONST char *name;
1245 char *qualName;
1246 Tcl_Namespace *nsPtr;
1247 Blt_HashEntry *hPtr;
1248 Tcl_Interp *interp = dataPtr->interp;
1249
1250 isNew = 0;
1251 nsPtr = NULL;
1252 vPtr = NULL;
1253
1254 if (Blt_ParseQualifiedName(interp, vecName, &nsPtr, &name) != TCL_OK) {
1255 Tcl_AppendResult(interp, "can't find namespace in \"", vecName, "\"",
1256 (char *)NULL);
1257 return NULL;
1258 }
1259 if (nsPtr == NULL) {
1260 nsPtr = Tcl_GetCurrentNamespace(interp);
1261 }
1262 Tcl_DStringInit(&dString);
1263 if ((name[0] == '#') && (strcmp(name, "#auto") == 0)) {
1264 char string[200];
1265
1266 do { /* Generate a unique vector name. */
1267 sprintf(string, "vector%d", dataPtr->nextId++);
1268 qualName = Blt_GetQualifiedName(nsPtr, string, &dString);
1269 hPtr = Blt_FindHashEntry(&(dataPtr->vectorTable), qualName);
1270 } while (hPtr != NULL);
1271 } else {
1272 register CONST char *p;
1273
1274 for (p = name; *p != '\0'; p++) {
1275 if (!VECTOR_CHAR(*p)) {
1276 Tcl_AppendResult(interp, "bad vector name \"", name,
1277 "\": must contain digits, letters, underscore, or period",
1278 (char *)NULL);
1279 goto error;
1280 }
1281 }
1282 qualName = Blt_GetQualifiedName(nsPtr, name, &dString);
1283 vPtr = Blt_VectorParseElement((Tcl_Interp *)NULL, dataPtr, qualName,
1284 (char **)NULL, NS_SEARCH_CURRENT);
1285 }
1286 if (vPtr == NULL) {
1287 hPtr = Blt_CreateHashEntry(&(dataPtr->vectorTable), qualName, &isNew);
1288 vPtr = Blt_VectorNew(dataPtr);
1289 vPtr->hashPtr = hPtr;
1290 vPtr->nsPtr = nsPtr;
1291
1292 vPtr->name = Blt_GetHashKey(&(dataPtr->vectorTable), hPtr);
1293 #ifdef NAMESPACE_DELETE_NOTIFY
1294 Blt_CreateNsDeleteNotify(interp, nsPtr, vPtr, VectorInstDeleteProc);
1295 #endif /* NAMESPACE_DELETE_NOTIFY */
1296 Blt_SetHashValue(hPtr, vPtr);
1297 }
1298 if (cmdName != NULL && cmdName[0]) {
1299 Tcl_CmdInfo cmdInfo;
1300
1301 if ((cmdName == vecName) ||
1302 ((name[0] == '#') && (strcmp(name, "#auto") == 0))) {
1303 cmdName = qualName;
1304 }
1305 if (Tcl_GetCommandInfo(interp, (char *)cmdName, &cmdInfo)) {
1306 #if TCL_MAJOR_VERSION > 7
1307 if (vPtr != cmdInfo.objClientData) {
1308 #else
1309 if (vPtr != cmdInfo.clientData) {
1310 #endif
1311 Tcl_AppendResult(interp, "command \"", cmdName,
1312 "\" already exists", (char *)NULL);
1313 goto error;
1314 }
1315 /* We get here only if the old name is the same as the new. */
1316 goto checkVariable;
1317 }
1318 }
1319 if (vPtr->cmdToken != 0 && cmdName[0]) {
1320 DeleteCommand(vPtr); /* Command already exists, delete old first */
1321 }
1322 if (cmdName != NULL) {
1323 #if (TCL_MAJOR_VERSION == 7)
1324 vPtr->cmdToken = Blt_CreateCommand(interp, cmdName, Blt_VectorInstCmd,
1325 vPtr, VectorInstDeleteProc);
1326 #else
1327 Tcl_DString dString2;
1328
1329 Tcl_DStringInit(&dString2);
1330 if (cmdName != qualName) {
1331 if (Blt_ParseQualifiedName(interp, cmdName, &nsPtr, &name)
1332 != TCL_OK) {
1333 Tcl_AppendResult(interp, "can't find namespace in \"", cmdName,
1334 "\"", (char *)NULL);
1335 goto error;
1336 }
1337 if (nsPtr == NULL) {
1338 nsPtr = Tcl_GetCurrentNamespace(interp);
1339 }
1340 cmdName = Blt_GetQualifiedName(nsPtr, name, &dString2);
1341 }
1342 vPtr->cmdToken = Tcl_CreateObjCommand(interp, (char *)cmdName,
1343 Blt_VectorInstCmd, vPtr, VectorInstDeleteProc);
1344 Tcl_DStringFree(&dString2);
1345 #endif
1346 }
1347 checkVariable:
1348 if (varName != NULL&& varName[0]) {
1349 if ((varName[0] == '#') && (strcmp(varName, "#auto") == 0)) {
1350 varName = qualName;
1351 }
1352 varName = qualName;
1353 if (Blt_VectorMapVariable(interp, vPtr, varName) != TCL_OK) {
1354 goto error;
1355 }
1356 }
1357
1358 Tcl_DStringFree(&dString);
1359 *newPtr = isNew;
1360 return vPtr;
1361
1362 error:
1363 Tcl_DStringFree(&dString);
1364 if (vPtr != NULL) {
1365 Blt_VectorFree(vPtr);
1366 }
1367 return NULL;
1368 }
1369
1370
1371 int
Blt_VectorDuplicate(destPtr,srcPtr)1372 Blt_VectorDuplicate(destPtr, srcPtr)
1373 VectorObject *destPtr, *srcPtr;
1374 {
1375 int nBytes;
1376 int length;
1377
1378 if (destPtr == srcPtr) {
1379 /* Copying the same vector. */
1380 }
1381 length = srcPtr->last - srcPtr->first + 1;
1382 if (Blt_VectorChangeLength(destPtr, length) != TCL_OK) {
1383 return TCL_ERROR;
1384 }
1385 nBytes = length * sizeof(double);
1386 memcpy(destPtr->valueArr, srcPtr->valueArr + srcPtr->first, nBytes);
1387 destPtr->offset = srcPtr->offset;
1388 return TCL_OK;
1389 }
1390
1391
1392 /*
1393 *----------------------------------------------------------------------
1394 *
1395 * VectorNamesOp --
1396 *
1397 * Reports the names of all the current vectors in the interpreter.
1398 *
1399 * Results:
1400 * A standard Tcl result. interp->result will contain a list of
1401 * all the names of the vector instances.
1402 *
1403 *----------------------------------------------------------------------
1404 */
1405 /*ARGSUSED*/
1406 #if (TCL_MAJOR_VERSION == 7)
1407
1408 static int
VectorNamesOp(clientData,interp,argc,argv)1409 VectorNamesOp(clientData, interp, argc, argv)
1410 ClientData clientData; /* Interpreter-specific data. */
1411 Tcl_Interp *interp;
1412 int argc;
1413 char **argv;
1414 {
1415 VectorInterpData *dataPtr = clientData;
1416 Blt_HashEntry *hPtr;
1417 char *name;
1418 Blt_HashSearch cursor;
1419
1420 for (hPtr = Blt_FirstHashEntry(&(dataPtr->vectorTable), &cursor);
1421 hPtr != NULL; hPtr = Blt_NextHashEntry(&cursor)) {
1422 name = Blt_GetHashKey(&(dataPtr->vectorTable), hPtr);
1423 if ((argc == 2) || (Tcl_StringMatch(name, argv[2]))) {
1424 Tcl_AppendElement(interp, name);
1425 }
1426 }
1427 return TCL_OK;
1428 }
1429
1430 #else
1431
1432 static int
VectorNamesObjOp(clientData,interp,objc,objv)1433 VectorNamesObjOp(clientData, interp, objc, objv)
1434 ClientData clientData; /* Interpreter-specific data. */
1435 Tcl_Interp *interp;
1436 int objc;
1437 Tcl_Obj *CONST *objv;
1438 {
1439 VectorInterpData *dataPtr = clientData;
1440 Blt_HashEntry *hPtr;
1441 char *name;
1442 Blt_HashSearch cursor;
1443
1444 for (hPtr = Blt_FirstHashEntry(&(dataPtr->vectorTable), &cursor);
1445 hPtr != NULL; hPtr = Blt_NextHashEntry(&cursor)) {
1446 name = Blt_GetHashKey(&(dataPtr->vectorTable), hPtr);
1447 if ((objc == 2) || (Tcl_StringMatch(name, Tcl_GetString(objv[2])))) {
1448 Tcl_AppendElement(interp, name);
1449 }
1450 }
1451 return TCL_OK;
1452 }
1453
1454 #endif
1455
1456 /*
1457 *----------------------------------------------------------------------
1458 *
1459 * VectorCreateOp --
1460 *
1461 * Creates a Tcl command, and array variable representing an
1462 * instance of a vector.
1463 *
1464 * vector a
1465 * vector b(20)
1466 * vector c(-5:14)
1467 *
1468 * Results:
1469 * A standard Tcl result.
1470 *
1471 * Side effects:
1472 * See the user documentation.
1473 *
1474 *----------------------------------------------------------------------
1475 */
1476 /*ARGSUSED*/
1477 static int
VectorCreate2(clientData,interp,argStart,argc,argv)1478 VectorCreate2(clientData, interp, argStart, argc, argv)
1479 ClientData clientData; /* Interpreter-specific data. */
1480 Tcl_Interp *interp;
1481 int argStart;
1482 int argc;
1483 char **argv;
1484 {
1485 VectorInterpData *dataPtr = clientData;
1486 VectorObject *vPtr;
1487 char *leftParen, *rightParen;
1488 int isNew, size, first, last;
1489 char *cmdName, *varName;
1490 int length;
1491 int inspectFlags, freeOnUnset, flush;
1492 char **nameArr;
1493 int count, numcols = 1;
1494 register int i;
1495
1496 /*
1497 * Handle switches to the vector command and collect the vector
1498 * name arguments into an array.
1499 */
1500 varName = cmdName = NULL;
1501 freeOnUnset = dataPtr->bltFreeOnUnset;
1502 nameArr = Blt_Malloc(sizeof(char *) * argc);
1503 assert(nameArr);
1504
1505 inspectFlags = TRUE;
1506 flush = dataPtr->bltFlushArray;
1507 count = 0;
1508 vPtr = NULL;
1509 for (i = argStart; i < argc; i++) {
1510 if ((inspectFlags) && (argv[i][0] == '-')) {
1511 length = strlen(argv[i]);
1512 if ((length > 1) &&
1513 (strncmp(argv[i], "-variable", length) == 0)) {
1514 if ((i + 1) == argc) {
1515 Tcl_AppendResult(interp,
1516 "no variable name supplied with \"",
1517 argv[i], "\" switch", (char *)NULL);
1518 goto error;
1519 }
1520 i++;
1521 varName = argv[i];
1522 } else if ((length > 1) &&
1523 (strncmp(argv[i], "-command", length) == 0)) {
1524 if ((i + 1) == argc) {
1525 Tcl_AppendResult(interp,
1526 "no command name supplied with \"",
1527 argv[i], "\" switch", (char *)NULL);
1528 goto error;
1529 }
1530 i++;
1531 cmdName = argv[i];
1532 } else if ((length > 1) &&
1533 (strncmp(argv[i], "-watchunset", length) == 0)) {
1534 int bool;
1535
1536 if ((i + 1) == argc) {
1537 Tcl_AppendResult(interp, "no value name supplied with \"",
1538 argv[i], "\" switch", (char *)NULL);
1539 goto error;
1540 }
1541 i++;
1542 if (Tcl_GetBoolean(interp, argv[i], &bool) != TCL_OK) {
1543 goto error;
1544 }
1545 freeOnUnset = bool;
1546 } else if ((length > 1) && (strncmp(argv[i], "-flush", length) == 0)) {
1547 int bool;
1548
1549 if ((i + 1) == argc) {
1550 Tcl_AppendResult(interp, "no value name supplied with \"",
1551 argv[i], "\" switch", (char *)NULL);
1552 goto error;
1553 }
1554 i++;
1555 if (Tcl_GetBoolean(interp, argv[i], &bool) != TCL_OK) {
1556 goto error;
1557 }
1558 flush = bool;
1559 } else if ((length > 1) && (argv[i][1] == '-') &&
1560 (argv[i][2] == '\0')) {
1561 inspectFlags = FALSE; /* Allow vector names to start with - */
1562 } else {
1563 Tcl_AppendResult(interp, "bad vector switch \"", argv[i], "\"",
1564 (char *)NULL);
1565 goto error;
1566 }
1567 } else {
1568 nameArr[count++] = argv[i];
1569 }
1570 }
1571 if (varName == NULL && dataPtr->bltNoVariable) {
1572 varName = "";
1573 }
1574 if (cmdName == NULL && dataPtr->bltNoCommand) {
1575 cmdName = "";
1576 }
1577 if (count == 0) {
1578 Tcl_AppendResult(interp, "no vector names supplied", (char *)NULL);
1579 goto error;
1580 }
1581 if (count > 1) {
1582 if ((cmdName != NULL) && (cmdName[0] != '\0')) {
1583 Tcl_AppendResult(interp,
1584 "can't specify more than one vector with \"-command\" switch",
1585 (char *)NULL);
1586 goto error;
1587 }
1588 if ((varName != NULL) && (varName[0] != '\0')) {
1589 Tcl_AppendResult(interp,
1590 "can't specify more than one vector with \"-variable\" switch",
1591 (char *)NULL);
1592 goto error;
1593 }
1594 }
1595 for (i = 0; i < count; i++) {
1596 size = first = last = 0;
1597 leftParen = strchr(nameArr[i], '(');
1598 rightParen = strchr(nameArr[i], ')');
1599 if (((leftParen != NULL) && (rightParen == NULL)) ||
1600 ((leftParen == NULL) && (rightParen != NULL)) ||
1601 (leftParen > rightParen)) {
1602 Tcl_AppendResult(interp, "bad vector specification \"", nameArr[i],
1603 "\"", (char *)NULL);
1604 goto error;
1605 }
1606 if (leftParen != NULL) {
1607 int result;
1608 char *colon, *comma;
1609
1610 *rightParen = '\0';
1611 comma = strchr(leftParen + 1, ',');
1612 colon = strchr(leftParen + 1, ':');
1613 if (comma != NULL) {
1614 int rows;
1615 *comma = '\0';
1616 result = Tcl_GetInt(interp, leftParen + 1, &rows);
1617 if ((*(comma + 1) != '\0') && (result == TCL_OK)) {
1618 result = Tcl_GetInt(interp, comma + 1, &numcols);
1619 }
1620 size = rows*numcols;
1621 if (result != TCL_OK || rows<=0 || numcols<=0) {
1622 Tcl_AppendResult(interp, "bad matrix vector \"",
1623 nameArr[i], "\"", (char *)NULL);
1624 result = TCL_ERROR;
1625 }
1626 } else if (colon != NULL) {
1627
1628 /* Specification is in the form vecName(first:last) */
1629 *colon = '\0';
1630 result = Tcl_GetInt(interp, leftParen + 1, &first);
1631 if ((*(colon + 1) != '\0') && (result == TCL_OK)) {
1632 result = Tcl_GetInt(interp, colon + 1, &last);
1633 if (first > last) {
1634 Tcl_AppendResult(interp, "bad vector range \"",
1635 nameArr[i], "\"", (char *)NULL);
1636 result = TCL_ERROR;
1637 }
1638 size = (last - first) + 1;
1639 }
1640 *colon = ':';
1641 } else {
1642 /* Specification is in the form vecName(size) */
1643 result = Tcl_GetInt(interp, leftParen + 1, &size);
1644 }
1645 *rightParen = ')';
1646 if (result != TCL_OK) {
1647 goto error;
1648 }
1649 if (size < 0) {
1650 Tcl_AppendResult(interp, "bad vector size \"", nameArr[i], "\"",
1651 (char *)NULL);
1652 goto error;
1653 }
1654 }
1655 if (leftParen != NULL) {
1656 *leftParen = '\0';
1657 }
1658 if (dataPtr->bltMaxSize>0 && size>dataPtr->bltMaxSize) {
1659 Tcl_AppendResult(interp, "vector size too large\"", nameArr[i], "\"",
1660 (char *)NULL);
1661 goto error;
1662 }
1663 /*
1664 * By default, we create a Tcl command by the name of the vector.
1665 */
1666 vPtr = Blt_VectorCreate(dataPtr, nameArr[i],
1667 (cmdName == NULL) ? nameArr[i] : cmdName,
1668 (varName == NULL) ? nameArr[i] : varName,
1669 &isNew);
1670 if (leftParen != NULL) {
1671 *leftParen = '(';
1672 }
1673 if (vPtr == NULL) {
1674 goto error;
1675 }
1676 vPtr->freeOnUnset = freeOnUnset;
1677 vPtr->flush = flush;
1678 vPtr->offset = first;
1679 if (first && first%vPtr->numcols) {
1680 first += (vPtr->numcols-(first%vPtr->numcols));
1681 }
1682 vPtr->numcols = numcols;
1683 if (size > 0) {
1684 if (Blt_VectorChangeLength(vPtr, size) != TCL_OK) {
1685 goto error;
1686 }
1687 }
1688 if (!isNew) {
1689 if (vPtr->flush) {
1690 Blt_VectorFlushCache(vPtr);
1691 }
1692 Blt_VectorUpdateClients(vPtr);
1693 }
1694 }
1695 Blt_Free(nameArr);
1696 if (vPtr != NULL) {
1697 /* Return the name of the last vector created */
1698 Tcl_SetResult(interp, vPtr->name, TCL_VOLATILE);
1699 }
1700 return TCL_OK;
1701 error:
1702 Blt_Free(nameArr);
1703 return TCL_ERROR;
1704 }
1705
1706 static int
VectorObjCallOp(clientData,interp,objc,objv,proc)1707 VectorObjCallOp(clientData, interp, objc, objv, proc)
1708 ClientData clientData;
1709 Tcl_Interp *interp;
1710 int objc;
1711 Tcl_Obj *CONST *objv;
1712 Blt_Op proc;
1713 {
1714 int i, result;
1715 const char **argv;
1716 argv = (const char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
1717
1718 for (i = 0; i < objc; i++) {
1719 argv[i] = Tcl_GetString(objv[i]);
1720 }
1721 argv[objc] = 0;
1722 result = (*proc)(clientData, interp, objc, argv);
1723 ckfree((char*) argv);
1724 return result;
1725 }
1726
1727 /*
1728 *----------------------------------------------------------------------
1729 *
1730 * VectorCreateOp --
1731 *
1732 * Creates a Tcl command, and array variable representing an
1733 * instance of a vector.
1734 *
1735 * vector a
1736 * vector b(20)
1737 * vector c(-5:14)
1738 *
1739 * Results:
1740 * A standard Tcl result.
1741 *
1742 * Side effects:
1743 * See the user documentation.
1744 *
1745 *----------------------------------------------------------------------
1746 */
1747 /*ARGSUSED*/
1748 static int
VectorCreateOp(clientData,interp,argc,argv)1749 VectorCreateOp(clientData, interp, argc, argv)
1750 ClientData clientData;
1751 Tcl_Interp *interp;
1752 int argc;
1753 char **argv;
1754 {
1755 return VectorCreate2(clientData, interp, 2, argc, argv);
1756 }
1757
1758 static int
VectorCreateObjOp(clientData,interp,objc,objv)1759 VectorCreateObjOp(clientData, interp, objc, objv)
1760 ClientData clientData;
1761 Tcl_Interp *interp;
1762 int objc;
1763 Tcl_Obj *CONST *objv;
1764 {
1765 return VectorObjCallOp(clientData, interp, objc, objv, VectorCreateOp);
1766 }
1767
1768 /*
1769 *----------------------------------------------------------------------
1770 *
1771 * VectorDestroyOp --
1772 *
1773 * Destroys the vector and its related Tcl command and array
1774 * variable (if they exist).
1775 *
1776 * Results:
1777 * A standard Tcl result.
1778 *
1779 * Side effects:
1780 * Deletes the vector.
1781 *
1782 *----------------------------------------------------------------------
1783 */
1784 /*ARGSUSED*/
1785 static int
VectorDestroyOp(clientData,interp,argc,argv)1786 VectorDestroyOp(clientData, interp, argc, argv)
1787 ClientData clientData; /* Interpreter-specific data. */
1788 Tcl_Interp *interp;
1789 int argc;
1790 char **argv;
1791 {
1792 VectorInterpData *dataPtr = clientData;
1793 VectorObject *vPtr;
1794 register int i;
1795
1796 for (i = 2; i < argc; i++) {
1797 if (Blt_VectorLookupName(dataPtr, argv[i], &vPtr) != TCL_OK) {
1798 return TCL_ERROR;
1799 }
1800 Blt_VectorFree(vPtr);
1801 }
1802 return TCL_OK;
1803 }
1804
1805 static int
VectorDestroyObjOp(clientData,interp,objc,objv)1806 VectorDestroyObjOp(clientData, interp, objc, objv)
1807 ClientData clientData;
1808 Tcl_Interp *interp;
1809 int objc;
1810 Tcl_Obj *CONST *objv;
1811 {
1812 return VectorObjCallOp(clientData, interp, objc, objv, VectorDestroyOp);
1813 }
1814
1815 #if (TCL_MAJOR_VERSION == 7)
1816
1817 static int
VectorOpOp(clientData,interp,argc,argv)1818 VectorOpOp(clientData, interp, argc, argv)
1819 ClientData clientData; /* Interpreter-specific data. */
1820 Tcl_Interp *interp;
1821 int argc;
1822 char **argv;
1823 {
1824 int i, result;
1825 const char **nargv;
1826 Blt_Vector *vecPtr;
1827
1828 result = Blt_GetVector(interp, Tcl_GetString(argv[3]), &vecPtr);
1829 if (result != TCL_OK) {
1830 return result;
1831 }
1832 nargv = (const char **) ckalloc((unsigned)(argc) * sizeof(char *));
1833
1834 nargv[0] = argv[3];
1835 nargv[1] = argv[2];
1836 for (i = 2; i < (argc-2); i++) {
1837 nargv[i] = argv[i+2];
1838 }
1839 nargv[argc-2] = 0;
1840 result = Blt_VectorInstCmd((ClientData)vecPtr, interp, argc-2, nargv);
1841 ckfree((char*) nargv);
1842 return result;
1843 }
1844
1845 #else
1846
1847
1848 /*
1849 * Set/get various options. These include:
1850 *
1851 * -oldcreate : compatibility mode of implicit 'create'.
1852 * -flush : flush array cells
1853 * -watchunset: delete on var deletion.
1854 * -maxsize : max allocation.
1855 *
1856 * These are global settings to all interps.
1857 */
1858
1859 static int
VectorConfigureObjOp(clientData,interp,objc,objv)1860 VectorConfigureObjOp(clientData, interp, objc, objv)
1861 ClientData clientData;
1862 Tcl_Interp *interp;
1863 int objc;
1864 Tcl_Obj *CONST *objv;
1865 {
1866 enum optionIndices {
1867 OPTION_FLUSH, OPTION_OLDCREATE, OPTION_WATCHUNSET, OPTION_MAXSIZE,
1868 OPTION_NOCOMMAND, OPTION_NOVARIABLE
1869 };
1870 static char *optionArr[] = {
1871 "-flush", "-oldcreate", "-watchunset", "-maxsize",
1872 "-nocommand", "-novariable", 0
1873 };
1874 int i;
1875 VectorInterpData *d = clientData;
1876
1877 if (objc%2) {
1878 Tcl_WrongNumArgs(interp, 2, objv, "?-flush bool? ?-watchunset bool? ?-oldcreate bool?");
1879 return TCL_ERROR;
1880 }
1881 if (objc == 2) {
1882 Tcl_Obj * o = Tcl_NewListObj(0,0);
1883 Tcl_ListObjAppendElement(interp, o, Tcl_NewStringObj("-flush", -1));
1884 Tcl_ListObjAppendElement(interp, o, Tcl_NewBooleanObj(d->bltFlushArray));
1885 Tcl_ListObjAppendElement(interp, o, Tcl_NewStringObj("-watchunset", -1));
1886 Tcl_ListObjAppendElement(interp, o, Tcl_NewBooleanObj(d->bltFreeOnUnset));
1887 Tcl_ListObjAppendElement(interp, o, Tcl_NewStringObj("-oldcreate", -1));
1888 Tcl_ListObjAppendElement(interp, o, Tcl_NewBooleanObj(d->bltOldCreate));
1889 Tcl_ListObjAppendElement(interp, o, Tcl_NewStringObj("-nocommand", -1));
1890 Tcl_ListObjAppendElement(interp, o, Tcl_NewBooleanObj(d->bltNoCommand));
1891 Tcl_ListObjAppendElement(interp, o, Tcl_NewStringObj("-novariable", -1));
1892 Tcl_ListObjAppendElement(interp, o, Tcl_NewBooleanObj(d->bltNoVariable));
1893 Tcl_ListObjAppendElement(interp, o, Tcl_NewStringObj("-maxsize", -1));
1894 Tcl_ListObjAppendElement(interp, o, Tcl_NewIntObj(d->bltMaxSize));
1895 Tcl_SetObjResult(interp, o);
1896 return TCL_OK;
1897 }
1898 for (i=2; i<objc; i+=2) {
1899 int option, *ovar;
1900 if (Tcl_GetIndexFromObj(interp, objv[i], optionArr, "option",
1901 0, &option) != TCL_OK) {
1902 return TCL_OK;
1903 }
1904
1905 switch (option) {
1906 case OPTION_FLUSH: ovar=&d->bltFlushArray; break;
1907 case OPTION_OLDCREATE: ovar=&d->bltOldCreate; break;
1908 case OPTION_WATCHUNSET: ovar=&d->bltFreeOnUnset; break;
1909 case OPTION_NOCOMMAND: ovar=&d->bltNoCommand; break;
1910 case OPTION_NOVARIABLE: ovar=&d->bltNoVariable; break;
1911 case OPTION_MAXSIZE:
1912 if (Tcl_GetIntFromObj(interp, objv[i+1], &d->bltMaxSize) != TCL_OK) {
1913 return TCL_ERROR;
1914 }
1915 return TCL_OK;
1916 }
1917
1918 if (Tcl_GetBooleanFromObj(interp, objv[i+1], ovar) != TCL_OK) {
1919 return TCL_ERROR;
1920 }
1921 }
1922 return TCL_OK;
1923 }
1924
1925 static int
VectorOpObjOp(clientData,interp,objc,objv)1926 VectorOpObjOp(clientData, interp, objc, objv)
1927 ClientData clientData;
1928 Tcl_Interp *interp;
1929 int objc;
1930 Tcl_Obj *CONST *objv;
1931 {
1932 int i, j, o1 = 2, result;
1933 Tcl_Obj **nobjv;
1934 Blt_Vector *vecPtr;
1935 char *string;
1936
1937 string = Tcl_GetString(objv[2]);
1938 if (!strncmp(string, "ma", 2)) {
1939 /* The "vector op matrix rowize VEC ?N?" command. */
1940 o1 = 3;
1941 }
1942 result = Blt_GetVector(interp, Tcl_GetString(objv[o1+1]), &vecPtr);
1943 if (result != TCL_OK) {
1944 return result;
1945 }
1946 nobjv = (Tcl_Obj **) ckalloc((unsigned)(objc) * sizeof(Tcl_Obj *));
1947
1948 j = 0;
1949 nobjv[j++] = objv[o1+1];
1950 nobjv[j++] = objv[2];
1951 i = 4;
1952 if (o1 != 2) {
1953 nobjv[j++] = objv[3];
1954 i = 5;
1955 }
1956 for (; i < objc; j++, i++) {
1957 nobjv[j] = objv[i];
1958 }
1959 nobjv[j++] = 0;
1960 /* TODO: fix error messages in this call duplicating the arg. */
1961 result = Blt_VectorInstCmd((ClientData)vecPtr, interp, objc-2, nobjv);
1962 ckfree((char*) nobjv);
1963 return result;
1964 }
1965
1966
1967 #endif
1968
1969 /*
1970 *----------------------------------------------------------------------
1971 *
1972 * VectorExprOp --
1973 *
1974 * Computes the result of the expression which may be
1975 * either a scalar (single value) or vector (list of values).
1976 *
1977 * Results:
1978 * A standard Tcl result.
1979 *
1980 *----------------------------------------------------------------------
1981 */
1982 /*ARGSUSED*/
1983 static int
VectorExprOp(clientData,interp,argc,argv)1984 VectorExprOp(clientData, interp, argc, argv)
1985 ClientData clientData; /* Not Used. */
1986 Tcl_Interp *interp;
1987 int argc;
1988 char **argv;
1989 {
1990 return Blt_ExprVector(interp, argv[2], (Blt_Vector *) NULL);
1991 }
1992
1993 static int
VectorExprObjOp(clientData,interp,objc,objv)1994 VectorExprObjOp(clientData, interp, objc, objv)
1995 ClientData clientData;
1996 Tcl_Interp *interp;
1997 int objc;
1998 Tcl_Obj *CONST *objv;
1999 {
2000 return VectorObjCallOp(clientData, interp, objc, objv, VectorExprOp);
2001 }
2002
2003 #if (TCL_MAJOR_VERSION == 7)
2004
2005 static Blt_OpSpec vectorCmdOps[] =
2006 {
2007 {"create", 1, (Blt_Op)VectorCreateOp, 3, 0,
2008 "vecName ?vecName...? ?switches...?",},
2009 {"destroy", 1, (Blt_Op)VectorDestroyOp, 3, 0,
2010 "vecName ?vecName...?",},
2011 {"expr", 1, (Blt_Op)VectorExprOp, 3, 3, "expression",},
2012 {"names", 1, (Blt_Op)VectorNamesOp, 2, 3, "?pattern?",},
2013 {"op", 1, (Blt_Op)VectorOpOp, 4, 0, "cmd ...",},
2014 };
2015
2016 static int nCmdOps = sizeof(vectorCmdOps) / sizeof(Blt_OpSpec);
2017
2018 /*ARGSUSED*/
2019 static int
VectorCmd(clientData,interp,argc,argv)2020 VectorCmd(clientData, interp, argc, argv)
2021 ClientData clientData; /* Interpreter-specific data. */
2022 Tcl_Interp *interp;
2023 int argc;
2024 char **argv;
2025 {
2026 Blt_Op proc;
2027
2028 /*
2029 * Try to replicate the old vector command's behavior:
2030 */
2031 if (argc > 1) {
2032 char c;
2033 register int i;
2034 register Blt_OpSpec *specPtr;
2035
2036 c = argv[1][0];
2037 for (specPtr = vectorCmdOps, i = 0; i < nCmdOps; i++, specPtr++) {
2038 if ((c == specPtr->name[0]) &&
2039 (strcmp(argv[1], specPtr->name) == 0)) {
2040 goto doOp;
2041 }
2042 }
2043 /*
2044 * The first argument is not an operation, so assume that its
2045 * actually the name of a vector to be created
2046 */
2047 return VectorCreate2(clientData, interp, 1, argc, argv);
2048 }
2049 doOp:
2050 /* Do the usual vector operation lookup now. */
2051 proc = Blt_GetOp(interp, nCmdOps, vectorCmdOps, BLT_OP_ARG1, argc, argv,0);
2052 if (proc == NULL) {
2053 return TCL_ERROR;
2054 }
2055 return (*proc) (clientData, interp, argc, argv);
2056 }
2057
2058 #else
2059
2060 static Blt_OpSpec vectorCmdOps[] =
2061 {
2062 {"configure", 1, (Blt_Op)VectorConfigureObjOp, 2, 0, "?-flush bool? ?-watchunset bool? ?-oldcreate bool? ?-maxsize N? ?-nocommand bool? ?-novariable bool?",},
2063 {"create", 1, (Blt_Op)VectorCreateObjOp, 3, 0,
2064 "vecName ?vecName...? ?switches...?",},
2065 {"destroy", 1, (Blt_Op)VectorDestroyObjOp, 3, 0,
2066 "vecName ?vecName...?",},
2067 {"expr", 1, (Blt_Op)VectorExprObjOp, 3, 3, "expression",},
2068 {"names", 1, (Blt_Op)VectorNamesObjOp, 2, 3, "?pattern?",},
2069 {"op", 1, (Blt_Op)VectorOpObjOp, 4, 0, "cmd vecName ...",},
2070 };
2071
2072 static int nCmdOps = sizeof(vectorCmdOps) / sizeof(Blt_OpSpec);
2073
2074 static int
VectorObjCmd(clientData,interp,objc,objv)2075 VectorObjCmd(clientData, interp, objc, objv)
2076 ClientData clientData; /* Interpreter-specific data. */
2077 Tcl_Interp *interp;
2078 int objc;
2079 Tcl_Obj *CONST *objv;
2080 {
2081 Blt_Op proc;
2082 VectorInterpData *dataPtr = clientData;
2083
2084 /*
2085 * Try to replicate the old vector command's behavior:
2086 */
2087 if (objc > 1 && dataPtr->bltOldCreate) {
2088 char c, *str;
2089 register int i;
2090 register Blt_OpSpec *specPtr;
2091 int result;
2092 int argc;
2093 char **argv;
2094 Tcl_Obj *listPtr;
2095
2096 str = Tcl_GetString(objv[1]);
2097 c = str[0];
2098 for (specPtr = vectorCmdOps, i = 0; i < nCmdOps; i++, specPtr++) {
2099 if ((c == specPtr->name[0]) &&
2100 (strcmp(str, specPtr->name) == 0)) {
2101 goto doOp;
2102 }
2103 }
2104 /*
2105 * The first argument is not an operation, so assume that its
2106 * actually the name of a vector to be created
2107 */
2108 listPtr = Tcl_NewListObj(objc, objv);
2109 result = Tcl_SplitList( interp, Tcl_GetString(listPtr), &argc, &argv);
2110 if (result == TCL_OK) {
2111 result = VectorCreate2(clientData, interp, 1, argc, argv);
2112 ckfree((char*) argv);
2113 }
2114 Tcl_DecrRefCount(listPtr);
2115 return result;
2116 }
2117 doOp:
2118 /* Do the usual vector operation lookup now. */
2119 proc = Blt_GetOpFromObj(interp, nCmdOps, vectorCmdOps, BLT_OP_ARG1, objc, objv,0);
2120 if (proc == NULL) {
2121 return TCL_ERROR;
2122 }
2123 return (*proc) (clientData, interp, objc, objv);
2124 }
2125
2126 #endif
2127
2128
2129 /*
2130 * -----------------------------------------------------------------------
2131 *
2132 * VectorInterpDeleteProc --
2133 *
2134 * This is called when the interpreter hosting the "vector" command
2135 * is deleted.
2136 *
2137 * Results:
2138 * None.
2139 *
2140 * Side effects:
2141 * Destroys the math and index hash tables. In addition removes
2142 * the hash table managing all vector names.
2143 *
2144 * ------------------------------------------------------------------------
2145 */
2146 /* ARGSUSED */
2147 static void
VectorInterpDeleteProc(clientData,interp)2148 VectorInterpDeleteProc(clientData, interp)
2149 ClientData clientData; /* Interpreter-specific data. */
2150 Tcl_Interp *interp;
2151 {
2152 VectorInterpData *dataPtr = clientData;
2153 Blt_HashEntry *hPtr;
2154 Blt_HashSearch cursor;
2155 VectorObject *vPtr;
2156
2157 for (hPtr = Blt_FirstHashEntry(&(dataPtr->vectorTable), &cursor);
2158 hPtr != NULL; hPtr = Blt_NextHashEntry(&cursor)) {
2159 vPtr = (VectorObject *)Blt_GetHashValue(hPtr);
2160 vPtr->hashPtr = NULL;
2161 Blt_VectorFree(vPtr);
2162 }
2163 Blt_DeleteHashTable(&(dataPtr->vectorTable));
2164
2165 /* If any user-defined math functions were installed, remove them. */
2166 Blt_VectorUninstallMathFunctions(&(dataPtr->mathProcTable));
2167 Blt_DeleteHashTable(&(dataPtr->mathProcTable));
2168
2169 Blt_DeleteHashTable(&(dataPtr->indexProcTable));
2170 Tcl_DeleteAssocData(interp, VECTOR_THREAD_KEY);
2171 Blt_Free(dataPtr);
2172 }
2173
2174 VectorInterpData *
Blt_VectorGetInterpData(interp)2175 Blt_VectorGetInterpData(interp)
2176 Tcl_Interp *interp;
2177 {
2178 VectorInterpData *dataPtr;
2179 Tcl_InterpDeleteProc *proc;
2180
2181 dataPtr = (VectorInterpData *)
2182 Tcl_GetAssocData(interp, VECTOR_THREAD_KEY, &proc);
2183 if (dataPtr == NULL) {
2184 dataPtr = Blt_Calloc(sizeof(VectorInterpData), 1);
2185 assert(dataPtr);
2186 dataPtr->interp = interp;
2187 dataPtr->nextId = 0;
2188 Tcl_SetAssocData(interp, VECTOR_THREAD_KEY, VectorInterpDeleteProc,
2189 dataPtr);
2190 Blt_InitHashTable(&(dataPtr->vectorTable), BLT_STRING_KEYS);
2191 Blt_InitHashTable(&(dataPtr->mathProcTable), BLT_STRING_KEYS);
2192 Blt_InitHashTable(&(dataPtr->indexProcTable), BLT_STRING_KEYS);
2193 Blt_VectorInstallMathFunctions(&(dataPtr->mathProcTable));
2194 Blt_VectorInstallSpecialIndices(&(dataPtr->indexProcTable));
2195 #ifdef HAVE_SRAND48
2196 srand48(time((time_t *) NULL));
2197 #endif
2198 }
2199 return dataPtr;
2200 }
2201
2202 /*
2203 * -----------------------------------------------------------------------
2204 *
2205 * Blt_VectorInit --
2206 *
2207 * This procedure is invoked to initialize the "vector" command.
2208 *
2209 * Results:
2210 * None.
2211 *
2212 * Side effects:
2213 * Creates the new command and adds a new entry into a global Tcl
2214 * associative array.
2215 *
2216 * ------------------------------------------------------------------------
2217 */
2218
2219 #if (TCL_MAJOR_VERSION == 7)
2220
2221 int
Blt_VectorInit(interp)2222 Blt_VectorInit(interp)
2223 Tcl_Interp *interp;
2224 {
2225 VectorInterpData *dataPtr; /* Interpreter-specific data. */
2226 static Blt_CmdSpec cmdSpec = {"vector", VectorCmd, };
2227
2228 dataPtr = Blt_VectorGetInterpData(interp);
2229 /*
2230 * This routine may be run several times in the same interpreter.
2231 * For example, if someone tries to initial the BLT commands from
2232 * another namespace. Keep a reference count, so we know when it's
2233 * safe to clean up.
2234 */
2235 cmdSpec.clientData = dataPtr;
2236 if (Blt_InitCmd(interp, "blt", &cmdSpec) == NULL) {
2237 return TCL_ERROR;
2238 }
2239 return TCL_OK;
2240 }
2241
2242 #else
2243
2244 int
Blt_VectorInit(interp)2245 Blt_VectorInit(interp)
2246 Tcl_Interp *interp;
2247 {
2248 VectorInterpData *dataPtr; /* Interpreter-specific data. */
2249 static Blt_ObjCmdSpec cmdSpec = {"vector", VectorObjCmd, };
2250
2251 dataPtr = Blt_VectorGetInterpData(interp);
2252 /*
2253 * This routine may be run several times in the same interpreter.
2254 * For example, if someone tries to initial the BLT commands from
2255 * another namespace. Keep a reference count, so we know when it's
2256 * safe to clean up.
2257 */
2258 cmdSpec.clientData = dataPtr;
2259 if (Blt_InitObjCmd(interp, "blt", &cmdSpec) == NULL) {
2260 return TCL_ERROR;
2261 }
2262 return TCL_OK;
2263 }
2264
2265 #endif
2266
2267
2268 /* C Application interface to vectors */
2269
2270 /*
2271 * -----------------------------------------------------------------------
2272 *
2273 * Blt_CreateVector --
2274 *
2275 * Creates a new vector by the name and size.
2276 *
2277 * Results:
2278 * A standard Tcl result. If the new array size is invalid or a
2279 * vector already exists by that name, TCL_ERROR is returned.
2280 * Otherwise TCL_OK is returned and the new vector is created.
2281 *
2282 * Side Effects:
2283 * Memory will be allocated for the new vector. A new Tcl command
2284 * and Tcl array variable will be created.
2285 *
2286 * -----------------------------------------------------------------------
2287 */
2288
2289 /*LINTLIBRARY*/
2290 int
Blt_CreateVector2(interp,vecName,cmdName,varName,initialSize,vecPtrPtr)2291 Blt_CreateVector2(interp, vecName, cmdName, varName, initialSize, vecPtrPtr)
2292 Tcl_Interp *interp;
2293 char *vecName;
2294 char *cmdName, *varName;
2295 int initialSize;
2296 Blt_Vector **vecPtrPtr;
2297 {
2298 VectorInterpData *dataPtr; /* Interpreter-specific data. */
2299 VectorObject *vPtr;
2300 int isNew;
2301 char *nameCopy;
2302
2303 if (initialSize < 0) {
2304 Tcl_AppendResult(interp, "bad vector size \"", Blt_Itoa(initialSize),
2305 "\"", (char *)NULL);
2306 return TCL_ERROR;
2307 }
2308 dataPtr = Blt_VectorGetInterpData(interp);
2309
2310 nameCopy = Blt_Strdup(vecName);
2311 vPtr = Blt_VectorCreate(dataPtr, nameCopy, cmdName, varName, &isNew);
2312 Blt_Free(nameCopy);
2313
2314 if (vPtr == NULL) {
2315 return TCL_ERROR;
2316 }
2317 if (initialSize > 0) {
2318 if (Blt_VectorChangeLength(vPtr, initialSize) != TCL_OK) {
2319 return TCL_ERROR;
2320 }
2321 }
2322 if (vecPtrPtr != NULL) {
2323 *vecPtrPtr = (Blt_Vector *) vPtr;
2324 }
2325 return TCL_OK;
2326 }
2327
2328 int
Blt_CreateVector(interp,name,size,vecPtrPtr)2329 Blt_CreateVector(interp, name, size, vecPtrPtr)
2330 Tcl_Interp *interp;
2331 char *name;
2332 int size;
2333 Blt_Vector **vecPtrPtr;
2334 {
2335 return Blt_CreateVector2(interp, name, name, name, size, vecPtrPtr);
2336 }
2337
2338 /*
2339 * -----------------------------------------------------------------------
2340 *
2341 * Blt_DeleteVector --
2342 *
2343 * Deletes the vector of the given name. All clients with
2344 * designated callback routines will be notified.
2345 *
2346 * Results:
2347 * A standard Tcl result. If no vector exists by that name,
2348 * TCL_ERROR is returned. Otherwise TCL_OK is returned and
2349 * vector is deleted.
2350 *
2351 * Side Effects:
2352 * Memory will be released for the new vector. Both the Tcl
2353 * command and array variable will be deleted. All clients which
2354 * set call back procedures will be notified.
2355 *
2356 * -----------------------------------------------------------------------
2357 */
2358 /*LINTLIBRARY*/
2359 int
Blt_DeleteVector(vecPtr)2360 Blt_DeleteVector(vecPtr)
2361 Blt_Vector *vecPtr;
2362 {
2363 VectorObject *vPtr = (VectorObject *)vecPtr;
2364 Blt_VectorFree(vPtr);
2365 return TCL_OK;
2366 }
2367
2368 /*
2369 * -----------------------------------------------------------------------
2370 *
2371 * Blt_DeleteVectorByName --
2372 *
2373 * Deletes the vector of the given name. All clients with
2374 * designated callback routines will be notified.
2375 *
2376 * Results:
2377 * A standard Tcl result. If no vector exists by that name,
2378 * TCL_ERROR is returned. Otherwise TCL_OK is returned and
2379 * vector is deleted.
2380 *
2381 * Side Effects:
2382 * Memory will be released for the new vector. Both the Tcl
2383 * command and array variable will be deleted. All clients which
2384 * set call back procedures will be notified.
2385 *
2386 * -----------------------------------------------------------------------
2387 */
2388 /*LINTLIBRARY*/
2389 int
Blt_DeleteVectorByName(interp,name)2390 Blt_DeleteVectorByName(interp, name)
2391 Tcl_Interp *interp;
2392 char *name;
2393 {
2394 VectorInterpData *dataPtr; /* Interpreter-specific data. */
2395 VectorObject *vPtr;
2396 char *nameCopy;
2397 int result;
2398
2399 /*
2400 * If the vector name was passed via a read-only string (e.g. "x"),
2401 * the Blt_VectorParseElement routine will segfault when it tries to write
2402 * into the string. Therefore make a writable copy and free it
2403 * when we're done.
2404 */
2405 nameCopy = Blt_Strdup(name);
2406 dataPtr = Blt_VectorGetInterpData(interp);
2407 result = Blt_VectorLookupName(dataPtr, nameCopy, &vPtr);
2408 Blt_Free(nameCopy);
2409
2410 if (result != TCL_OK) {
2411 return TCL_ERROR;
2412 }
2413 Blt_VectorFree(vPtr);
2414 return TCL_OK;
2415 }
2416
2417 /*
2418 * ----------------------------------------------------------------------
2419 *
2420 * Blt_VectorExists2 --
2421 *
2422 * Returns whether the vector associated with the client token
2423 * still exists.
2424 *
2425 * Results:
2426 * Returns 1 is the vector still exists, 0 otherwise.
2427 *
2428 * ----------------------------------------------------------------------
2429 */
2430 int
Blt_VectorExists2(interp,vecName)2431 Blt_VectorExists2(interp, vecName)
2432 Tcl_Interp *interp;
2433 char *vecName;
2434 {
2435 VectorInterpData *dataPtr; /* Interpreter-specific data. */
2436
2437 dataPtr = Blt_VectorGetInterpData(interp);
2438 if (GetVectorObject(dataPtr, vecName, NS_SEARCH_BOTH) != NULL) {
2439 return TRUE;
2440 }
2441 return FALSE;
2442 }
2443
2444 /*
2445 * ----------------------------------------------------------------------
2446 *
2447 * Blt_VectorExists --
2448 *
2449 * Returns whether the vector associated with the client token
2450 * still exists.
2451 *
2452 * Results:
2453 * Returns 1 is the vector still exists, 0 otherwise.
2454 *
2455 * ----------------------------------------------------------------------
2456 */
2457 int
Blt_VectorExists(interp,vecName)2458 Blt_VectorExists(interp, vecName)
2459 Tcl_Interp *interp;
2460 char *vecName;
2461 {
2462 char *nameCopy;
2463 int result;
2464
2465 /*
2466 * If the vector name was passed via a read-only string (e.g. "x"),
2467 * the Blt_VectorParseName routine will segfault when it tries to write
2468 * into the string. Therefore make a writable copy and free it
2469 * when we're done.
2470 */
2471 nameCopy = Blt_Strdup(vecName);
2472 result = Blt_VectorExists2(interp, nameCopy);
2473 Blt_Free(nameCopy);
2474 return result;
2475 }
2476
2477 /*
2478 * -----------------------------------------------------------------------
2479 *
2480 * Blt_GetVector --
2481 *
2482 * Returns a pointer to the vector associated with the given name.
2483 *
2484 * Results:
2485 * A standard Tcl result. If there is no vector "name", TCL_ERROR
2486 * is returned. Otherwise TCL_OK is returned and vecPtrPtr will
2487 * point to the vector.
2488 *
2489 * -----------------------------------------------------------------------
2490 */
2491 int
Blt_GetVector(interp,name,vecPtrPtr)2492 Blt_GetVector(interp, name, vecPtrPtr)
2493 Tcl_Interp *interp;
2494 char *name;
2495 Blt_Vector **vecPtrPtr;
2496 {
2497 VectorInterpData *dataPtr; /* Interpreter-specific data. */
2498 VectorObject *vPtr;
2499 char *nameCopy;
2500 int result;
2501
2502 dataPtr = Blt_VectorGetInterpData(interp);
2503 /*
2504 * If the vector name was passed via a read-only string (e.g. "x"),
2505 * the Blt_VectorParseName routine will segfault when it tries to write
2506 * into the string. Therefore make a writable copy and free it
2507 * when we're done.
2508 */
2509 nameCopy = Blt_Strdup(name);
2510 result = Blt_VectorLookupName(dataPtr, nameCopy, &vPtr);
2511 Blt_Free(nameCopy);
2512 if (result != TCL_OK) {
2513 return TCL_ERROR;
2514 }
2515 Blt_VectorUpdateRange(vPtr);
2516 *vecPtrPtr = (Blt_Vector *) vPtr;
2517 return TCL_OK;
2518 }
2519
2520 /*
2521 * -----------------------------------------------------------------------
2522 *
2523 * Blt_ResetVector --
2524 *
2525 * Resets the vector data. This is called by a client to
2526 * indicate that the vector data has changed. The vector does
2527 * not need to point to different memory. Any clients of the
2528 * vector will be notified of the change.
2529 *
2530 * Results:
2531 * A standard Tcl result. If the new array size is invalid,
2532 * TCL_ERROR is returned. Otherwise TCL_OK is returned and the
2533 * new vector data is recorded.
2534 *
2535 * Side Effects:
2536 * Any client designated callbacks will be posted. Memory may
2537 * be changed for the vector array.
2538 *
2539 * -----------------------------------------------------------------------
2540 */
2541 int
Blt_ResetVector(vecPtr,valueArr,length,size,freeProc)2542 Blt_ResetVector(vecPtr, valueArr, length, size, freeProc)
2543 Blt_Vector *vecPtr;
2544 double *valueArr; /* Array containing the elements of the
2545 * vector. If NULL, indicates to reset the
2546 * vector.*/
2547 int length; /* The number of elements that the vector
2548 * currently holds. */
2549 int size; /* The maximum number of elements that the
2550 * array can hold. */
2551 Tcl_FreeProc *freeProc; /* Address of memory deallocation routine
2552 * for the array of values. Can also be
2553 * TCL_STATIC, TCL_DYNAMIC, or TCL_VOLATILE. */
2554 {
2555 VectorObject *vPtr = (VectorObject *)vecPtr;
2556
2557 if (size < 0) {
2558 Tcl_AppendResult(vPtr->interp, "bad array size", (char *)NULL);
2559 return TCL_ERROR;
2560 }
2561 return Blt_VectorReset(vPtr, valueArr, length, size, freeProc);
2562 }
2563
2564 /*
2565 * -----------------------------------------------------------------------
2566 *
2567 * Blt_ResizeVector --
2568 *
2569 * Changes the size of the vector. All clients with designated
2570 * callback routines will be notified of the size change.
2571 *
2572 * Results:
2573 * A standard Tcl result. If no vector exists by that name,
2574 * TCL_ERROR is returned. Otherwise TCL_OK is returned and
2575 * vector is resized.
2576 *
2577 * Side Effects:
2578 * Memory may be reallocated for the new vector size. All clients
2579 * which set call back procedures will be notified.
2580 *
2581 * -----------------------------------------------------------------------
2582 */
2583 int
Blt_ResizeVector(vecPtr,length)2584 Blt_ResizeVector(vecPtr, length)
2585 Blt_Vector *vecPtr;
2586 int length;
2587 {
2588 VectorObject *vPtr = (VectorObject *)vecPtr;
2589
2590 if (Blt_VectorChangeLength(vPtr, length) != TCL_OK) {
2591 Tcl_AppendResult(vPtr->interp, "can't resize vector \"", vPtr->name,
2592 "\"", (char *)NULL);
2593 return TCL_ERROR;
2594 }
2595 if (vPtr->flush) {
2596 Blt_VectorFlushCache(vPtr);
2597 }
2598 Blt_VectorUpdateClients(vPtr);
2599 return TCL_OK;
2600 }
2601
2602 /*
2603 *--------------------------------------------------------------
2604 *
2605 * Blt_AllocVectorId --
2606 *
2607 * Creates an identifier token for an existing vector. The
2608 * identifier is used by the client routines to get call backs
2609 * when (and if) the vector changes.
2610 *
2611 * Results:
2612 * A standard Tcl result. If "vecName" is not associated with
2613 * a vector, TCL_ERROR is returned and interp->result is filled
2614 * with an error message.
2615 *
2616 *--------------------------------------------------------------
2617 */
2618 Blt_VectorId
Blt_AllocVectorId(interp,name)2619 Blt_AllocVectorId(interp, name)
2620 Tcl_Interp *interp;
2621 char *name;
2622 {
2623 VectorInterpData *dataPtr; /* Interpreter-specific data. */
2624 VectorObject *vPtr;
2625 VectorClient *clientPtr;
2626 Blt_VectorId clientId;
2627 int result;
2628 char *nameCopy;
2629
2630 dataPtr = Blt_VectorGetInterpData(interp);
2631 /*
2632 * If the vector name was passed via a read-only string (e.g. "x"),
2633 * the Blt_VectorParseName routine will segfault when it tries to write
2634 * into the string. Therefore make a writable copy and free it
2635 * when we're done.
2636 */
2637 nameCopy = Blt_Strdup(name);
2638 result = Blt_VectorLookupName(dataPtr, nameCopy, &vPtr);
2639 Blt_Free(nameCopy);
2640
2641 if (result != TCL_OK) {
2642 return (Blt_VectorId) 0;
2643 }
2644 /* Allocate a new client structure */
2645 clientPtr = Blt_Calloc(1, sizeof(VectorClient));
2646 assert(clientPtr);
2647 clientPtr->magic = VECTOR_MAGIC;
2648
2649 /* Add the new client to the server's list of clients */
2650 clientPtr->linkPtr = Blt_ChainAppend(vPtr->chainPtr, clientPtr);
2651 clientPtr->serverPtr = vPtr;
2652 clientId = (Blt_VectorId) clientPtr;
2653 return clientId;
2654 }
2655
2656 /*
2657 * -----------------------------------------------------------------------
2658 *
2659 * Blt_SetVectorChangedProc --
2660 *
2661 * Sets the routine to be called back when the vector is changed
2662 * or deleted. *clientData* will be provided as an argument. If
2663 * *proc* is NULL, no callback will be made.
2664 *
2665 * Results:
2666 * None.
2667 *
2668 * Side Effects:
2669 * The designated routine will be called when the vector is changed
2670 * or deleted.
2671 *
2672 * -----------------------------------------------------------------------
2673 */
2674 void
Blt_SetVectorChangedProc(clientId,proc,clientData)2675 Blt_SetVectorChangedProc(clientId, proc, clientData)
2676 Blt_VectorId clientId; /* Client token identifying the vector */
2677 Blt_VectorChangedProc *proc;/* Address of routine to call when the contents
2678 * of the vector change. If NULL, no routine
2679 * will be called */
2680 ClientData clientData; /* One word of information to pass along when
2681 * the above routine is called */
2682 {
2683 VectorClient *clientPtr = (VectorClient *)clientId;
2684
2685 if (clientPtr->magic != VECTOR_MAGIC) {
2686 return; /* Not a valid token */
2687 }
2688 clientPtr->clientData = clientData;
2689 clientPtr->proc = proc;
2690 }
2691
2692 /*
2693 *--------------------------------------------------------------
2694 *
2695 * Blt_FreeVectorId --
2696 *
2697 * Releases the token for an existing vector. This indicates
2698 * that the client is no longer interested the vector. Any
2699 * previously specified callback routine will no longer be
2700 * invoked when (and if) the vector changes.
2701 *
2702 * Results:
2703 * None.
2704 *
2705 * Side Effects:
2706 * Any previously specified callback routine will no longer be
2707 * invoked when (and if) the vector changes.
2708 *
2709 *--------------------------------------------------------------
2710 */
2711 void
Blt_FreeVectorId(clientId)2712 Blt_FreeVectorId(clientId)
2713 Blt_VectorId clientId; /* Client token identifying the vector */
2714 {
2715 VectorClient *clientPtr = (VectorClient *)clientId;
2716
2717 if (clientPtr->magic != VECTOR_MAGIC) {
2718 return; /* Not a valid token */
2719 }
2720 if (clientPtr->serverPtr != NULL) {
2721 /* Remove the client from the server's list */
2722 Blt_ChainDeleteLink(clientPtr->serverPtr->chainPtr, clientPtr->linkPtr);
2723 }
2724 Blt_Free(clientPtr);
2725 }
2726
2727 /*
2728 *--------------------------------------------------------------
2729 *
2730 * Blt_NameOfVectorId --
2731 *
2732 * Returns the name of the vector (and array variable).
2733 *
2734 * Results:
2735 * The name of the array variable is returned.
2736 *
2737 *--------------------------------------------------------------
2738 */
2739 char *
Blt_NameOfVectorId(clientId)2740 Blt_NameOfVectorId(clientId)
2741 Blt_VectorId clientId; /* Client token identifying the vector */
2742 {
2743 VectorClient *clientPtr = (VectorClient *)clientId;
2744
2745 if ((clientPtr->magic != VECTOR_MAGIC) || (clientPtr->serverPtr == NULL)) {
2746 return NULL;
2747 }
2748 return clientPtr->serverPtr->name;
2749 }
2750
2751 char *
Blt_NameOfVector(vecPtr)2752 Blt_NameOfVector(vecPtr)
2753 Blt_Vector *vecPtr; /* Vector to query. */
2754 {
2755 VectorObject *vPtr = (VectorObject *)vecPtr;
2756 return vPtr->name;
2757 }
2758
2759 /*
2760 *--------------------------------------------------------------
2761 *
2762 * Blt_VectorNotifyPending --
2763 *
2764 * Returns the name of the vector (and array variable).
2765 *
2766 * Results:
2767 * The name of the array variable is returned.
2768 *
2769 *--------------------------------------------------------------
2770 */
2771 int
Blt_VectorNotifyPending(clientId)2772 Blt_VectorNotifyPending(clientId)
2773 Blt_VectorId clientId; /* Client token identifying the vector */
2774 {
2775 VectorClient *clientPtr = (VectorClient *)clientId;
2776
2777 if ((clientPtr == NULL) || (clientPtr->magic != VECTOR_MAGIC) ||
2778 (clientPtr->serverPtr == NULL)) {
2779 return 0;
2780 }
2781 return (clientPtr->serverPtr->notifyFlags & NOTIFY_PENDING);
2782 }
2783
2784 /*
2785 * -----------------------------------------------------------------------
2786 *
2787 * Blt_GetVectorById --
2788 *
2789 * Returns a pointer to the vector associated with the client
2790 * token.
2791 *
2792 * Results:
2793 * A standard Tcl result. If the client token is not associated
2794 * with a vector any longer, TCL_ERROR is returned. Otherwise,
2795 * TCL_OK is returned and vecPtrPtr will point to vector.
2796 *
2797 * -----------------------------------------------------------------------
2798 */
2799 int
Blt_GetVectorById(interp,clientId,vecPtrPtr)2800 Blt_GetVectorById(interp, clientId, vecPtrPtr)
2801 Tcl_Interp *interp;
2802 Blt_VectorId clientId; /* Client token identifying the vector */
2803 Blt_Vector **vecPtrPtr;
2804 {
2805 VectorClient *clientPtr = (VectorClient *)clientId;
2806
2807 if (clientPtr->magic != VECTOR_MAGIC) {
2808 Tcl_AppendResult(interp, "bad vector token", (char *)NULL);
2809 return TCL_ERROR;
2810 }
2811 if (clientPtr->serverPtr == NULL) {
2812 Tcl_AppendResult(interp, "vector no longer exists", (char *)NULL);
2813 return TCL_ERROR;
2814 }
2815 Blt_VectorUpdateRange(clientPtr->serverPtr);
2816 *vecPtrPtr = (Blt_Vector *) clientPtr->serverPtr;
2817 return TCL_OK;
2818 }
2819
2820 /*LINTLIBRARY*/
2821 void
Blt_InstallIndexProc(interp,string,procPtr)2822 Blt_InstallIndexProc(interp, string, procPtr)
2823 Tcl_Interp *interp;
2824 char *string;
2825 Blt_VectorIndexProc *procPtr; /* Pointer to function to be called
2826 * when the vector finds the named index.
2827 * If NULL, this indicates to remove
2828 * the index from the table.
2829 */
2830 {
2831 VectorInterpData *dataPtr; /* Interpreter-specific data. */
2832 Blt_HashEntry *hPtr;
2833 int isNew;
2834
2835 dataPtr = Blt_VectorGetInterpData(interp);
2836 hPtr = Blt_CreateHashEntry(&(dataPtr->indexProcTable), string, &isNew);
2837 if (procPtr == NULL) {
2838 Blt_DeleteHashEntry(&(dataPtr->indexProcTable), hPtr);
2839 } else {
2840 Blt_SetHashValue(hPtr, procPtr);
2841 }
2842 }
2843