From 7d1f7120682cc4d944681bad0c1c5c38cf5bac4b Mon Sep 17 00:00:00 2001 From: welch Date: Sun, 28 Jun 1998 21:38:48 +0000 Subject: incr tcl updtaes --- generic/tclNamesp.c | 113 ++++++++++++++++++++++++++++++++++++++++++++++++---- generic/tclVar.c | 46 ++++++++++++++++++++- 2 files changed, 150 insertions(+), 9 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index d4ace43..d399426 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -546,7 +546,11 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; - nsPtr->cmdRefEpoch = 0; + nsPtr->cmdRefEpoch = 0; + nsPtr->resolverEpoch = 0; + nsPtr->cmdResProc = NULL; + nsPtr->varResProc = NULL; + nsPtr->compiledVarResProc = NULL; if (parentPtr != NULL) { entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, @@ -884,6 +888,7 @@ NamespaceFree(nsPtr) ckfree((char *) nsPtr); } + /* *---------------------------------------------------------------------- @@ -1212,8 +1217,8 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) Tcl_DString ds; Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, currNsPtr->fullName, -1); - if (currNsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + if (nsPtr != iPtr->globalNsPtr) { Tcl_DStringAppend(&ds, "::", 2); } Tcl_DStringAppend(&ds, cmdName, -1); @@ -1794,7 +1799,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, && (nsPtr != globalNsPtr)) { nsPtr = NULL; } - + *nsPtrPtr = nsPtr; *altNsPtrPtr = altNsPtr; Tcl_DStringFree(&buffer); @@ -1905,12 +1910,59 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags) * are given, TCL_GLOBAL_ONLY is * ignored. */ { + Interp *iPtr = (Interp*)interp; + + ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; char *simpleName; register Tcl_HashEntry *entryPtr; register Command *cmdPtr; register int search; int result; + Tcl_Command cmd; + + /* + * If this namespace has a command resolver, then give it first + * crack at the command resolution. If the interpreter has any + * command resolvers, consult them next. The command resolver + * procedures may return a Tcl_Command value, they may signal + * to continue onward, or they may signal an error. + */ + if ((flags & TCL_GLOBAL_ONLY) != 0) { + cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + } + else if (contextNsPtr != NULL) { + cxtNsPtr = (Namespace *) contextNsPtr; + } + else { + cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } + + if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { + resPtr = iPtr->resolverPtr; + + if (cxtNsPtr->cmdResProc) { + result = (*cxtNsPtr->cmdResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &cmd); + } else { + result = TCL_CONTINUE; + } + + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->cmdResProc) { + result = (*resPtr->cmdResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &cmd); + } + resPtr = resPtr->nextPtr; + } + + if (result == TCL_OK) { + return cmd; + } + else if (result != TCL_CONTINUE) { + return (Tcl_Command) NULL; + } + } /* * Find the namespace(s) that contain the command. @@ -1946,6 +1998,7 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags) Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown command \"", name, "\"", (char *) NULL); } + return (Tcl_Command) NULL; } @@ -1993,12 +2046,57 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) * are given, TCL_GLOBAL_ONLY is * ignored. */ { + Interp *iPtr = (Interp*)interp; + ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; char *simpleName; Tcl_HashEntry *entryPtr; Var *varPtr; register int search; int result; + Tcl_Var var; + + /* + * If this namespace has a variable resolver, then give it first + * crack at the variable resolution. It may return a Tcl_Var + * value, it may signal to continue onward, or it may signal + * an error. + */ + if ((flags & TCL_GLOBAL_ONLY) != 0) { + cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + } + else if (contextNsPtr != NULL) { + cxtNsPtr = (Namespace *) contextNsPtr; + } + else { + cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } + + if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + resPtr = iPtr->resolverPtr; + + if (cxtNsPtr->varResProc) { + result = (*cxtNsPtr->varResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } else { + result = TCL_CONTINUE; + } + + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->varResProc) { + result = (*resPtr->varResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } + resPtr = resPtr->nextPtr; + } + + if (result == TCL_OK) { + return var; + } + else if (result != TCL_CONTINUE) { + return (Tcl_Var) NULL; + } + } /* * Find the namespace(s) that contain the variable. @@ -2710,11 +2808,10 @@ NamespaceDeleteCmd(dummy, interp, objc, objv) for (i = 2; i < objc; i++) { name = Tcl_GetStringFromObj(objv[i], (int *) NULL); namespacePtr = Tcl_FindNamespace(interp, name, - (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG); - if (namespacePtr == NULL) { - return TCL_ERROR; + (Tcl_Namespace *) NULL, /* flags */ 0); + if (namespacePtr) { + Tcl_DeleteNamespace(namespacePtr); } - Tcl_DeleteNamespace(namespacePtr); } return TCL_OK; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 6725568..d86ca06 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -141,7 +141,8 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, * parens around the index. Otherwise they * are NULL. These are needed to restore * the parens after parsing the name. */ - Namespace *varNsPtr, *dummy1Ptr, *dummy2Ptr; + Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; + ResolverScheme *resPtr; Tcl_HashEntry *hPtr; register char *p; int new, i, result; @@ -183,6 +184,46 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, } /* + * If this namespace has a variable resolver, then give it first + * crack at the variable resolution. It may return a Tcl_Var + * value, it may signal to continue onward, or it may signal + * an error. + */ + if ((flags & TCL_GLOBAL_ONLY) != 0 || iPtr->varFramePtr == NULL) { + cxtNsPtr = iPtr->globalNsPtr; + } + else { + cxtNsPtr = iPtr->varFramePtr->nsPtr; + } + + if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + resPtr = iPtr->resolverPtr; + + if (cxtNsPtr->varResProc) { + result = (*cxtNsPtr->varResProc)(interp, part1, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } else { + result = TCL_CONTINUE; + } + + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->varResProc) { + result = (*resPtr->varResProc)(interp, part1, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } + resPtr = resPtr->nextPtr; + } + + if (result == TCL_OK) { + varPtr = (Var *) var; + goto lookupVarPart2; + } + else if (result != TCL_CONTINUE) { + return (Var *) NULL; + } + } + + /* * Look up part1. Look it up as either a namespace variable or as a * local variable in a procedure call frame (varFramePtr). * Interpret part1 as a namespace variable if: @@ -310,6 +351,8 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, } } } + +lookupVarPart2: if (openParen != NULL) { *openParen = '('; openParen = NULL; @@ -4273,6 +4316,7 @@ TclDeleteVars(iPtr, tablePtr) if (TclIsVarArray(varPtr)) { DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags); + varPtr->value.tablePtr = NULL; } if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { objPtr = varPtr->value.objPtr; -- cgit v0.12