diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2008-09-28 22:17:36 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2008-09-28 22:17:36 (GMT) |
commit | d41bad2545ee171add61111b71b9d8c5c3e89173 (patch) | |
tree | 33b115c93550ac4c16da41b57aba376b6af847bd /generic | |
parent | 58acf122398c693f3a99b458711b071301e10670 (diff) | |
download | tcl-d41bad2545ee171add61111b71b9d8c5c3e89173.zip tcl-d41bad2545ee171add61111b71b9d8c5c3e89173.tar.gz tcl-d41bad2545ee171add61111b71b9d8c5c3e89173.tar.bz2 |
Implement TIP 314. [Patch 1901783]
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tcl.decls | 13 | ||||
-rw-r--r-- | generic/tclCompCmds.c | 16 | ||||
-rw-r--r-- | generic/tclNamesp.c | 285 |
3 files changed, 274 insertions, 40 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index 0d8fea6..8a65b76 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.144 2008/09/24 09:41:13 dkf Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.145 2008/09/28 22:17:39 dkf Exp $ library tcl @@ -2187,6 +2187,17 @@ declare 601 generic { unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr) } +# TIP#314 (ensembles with parameters) +declare 602 generic { + int Tcl_SetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, + Tcl_Obj *paramList) +} +declare 603 generic { + int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, + Tcl_Obj **paramListPtr) +} + + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index dae4417..877bb11 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.146 2008/07/27 22:18:22 nijtmans Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.147 2008/09/28 22:17:39 dkf Exp $ */ #include "tclInt.h" @@ -6219,6 +6219,20 @@ TclCompileEnsemble( } /* + * Also refuse to compile anything that uses a formal parameter list for + * now, on the grounds that it is too complex. + */ + + if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK + || listObj != NULL) { + /* + * Figuring out how to compile this has become too much. Bail out. + */ + + return TCL_ERROR; + } + + /* * Next, get the flags. We need them on several code paths. */ diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index e08ab4e..c05913d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -23,7 +23,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.177 2008/09/26 19:36:50 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.178 2008/09/28 22:17:39 dkf Exp $ */ #include "tclInt.h" @@ -55,12 +55,12 @@ static Tcl_ThreadDataKey dataKey; */ typedef struct ResolvedNsName { - Namespace *nsPtr; /* A cached pointer to the Namespace that the - * name resolved to. */ - Namespace *refNsPtr; /* Points to the namespace context in which the - * name was resolved. NULL if the name is fully - * qualified and thus the resolution does not - * depend on the context. */ + Namespace *nsPtr; /* A cached pointer to the Namespace that the + * name resolved to. */ + Namespace *refNsPtr; /* Points to the namespace context in which + * the name was resolved. NULL if the name is + * fully qualified and thus the resolution + * does not depend on the context. */ int refCount; /* Reference count: 1 for each nsName object * that has a pointer to this ResolvedNsName * structure as its internal rep. This @@ -139,6 +139,11 @@ typedef struct EnsembleConfig { * subcommand will be reparsed by the ensemble * core, presumably because the ensemble * itself has been updated. */ + Tcl_Obj *parameterList; /* List of ensemble parameter names. */ + int numParameters; /* Cached number of parameters. This is either + * 0 (if the parameterList field is NULL) or + * the length of the list in the parameterList + * field. */ } EnsembleConfig; #define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead @@ -4807,16 +4812,19 @@ NamespaceEnsembleCmd( ENS_CONFIG, ENS_CREATE, ENS_EXISTS }; static const char *createOptions[] = { - "-command", "-map", "-prefixes", "-subcommands", "-unknown", NULL + "-command", "-map", "-parameters", "-prefixes", "-subcommands", + "-unknown", NULL }; enum EnsCreateOpts { - CRT_CMD, CRT_MAP, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN + CRT_CMD, CRT_MAP, CRT_PARAM, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN }; static const char *configOptions[] = { - "-map", "-namespace", "-prefixes", "-subcommands", "-unknown", NULL + "-map", "-namespace", "-parameters", "-prefixes", "-subcommands", + "-unknown", NULL }; enum EnsConfigOpts { - CONF_MAP, CONF_NAMESPACE, CONF_PREFIX, CONF_SUBCMDS, CONF_UNKNOWN + CONF_MAP, CONF_NAMESPACE, CONF_PARAM, CONF_PREFIX, CONF_SUBCMDS, + CONF_UNKNOWN }; int index; @@ -4851,6 +4859,7 @@ NamespaceEnsembleCmd( Tcl_Obj *mapObj = NULL; int permitPrefix = 1; Tcl_Obj *unknownObj = NULL; + Tcl_Obj *paramObj = NULL; objv += 3; objc -= 3; @@ -4891,6 +4900,15 @@ NamespaceEnsembleCmd( } subcmdObj = (len > 0 ? objv[1] : NULL); continue; + case CRT_PARAM: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + paramObj = (len > 0 ? objv[1] : NULL); + continue; case CRT_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; @@ -4997,6 +5015,7 @@ NamespaceEnsembleCmd( Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); + Tcl_SetEnsembleParameterList(interp, token, paramObj); /* * Tricky! Must ensure that the result is not shared (command delete @@ -5020,7 +5039,8 @@ NamespaceEnsembleCmd( case ENS_CONFIG: if (objc < 4 || (objc != 5 && objc & 1)) { - Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?-option value ...? ?arg ...?"); + Tcl_WrongNumArgs(interp, 3, objv, + "cmdname ?-option value ...? ?arg ...?"); return TCL_ERROR; } token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG); @@ -5042,6 +5062,12 @@ NamespaceEnsembleCmd( Tcl_SetObjResult(interp, resultObj); } break; + case CONF_PARAM: + Tcl_GetEnsembleParameterList(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; case CONF_MAP: Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); if (resultObj != NULL) { @@ -5099,6 +5125,13 @@ NamespaceEnsembleCmd( Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName, -1)); + /* -parameters option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_PARAM], -1)); + Tcl_GetEnsembleParameterList(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + /* -prefix option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_PREFIX], -1)); @@ -5126,12 +5159,13 @@ NamespaceEnsembleCmd( Tcl_DictSearch search; Tcl_Obj *listObj; int done, len, allocatedMapFlag = 0; - Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, + Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL, *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ int permitPrefix, flags = 0; /* silence gcc 4 warning */ Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); + Tcl_GetEnsembleParameterList(NULL, token, ¶mObj); Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); Tcl_GetEnsembleFlags(NULL, token, &flags); permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; @@ -5164,6 +5198,15 @@ NamespaceEnsembleCmd( } subcmdObj = (len > 0 ? objv[1] : NULL); continue; + case CONF_PARAM: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + paramObj = (len > 0 ? objv[1] : NULL); + continue; case CONF_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; @@ -5273,6 +5316,7 @@ NamespaceEnsembleCmd( : flags&~TCL_ENSEMBLE_PREFIX); Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); + Tcl_SetEnsembleParameterList(interp, token, paramObj); Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); Tcl_SetEnsembleFlags(interp, token, flags); return TCL_OK; @@ -5339,6 +5383,8 @@ Tcl_CreateEnsemble( ensemblePtr->subcmdList = NULL; ensemblePtr->subcommandDict = NULL; ensemblePtr->flags = flags; + ensemblePtr->numParameters = 0; + ensemblePtr->parameterList = NULL; ensemblePtr->unknownHandler = NULL; ensemblePtr->token = Tcl_NRCreateCommand(interp, name, NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, @@ -5441,6 +5487,81 @@ Tcl_SetEnsembleSubcommandList( /* *---------------------------------------------------------------------- * + * Tcl_SetEnsembleParameterList -- + * + * Set the parameter list for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the parameter list - if non-NULL - is not a list). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleParameterList( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj *paramList) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldList; + int length; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + return TCL_ERROR; + } + if (paramList == NULL) { + length = 0; + } else { + if (TclListObjLength(interp, paramList, &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 1) { + paramList = NULL; + } + } + + ensemblePtr = cmdPtr->objClientData; + oldList = ensemblePtr->parameterList; + ensemblePtr->parameterList = paramList; + if (paramList != NULL) { + Tcl_IncrRefCount(paramList); + } + if (oldList != NULL) { + TclDecrRefCount(oldList); + } + ensemblePtr->numParameters = length; + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (cmdPtr->compileProc != NULL) { + ((Interp *)interp)->compileEpoch++; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_SetEnsembleMappingDict -- * * Set the mapping dictionary for a particular ensemble. @@ -5713,6 +5834,46 @@ Tcl_GetEnsembleSubcommandList( /* *---------------------------------------------------------------------- * + * Tcl_GetEnsembleParameterList -- + * + * Get the list of parameters associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The list of parameters is returned by updating the + * variable pointed to by the last parameter (NULL if there are + * no parameters). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleParameterList( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj **paramListPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *paramListPtr = ensemblePtr->parameterList; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetEnsembleMappingDict -- * * Get the command mapping dictionary associated with a particular @@ -6083,12 +6244,39 @@ NsEnsembleImplementationCmdNR( * names. */ int reparseCount = 0; /* Number of reparses. */ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); + /* + * Must recheck objc, since numParameters might have changed. Cf. test + * namespace-53.9. + */ + + restartEnsembleParse: + if (objc < 2 + ensemblePtr->numParameters) { + /* + * We don't have a subcommand argument. Make error message. + */ + + Tcl_DString buf; /* Message being built */ + Tcl_Obj **elemPtrs; /* Parameter names */ + int len; /* Number of parameters to append */ + + Tcl_DStringInit(&buf); + if (ensemblePtr->parameterList == NULL) { + len = 0; + } else if (TclListObjGetElements(NULL, ensemblePtr->parameterList, + &len, &elemPtrs) != TCL_OK) { + Tcl_Panic("List of ensemble parameters is not a list"); + } + for (; len>0; len--,elemPtrs++) { + Tcl_DStringAppend(&buf, Tcl_GetString(*elemPtrs), -1); + Tcl_DStringAppend(&buf, " ", -1); + } + Tcl_DStringAppend(&buf, "subcommand ?arg ...?", -1); + Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf)); + Tcl_DStringFree(&buf); + return TCL_ERROR; } - restartEnsembleParse: if (ensemblePtr->nsPtr->flags & NS_DYING) { /* * Don't know how we got here, but make things give up quickly. @@ -6114,8 +6302,9 @@ NsEnsembleImplementationCmdNR( * part where we do the invocation of the subcommand. */ - if (objv[1]->typePtr == &tclEnsembleCmdType) { - EnsembleCmdRep *ensembleCmd = objv[1]->internalRep.otherValuePtr; + if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){ + EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters] + ->internalRep.otherValuePtr; if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && ensembleCmd->epoch == ensemblePtr->epoch && @@ -6136,7 +6325,7 @@ NsEnsembleImplementationCmdNR( */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, - TclGetString(objv[1])); + TclGetString(objv[1 + ensemblePtr->numParameters])); if (hPtr != NULL) { char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr); @@ -6146,7 +6335,8 @@ NsEnsembleImplementationCmdNR( * Cache for later in the subcommand object. */ - MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); + MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters], + ensemblePtr, fullName, prefixObj); } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { /* * Could not map, no prefixing, go to unknown/error handling. @@ -6167,8 +6357,8 @@ NsEnsembleImplementationCmdNR( int stringLength, i; int tableLength = ensemblePtr->subcommandTable.numEntries; - subcmdName = TclGetString(objv[1]); - stringLength = objv[1]->length; + subcmdName = TclGetString(objv[1 + ensemblePtr->numParameters]); + stringLength = objv[1 + ensemblePtr->numParameters]->length; for (i=0 ; i<tableLength ; i++) { register int cmp = strncmp(subcmdName, ensemblePtr->subcommandArrayPtr[i], @@ -6214,7 +6404,8 @@ NsEnsembleImplementationCmdNR( * Cache for later in the subcommand object. */ - MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); + MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters], + ensemblePtr, fullName, prefixObj); } Tcl_IncrRefCount(prefixObj); @@ -6226,8 +6417,12 @@ NsEnsembleImplementationCmdNR( * number of arguments to this ensemble command), populating it and then * feeding it back through the main command-lookup engine. In theory, we * could look up the command in the namespace ourselves, as we already - * have the namespace in which it is guaranteed to exist, but we don't do - * that (the cacheing of the command object used should help with that.) + * have the namespace in which it is guaranteed to exist, + * + * ((Q: That's not true if the -map option is used, is it?)) + * + * but we don't do that (the cacheing of the command object used should + * help with that.) */ { @@ -6262,7 +6457,11 @@ NsEnsembleImplementationCmdNR( listRepPtr->elemCount = copyObjc; copyObjv = &listRepPtr->elements; memcpy(copyObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); - memcpy(copyObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + memcpy(copyObjv+prefixObjc, objv+1, + sizeof(Tcl_Obj *) * ensemblePtr->numParameters); + memcpy(copyObjv+prefixObjc+ensemblePtr->numParameters, + objv+ensemblePtr->numParameters+2, + sizeof(Tcl_Obj *) * (objc-ensemblePtr->numParameters-2)); for (i=0; i < copyObjc; i++) { Tcl_IncrRefCount(copyObjv[i]); @@ -6272,20 +6471,25 @@ NsEnsembleImplementationCmdNR( /* * Record what arguments the script sent in so that things like - * Tcl_WrongNumArgs can give the correct error message. + * Tcl_WrongNumArgs can give the correct error message. Parameters + * count both as inserted and removed arguments. */ if (iPtr->ensembleRewrite.sourceObjs == NULL) { iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 2; - iPtr->ensembleRewrite.numInsertedObjs = prefixObjc; + iPtr->ensembleRewrite.numRemovedObjs = + 2 + ensemblePtr->numParameters; + iPtr->ensembleRewrite.numInsertedObjs = + prefixObjc + ensemblePtr->numParameters; TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } else { - register int ni = iPtr->ensembleRewrite.numInsertedObjs; - - if (ni < 2) { - iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; + register int ni = 2 + ensemblePtr->numParameters + - iPtr->ensembleRewrite.numInsertedObjs; + /* Position in objv of new front of insertion + * relative to old one. */ + if (ni > 0) { + iPtr->ensembleRewrite.numRemovedObjs += ni; iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-1; } else { iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2; @@ -6328,18 +6532,20 @@ NsEnsembleImplementationCmdNR( Tcl_ResetResult(interp); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", - TclGetString(objv[1]), NULL); + TclGetString(objv[1+ensemblePtr->numParameters]), NULL); if (ensemblePtr->subcommandTable.numEntries == 0) { - Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]), + Tcl_AppendResult(interp, "unknown subcommand \"", + TclGetString(objv[1+ensemblePtr->numParameters]), "\": namespace ", ensemblePtr->nsPtr->fullName, " does not export any commands", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(objv[1]), NULL); + TclGetString(objv[1+ensemblePtr->numParameters]), NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "unknown ", (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), - "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL); + "subcommand \"", TclGetString(objv[1+ensemblePtr->numParameters]), + "\": must be ", NULL); if (ensemblePtr->subcommandTable.numEntries == 1) { Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); } else { @@ -6353,7 +6559,7 @@ NsEnsembleImplementationCmdNR( ensemblePtr->subcommandArrayPtr[i], NULL); } Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(objv[1]), NULL); + TclGetString(objv[1+ensemblePtr->numParameters]), NULL); return TCL_ERROR; } @@ -6650,6 +6856,9 @@ DeleteEnsembleConfig( if (ensemblePtr->subcmdList != NULL) { Tcl_DecrRefCount(ensemblePtr->subcmdList); } + if (ensemblePtr->parameterList != NULL) { + Tcl_DecrRefCount(ensemblePtr->parameterList); + } if (ensemblePtr->subcommandDict != NULL) { Tcl_DecrRefCount(ensemblePtr->subcommandDict); } |