/* * bltVector.c -- * * This module implements vector data objects. * * Copyright 1995-1998 Lucent Technologies, Inc. * * Permission to use, copy, modify, and distribute this software and * its documentation for any purpose and without fee is hereby * granted, provided that the above copyright notice appear in all * copies and that both that the copyright notice and warranty * disclaimer appear in supporting documentation, and that the names * of Lucent Technologies any of their entities not be used in * advertising or publicity pertaining to distribution of the software * without specific, written prior permission. * * Lucent Technologies disclaims all warranties with regard to this * software, including all implied warranties of merchantability and * fitness. In no event shall Lucent Technologies be liable for any * special, indirect or consequential damages or any damages * whatsoever resulting from loss of use, data or profits, whether in * an action of contract, negligence or other tortuous action, arising * out of or in connection with the use or performance of this * software. */ /* * TODO: * o Add H. Kirsch's vector binary read operation * x binread file0 * x binread -file file0 * * o Add ASCII/binary file reader * x read fileName * * o Allow Tcl-based client notifications. * vector x * x notify call Display * x notify delete Display * x notify reorder #1 #2 */ #include "bltVecInt.h" #include "bltMath.h" #ifdef TIME_WITH_SYS_TIME #include #include #else #ifdef HAVE_SYS_TIME_H #include #else #include #endif /* HAVE_SYS_TIME_H */ #endif /* TIME_WITH_SYS_TIME */ #ifndef TCL_NAMESPACE_ONLY #define TCL_NAMESPACE_ONLY TCL_GLOBAL_ONLY #endif #define DEF_ARRAY_SIZE 64 #define VECFLAGS(v) \ (((v)->varNsPtr != NULL) ? (TCL_NAMESPACE_ONLY | TCL_GLOBAL_ONLY) : 0; #define TRACE_ALL (TCL_TRACE_WRITES | TCL_TRACE_READS | TCL_TRACE_UNSETS) #define VECTOR_CHAR(c) ((isalnum(UCHAR(c))) || \ (c == '_') || (c == ':') || (c == '@') || (c == '.')) /* * VectorClient -- * * A vector can be shared by several clients. Each client * allocates this structure that acts as its key for using the * vector. Clients can also designate a callback routine that is * executed whenever the vector is updated or destroyed. * */ typedef struct { unsigned int magic; /* Magic value designating whether this * really is a vector token or not */ VectorObject *serverPtr; /* Pointer to the master record of the * vector. If NULL, indicates that the * vector has been destroyed but as of * yet, this client hasn't recognized * it. */ Blt_VectorChangedProc *proc;/* Routine to call when the contents * of the vector change or the vector * is deleted. */ ClientData clientData; /* Data passed whenever the vector * change procedure is called. */ Blt_ChainLink *linkPtr; /* Used to quickly remove this entry from * its server's client chain. */ } VectorClient; static Tcl_CmdDeleteProc VectorInstDeleteProc; static Tcl_CmdProc VectorCmd; static Tcl_InterpDeleteProc VectorInterpDeleteProc; extern void srand48 _ANSI_ARGS_((long int seed)); static VectorObject * FindVectorInNamespace(dataPtr, nsPtr, vecName) VectorInterpData *dataPtr; /* Interpreter-specific data. */ Tcl_Namespace *nsPtr; CONST char *vecName; { Tcl_DString dString; CONST char *name; Blt_HashEntry *hPtr; name = Blt_GetQualifiedName(nsPtr, vecName, &dString); hPtr = Blt_FindHashEntry(&(dataPtr->vectorTable), name); Tcl_DStringFree(&dString); if (hPtr != NULL) { return (VectorObject *)Blt_GetHashValue(hPtr); } return NULL; } /* * ---------------------------------------------------------------------- * * GetVectorObject -- * * Searches for the vector associated with the name given. * Allow for a range specification. * * Results: * Returns a pointer to the vector if found, otherwise NULL. * * ---------------------------------------------------------------------- */ static VectorObject * GetVectorObject(dataPtr, name, flags) VectorInterpData *dataPtr; /* Interpreter-specific data. */ CONST char *name; int flags; { CONST char *vecName; Tcl_Namespace *nsPtr; VectorObject *vPtr; nsPtr = NULL; vecName = name; if (Blt_ParseQualifiedName(dataPtr->interp, name, &nsPtr, &vecName) != TCL_OK) { return NULL; /* Can't find namespace. */ } vPtr = NULL; if (nsPtr != NULL) { vPtr = FindVectorInNamespace(dataPtr, nsPtr, vecName); } else { if (flags & NS_SEARCH_CURRENT) { nsPtr = Tcl_GetCurrentNamespace(dataPtr->interp); vPtr = FindVectorInNamespace(dataPtr, nsPtr, vecName); } if ((vPtr == NULL) && (flags & NS_SEARCH_GLOBAL)) { nsPtr = Tcl_GetGlobalNamespace(dataPtr->interp); vPtr = FindVectorInNamespace(dataPtr, nsPtr, vecName); } } return vPtr; } void Blt_VectorUpdateRange(vPtr) VectorObject *vPtr; { double min, max; register int i; min = DBL_MAX, max = -DBL_MAX; for (i = 0; i < vPtr->length; i++) { if (FINITE(vPtr->valueArr[i])) { min = max = vPtr->valueArr[i]; break; } } for (/* empty */; i < vPtr->length; i++) { if (FINITE(vPtr->valueArr[i])) { if (min > vPtr->valueArr[i]) { min = vPtr->valueArr[i]; } else if (max < vPtr->valueArr[i]) { max = vPtr->valueArr[i]; } } } vPtr->min = min; vPtr->max = max; vPtr->notifyFlags &= ~UPDATE_RANGE; } /* * ---------------------------------------------------------------------- * * Blt_VectorGetIndex -- * * Converts the string representing an index in the vector, to * its numeric value. A valid index may be an numeric string of * the string "end" (indicating the last element in the string). * * Results: * A standard Tcl result. If the string is a valid index, TCL_OK * is returned. Otherwise TCL_ERROR is returned and interp->result * will contain an error message. * * ---------------------------------------------------------------------- */ int Blt_VectorGetIndex(interp, vPtr, string, indexPtr, flags, procPtrPtr) Tcl_Interp *interp; VectorObject *vPtr; CONST char *string; int *indexPtr; int flags; Blt_VectorIndexProc **procPtrPtr; { char c; int value; c = string[0]; /* Treat the index "end" like a numeric index. */ if ((c == 'e') && (strcmp(string, "end") == 0)) { if (vPtr->length < 1) { if (interp != NULL) { Tcl_AppendResult(interp, "bad index \"end\": vector is empty", (char *)NULL); } return TCL_ERROR; } *indexPtr = vPtr->length - 1; return TCL_OK; } else if ((c == '+') && (strcmp(string, "++end") == 0)) { *indexPtr = vPtr->length; return TCL_OK; } if (procPtrPtr != NULL) { Blt_HashEntry *hPtr; hPtr = Blt_FindHashEntry(&(vPtr->dataPtr->indexProcTable), string); if (hPtr != NULL) { *indexPtr = SPECIAL_INDEX; *procPtrPtr = (Blt_VectorIndexProc *) Blt_GetHashValue(hPtr); return TCL_OK; } } if (Tcl_GetInt(interp, (char *)string, &value) != TCL_OK) { long int lvalue; /* * Unlike Tcl_GetInt, Tcl_ExprLong needs a valid interpreter, * but the interp passed in may be NULL. So we have to use * vPtr->interp and then reset the result. */ if (Tcl_ExprLong(vPtr->interp, (char *)string, &lvalue) != TCL_OK) { Tcl_ResetResult(vPtr->interp); if (interp != NULL) { Tcl_AppendResult(interp, "bad index \"", string, "\"", (char *)NULL); } return TCL_ERROR; } value = lvalue; } /* * Correct the index by the current value of the offset. This makes * all the numeric indices non-negative, which is how we distinguish * the special non-numeric indices. */ value -= vPtr->offset; if ((value < 0) || ((flags & INDEX_CHECK) && (value >= vPtr->length))) { if (interp != NULL) { Tcl_AppendResult(interp, "index \"", string, "\" is out of range", (char *)NULL); } return TCL_ERROR; } *indexPtr = (int)value; return TCL_OK; } /* * ---------------------------------------------------------------------- * * Blt_VectorGetIndexRange -- * * Converts the string representing an index in the vector, to * its numeric value. A valid index may be an numeric string of * the string "end" (indicating the last element in the string). * * Results: * A standard Tcl result. If the string is a valid index, TCL_OK * is returned. Otherwise TCL_ERROR is returned and interp->result * will contain an error message. * * ---------------------------------------------------------------------- */ int Blt_VectorGetIndexRange(interp, vPtr, string, flags, procPtrPtr) Tcl_Interp *interp; VectorObject *vPtr; CONST char *string; int flags; Blt_VectorIndexProc **procPtrPtr; { int ielem; char *colon; colon = NULL; if (flags & INDEX_COLON) { colon = strchr(string, ':'); } if (colon != NULL) { if (string == colon) { vPtr->first = 0; /* Default to the first index */ } else { int result; *colon = '\0'; result = Blt_VectorGetIndex(interp, vPtr, string, &ielem, flags, (Blt_VectorIndexProc **) NULL); *colon = ':'; if (result != TCL_OK) { return TCL_ERROR; } vPtr->first = ielem; } if (*(colon + 1) == '\0') { /* Default to the last index */ vPtr->last = (vPtr->length > 0) ? vPtr->length - 1 : 0; } else { if (Blt_VectorGetIndex(interp, vPtr, colon + 1, &ielem, flags, (Blt_VectorIndexProc **) NULL) != TCL_OK) { return TCL_ERROR; } vPtr->last = ielem; } if (vPtr->first > vPtr->last) { if (interp != NULL) { Tcl_AppendResult(interp, "bad range \"", string, "\" (first > last)", (char *)NULL); } return TCL_ERROR; } } else { if (Blt_VectorGetIndex(interp, vPtr, string, &ielem, flags, procPtrPtr) != TCL_OK) { return TCL_ERROR; } vPtr->last = vPtr->first = ielem; } return TCL_OK; } VectorObject * Blt_VectorParseElement(interp, dataPtr, start, endPtr, flags) Tcl_Interp *interp; VectorInterpData *dataPtr; /* Interpreter-specific data. */ CONST char *start; char **endPtr; int flags; { register char *p; char saved; VectorObject *vPtr; p = (char *)start; /* Find the end of the vector name */ while (VECTOR_CHAR(*p)) { p++; } saved = *p; *p = '\0'; vPtr = GetVectorObject(dataPtr, start, flags); if (vPtr == NULL) { if (interp != NULL) { Tcl_AppendResult(interp, "can't find vector \"", start, "\"", (char *)NULL); } *p = saved; return NULL; } *p = saved; vPtr->first = 0; vPtr->last = vPtr->length - 1; if (*p == '(') { int count, result; start = p + 1; p++; /* Find the matching right parenthesis */ count = 1; while (*p != '\0') { if (*p == ')') { count--; if (count == 0) { break; } } else if (*p == '(') { count++; } p++; } if (count > 0) { if (interp != NULL) { Tcl_AppendResult(interp, "unbalanced parentheses \"", start, "\"", (char *)NULL); } return NULL; } *p = '\0'; result = Blt_VectorGetIndexRange(interp, vPtr, start, (INDEX_COLON | INDEX_CHECK), (Blt_VectorIndexProc **) NULL); *p = ')'; if (result != TCL_OK) { return NULL; } p++; } if (endPtr != NULL) { *endPtr = p; } return vPtr; } /* * ---------------------------------------------------------------------- * * Blt_VectorNotifyClients -- * * Notifies each client of the vector that the vector has changed * (updated or destroyed) by calling the provided function back. * The function pointer may be NULL, in that case the client is * not notified. * * Results: * None. * * Side effects: * The results depend upon what actions the client callbacks * take. * * ---------------------------------------------------------------------- */ void Blt_VectorNotifyClients(clientData) ClientData clientData; { VectorObject *vPtr = clientData; Blt_ChainLink *linkPtr; VectorClient *clientPtr; Blt_VectorNotify notify; notify = (vPtr->notifyFlags & NOTIFY_DESTROYED) ? BLT_VECTOR_NOTIFY_DESTROY : BLT_VECTOR_NOTIFY_UPDATE; vPtr->notifyFlags &= ~(NOTIFY_UPDATED | NOTIFY_DESTROYED | NOTIFY_PENDING); for (linkPtr = Blt_ChainFirstLink(vPtr->chainPtr); linkPtr != NULL; linkPtr = Blt_ChainNextLink(linkPtr)) { clientPtr = Blt_ChainGetValue(linkPtr); if (clientPtr->proc != NULL) { (*clientPtr->proc) (vPtr->interp, clientPtr->clientData, notify); } } /* * Some clients may not handle the "destroy" callback properly * (they should call Blt_FreeVectorId to release the client * identifier), so mark any remaining clients to indicate that * vector's server has gone away. */ if (notify == BLT_VECTOR_NOTIFY_DESTROY) { for (linkPtr = Blt_ChainFirstLink(vPtr->chainPtr); linkPtr != NULL; linkPtr = Blt_ChainNextLink(linkPtr)) { clientPtr = Blt_ChainGetValue(linkPtr); clientPtr->serverPtr = NULL; } } } /* * ---------------------------------------------------------------------- * * Blt_VectorUpdateClients -- * * Notifies each client of the vector that the vector has changed * (updated or destroyed) by calling the provided function back. * * Results: * None. * * Side effects: * The individual client callbacks are eventually invoked. * * ---------------------------------------------------------------------- */ void Blt_VectorUpdateClients(vPtr) VectorObject *vPtr; { vPtr->dirty++; vPtr->max = vPtr->min = bltNaN; if (vPtr->notifyFlags & NOTIFY_NEVER) { return; } vPtr->notifyFlags |= NOTIFY_UPDATED; if (vPtr->notifyFlags & NOTIFY_ALWAYS) { Blt_VectorNotifyClients(vPtr); return; } if (!(vPtr->notifyFlags & NOTIFY_PENDING)) { vPtr->notifyFlags |= NOTIFY_PENDING; Tcl_DoWhenIdle(Blt_VectorNotifyClients, vPtr); } } /* * ---------------------------------------------------------------------- * * Blt_VectorFlushCache -- * * Unsets all the elements of the Tcl array variable associated * with the vector, freeing memory associated with the variable. * This includes both the hash table and the hash keys. The down * side is that this effectively flushes the caching of vector * elements in the array. This means that the subsequent reads * of the array will require a decimal to string conversion. * * This is needed when the vector changes its values, making * the array variable out-of-sync. * * Results: * None. * * Side effects: * All elements of array variable (except one) are unset, freeing * the memory associated with the variable. * * ---------------------------------------------------------------------- */ void Blt_VectorFlushCache(vPtr) VectorObject *vPtr; { Tcl_CallFrame *framePtr; Tcl_Interp *interp = vPtr->interp; if (vPtr->arrayName == NULL) { return; /* Doesn't use the variable API */ } framePtr = NULL; if (vPtr->varNsPtr != NULL) { framePtr = Blt_EnterNamespace(interp, vPtr->varNsPtr); } /* Turn off the trace temporarily so that we can unset all the * elements in the array. */ Tcl_UntraceVar2(interp, vPtr->arrayName, (char *)NULL, TRACE_ALL | vPtr->varFlags, Blt_VectorVarTrace, vPtr); /* Clear all the element entries from the entire array */ Tcl_UnsetVar2(interp, vPtr->arrayName, (char *)NULL, vPtr->varFlags); /* Restore the "end" index by default and the trace on the entire array */ Tcl_SetVar2(interp, vPtr->arrayName, "end", "", vPtr->varFlags); Tcl_TraceVar2(interp, vPtr->arrayName, (char *)NULL, TRACE_ALL | vPtr->varFlags, Blt_VectorVarTrace, vPtr); if ((vPtr->varNsPtr != NULL) && (framePtr != NULL)) { Blt_LeaveNamespace(interp, framePtr); /* Go back to current */ } } /* * ---------------------------------------------------------------------- * * Blt_VectorLookupName -- * * Searches for the vector associated with the name given. Allow * for a range specification. * * Results: * Returns a pointer to the vector if found, otherwise NULL. * If the name is not associated with a vector and the * TCL_LEAVE_ERR_MSG flag is set, and interp->result will contain * an error message. * * ---------------------------------------------------------------------- */ int Blt_VectorLookupName(dataPtr, vecName, vPtrPtr) VectorInterpData *dataPtr; /* Interpreter-specific data. */ char *vecName; VectorObject **vPtrPtr; { VectorObject *vPtr; char *endPtr; vPtr = Blt_VectorParseElement(dataPtr->interp, dataPtr, vecName, &endPtr, NS_SEARCH_BOTH); if (vPtr == NULL) { return TCL_ERROR; } if (*endPtr != '\0') { Tcl_AppendResult(dataPtr->interp, "extra characters after vector name", (char *)NULL); return TCL_ERROR; } *vPtrPtr = vPtr; return TCL_OK; } /* * ---------------------------------------------------------------------- * * DeleteCommand -- * * Deletes the Tcl command associated with the vector, without * triggering a callback to "VectorInstDeleteProc". * * Results: * None. * * ---------------------------------------------------------------------- */ static void DeleteCommand(vPtr) VectorObject *vPtr; /* Vector associated with the Tcl command. */ { Tcl_Interp *interp = vPtr->interp; char *qualName; /* Name of Tcl command. */ Tcl_CmdInfo cmdInfo; Tcl_DString dString; Tcl_DStringInit(&dString); qualName = Blt_GetQualifiedName( Blt_GetCommandNamespace(interp, vPtr->cmdToken), Tcl_GetCommandName(interp, vPtr->cmdToken), &dString); if (Tcl_GetCommandInfo(interp, qualName, &cmdInfo)) { cmdInfo.deleteProc = NULL; /* Disable the callback before * deleting the Tcl command.*/ Tcl_SetCommandInfo(interp, qualName, &cmdInfo); Tcl_DeleteCommandFromToken(interp, vPtr->cmdToken); } Tcl_DStringFree(&dString); vPtr->cmdToken = 0; } /* * ---------------------------------------------------------------------- * * UnmapVariable -- * * Destroys the trace on the current Tcl variable designated * to access the vector. * * Results: * None. * * ---------------------------------------------------------------------- */ static void UnmapVariable(vPtr) VectorObject *vPtr; { Tcl_Interp *interp = vPtr->interp; Tcl_CallFrame *framePtr; framePtr = NULL; if (vPtr->varNsPtr != NULL) { /* Activate namespace */ framePtr = Blt_EnterNamespace(interp, vPtr->varNsPtr); } /* Unset the entire array */ Tcl_UntraceVar2(interp, vPtr->arrayName, (char *)NULL, (TRACE_ALL | vPtr->varFlags), Blt_VectorVarTrace, vPtr); Tcl_UnsetVar2(interp, vPtr->arrayName, (char *)NULL, vPtr->varFlags); if ((vPtr->varNsPtr != NULL) && (framePtr != NULL)) { /* Go back to current namespace */ Blt_LeaveNamespace(interp, framePtr); } if (vPtr->arrayName != NULL) { Blt_Free(vPtr->arrayName); vPtr->arrayName = NULL; } vPtr->varNsPtr = NULL; } /* * ---------------------------------------------------------------------- * * Blt_VectorMapVariable -- * * Sets up traces on a Tcl variable to access the vector. * * If another variable is already mapped, it's first untraced and * removed. Don't do anything else for variables named "" (even * though Tcl allows this pathology). Saves the name of the new * array variable. * * Results: * A standard Tcl result. If an error occurs setting the variable * TCL_ERROR is returned and an error message is left in the * interpreter. * * Side effects: * Traces are set for the new variable. The new variable name is * saved in a malloc'ed string in vPtr->arrayName. If this * variable is non-NULL, it indicates that a Tcl variable has * been mapped to this vector. * * ---------------------------------------------------------------------- */ int Blt_VectorMapVariable(interp, vPtr, name) Tcl_Interp *interp; VectorObject *vPtr; CONST char *name; { Tcl_Namespace *nsPtr; Tcl_CallFrame *framePtr; CONST char *varName; CONST char *result; if (vPtr->arrayName != NULL) { UnmapVariable(vPtr); } if ((name == NULL) || (name[0] == '\0')) { return TCL_OK; /* If the variable name is the empty * string, simply return after * removing any existing variable. */ } framePtr = NULL; /* Get the variable name (without the namespace qualifier). */ if (Blt_ParseQualifiedName(interp, name, &nsPtr, &varName) != TCL_OK) { Tcl_AppendResult(interp, "can't find namespace in \"", name, "\"", (char *)NULL); return TCL_ERROR; } if (nsPtr != NULL) { /* [incr Tcl] 2.x doesn't like qualifiers with variable names, * so we need to enter the namespace if one was designated. */ framePtr = Blt_EnterNamespace(interp, nsPtr); } /* * To play it safe, delete the variable first. This has * side-effect of unmapping the variable from any vector that may * be currently using it. */ Tcl_UnsetVar2(interp, (char *)varName, (char *)NULL, 0); /* Set the index "end" in the array. This will create the * variable immediately so that we can check its namespace * context. */ result = Tcl_SetVar2(interp, (char *)varName, "end", "", TCL_LEAVE_ERR_MSG); /* Determine if the variable is global or not. If there wasn't a * namespace qualifier, it still may be global. We need to look * inside the Var structure to see what it's namespace field says. * NULL indicates that it's local. */ vPtr->varNsPtr = Blt_GetVariableNamespace(interp, varName); vPtr->varFlags = (vPtr->varNsPtr != NULL) ? (TCL_NAMESPACE_ONLY | TCL_GLOBAL_ONLY) : 0; if (result != NULL) { /* Trace the array on reads, writes, and unsets */ Tcl_TraceVar2(interp, (char *)varName, (char *)NULL, (TRACE_ALL | vPtr->varFlags), Blt_VectorVarTrace, vPtr); } if ((nsPtr != NULL) && (framePtr != NULL)) { Blt_LeaveNamespace(interp, framePtr); /* Go back to current */ } vPtr->arrayName = Blt_Strdup(varName); return (result == NULL) ? TCL_ERROR : TCL_OK; } /* * ---------------------------------------------------------------------- * * Blt_VectorChangeLength -- * * Resizes the vector to the new size. * * The new size of the vector is computed by doubling the * size of the vector until it fits the number of slots needed * (designated by *length*). * * If the new size is the same as the old, simply adjust the * length of the vector. Otherwise we're copying the data from * one memory location to another. The trailing elements of the * vector need to be reset to zero. * * If the storage changed memory locations, free up the old * location if it was dynamically allocated. * * Results: * A standard Tcl result. If the reallocation is successful, * TCL_OK is returned, otherwise TCL_ERROR. * * Side effects: * Memory for the array is reallocated. * * ---------------------------------------------------------------------- */ int Blt_VectorChangeLength(vPtr, length) VectorObject *vPtr; int length; { int newSize; /* Size of array in elements */ double *newArr; Tcl_FreeProc *freeProc; newArr = NULL; newSize = 0; freeProc = TCL_STATIC; if (length > 0) { int wanted, used; wanted = length; used = vPtr->length; /* Compute the new size by doubling old size until it's big enough */ newSize = DEF_ARRAY_SIZE; if (wanted > DEF_ARRAY_SIZE) { while (newSize < wanted) { newSize += newSize; } } freeProc = vPtr->freeProc; if (newSize == vPtr->size) { newArr = vPtr->valueArr; /* Same size, use current array. */ } else { /* Dynamically allocate memory for the new array. */ newArr = Blt_Malloc(newSize * sizeof(double)); if (newArr == NULL) { Tcl_AppendResult(vPtr->interp, "can't allocate ", Blt_Itoa(newSize), " elements for vector \"", vPtr->name, "\"", (char *)NULL); return TCL_ERROR; } if (used > wanted) { used = wanted; } /* Copy any previous data */ if (used > 0) { memcpy(newArr, vPtr->valueArr, used * sizeof(double)); } freeProc = TCL_DYNAMIC; } /* Clear any new slots that we're now using in the array */ if (wanted > used) { memset(newArr + used, 0, (wanted - used) * sizeof(double)); } } if ((newArr != vPtr->valueArr) && (vPtr->valueArr != NULL)) { /* * We're not using the old storage anymore, so free it if it's * not static. It's static because the user previously reset * the vector with a statically allocated array (setting freeProc * to TCL_STATIC). */ if (vPtr->freeProc != TCL_STATIC) { if (vPtr->freeProc == TCL_DYNAMIC) { Blt_Free(vPtr->valueArr); } else { (*vPtr->freeProc) ((char *)vPtr->valueArr); } } } vPtr->valueArr = newArr; vPtr->size = newSize; vPtr->length = length; vPtr->first = 0; vPtr->last = length - 1; vPtr->freeProc = freeProc; /* Set the type of the new storage */ return TCL_OK; } /* * ----------------------------------------------------------------------- * * Blt_ResetVector -- * * Resets the vector data. This is called by a client to * indicate that the vector data has changed. The vector does * not need to point to different memory. Any clients of the * vector will be notified of the change. * * Results: * A standard Tcl result. If the new array size is invalid, * TCL_ERROR is returned. Otherwise TCL_OK is returned and the * new vector data is recorded. * * Side Effects: * Any client designated callbacks will be posted. Memory may * be changed for the vector array. * * ----------------------------------------------------------------------- */ int Blt_VectorReset(vPtr, valueArr, length, size, freeProc) VectorObject *vPtr; double *valueArr; /* Array containing the elements of the * vector. If NULL, indicates to reset the * vector.*/ int length; /* The number of elements that the vector * currently holds. */ int size; /* The maximum number of elements that the * array can hold. */ Tcl_FreeProc *freeProc; /* Address of memory deallocation routine * for the array of values. Can also be * TCL_STATIC, TCL_DYNAMIC, or TCL_VOLATILE. */ { if (vPtr->valueArr != valueArr) { /* New array of values resides * in different memory than * the current vector. */ if ((valueArr == NULL) || (size == 0)) { /* Empty array. Set up default values */ freeProc = TCL_STATIC; valueArr = NULL; size = length = 0; } else if (freeProc == TCL_VOLATILE) { double *newArr; /* Data is volatile. Make a copy of the value array. */ newArr = Blt_Malloc(size * sizeof(double)); if (newArr == NULL) { Tcl_AppendResult(vPtr->interp, "can't allocate ", Blt_Itoa(size), " elements for vector \"", vPtr->name, "\"", (char *)NULL); return TCL_ERROR; } memcpy((char *)newArr, (char *)valueArr, sizeof(double) * length); valueArr = newArr; freeProc = TCL_DYNAMIC; } if (vPtr->freeProc != TCL_STATIC) { /* Old data was dynamically allocated. Free it before * attaching new data. */ if (vPtr->freeProc == TCL_DYNAMIC) { Blt_Free(vPtr->valueArr); } else { (*freeProc) ((char *)vPtr->valueArr); } } vPtr->freeProc = freeProc; vPtr->valueArr = valueArr; vPtr->size = size; } vPtr->length = length; if (vPtr->flush) { Blt_VectorFlushCache(vPtr); } Blt_VectorUpdateClients(vPtr); return TCL_OK; } VectorObject * Blt_VectorNew(dataPtr) VectorInterpData *dataPtr; /* Interpreter-specific data. */ { VectorObject *vPtr; vPtr = Blt_Calloc(1, sizeof(VectorObject)); assert(vPtr); vPtr->notifyFlags = NOTIFY_WHENIDLE; vPtr->freeProc = TCL_STATIC; vPtr->dataPtr = dataPtr; vPtr->valueArr = NULL; vPtr->length = vPtr->size = 0; vPtr->interp = dataPtr->interp; vPtr->hashPtr = NULL; vPtr->chainPtr = Blt_ChainCreate(); vPtr->flush = FALSE; vPtr->min = vPtr->max = bltNaN; return vPtr; } /* * ---------------------------------------------------------------------- * * Blt_VectorFree -- * * Removes the memory and frees resources associated with the * vector. * * o Removes the trace and the Tcl array variable and unsets * the variable. * o Notifies clients of the vector that the vector is being * destroyed. * o Removes any clients that are left after notification. * o Frees the memory (if necessary) allocated for the array. * o Removes the entry from the hash table of vectors. * o Frees the memory allocated for the name. * * Results: * None. * * Side effects: * * ---------------------------------------------------------------------- */ void Blt_VectorFree(vPtr) VectorObject *vPtr; { Blt_ChainLink *linkPtr; VectorClient *clientPtr; if (vPtr->cmdToken != 0) { DeleteCommand(vPtr); } if (vPtr->arrayName != NULL) { UnmapVariable(vPtr); } vPtr->length = 0; /* Immediately notify clients that vector is going away */ if (vPtr->notifyFlags & NOTIFY_PENDING) { vPtr->notifyFlags &= ~NOTIFY_PENDING; Tcl_CancelIdleCall(Blt_VectorNotifyClients, vPtr); } vPtr->notifyFlags |= NOTIFY_DESTROYED; Blt_VectorNotifyClients(vPtr); for (linkPtr = Blt_ChainFirstLink(vPtr->chainPtr); linkPtr != NULL; linkPtr = Blt_ChainNextLink(linkPtr)) { clientPtr = Blt_ChainGetValue(linkPtr); Blt_Free(clientPtr); } Blt_ChainDestroy(vPtr->chainPtr); if ((vPtr->valueArr != NULL) && (vPtr->freeProc != TCL_STATIC)) { if (vPtr->freeProc == TCL_DYNAMIC) { Blt_Free(vPtr->valueArr); } else { (*vPtr->freeProc) ((char *)vPtr->valueArr); } } if (vPtr->hashPtr != NULL) { Blt_DeleteHashEntry(&(vPtr->dataPtr->vectorTable), vPtr->hashPtr); } #ifdef NAMESPACE_DELETE_NOTIFY if (vPtr->nsPtr != NULL) { Blt_DestroyNsDeleteNotify(vPtr->interp, vPtr->nsPtr, vPtr); } #endif /* NAMESPACE_DELETE_NOTIFY */ Blt_Free(vPtr); } /* * ---------------------------------------------------------------------- * * VectorInstDeleteProc -- * * Deletes the command associated with the vector. This is * called only when the command associated with the vector is * destroyed. * * Results: * None. * * ---------------------------------------------------------------------- */ static void VectorInstDeleteProc(clientData) ClientData clientData; { VectorObject *vPtr = clientData; vPtr->cmdToken = 0; Blt_VectorFree(vPtr); } /* * ---------------------------------------------------------------------- * * Blt_VectorCreate -- * * Creates a vector structure and the following items: * * o Tcl command * o Tcl array variable and establishes traces on the variable * o Adds a new entry in the vector hash table * * Results: * A pointer to the new vector structure. If an error occurred * NULL is returned and an error message is left in * interp->result. * * Side effects: * A new Tcl command and array variable is added to the * interpreter. * * ---------------------------------------------------------------------- */ VectorObject * Blt_VectorCreate(dataPtr, vecName, cmdName, varName, newPtr) VectorInterpData *dataPtr; /* Interpreter-specific data. */ CONST char *vecName; /* Namespace-qualified name of the vector */ CONST char *cmdName; /* Name of the Tcl command mapped to * the vector */ CONST char *varName; /* Name of the Tcl array mapped to the * vector */ int *newPtr; { Tcl_DString dString; VectorObject *vPtr; int isNew; CONST char *name; char *qualName; Tcl_Namespace *nsPtr; Blt_HashEntry *hPtr; Tcl_Interp *interp = dataPtr->interp; isNew = 0; nsPtr = NULL; vPtr = NULL; if (Blt_ParseQualifiedName(interp, vecName, &nsPtr, &name) != TCL_OK) { Tcl_AppendResult(interp, "can't find namespace in \"", vecName, "\"", (char *)NULL); return NULL; } if (nsPtr == NULL) { nsPtr = Tcl_GetCurrentNamespace(interp); } Tcl_DStringInit(&dString); if ((name[0] == '#') && (strcmp(name, "#auto") == 0)) { char string[200]; do { /* Generate a unique vector name. */ sprintf(string, "vector%d", dataPtr->nextId++); qualName = Blt_GetQualifiedName(nsPtr, string, &dString); hPtr = Blt_FindHashEntry(&(dataPtr->vectorTable), qualName); } while (hPtr != NULL); } else { register CONST char *p; for (p = name; *p != '\0'; p++) { if (!VECTOR_CHAR(*p)) { Tcl_AppendResult(interp, "bad vector name \"", name, "\": must contain digits, letters, underscore, or period", (char *)NULL); goto error; } } qualName = Blt_GetQualifiedName(nsPtr, name, &dString); vPtr = Blt_VectorParseElement((Tcl_Interp *)NULL, dataPtr, qualName, (char **)NULL, NS_SEARCH_CURRENT); } if (vPtr == NULL) { hPtr = Blt_CreateHashEntry(&(dataPtr->vectorTable), qualName, &isNew); vPtr = Blt_VectorNew(dataPtr); vPtr->hashPtr = hPtr; vPtr->nsPtr = nsPtr; vPtr->name = Blt_GetHashKey(&(dataPtr->vectorTable), hPtr); #ifdef NAMESPACE_DELETE_NOTIFY Blt_CreateNsDeleteNotify(interp, nsPtr, vPtr, VectorInstDeleteProc); #endif /* NAMESPACE_DELETE_NOTIFY */ Blt_SetHashValue(hPtr, vPtr); } if (cmdName != NULL) { Tcl_CmdInfo cmdInfo; if ((cmdName == vecName) || ((name[0] == '#') && (strcmp(name, "#auto") == 0))) { cmdName = qualName; } if (Tcl_GetCommandInfo(interp, (char *)cmdName, &cmdInfo)) { #if TCL_MAJOR_VERSION > 7 if (vPtr != cmdInfo.objClientData) { #else if (vPtr != cmdInfo.clientData) { #endif Tcl_AppendResult(interp, "command \"", cmdName, "\" already exists", (char *)NULL); goto error; } /* We get here only if the old name is the same as the new. */ goto checkVariable; } } if (vPtr->cmdToken != 0) { DeleteCommand(vPtr); /* Command already exists, delete old first */ } if (cmdName != NULL) { #if (TCL_MAJOR_VERSION == 7) vPtr->cmdToken = Blt_CreateCommand(interp, cmdName, Blt_VectorInstCmd, vPtr, VectorInstDeleteProc); #else Tcl_DString dString2; Tcl_DStringInit(&dString2); if (cmdName != qualName) { if (Blt_ParseQualifiedName(interp, cmdName, &nsPtr, &name) != TCL_OK) { Tcl_AppendResult(interp, "can't find namespace in \"", cmdName, "\"", (char *)NULL); goto error; } if (nsPtr == NULL) { nsPtr = Tcl_GetCurrentNamespace(interp); } cmdName = Blt_GetQualifiedName(nsPtr, name, &dString2); } vPtr->cmdToken = Tcl_CreateObjCommand(interp, (char *)cmdName, Blt_VectorInstCmd, vPtr, VectorInstDeleteProc); Tcl_DStringFree(&dString2); #endif } checkVariable: if (varName != NULL) { if ((varName[0] == '#') && (strcmp(varName, "#auto") == 0)) { varName = qualName; } if (Blt_VectorMapVariable(interp, vPtr, varName) != TCL_OK) { goto error; } } Tcl_DStringFree(&dString); *newPtr = isNew; return vPtr; error: Tcl_DStringFree(&dString); if (vPtr != NULL) { Blt_VectorFree(vPtr); } return NULL; } int Blt_VectorDuplicate(destPtr, srcPtr) VectorObject *destPtr, *srcPtr; { int nBytes; int length; if (destPtr == srcPtr) { /* Copying the same vector. */ } length = srcPtr->last - srcPtr->first + 1; if (Blt_VectorChangeLength(destPtr, length) != TCL_OK) { return TCL_ERROR; } nBytes = length * sizeof(double); memcpy(destPtr->valueArr, srcPtr->valueArr + srcPtr->first, nBytes); destPtr->offset = srcPtr->offset; return TCL_OK; } /* *---------------------------------------------------------------------- * * VectorNamesOp -- * * Reports the names of all the current vectors in the interpreter. * * Results: * A standard Tcl result. interp->result will contain a list of * all the names of the vector instances. * *---------------------------------------------------------------------- */ /*ARGSUSED*/ static int VectorNamesOp(clientData, interp, argc, argv) ClientData clientData; /* Interpreter-specific data. */ Tcl_Interp *interp; int argc; char **argv; { VectorInterpData *dataPtr = clientData; Blt_HashEntry *hPtr; char *name; Blt_HashSearch cursor; for (hPtr = Blt_FirstHashEntry(&(dataPtr->vectorTable), &cursor); hPtr != NULL; hPtr = Blt_NextHashEntry(&cursor)) { name = Blt_GetHashKey(&(dataPtr->vectorTable), hPtr); if ((argc == 2) || (Tcl_StringMatch(name, argv[2]))) { Tcl_AppendElement(interp, name); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * VectorCreateOp -- * * Creates a Tcl command, and array variable representing an * instance of a vector. * * vector a * vector b(20) * vector c(-5:14) * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /*ARGSUSED*/ static int VectorCreate2(clientData, interp, argStart, argc, argv) ClientData clientData; /* Interpreter-specific data. */ Tcl_Interp *interp; int argStart; int argc; char **argv; { VectorInterpData *dataPtr = clientData; VectorObject *vPtr; char *leftParen, *rightParen; int isNew, size, first, last; char *cmdName, *varName; int length; int inspectFlags, freeOnUnset, flush; char **nameArr; int count; register int i; /* * Handle switches to the vector command and collect the vector * name arguments into an array. */ varName = cmdName = NULL; freeOnUnset = 0; nameArr = Blt_Malloc(sizeof(char *) * argc); assert(nameArr); inspectFlags = TRUE; flush = FALSE; count = 0; vPtr = NULL; for (i = argStart; i < argc; i++) { if ((inspectFlags) && (argv[i][0] == '-')) { length = strlen(argv[i]); if ((length > 1) && (strncmp(argv[i], "-variable", length) == 0)) { if ((i + 1) == argc) { Tcl_AppendResult(interp, "no variable name supplied with \"", argv[i], "\" switch", (char *)NULL); goto error; } i++; varName = argv[i]; } else if ((length > 1) && (strncmp(argv[i], "-command", length) == 0)) { if ((i + 1) == argc) { Tcl_AppendResult(interp, "no command name supplied with \"", argv[i], "\" switch", (char *)NULL); goto error; } i++; cmdName = argv[i]; } else if ((length > 1) && (strncmp(argv[i], "-watchunset", length) == 0)) { int bool; if ((i + 1) == argc) { Tcl_AppendResult(interp, "no value name supplied with \"", argv[i], "\" switch", (char *)NULL); goto error; } i++; if (Tcl_GetBoolean(interp, argv[i], &bool) != TCL_OK) { goto error; } freeOnUnset = bool; } else if ((length > 1) && (strncmp(argv[i], "-flush", length) == 0)) { int bool; if ((i + 1) == argc) { Tcl_AppendResult(interp, "no value name supplied with \"", argv[i], "\" switch", (char *)NULL); goto error; } i++; if (Tcl_GetBoolean(interp, argv[i], &bool) != TCL_OK) { goto error; } flush = bool; } else if ((length > 1) && (argv[i][1] == '-') && (argv[i][2] == '\0')) { inspectFlags = FALSE; /* Allow vector names to start with - */ } else { Tcl_AppendResult(interp, "bad vector switch \"", argv[i], "\"", (char *)NULL); goto error; } } else { nameArr[count++] = argv[i]; } } if (count == 0) { Tcl_AppendResult(interp, "no vector names supplied", (char *)NULL); goto error; } if (count > 1) { if ((cmdName != NULL) && (cmdName[0] != '\0')) { Tcl_AppendResult(interp, "can't specify more than one vector with \"-command\" switch", (char *)NULL); goto error; } if ((varName != NULL) && (varName[0] != '\0')) { Tcl_AppendResult(interp, "can't specify more than one vector with \"-variable\" switch", (char *)NULL); goto error; } } for (i = 0; i < count; i++) { size = first = last = 0; leftParen = strchr(nameArr[i], '('); rightParen = strchr(nameArr[i], ')'); if (((leftParen != NULL) && (rightParen == NULL)) || ((leftParen == NULL) && (rightParen != NULL)) || (leftParen > rightParen)) { Tcl_AppendResult(interp, "bad vector specification \"", nameArr[i], "\"", (char *)NULL); goto error; } if (leftParen != NULL) { int result; char *colon; *rightParen = '\0'; colon = strchr(leftParen + 1, ':'); if (colon != NULL) { /* Specification is in the form vecName(first:last) */ *colon = '\0'; result = Tcl_GetInt(interp, leftParen + 1, &first); if ((*(colon + 1) != '\0') && (result == TCL_OK)) { result = Tcl_GetInt(interp, colon + 1, &last); if (first > last) { Tcl_AppendResult(interp, "bad vector range \"", nameArr[i], "\"", (char *)NULL); result = TCL_ERROR; } size = (last - first) + 1; } *colon = ':'; } else { /* Specification is in the form vecName(size) */ result = Tcl_GetInt(interp, leftParen + 1, &size); } *rightParen = ')'; if (result != TCL_OK) { goto error; } if (size < 0) { Tcl_AppendResult(interp, "bad vector size \"", nameArr[i], "\"", (char *)NULL); goto error; } } if (leftParen != NULL) { *leftParen = '\0'; } /* * By default, we create a Tcl command by the name of the vector. */ vPtr = Blt_VectorCreate(dataPtr, nameArr[i], (cmdName == NULL) ? nameArr[i] : cmdName, (varName == NULL) ? nameArr[i] : varName, &isNew); if (leftParen != NULL) { *leftParen = '('; } if (vPtr == NULL) { goto error; } vPtr->freeOnUnset = freeOnUnset; vPtr->flush = flush; vPtr->offset = first; if (size > 0) { if (Blt_VectorChangeLength(vPtr, size) != TCL_OK) { goto error; } } if (!isNew) { if (vPtr->flush) { Blt_VectorFlushCache(vPtr); } Blt_VectorUpdateClients(vPtr); } } Blt_Free(nameArr); if (vPtr != NULL) { /* Return the name of the last vector created */ Tcl_SetResult(interp, vPtr->name, TCL_VOLATILE); } return TCL_OK; error: Blt_Free(nameArr); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * VectorCreateOp -- * * Creates a Tcl command, and array variable representing an * instance of a vector. * * vector a * vector b(20) * vector c(-5:14) * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /*ARGSUSED*/ static int VectorCreateOp(clientData, interp, argc, argv) ClientData clientData; Tcl_Interp *interp; int argc; char **argv; { return VectorCreate2(clientData, interp, 2, argc, argv); } /* *---------------------------------------------------------------------- * * VectorDestroyOp -- * * Destroys the vector and its related Tcl command and array * variable (if they exist). * * Results: * A standard Tcl result. * * Side effects: * Deletes the vector. * *---------------------------------------------------------------------- */ /*ARGSUSED*/ static int VectorDestroyOp(clientData, interp, argc, argv) ClientData clientData; /* Interpreter-specific data. */ Tcl_Interp *interp; int argc; char **argv; { VectorInterpData *dataPtr = clientData; VectorObject *vPtr; register int i; for (i = 2; i < argc; i++) { if (Blt_VectorLookupName(dataPtr, argv[i], &vPtr) != TCL_OK) { return TCL_ERROR; } Blt_VectorFree(vPtr); } return TCL_OK; } static Blt_OpSpec vectorCmdOps[] = { {"create", 1, (Blt_Op)VectorCreateOp, 3, 0, "vecName ?vecName...? ?switches...?",}, {"destroy", 1, (Blt_Op)VectorDestroyOp, 3, 0, "vecName ?vecName...?",}, {"names", 1, (Blt_Op)VectorNamesOp, 2, 3, "?pattern?...",}, }; static int nCmdOps = sizeof(vectorCmdOps) / sizeof(Blt_OpSpec); /*ARGSUSED*/ static int VectorCmd(clientData, interp, argc, argv) ClientData clientData; /* Interpreter-specific data. */ Tcl_Interp *interp; int argc; char **argv; { Blt_Op proc; /* * Try to replicate the old vector command's behavior: */ if (argc > 1) { char c; register int i; register Blt_OpSpec *specPtr; c = argv[1][0]; for (specPtr = vectorCmdOps, i = 0; i < nCmdOps; i++, specPtr++) { if ((c == specPtr->name[0]) && (strcmp(argv[1], specPtr->name) == 0)) { goto doOp; } } /* * The first argument is not an operation, so assume that its * actually the name of a vector to be created */ return VectorCreate2(clientData, interp, 1, argc, argv); } doOp: /* Do the usual vector operation lookup now. */ proc = Blt_GetOp(interp, nCmdOps, vectorCmdOps, BLT_OP_ARG1, argc, argv,0); if (proc == NULL) { return TCL_ERROR; } return (*proc) (clientData, interp, argc, argv); } /* * ----------------------------------------------------------------------- * * VectorInterpDeleteProc -- * * This is called when the interpreter hosting the "vector" command * is deleted. * * Results: * None. * * Side effects: * Destroys the math and index hash tables. In addition removes * the hash table managing all vector names. * * ------------------------------------------------------------------------ */ /* ARGSUSED */ static void VectorInterpDeleteProc(clientData, interp) ClientData clientData; /* Interpreter-specific data. */ Tcl_Interp *interp; { VectorInterpData *dataPtr = clientData; Blt_HashEntry *hPtr; Blt_HashSearch cursor; VectorObject *vPtr; for (hPtr = Blt_FirstHashEntry(&(dataPtr->vectorTable), &cursor); hPtr != NULL; hPtr = Blt_NextHashEntry(&cursor)) { vPtr = (VectorObject *)Blt_GetHashValue(hPtr); vPtr->hashPtr = NULL; Blt_VectorFree(vPtr); } Blt_DeleteHashTable(&(dataPtr->vectorTable)); /* If any user-defined math functions were installed, remove them. */ Blt_DeleteHashTable(&(dataPtr->mathProcTable)); Blt_DeleteHashTable(&(dataPtr->indexProcTable)); Tcl_DeleteAssocData(interp, VECTOR_THREAD_KEY); Blt_Free(dataPtr); } VectorInterpData * Blt_VectorGetInterpData(interp) Tcl_Interp *interp; { VectorInterpData *dataPtr; Tcl_InterpDeleteProc *proc; dataPtr = (VectorInterpData *) Tcl_GetAssocData(interp, VECTOR_THREAD_KEY, &proc); if (dataPtr == NULL) { dataPtr = Blt_Malloc(sizeof(VectorInterpData)); assert(dataPtr); dataPtr->interp = interp; dataPtr->nextId = 0; Tcl_SetAssocData(interp, VECTOR_THREAD_KEY, VectorInterpDeleteProc, dataPtr); Blt_InitHashTable(&(dataPtr->vectorTable), BLT_STRING_KEYS); Blt_InitHashTable(&(dataPtr->mathProcTable), BLT_STRING_KEYS); Blt_InitHashTable(&(dataPtr->indexProcTable), BLT_STRING_KEYS); srand48(time((time_t *) NULL)); } return dataPtr; } /* * ----------------------------------------------------------------------- * * Blt_VectorInit -- * * This procedure is invoked to initialize the "vector" command. * * Results: * None. * * Side effects: * Creates the new command and adds a new entry into a global Tcl * associative array. * * ------------------------------------------------------------------------ */ int Blt_VectorInit(interp) Tcl_Interp *interp; { VectorInterpData *dataPtr; /* Interpreter-specific data. */ static Blt_CmdSpec cmdSpec = {"vector", VectorCmd, }; dataPtr = Blt_VectorGetInterpData(interp); /* * This routine may be run several times in the same interpreter. * For example, if someone tries to initial the BLT commands from * another namespace. Keep a reference count, so we know when it's * safe to clean up. */ cmdSpec.clientData = dataPtr; if (Blt_InitCmd(interp, "blt", &cmdSpec) == NULL) { return TCL_ERROR; } return TCL_OK; } /* C Application interface to vectors */ /* * ----------------------------------------------------------------------- * * Blt_CreateVector -- * * Creates a new vector by the name and size. * * Results: * A standard Tcl result. If the new array size is invalid or a * vector already exists by that name, TCL_ERROR is returned. * Otherwise TCL_OK is returned and the new vector is created. * * Side Effects: * Memory will be allocated for the new vector. A new Tcl command * and Tcl array variable will be created. * * ----------------------------------------------------------------------- */ /*LINTLIBRARY*/ int Blt_CreateVector2(interp, vecName, cmdName, varName, initialSize, vecPtrPtr) Tcl_Interp *interp; char *vecName; char *cmdName, *varName; int initialSize; Blt_Vector **vecPtrPtr; { VectorInterpData *dataPtr; /* Interpreter-specific data. */ VectorObject *vPtr; int isNew; char *nameCopy; if (initialSize < 0) { Tcl_AppendResult(interp, "bad vector size \"", Blt_Itoa(initialSize), "\"", (char *)NULL); return TCL_ERROR; } dataPtr = Blt_VectorGetInterpData(interp); nameCopy = Blt_Strdup(vecName); vPtr = Blt_VectorCreate(dataPtr, nameCopy, cmdName, varName, &isNew); Blt_Free(nameCopy); if (vPtr == NULL) { return TCL_ERROR; } if (initialSize > 0) { if (Blt_VectorChangeLength(vPtr, initialSize) != TCL_OK) { return TCL_ERROR; } } if (vecPtrPtr != NULL) { *vecPtrPtr = (Blt_Vector *) vPtr; } return TCL_OK; } int Blt_CreateVector(interp, name, size, vecPtrPtr) Tcl_Interp *interp; char *name; int size; Blt_Vector **vecPtrPtr; { return Blt_CreateVector2(interp, name, name, name, size, vecPtrPtr); } /* * ----------------------------------------------------------------------- * * Blt_DeleteVector -- * * Deletes the vector of the given name. All clients with * designated callback routines will be notified. * * Results: * A standard Tcl result. If no vector exists by that name, * TCL_ERROR is returned. Otherwise TCL_OK is returned and * vector is deleted. * * Side Effects: * Memory will be released for the new vector. Both the Tcl * command and array variable will be deleted. All clients which * set call back procedures will be notified. * * ----------------------------------------------------------------------- */ /*LINTLIBRARY*/ int Blt_DeleteVector(vecPtr) Blt_Vector *vecPtr; { VectorObject *vPtr = (VectorObject *)vecPtr; Blt_VectorFree(vPtr); return TCL_OK; } /* * ----------------------------------------------------------------------- * * Blt_DeleteVectorByName -- * * Deletes the vector of the given name. All clients with * designated callback routines will be notified. * * Results: * A standard Tcl result. If no vector exists by that name, * TCL_ERROR is returned. Otherwise TCL_OK is returned and * vector is deleted. * * Side Effects: * Memory will be released for the new vector. Both the Tcl * command and array variable will be deleted. All clients which * set call back procedures will be notified. * * ----------------------------------------------------------------------- */ /*LINTLIBRARY*/ int Blt_DeleteVectorByName(interp, name) Tcl_Interp *interp; char *name; { VectorInterpData *dataPtr; /* Interpreter-specific data. */ VectorObject *vPtr; char *nameCopy; int result; /* * If the vector name was passed via a read-only string (e.g. "x"), * the Blt_VectorParseElement routine will segfault when it tries to write * into the string. Therefore make a writable copy and free it * when we're done. */ nameCopy = Blt_Strdup(name); dataPtr = Blt_VectorGetInterpData(interp); result = Blt_VectorLookupName(dataPtr, nameCopy, &vPtr); Blt_Free(nameCopy); if (result != TCL_OK) { return TCL_ERROR; } Blt_VectorFree(vPtr); return TCL_OK; } /* * ---------------------------------------------------------------------- * * Blt_VectorExists2 -- * * Returns whether the vector associated with the client token * still exists. * * Results: * Returns 1 is the vector still exists, 0 otherwise. * * ---------------------------------------------------------------------- */ int Blt_VectorExists2(interp, vecName) Tcl_Interp *interp; char *vecName; { VectorInterpData *dataPtr; /* Interpreter-specific data. */ dataPtr = Blt_VectorGetInterpData(interp); if (GetVectorObject(dataPtr, vecName, NS_SEARCH_BOTH) != NULL) { return TRUE; } return FALSE; } /* * ---------------------------------------------------------------------- * * Blt_VectorExists -- * * Returns whether the vector associated with the client token * still exists. * * Results: * Returns 1 is the vector still exists, 0 otherwise. * * ---------------------------------------------------------------------- */ int Blt_VectorExists(interp, vecName) Tcl_Interp *interp; char *vecName; { char *nameCopy; int result; /* * If the vector name was passed via a read-only string (e.g. "x"), * the Blt_VectorParseName routine will segfault when it tries to write * into the string. Therefore make a writable copy and free it * when we're done. */ nameCopy = Blt_Strdup(vecName); result = Blt_VectorExists2(interp, nameCopy); Blt_Free(nameCopy); return result; } /* * ----------------------------------------------------------------------- * * Blt_GetVector -- * * Returns a pointer to the vector associated with the given name. * * Results: * A standard Tcl result. If there is no vector "name", TCL_ERROR * is returned. Otherwise TCL_OK is returned and vecPtrPtr will * point to the vector. * * ----------------------------------------------------------------------- */ int Blt_GetVector(interp, name, vecPtrPtr) Tcl_Interp *interp; char *name; Blt_Vector **vecPtrPtr; { VectorInterpData *dataPtr; /* Interpreter-specific data. */ VectorObject *vPtr; char *nameCopy; int result; dataPtr = Blt_VectorGetInterpData(interp); /* * If the vector name was passed via a read-only string (e.g. "x"), * the Blt_VectorParseName routine will segfault when it tries to write * into the string. Therefore make a writable copy and free it * when we're done. */ nameCopy = Blt_Strdup(name); result = Blt_VectorLookupName(dataPtr, nameCopy, &vPtr); Blt_Free(nameCopy); if (result != TCL_OK) { return TCL_ERROR; } Blt_VectorUpdateRange(vPtr); *vecPtrPtr = (Blt_Vector *) vPtr; return TCL_OK; } /* * ----------------------------------------------------------------------- * * Blt_ResetVector -- * * Resets the vector data. This is called by a client to * indicate that the vector data has changed. The vector does * not need to point to different memory. Any clients of the * vector will be notified of the change. * * Results: * A standard Tcl result. If the new array size is invalid, * TCL_ERROR is returned. Otherwise TCL_OK is returned and the * new vector data is recorded. * * Side Effects: * Any client designated callbacks will be posted. Memory may * be changed for the vector array. * * ----------------------------------------------------------------------- */ int Blt_ResetVector(vecPtr, valueArr, length, size, freeProc) Blt_Vector *vecPtr; double *valueArr; /* Array containing the elements of the * vector. If NULL, indicates to reset the * vector.*/ int length; /* The number of elements that the vector * currently holds. */ int size; /* The maximum number of elements that the * array can hold. */ Tcl_FreeProc *freeProc; /* Address of memory deallocation routine * for the array of values. Can also be * TCL_STATIC, TCL_DYNAMIC, or TCL_VOLATILE. */ { VectorObject *vPtr = (VectorObject *)vecPtr; if (size < 0) { Tcl_AppendResult(vPtr->interp, "bad array size", (char *)NULL); return TCL_ERROR; } return Blt_VectorReset(vPtr, valueArr, length, size, freeProc); } /* * ----------------------------------------------------------------------- * * Blt_ResizeVector -- * * Changes the size of the vector. All clients with designated * callback routines will be notified of the size change. * * Results: * A standard Tcl result. If no vector exists by that name, * TCL_ERROR is returned. Otherwise TCL_OK is returned and * vector is resized. * * Side Effects: * Memory may be reallocated for the new vector size. All clients * which set call back procedures will be notified. * * ----------------------------------------------------------------------- */ int Blt_ResizeVector(vecPtr, length) Blt_Vector *vecPtr; int length; { VectorObject *vPtr = (VectorObject *)vecPtr; if (Blt_VectorChangeLength(vPtr, length) != TCL_OK) { Tcl_AppendResult(vPtr->interp, "can't resize vector \"", vPtr->name, "\"", (char *)NULL); return TCL_ERROR; } if (vPtr->flush) { Blt_VectorFlushCache(vPtr); } Blt_VectorUpdateClients(vPtr); return TCL_OK; } /* *-------------------------------------------------------------- * * Blt_AllocVectorId -- * * Creates an identifier token for an existing vector. The * identifier is used by the client routines to get call backs * when (and if) the vector changes. * * Results: * A standard Tcl result. If "vecName" is not associated with * a vector, TCL_ERROR is returned and interp->result is filled * with an error message. * *-------------------------------------------------------------- */ Blt_VectorId Blt_AllocVectorId(interp, name) Tcl_Interp *interp; char *name; { VectorInterpData *dataPtr; /* Interpreter-specific data. */ VectorObject *vPtr; VectorClient *clientPtr; Blt_VectorId clientId; int result; char *nameCopy; dataPtr = Blt_VectorGetInterpData(interp); /* * If the vector name was passed via a read-only string (e.g. "x"), * the Blt_VectorParseName routine will segfault when it tries to write * into the string. Therefore make a writable copy and free it * when we're done. */ nameCopy = Blt_Strdup(name); result = Blt_VectorLookupName(dataPtr, nameCopy, &vPtr); Blt_Free(nameCopy); if (result != TCL_OK) { return (Blt_VectorId) 0; } /* Allocate a new client structure */ clientPtr = Blt_Calloc(1, sizeof(VectorClient)); assert(clientPtr); clientPtr->magic = VECTOR_MAGIC; /* Add the new client to the server's list of clients */ clientPtr->linkPtr = Blt_ChainAppend(vPtr->chainPtr, clientPtr); clientPtr->serverPtr = vPtr; clientId = (Blt_VectorId) clientPtr; return clientId; } /* * ----------------------------------------------------------------------- * * Blt_SetVectorChangedProc -- * * Sets the routine to be called back when the vector is changed * or deleted. *clientData* will be provided as an argument. If * *proc* is NULL, no callback will be made. * * Results: * None. * * Side Effects: * The designated routine will be called when the vector is changed * or deleted. * * ----------------------------------------------------------------------- */ void Blt_SetVectorChangedProc(clientId, proc, clientData) Blt_VectorId clientId; /* Client token identifying the vector */ Blt_VectorChangedProc *proc;/* Address of routine to call when the contents * of the vector change. If NULL, no routine * will be called */ ClientData clientData; /* One word of information to pass along when * the above routine is called */ { VectorClient *clientPtr = (VectorClient *)clientId; if (clientPtr->magic != VECTOR_MAGIC) { return; /* Not a valid token */ } clientPtr->clientData = clientData; clientPtr->proc = proc; } /* *-------------------------------------------------------------- * * Blt_FreeVectorId -- * * Releases the token for an existing vector. This indicates * that the client is no longer interested the vector. Any * previously specified callback routine will no longer be * invoked when (and if) the vector changes. * * Results: * None. * * Side Effects: * Any previously specified callback routine will no longer be * invoked when (and if) the vector changes. * *-------------------------------------------------------------- */ void Blt_FreeVectorId(clientId) Blt_VectorId clientId; /* Client token identifying the vector */ { VectorClient *clientPtr = (VectorClient *)clientId; if (clientPtr->magic != VECTOR_MAGIC) { return; /* Not a valid token */ } if (clientPtr->serverPtr != NULL) { /* Remove the client from the server's list */ Blt_ChainDeleteLink(clientPtr->serverPtr->chainPtr, clientPtr->linkPtr); } Blt_Free(clientPtr); } /* *-------------------------------------------------------------- * * Blt_NameOfVectorId -- * * Returns the name of the vector (and array variable). * * Results: * The name of the array variable is returned. * *-------------------------------------------------------------- */ char * Blt_NameOfVectorId(clientId) Blt_VectorId clientId; /* Client token identifying the vector */ { VectorClient *clientPtr = (VectorClient *)clientId; if ((clientPtr->magic != VECTOR_MAGIC) || (clientPtr->serverPtr == NULL)) { return NULL; } return clientPtr->serverPtr->name; } char * Blt_NameOfVector(vecPtr) Blt_Vector *vecPtr; /* Vector to query. */ { VectorObject *vPtr = (VectorObject *)vecPtr; return vPtr->name; } /* *-------------------------------------------------------------- * * Blt_VectorNotifyPending -- * * Returns the name of the vector (and array variable). * * Results: * The name of the array variable is returned. * *-------------------------------------------------------------- */ int Blt_VectorNotifyPending(clientId) Blt_VectorId clientId; /* Client token identifying the vector */ { VectorClient *clientPtr = (VectorClient *)clientId; if ((clientPtr == NULL) || (clientPtr->magic != VECTOR_MAGIC) || (clientPtr->serverPtr == NULL)) { return 0; } return (clientPtr->serverPtr->notifyFlags & NOTIFY_PENDING); } /* * ----------------------------------------------------------------------- * * Blt_GetVectorById -- * * Returns a pointer to the vector associated with the client * token. * * Results: * A standard Tcl result. If the client token is not associated * with a vector any longer, TCL_ERROR is returned. Otherwise, * TCL_OK is returned and vecPtrPtr will point to vector. * * ----------------------------------------------------------------------- */ int Blt_GetVectorById(interp, clientId, vecPtrPtr) Tcl_Interp *interp; Blt_VectorId clientId; /* Client token identifying the vector */ Blt_Vector **vecPtrPtr; { VectorClient *clientPtr = (VectorClient *)clientId; if (clientPtr->magic != VECTOR_MAGIC) { Tcl_AppendResult(interp, "bad vector token", (char *)NULL); return TCL_ERROR; } if (clientPtr->serverPtr == NULL) { Tcl_AppendResult(interp, "vector no longer exists", (char *)NULL); return TCL_ERROR; } Blt_VectorUpdateRange(clientPtr->serverPtr); *vecPtrPtr = (Blt_Vector *) clientPtr->serverPtr; return TCL_OK; } /*LINTLIBRARY*/ void Blt_InstallIndexProc(interp, string, procPtr) Tcl_Interp *interp; char *string; Blt_VectorIndexProc *procPtr; /* Pointer to function to be called * when the vector finds the named index. * If NULL, this indicates to remove * the index from the table. */ { VectorInterpData *dataPtr; /* Interpreter-specific data. */ Blt_HashEntry *hPtr; int isNew; dataPtr = Blt_VectorGetInterpData(interp); hPtr = Blt_CreateHashEntry(&(dataPtr->indexProcTable), string, &isNew); if (procPtr == NULL) { Blt_DeleteHashEntry(&(dataPtr->indexProcTable), hPtr); } else { Blt_SetHashValue(hPtr, procPtr); } }