diff options
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tclBasic.c | 46 | ||||
-rw-r--r-- | generic/tclEnsemble.c | 3709 | ||||
-rw-r--r-- | generic/tclInt.h | 4905 | ||||
-rw-r--r-- | generic/tclOO.c | 3073 | ||||
-rw-r--r-- | generic/tclProc.c | 22 |
5 files changed, 11715 insertions, 40 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5b0112d..8a5afd0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2270,11 +2270,11 @@ Tcl_CreateObjCommand( tail = cmdName; } - return tclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, + return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, proc, clientData, deleteProc); } -Tcl_Command tclCreateObjCommandInNs ( +Tcl_Command TclCreateObjCommandInNs ( Tcl_Interp *interp, const char *cmdName, /* Name of command, without any namespace components */ Tcl_Namespace *namespace, /* The namespace to create the command in */ @@ -8192,7 +8192,7 @@ Tcl_NRCreateCommand( return (Tcl_Command) cmdPtr; } -Tcl_Command tclNRCreateCommandInNs ( +Tcl_Command TclNRCreateCommandInNs ( Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, @@ -8201,7 +8201,7 @@ Tcl_Command tclNRCreateCommandInNs ( ClientData clientData, Tcl_CmdDeleteProc *deleteProc) { Command *cmdPtr = (Command *) - tclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); + TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; @@ -8991,9 +8991,9 @@ TclNRCoroutineObjCmd( { Command *cmdPtr; CoroutineData *corPtr; - const char *fullName, *procName; - Namespace *nsPtr, *altNsPtr, *cxtNsPtr; - Tcl_DString ds; + const char *procName, *simpleName; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr, + *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; if (objc < 3) { @@ -9001,27 +9001,22 @@ TclNRCoroutineObjCmd( return TCL_ERROR; } - /* - * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have - * something in tclUtil.c to find the FQ name. - */ - - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, inNsPtr, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); + procName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); return TCL_ERROR; } @@ -9032,16 +9027,9 @@ TclNRCoroutineObjCmd( corPtr = ckalloc(sizeof(CoroutineData)); - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - TclDStringAppendLiteral(&ds, "::"); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); - Tcl_DStringFree(&ds); + cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, + (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, + corPtr, DeleteCoroutine); corPtr->cmdPtr = cmdPtr; cmdPtr->refCount++; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c new file mode 100644 index 0000000..92c0c76 --- /dev/null +++ b/generic/tclEnsemble.c @@ -0,0 +1,3709 @@ +/* + * tclEnsemble.c -- + * + * Contains support for ensembles (see TIP#112), which provide simple + * mechanism for creating composite commands on top of namespaces. + * + * Copyright (c) 2005-2013 Donal K. Fellows. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclCompile.h" + +/* + * Declarations for functions local to this file: + */ + +static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); +static inline int EnsembleUnknownCallback(Tcl_Interp *interp, + EnsembleConfig *ensemblePtr, int objc, + Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); +static int NsEnsembleImplementationCmd(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NsEnsembleImplementationCmdNR(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); +static int NsEnsembleStringOrder(const void *strPtr1, + const void *strPtr2); +static void DeleteEnsembleConfig(ClientData clientData); +static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, + EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr, + Tcl_Obj *fix); +static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); +static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); +static void CompileToInvokedCommand(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Tcl_Obj *replacements, + Command *cmdPtr, CompileEnv *envPtr); +static int CompileBasicNArgCommand(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + CompileEnv *envPtr); + +static Tcl_NRPostProc FreeER; + +/* + * The lists of subcommands and options for the [namespace ensemble] command. + */ + +static const char *const ensembleSubcommands[] = { + "configure", "create", "exists", NULL +}; +enum EnsSubcmds { + ENS_CONFIG, ENS_CREATE, ENS_EXISTS +}; + +static const char *const ensembleCreateOptions[] = { + "-command", "-map", "-parameters", "-prefixes", "-subcommands", + "-unknown", NULL +}; +enum EnsCreateOpts { + CRT_CMD, CRT_MAP, CRT_PARAM, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN +}; + +static const char *const ensembleConfigOptions[] = { + "-map", "-namespace", "-parameters", "-prefixes", "-subcommands", + "-unknown", NULL +}; +enum EnsConfigOpts { + CONF_MAP, CONF_NAMESPACE, CONF_PARAM, CONF_PREFIX, CONF_SUBCMDS, + CONF_UNKNOWN +}; + +/* + * This structure defines a Tcl object type that contains a reference to an + * ensemble subcommand (e.g. the "length" in [string length ab]). It is used + * to cache the mapping between the subcommand itself and the real command + * that implements it. + */ + +static const Tcl_ObjType ensembleCmdType = { + "ensembleCommand", /* the type's name */ + FreeEnsembleCmdRep, /* freeIntRepProc */ + DupEnsembleCmdRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; + +/* + * The internal rep for caching ensemble subcommand lookups and + * spell corrections. + */ + +typedef struct { + int epoch; /* Used to confirm when the data in this + * really structure matches up with the + * ensemble. */ + Command *token; /* Reference to the command for which this + * structure is a cache of the resolution. */ + Tcl_Obj *fix; /* Corrected spelling, if needed. */ + Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand + * hash table. */ +} EnsembleCmdRep; + + +static inline Tcl_Obj * +NewNsObj( + Tcl_Namespace *namespacePtr) +{ + register Namespace *nsPtr = (Namespace *) namespacePtr; + + if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) { + return Tcl_NewStringObj("::", 2); + } else { + return Tcl_NewStringObj(nsPtr->fullName, -1); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclNamespaceEnsembleCmd -- + * + * Invoked to implement the "namespace ensemble" command that creates and + * manipulates ensembles built on top of namespaces. Handles the + * following syntax: + * + * namespace ensemble name ?dictionary? + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Creates the ensemble for the namespace if one did not previously + * exist. Alternatively, alters the way that the ensemble's subcommand => + * implementation prefix is configured. + * + *---------------------------------------------------------------------- + */ + +int +TclNamespaceEnsembleCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Namespace *namespacePtr; + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr, + *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; + Tcl_Command token; + Tcl_DictSearch search; + Tcl_Obj *listObj; + const char *simpleName; + int index, done; + + if (nsPtr == NULL || nsPtr->flags & NS_DYING) { + if (!Tcl_InterpDeleted(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tried to manipulate ensemble of deleted namespace", + -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); + } + return TCL_ERROR; + } + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands, + "subcommand", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum EnsSubcmds) index) { + case ENS_CREATE: { + const char *name; + int len, allocatedMapFlag = 0; + /* + * Defaults + */ + Tcl_Obj *subcmdObj = NULL; + Tcl_Obj *mapObj = NULL; + int permitPrefix = 1; + Tcl_Obj *unknownObj = NULL; + Tcl_Obj *paramObj = NULL; + + /* + * Check that we've got option-value pairs... [Bug 1558654] + */ + + if (objc & 1) { + Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?"); + return TCL_ERROR; + } + objv += 2; + objc -= 2; + + name = nsPtr->name; + cxtPtr = (Namespace *) nsPtr->parentPtr; + + /* + * Parse the option list, applying type checks as we go. Note that we + * are not incrementing any reference counts in the objects at this + * stage, so the presence of an option multiple times won't cause any + * memory leaks. + */ + + for (; objc>1 ; objc-=2,objv+=2) { + if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions, + "option", 0, &index) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + switch ((enum EnsCreateOpts) index) { + case CRT_CMD: + name = TclGetString(objv[1]); + cxtPtr = nsPtr; + continue; + case CRT_SUBCMDS: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + 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, *subcmdWordsObj; + + /* + * Verify that the map is sensible. + */ + + if (Tcl_DictObjFirst(interp, objv[1], &search, + &subcmdWordsObj, &listObj, &done) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + if (done) { + mapObj = NULL; + continue; + } + do { + Tcl_Obj **listv; + const char *cmd; + + if (TclListObjGetElements(interp, listObj, &len, + &listv) != TCL_OK) { + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + if (len < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "ensemble subcommand implementations " + "must be non-empty lists", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", NULL); + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + cmd = TclGetString(listv[0]); + if (!(cmd[0] == ':' && cmd[1] == ':')) { + Tcl_Obj *newList = Tcl_NewListObj(len, listv); + Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr); + + if (nsPtr->parentPtr) { + Tcl_AppendStringsToObj(newCmd, "::", NULL); + } + Tcl_AppendObjToObj(newCmd, listv[0]); + Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); + if (patchedDict == NULL) { + patchedDict = Tcl_DuplicateObj(objv[1]); + } + Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, + newList); + } + Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done); + } while (!done); + + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + mapObj = (patchedDict ? patchedDict : objv[1]); + if (patchedDict) { + allocatedMapFlag = 1; + } + continue; + } + case CRT_PREFIX: + if (Tcl_GetBooleanFromObj(interp, objv[1], + &permitPrefix) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + continue; + case CRT_UNKNOWN: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + unknownObj = (len > 0 ? objv[1] : NULL); + continue; + } + } + + TclGetNamespaceForQualName(interp, name, cxtPtr, + TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr, + &simpleName); + + /* + * Create the ensemble. Note that this might delete another ensemble + * linked to the same namespace, so we must be careful. However, we + * should be OK because we only link the namespace into the list once + * we've created it (and after any deletions have occurred.) + */ + + token = TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, + (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); + 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 + * traces could have corrupted the pristine object that we started + * with). [Snit test rename-1.5] + */ + + Tcl_ResetResult(interp); + Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); + return TCL_OK; + } + + case ENS_EXISTS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "cmdname"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + Tcl_FindEnsemble(interp, objv[2], 0) != NULL)); + return TCL_OK; + + case ENS_CONFIG: + if (objc < 3 || (objc != 4 && !(objc & 1))) { + Tcl_WrongNumArgs(interp, 2, objv, + "cmdname ?-option value ...? ?arg ...?"); + return TCL_ERROR; + } + token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG); + if (token == NULL) { + return TCL_ERROR; + } + + if (objc == 4) { + Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ + + if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions, + "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum EnsConfigOpts) index) { + case CONF_SUBCMDS: + Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); + if (resultObj != NULL) { + 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) { + Tcl_SetObjResult(interp, resultObj); + } + break; + case CONF_NAMESPACE: + namespacePtr = NULL; /* silence gcc 4 warning */ + Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); + Tcl_SetObjResult(interp, NewNsObj(namespacePtr)); + break; + case CONF_PREFIX: { + int flags = 0; /* silence gcc 4 warning */ + + Tcl_GetEnsembleFlags(NULL, token, &flags); + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); + break; + } + case CONF_UNKNOWN: + Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; + } + } else if (objc == 3) { + /* + * Produce list of all information. + */ + + Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */ + int flags = 0; /* silence gcc 4 warning */ + + TclNewObj(resultObj); + + /* -map option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], -1)); + Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + /* -namespace option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE], + -1)); + namespacePtr = NULL; /* silence gcc 4 warning */ + Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); + Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr)); + + /* -parameters option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[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(ensembleConfigOptions[CONF_PREFIX], -1)); + Tcl_GetEnsembleFlags(NULL, token, &flags); + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); + + /* -subcommands option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],-1)); + Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + /* -unknown option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1)); + Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + Tcl_SetObjResult(interp, resultObj); + } else { + int len, allocatedMapFlag = 0; + 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; + + objv += 3; + objc -= 3; + + /* + * Parse the option list, applying type checks as we go. Note that + * we are not incrementing any reference counts in the objects at + * this stage, so the presence of an option multiple times won't + * cause any memory leaks. + */ + + for (; objc>0 ; objc-=2,objv+=2) { + if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions, + "option", 0, &index) != TCL_OK) { + freeMapAndError: + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + switch ((enum EnsConfigOpts) index) { + case CONF_SUBCMDS: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto freeMapAndError; + } + subcmdObj = (len > 0 ? objv[1] : NULL); + continue; + case CONF_PARAM: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto freeMapAndError; + } + paramObj = (len > 0 ? objv[1] : NULL); + continue; + case CONF_MAP: { + Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv; + const char *cmd; + + /* + * Verify that the map is sensible. + */ + + if (Tcl_DictObjFirst(interp, objv[1], &search, + &subcmdWordsObj, &listObj, &done) != TCL_OK) { + goto freeMapAndError; + } + if (done) { + mapObj = NULL; + continue; + } + do { + if (TclListObjGetElements(interp, listObj, &len, + &listv) != TCL_OK) { + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + goto freeMapAndError; + } + if (len < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "ensemble subcommand implementations " + "must be non-empty lists", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", NULL); + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + goto freeMapAndError; + } + cmd = TclGetString(listv[0]); + if (!(cmd[0] == ':' && cmd[1] == ':')) { + Tcl_Obj *newList = Tcl_DuplicateObj(listObj); + Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr); + + if (nsPtr->parentPtr) { + Tcl_AppendStringsToObj(newCmd, "::", NULL); + } + Tcl_AppendObjToObj(newCmd, listv[0]); + Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd); + if (patchedDict == NULL) { + patchedDict = Tcl_DuplicateObj(objv[1]); + } + Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, + newList); + } + Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, + &done); + } while (!done); + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + mapObj = (patchedDict ? patchedDict : objv[1]); + if (patchedDict) { + allocatedMapFlag = 1; + } + continue; + } + case CONF_NAMESPACE: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "option -namespace is read-only", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY", + NULL); + goto freeMapAndError; + case CONF_PREFIX: + if (Tcl_GetBooleanFromObj(interp, objv[1], + &permitPrefix) != TCL_OK) { + goto freeMapAndError; + } + continue; + case CONF_UNKNOWN: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto freeMapAndError; + } + unknownObj = (len > 0 ? objv[1] : NULL); + continue; + } + } + + /* + * Update the namespace now that we've finished the parsing stage. + */ + + flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX + : 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; + + default: + Tcl_Panic("unexpected ensemble command"); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateEnsembleInNs -- + * + * Like Tcl_CreateEnsemble, but additionally accepts as an argument the + * name of the namespace to create the command in. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclCreateEnsembleInNs( + Tcl_Interp *interp, + + const char *name, /* Simple name of command to create (no */ + /* namespace components). */ + Tcl_Namespace /* Name of namespace to create the command in. */ + *nameNsPtr, + Tcl_Namespace + *ensembleNsPtr, /* Name of the namespace for the ensemble. */ + int flags + ) +{ + Namespace *nsPtr = (Namespace *) ensembleNsPtr; + EnsembleConfig *ensemblePtr; + Tcl_Command token; + + ensemblePtr = ckalloc(sizeof(EnsembleConfig)); + token = TclNRCreateCommandInNs(interp, name, + (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd, + NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); + if (token == NULL) { + ckfree(ensemblePtr); + return NULL; + } + + ensemblePtr->nsPtr = nsPtr; + ensemblePtr->epoch = 0; + Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); + ensemblePtr->subcommandArrayPtr = NULL; + ensemblePtr->subcmdList = NULL; + ensemblePtr->subcommandDict = NULL; + ensemblePtr->flags = flags; + ensemblePtr->numParameters = 0; + ensemblePtr->parameterList = NULL; + ensemblePtr->unknownHandler = NULL; + ensemblePtr->token = token; + ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; + nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; + + /* + * 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! + */ + + nsPtr->exportLookupEpoch++; + + if (flags & ENSEMBLE_COMPILE) { + ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; + } + + return ensemblePtr->token; + +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateEnsemble + * + * Create a simple ensemble attached to the given namespace. + * + * Deprecated by TclCreateEnsembleInNs. + * + * Value + * + * The token for the command created. + * + * Effect + * The ensemble is created and marked for compilation. + * + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateEnsemble( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *namespacePtr, + int flags) +{ + Tcl_Obj *nameObj = NULL; + Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr, + *actualNsPtr; + const char * simpleName; + + if (nsPtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } + + TclGetNamespaceForQualName(interp, name, nsPtr, 0, + &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); + if (nameObj != NULL) { + TclDecrRefCount(nameObj); + } + return TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleSubcommandList -- + * + * Set the subcommand list for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the subcommand list - if non-NULL - is not a list). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleSubcommandList( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj *subcmdList) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldList; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + return TCL_ERROR; + } + if (subcmdList != NULL) { + int length; + + if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 1) { + subcmdList = NULL; + } + } + + ensemblePtr = cmdPtr->objClientData; + oldList = ensemblePtr->subcmdList; + ensemblePtr->subcmdList = subcmdList; + if (subcmdList != NULL) { + Tcl_IncrRefCount(subcmdList); + } + if (oldList != NULL) { + TclDecrRefCount(oldList); + } + + /* + * 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_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_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_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. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the mapping - if non-NULL - is not a dict). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleMappingDict( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj *mapDict) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldDict; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + return TCL_ERROR; + } + if (mapDict != NULL) { + int size, done; + Tcl_DictSearch search; + Tcl_Obj *valuePtr; + + if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) { + return TCL_ERROR; + } + + for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done); + !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) { + Tcl_Obj *cmdObjPtr; + const char *bytes; + + if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdObjPtr) != TCL_OK) { + Tcl_DictObjDone(&search); + return TCL_ERROR; + } + bytes = TclGetString(cmdObjPtr); + if (bytes[0] != ':' || bytes[1] != ':') { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "ensemble target is not a fully-qualified command", + -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "UNQUALIFIED_TARGET", NULL); + Tcl_DictObjDone(&search); + return TCL_ERROR; + } + } + + if (size < 1) { + mapDict = NULL; + } + } + + ensemblePtr = cmdPtr->objClientData; + oldDict = ensemblePtr->subcommandDict; + ensemblePtr->subcommandDict = mapDict; + if (mapDict != NULL) { + Tcl_IncrRefCount(mapDict); + } + if (oldDict != NULL) { + TclDecrRefCount(oldDict); + } + + /* + * 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_SetEnsembleUnknownHandler -- + * + * Set the unknown handler for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the unknown handler - if non-NULL - is not a list). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleUnknownHandler( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj *unknownList) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldList; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + return TCL_ERROR; + } + if (unknownList != NULL) { + int length; + + if (TclListObjLength(interp, unknownList, &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 1) { + unknownList = NULL; + } + } + + ensemblePtr = cmdPtr->objClientData; + oldList = ensemblePtr->unknownHandler; + ensemblePtr->unknownHandler = unknownList; + if (unknownList != NULL) { + Tcl_IncrRefCount(unknownList); + } + if (oldList != NULL) { + TclDecrRefCount(oldList); + } + + /* + * 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++; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleFlags -- + * + * Set the flags for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleFlags( + Tcl_Interp *interp, + Tcl_Command token, + int flags) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + int wasCompiled; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE; + + /* + * This API refuses to set the ENSEMBLE_DEAD flag... + */ + + ensemblePtr->flags &= ENSEMBLE_DEAD; + ensemblePtr->flags |= flags & ~ENSEMBLE_DEAD; + + /* + * 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++; + + /* + * If the ENSEMBLE_COMPILE flag status was changed, install or remove the + * compiler function and bump the interpreter's compilation epoch so that + * bytecode gets regenerated. + */ + + if (flags & ENSEMBLE_COMPILE) { + if (!wasCompiled) { + ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble; + ((Interp *) interp)->compileEpoch++; + } + } else { + if (wasCompiled) { + ((Command *) ensemblePtr->token)->compileProc = NULL; + ((Interp *) interp)->compileEpoch++; + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleSubcommandList -- + * + * Get the list of subcommands associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The list of subcommands is returned by updating the + * variable pointed to by the last parameter (NULL if this is to be + * derived from the mapping dictionary or the associated namespace's + * exported commands). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleSubcommandList( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj **subcmdListPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *subcmdListPtr = ensemblePtr->subcmdList; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_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 + * ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The mapping dict is returned by updating the variable + * pointed to by the last parameter (NULL if none is installed). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleMappingDict( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj **mapDictPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *mapDictPtr = ensemblePtr->subcommandDict; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleUnknownHandler -- + * + * Get the unknown handler associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The unknown handler is returned by updating the variable + * pointed to by the last parameter (NULL if no handler is installed). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleUnknownHandler( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj **unknownListPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *unknownListPtr = ensemblePtr->unknownHandler; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleFlags -- + * + * Get the flags for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The flags are returned by updating the variable pointed to + * by the last parameter. + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleFlags( + Tcl_Interp *interp, + Tcl_Command token, + int *flagsPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *flagsPtr = ensemblePtr->flags; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleNamespace -- + * + * Get the namespace associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). Namespace is returned by updating the variable pointed to + * by the last parameter. + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleNamespace( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Namespace **namespacePtrPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindEnsemble -- + * + * Given a command name, get the ensemble token for it, allowing for + * [namespace import]s. [Bug 1017022] + * + * Results: + * The token for the ensemble command with the given name, or NULL if the + * command either does not exist or is not an ensemble (when an error + * message will be written into the interp if thats non-NULL). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_FindEnsemble( + Tcl_Interp *interp, /* Where to do the lookup, and where to write + * the errors if TCL_LEAVE_ERR_MSG is set in + * the flags. */ + Tcl_Obj *cmdNameObj, /* Name of command to look up. */ + int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags + * are probably not useful. */ +{ + Command *cmdPtr; + + cmdPtr = (Command *) + Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); + if (cmdPtr == NULL) { + return NULL; + } + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + /* + * Reuse existing infrastructure for following import link chains + * rather than duplicating it. + */ + + cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + + if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){ + if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not an ensemble command", + TclGetString(cmdNameObj))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", + TclGetString(cmdNameObj), NULL); + } + return NULL; + } + } + + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsEnsemble -- + * + * Simple test for ensemble-hood that takes into account imported + * ensemble commands as well. + * + * Results: + * Boolean value + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsEnsemble( + Tcl_Command token) +{ + Command *cmdPtr = (Command *) token; + + if (cmdPtr->objProc == NsEnsembleImplementationCmd) { + return 1; + } + cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { + return 0; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclMakeEnsemble -- + * + * Create an ensemble from a table of implementation commands. The + * ensemble will be subject to (limited) compilation if any of the + * implementation commands are compilable. + * + * The 'name' parameter may be a single command name or a list if + * creating an ensemble subcommand (see the binary implementation). + * + * Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on + * top-level ensemble commands. + * + * Results: + * Handle for the new ensemble, or NULL on failure. + * + * Side effects: + * May advance the bytecode compilation epoch. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclMakeEnsemble( + Tcl_Interp *interp, + const char *name, /* The ensemble name (as explained above) */ + const EnsembleImplMap map[]) /* The subcommands to create */ +{ + Tcl_Command ensemble; + Tcl_Namespace *ns; + Tcl_DString buf, hiddenBuf; + const char **nameParts = NULL; + const char *cmdName = NULL; + int i, nameCount = 0, ensembleFlags = 0, hiddenLen; + + /* + * Construct the path for the ensemble namespace and create it. + */ + + Tcl_DStringInit(&buf); + Tcl_DStringInit(&hiddenBuf); + TclDStringAppendLiteral(&hiddenBuf, "tcl:"); + Tcl_DStringAppend(&hiddenBuf, name, -1); + TclDStringAppendLiteral(&hiddenBuf, ":"); + hiddenLen = Tcl_DStringLength(&hiddenBuf); + if (name[0] == ':' && name[1] == ':') { + /* + * An absolute name, so use it directly. + */ + + cmdName = name; + Tcl_DStringAppend(&buf, name, -1); + ensembleFlags = TCL_ENSEMBLE_PREFIX; + } else { + /* + * Not an absolute name, so do munging of it. Note that this treats a + * multi-word list differently to a single word. + */ + + TclDStringAppendLiteral(&buf, "::tcl"); + + if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) { + Tcl_Panic("invalid ensemble name '%s'", name); + } + + for (i = 0; i < nameCount; ++i) { + TclDStringAppendLiteral(&buf, "::"); + Tcl_DStringAppend(&buf, nameParts[i], -1); + } + } + + ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL, + TCL_CREATE_NS_IF_UNKNOWN); + if (!ns) { + Tcl_Panic("unable to find or create %s namespace!", + Tcl_DStringValue(&buf)); + } + + /* + * Create the named ensemble in the correct namespace + */ + + if (cmdName == NULL) { + if (nameCount == 1) { + ensembleFlags = TCL_ENSEMBLE_PREFIX; + cmdName = Tcl_DStringValue(&buf) + 5; + } else { + ns = ns->parentPtr; + cmdName = nameParts[nameCount - 1]; + } + } + + /* + * Switch on compilation always for core ensembles now that we can do + * nice bytecode things with them. Do it now. Waiting until later will + * just cause pointless epoch bumps. + */ + + ensembleFlags |= ENSEMBLE_COMPILE; + ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags); + + /* + * Create the ensemble mapping dictionary and the ensemble command procs. + */ + + if (ensemble != NULL) { + Tcl_Obj *mapDict, *fromObj, *toObj; + Command *cmdPtr; + + TclDStringAppendLiteral(&buf, "::"); + TclNewObj(mapDict); + for (i=0 ; map[i].name != NULL ; i++) { + fromObj = Tcl_NewStringObj(map[i].name, -1); + TclNewStringObj(toObj, Tcl_DStringValue(&buf), + Tcl_DStringLength(&buf)); + Tcl_AppendToObj(toObj, map[i].name, -1); + Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); + + if (map[i].proc || map[i].nreProc) { + /* + * If the command is unsafe, hide it when we're in a safe + * interpreter. The code to do this is really hokey! It also + * doesn't work properly yet; this function is always + * currently called before the safe-interp flag is set so the + * Tcl_IsSafe check fails. + */ + + if (map[i].unsafe && Tcl_IsSafe(interp)) { + cmdPtr = (Command *) + Tcl_NRCreateCommand(interp, "___tmp", map[i].proc, + map[i].nreProc, map[i].clientData, NULL); + Tcl_DStringSetLength(&hiddenBuf, hiddenLen); + if (Tcl_HideCommand(interp, "___tmp", + Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + } + } else { + /* + * Not hidden, so just create it. Yay! + */ + + cmdPtr = (Command *) + Tcl_NRCreateCommand(interp, TclGetString(toObj), + map[i].proc, map[i].nreProc, map[i].clientData, + NULL); + } + cmdPtr->compileProc = map[i].compileProc; + } + } + Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); + } + + Tcl_DStringFree(&buf); + Tcl_DStringFree(&hiddenBuf); + if (nameParts != NULL) { + ckfree((char *) nameParts); + } + return ensemble; +} + +/* + *---------------------------------------------------------------------- + * + * NsEnsembleImplementationCmd -- + * + * Implements an ensemble of commands (being those exported by a + * namespace other than the global namespace) as a command with the same + * (short) name as the namespace in the parent namespace. + * + * Results: + * A standard Tcl result code. Will be TCL_ERROR if the command is not an + * unambiguous prefix of any command exported by the ensemble's + * namespace. + * + * Side effects: + * Depends on the command within the namespace that gets executed. If the + * ensemble itself returns TCL_ERROR, a descriptive error message will be + * placed in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +static int +NsEnsembleImplementationCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR, + clientData, objc, objv); +} + +static int +NsEnsembleImplementationCmdNR( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + EnsembleConfig *ensemblePtr = clientData; + /* The ensemble itself. */ + Tcl_Obj *prefixObj; /* An object containing the prefix words of + * the command that implements the + * subcommand. */ + Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully + * specified but not yet cached command + * names. */ + int reparseCount = 0; /* Number of reparses. */ + Tcl_Obj *errorObj; /* Used for building error messages. */ + Tcl_Obj *subObj; + int subIdx; + + /* + * Must recheck objc, since numParameters might have changed. Cf. test + * namespace-53.9. + */ + + restartEnsembleParse: + subIdx = 1 + ensemblePtr->numParameters; + if (objc < subIdx + 1) { + /* + * We don't have a subcommand argument. Make error message. + */ + + Tcl_DString buf; /* Message being built */ + + Tcl_DStringInit(&buf); + if (ensemblePtr->parameterList) { + Tcl_DStringAppend(&buf, + TclGetString(ensemblePtr->parameterList), -1); + TclDStringAppendLiteral(&buf, " "); + } + TclDStringAppendLiteral(&buf, "subcommand ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf)); + Tcl_DStringFree(&buf); + + return TCL_ERROR; + } + + if (ensemblePtr->nsPtr->flags & NS_DYING) { + /* + * Don't know how we got here, but make things give up quickly. + */ + + if (!Tcl_InterpDeleted(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "ensemble activated for deleted namespace", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); + } + return TCL_ERROR; + } + + /* + * Determine if the table of subcommands is right. If so, we can just look + * up in there and go straight to dispatch. + */ + + subObj = objv[subIdx]; + + if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { + /* + * Table of subcommands is still valid; therefore there might be a + * valid cache of discovered information which we can reuse. Do the + * check here, and if we're still valid, we can jump straight to the + * part where we do the invocation of the subcommand. + */ + + if (subObj->typePtr==&ensembleCmdType){ + EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1; + + if (ensembleCmd->epoch == ensemblePtr->epoch && + ensembleCmd->token == (Command *)ensemblePtr->token) { + prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr); + Tcl_IncrRefCount(prefixObj); + if (ensembleCmd->fix) { + TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix); + } + goto runResultingSubcommand; + } + } + } else { + BuildEnsembleConfig(ensemblePtr); + ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch; + } + + /* + * Look in the hashtable for the subcommand name; this is the fastest way + * of all if there is no cache in operation. + */ + + hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, + TclGetString(subObj)); + if (hPtr != NULL) { + + /* + * Cache for later in the subcommand object. + */ + + MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL); + } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { + /* + * Could not map, no prefixing, go to unknown/error handling. + */ + + goto unknownOrAmbiguousSubcommand; + } else { + /* + * If we've not already confirmed the command with the hash as part of + * building our export table, we need to scan the sorted array for + * matches. + */ + + const char *subcmdName; /* Name of the subcommand, or unique prefix of + * it (will be an error for a non-unique + * prefix). */ + char *fullName = NULL; /* Full name of the subcommand. */ + int stringLength, i; + int tableLength = ensemblePtr->subcommandTable.numEntries; + Tcl_Obj *fix; + + subcmdName = Tcl_GetStringFromObj(subObj, &stringLength); + for (i=0 ; i<tableLength ; i++) { + register int cmp = strncmp(subcmdName, + ensemblePtr->subcommandArrayPtr[i], + (unsigned) stringLength); + + if (cmp == 0) { + if (fullName != NULL) { + /* + * Since there's never the exact-match case to worry about + * (hash search filters this), getting here indicates that + * our subcommand is an ambiguous prefix of (at least) two + * exported subcommands, which is an error case. + */ + + goto unknownOrAmbiguousSubcommand; + } + fullName = ensemblePtr->subcommandArrayPtr[i]; + } else if (cmp < 0) { + /* + * Because we are searching a sorted table, we can now stop + * searching because we have gone past anything that could + * possibly match. + */ + + break; + } + } + if (fullName == NULL) { + /* + * The subcommand is not a prefix of anything, so bail out! + */ + + goto unknownOrAmbiguousSubcommand; + } + hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName); + if (hPtr == NULL) { + Tcl_Panic("full name %s not found in supposedly synchronized hash", + fullName); + } + + /* + * Record the spelling correction for usage message. + */ + + fix = Tcl_NewStringObj(fullName, -1); + + /* + * Cache for later in the subcommand object. + */ + + MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix); + TclSpellFix(interp, objv, objc, subIdx, subObj, fix); + } + + prefixObj = Tcl_GetHashValue(hPtr); + Tcl_IncrRefCount(prefixObj); + runResultingSubcommand: + + /* + * Do the real work of execution of the subcommand by building an array of + * objects (note that this is potentially not the same length as the + * 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, + * + * ((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.) + */ + + { + Tcl_Obj *copyPtr; /* The actual list of words to dispatch to. + * Will be freed by the dispatch engine. */ + Tcl_Obj **copyObjv; + int copyObjc, prefixObjc; + + Tcl_ListObjLength(NULL, prefixObj, &prefixObjc); + + if (objc == 2) { + copyPtr = TclListObjCopy(NULL, prefixObj); + } else { + copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL); + Tcl_ListObjAppendList(NULL, copyPtr, prefixObj); + Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, + ensemblePtr->numParameters, objv + 1); + Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, + objc - 2 - ensemblePtr->numParameters, + objv + 2 + ensemblePtr->numParameters); + } + Tcl_IncrRefCount(copyPtr); + TclNRAddCallback(interp, TclNRReleaseValues, copyPtr, NULL, NULL, NULL); + TclDecrRefCount(prefixObj); + + /* + * Record what arguments the script sent in so that things like + * Tcl_WrongNumArgs can give the correct error message. Parameters + * count both as inserted and removed arguments. + */ + + if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters, + prefixObjc + ensemblePtr->numParameters, objv)) { + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, + NULL); + } + + /* + * Hand off to the target command. + */ + + TclSkipTailcall(interp); + Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); + ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; + return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); + } + + unknownOrAmbiguousSubcommand: + /* + * Have not been able to match the subcommand asked for with a real + * subcommand that we export. See whether a handler has been registered + * for dealing with this situation. Will only call (at most) once for any + * particular ensemble invocation. + */ + + if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { + switch (EnsembleUnknownCallback(interp, ensemblePtr, objc, objv, + &prefixObj)) { + case TCL_OK: + goto runResultingSubcommand; + case TCL_ERROR: + return TCL_ERROR; + case TCL_CONTINUE: + goto restartEnsembleParse; + } + } + + /* + * We cannot determine what subcommand to hand off to, so generate a + * (standard) failure message. Note the one odd case compared with + * standard ensemble-like command, which is where a namespace has no + * exported commands at all... + */ + + Tcl_ResetResult(interp); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", + TclGetString(subObj), NULL); + if (ensemblePtr->subcommandTable.numEntries == 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown subcommand \"%s\": namespace %s does not" + " export any commands", TclGetString(subObj), + ensemblePtr->nsPtr->fullName)); + return TCL_ERROR; + } + errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ", + (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), + TclGetString(subObj)); + if (ensemblePtr->subcommandTable.numEntries == 1) { + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1); + } else { + int i; + + for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) { + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1); + Tcl_AppendToObj(errorObj, ", ", 2); + } + Tcl_AppendPrintfToObj(errorObj, "or %s", + ensemblePtr->subcommandArrayPtr[i]); + } + Tcl_SetObjResult(interp, errorObj); + return TCL_ERROR; +} + +int +TclClearRootEnsemble( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + TclResetRewriteEnsemble(interp, 1); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitRewriteEnsemble -- + * + * Applies a rewrite of arguments so that an ensemble subcommand will + * report error messages correctly for the overall command. + * + * Results: + * Whether this is the first rewrite applied, a value which must be + * passed to TclResetRewriteEnsemble when undoing this command's + * behaviour. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclInitRewriteEnsemble( + Tcl_Interp *interp, + int numRemoved, + int numInserted, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + + int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = numRemoved; + iPtr->ensembleRewrite.numInsertedObjs = numInserted; + } else { + int numIns = iPtr->ensembleRewrite.numInsertedObjs; + + if (numIns < numRemoved) { + iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns; + iPtr->ensembleRewrite.numInsertedObjs = numInserted; + } else { + iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved; + } + } + return isRootEnsemble; +} + +/* + *---------------------------------------------------------------------- + * + * TclResetRewriteEnsemble -- + * + * Removes any rewrites applied to support proper reporting of error + * messages used in ensembles. Should be paired with + * TclInitRewriteEnsemble. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclResetRewriteEnsemble( + Tcl_Interp *interp, + int isRootEnsemble) +{ + Interp *iPtr = (Interp *) interp; + + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclSpellFix -- + * + * Record a spelling correction that needs making in the + * generation of the WrongNumArgs usage message. + * + * Results: + * None. + * + * Side effects: + * Can create an alternative ensemble rewrite structure. + * + *---------------------------------------------------------------------- + */ + +static int +FreeER( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj **tmp = (Tcl_Obj **)data[0]; + + ckfree(tmp[2]); + ckfree(tmp); + return result; +} + +void +TclSpellFix( + Tcl_Interp *interp, + Tcl_Obj *const *objv, + int objc, + int badIdx, + Tcl_Obj *bad, + Tcl_Obj *fix) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *const *search; + Tcl_Obj **store; + int idx; + int size; + + if (iPtr->ensembleRewrite.sourceObjs == NULL) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } + + /* Compute the valid length of the ensemble root */ + + size = iPtr->ensembleRewrite.numRemovedObjs + objc + - iPtr->ensembleRewrite.numInsertedObjs; + + search = iPtr->ensembleRewrite.sourceObjs; + if (search[0] == NULL) { + /* Awful casting abuse here */ + search = (Tcl_Obj *const *) search[1]; + } + + if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) { + /* + * Misspelled value was inserted. We cannot directly jump + * to the bad value, but have to search. + */ + idx = 1; + while (idx < size) { + if (search[idx] == bad) { + break; + } + idx++; + } + if (idx == size) { + return; + } + } else { + /* Jump to the misspelled value. */ + idx = iPtr->ensembleRewrite.numRemovedObjs + badIdx + - iPtr->ensembleRewrite.numInsertedObjs; + + /* Verify */ + if (search[idx] != bad) { + Tcl_Panic("SpellFix: programming error"); + } + } + + search = iPtr->ensembleRewrite.sourceObjs; + if (search[0] == NULL) { + store = (Tcl_Obj **)search[2]; + } else { + Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *)); + tmp[0] = NULL; + tmp[1] = (Tcl_Obj *)iPtr->ensembleRewrite.sourceObjs; + tmp[2] = (Tcl_Obj *)ckalloc(size * sizeof(Tcl_Obj *)); + memcpy(tmp[2], tmp[1], size*sizeof(Tcl_Obj *)); + + iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp; + TclNRAddCallback(interp, FreeER, tmp, NULL, NULL, NULL); + store = (Tcl_Obj **)tmp[2]; + } + + store[idx] = fix; + Tcl_IncrRefCount(fix); + TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TclFetchEnsembleRoot -- + * + * Returns the root of ensemble rewriting, if any. + * If no root exists, returns objv instead. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj *const * +TclFetchEnsembleRoot( + Tcl_Interp *interp, + Tcl_Obj *const *objv, + int objc, + int *objcPtr) +{ + Interp *iPtr = (Interp *) interp; + + if (iPtr->ensembleRewrite.sourceObjs) { + *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + return iPtr->ensembleRewrite.sourceObjs; + } + *objcPtr = objc; + return objv; +} + +/* + * ---------------------------------------------------------------------- + * + * EnsmebleUnknownCallback -- + * + * Helper for the ensemble engine that handles the procesing of unknown + * callbacks. See the user documentation of the ensemble unknown handler + * for details; this function is only ever called when such a function is + * defined, and is only ever called once per ensemble dispatch (i.e. if a + * reparse still fails, this isn't called again). + * + * Results: + * TCL_OK - *prefixObjPtr contains the command words to dispatch + * to. + * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid). + * TCL_ERROR - Something went wrong! Error message in interpreter. + * + * Side effects: + * Calls the Tcl interpreter, so arbitrary. + * + * ---------------------------------------------------------------------- + */ + +static inline int +EnsembleUnknownCallback( + Tcl_Interp *interp, + EnsembleConfig *ensemblePtr, + int objc, + Tcl_Obj *const objv[], + Tcl_Obj **prefixObjPtr) +{ + int paramc, i, result, prefixObjc; + Tcl_Obj **paramv, *unknownCmd, *ensObj; + + /* + * Create the unknown command callback to determine what to do. + */ + + unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); + TclNewObj(ensObj); + Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); + Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); + for (i=1 ; i<objc ; i++) { + Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]); + } + TclListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv); + Tcl_IncrRefCount(unknownCmd); + + /* + * Now call the unknown handler. (We don't bother NRE-enabling this; deep + * recursing through unknown handlers is horribly perverse.) Note that it + * is always an error for an unknown handler to delete its ensemble; don't + * do that! + */ + + Tcl_Preserve(ensemblePtr); + TclSkipTailcall(interp); + result = Tcl_EvalObjv(interp, paramc, paramv, 0); + if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) { + if (!Tcl_InterpDeleted(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown subcommand handler deleted its ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED", + NULL); + } + result = TCL_ERROR; + } + Tcl_Release(ensemblePtr); + + /* + * If we succeeded, we should either have a list of words that form the + * command to be executed, or an empty list. In the empty-list case, the + * ensemble is believed to be updated so we should ask the ensemble engine + * to reparse the original command. + */ + + if (result == TCL_OK) { + *prefixObjPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(*prefixObjPtr); + TclDecrRefCount(unknownCmd); + Tcl_ResetResult(interp); + + /* + * Namespace is still there. Check if the result is a valid list. If + * it is, and it is non-empty, that list is what we are using as our + * replacement. + */ + + if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) { + TclDecrRefCount(*prefixObjPtr); + Tcl_AddErrorInfo(interp, "\n while parsing result of " + "ensemble unknown subcommand handler"); + return TCL_ERROR; + } + if (prefixObjc > 0) { + return TCL_OK; + } + + /* + * Namespace alive & empty result => reparse. + */ + + TclDecrRefCount(*prefixObjPtr); + return TCL_CONTINUE; + } + + /* + * Oh no! An exceptional result. Convert to an error. + */ + + if (!Tcl_InterpDeleted(interp)) { + if (result != TCL_ERROR) { + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown subcommand handler returned bad code: ", -1)); + switch (result) { + case TCL_RETURN: + Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1); + break; + case TCL_BREAK: + Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1); + break; + case TCL_CONTINUE: + Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1); + break; + default: + Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result); + } + Tcl_AddErrorInfo(interp, "\n result of " + "ensemble unknown subcommand handler: "); + Tcl_AppendObjToErrorInfo(interp, unknownCmd); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT", + NULL); + } else { + Tcl_AddErrorInfo(interp, + "\n (ensemble unknown subcommand handler)"); + } + } + TclDecrRefCount(unknownCmd); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * MakeCachedEnsembleCommand -- + * + * Cache what we've computed so far; it's not nice to repeatedly copy + * strings about. Note that to do this, we start by deleting any old + * representation that there was (though if it was an out of date + * ensemble rep, we can skip some of the deallocation process.) + * + * Results: + * None + * + * Side effects: + * Alters the internal representation of the first object parameter. + * + *---------------------------------------------------------------------- + */ + +static void +MakeCachedEnsembleCommand( + Tcl_Obj *objPtr, + EnsembleConfig *ensemblePtr, + Tcl_HashEntry *hPtr, + Tcl_Obj *fix) +{ + register EnsembleCmdRep *ensembleCmd; + + if (objPtr->typePtr == &ensembleCmdType) { + ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + TclCleanupCommandMacro(ensembleCmd->token); + if (ensembleCmd->fix) { + Tcl_DecrRefCount(ensembleCmd->fix); + } + } else { + /* + * Kill the old internal rep, and replace it with a brand new one of + * our own. + */ + + TclFreeIntRep(objPtr); + ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); + objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; + objPtr->typePtr = &ensembleCmdType; + } + + /* + * Populate the internal rep. + */ + + ensembleCmd->epoch = ensemblePtr->epoch; + ensembleCmd->token = (Command *) ensemblePtr->token; + ensembleCmd->token->refCount++; + if (fix) { + Tcl_IncrRefCount(fix); + } + ensembleCmd->fix = fix; + ensembleCmd->hPtr = hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsembleConfig -- + * + * Destroys the data structure used to represent an ensemble. This is + * called when the ensemble's command is deleted (which happens + * automatically if the ensemble's namespace is deleted.) Maintainers + * should note that ensembles should be deleted by deleting their + * commands. + * + * Results: + * None. + * + * Side effects: + * Memory is (eventually) deallocated. + * + *---------------------------------------------------------------------- + */ + +static void +ClearTable( + EnsembleConfig *ensemblePtr) +{ + Tcl_HashTable *hash = &ensemblePtr->subcommandTable; + + if (hash->numEntries != 0) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search); + + while (hPtr != NULL) { + Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(prefixObj); + hPtr = Tcl_NextHashEntry(&search); + } + ckfree((char *) ensemblePtr->subcommandArrayPtr); + } + Tcl_DeleteHashTable(hash); +} + +static void +DeleteEnsembleConfig( + ClientData clientData) +{ + EnsembleConfig *ensemblePtr = clientData; + Namespace *nsPtr = ensemblePtr->nsPtr; + + /* + * Unlink from the ensemble chain if it has not been marked as having been + * done already. + */ + + if (ensemblePtr->next != ensemblePtr) { + EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; + + if (ensPtr == ensemblePtr) { + nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; + } else { + while (ensPtr != NULL) { + if (ensPtr->next == ensemblePtr) { + ensPtr->next = ensemblePtr->next; + break; + } + ensPtr = ensPtr->next; + } + } + } + + /* + * Mark the namespace as dead so code that uses Tcl_Preserve() can tell + * whether disaster happened anyway. + */ + + ensemblePtr->flags |= ENSEMBLE_DEAD; + + /* + * Kill the pointer-containing fields. + */ + + ClearTable(ensemblePtr); + if (ensemblePtr->subcmdList != NULL) { + Tcl_DecrRefCount(ensemblePtr->subcmdList); + } + if (ensemblePtr->parameterList != NULL) { + Tcl_DecrRefCount(ensemblePtr->parameterList); + } + if (ensemblePtr->subcommandDict != NULL) { + Tcl_DecrRefCount(ensemblePtr->subcommandDict); + } + if (ensemblePtr->unknownHandler != NULL) { + Tcl_DecrRefCount(ensemblePtr->unknownHandler); + } + + /* + * Arrange for the structure to be reclaimed. Note that this is complex + * because we have to make sure that we can react sensibly when an + * ensemble is deleted during the process of initialising the ensemble + * (especially the unknown callback.) + */ + + Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC); +} + +/* + *---------------------------------------------------------------------- + * + * BuildEnsembleConfig -- + * + * Create the internal data structures that describe how an ensemble + * looks, being a hash mapping from the simple command name to the Tcl list + * that describes the implementation prefix words, and a sorted array of + * the names to allow for reasonably efficient unambiguous prefix handling. + * + * Results: + * None. + * + * Side effects: + * Reallocates and rebuilds the hash table and array stored at the + * ensemblePtr argument. For large ensembles or large namespaces, this is + * a potentially expensive operation. + * + *---------------------------------------------------------------------- + */ + +static void +BuildEnsembleConfig( + EnsembleConfig *ensemblePtr) +{ + Tcl_HashSearch search; /* Used for scanning the set of commands in + * the namespace that backs up this + * ensemble. */ + int i, j, isNew; + Tcl_HashTable *hash = &ensemblePtr->subcommandTable; + Tcl_HashEntry *hPtr; + Tcl_Obj *mapDict = ensemblePtr->subcommandDict; + Tcl_Obj *subList = ensemblePtr->subcmdList; + + ClearTable(ensemblePtr); + Tcl_InitHashTable(hash, TCL_STRING_KEYS); + + if (subList) { + int subc; + Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj; + char *name; + + /* + * There is a list of exactly what subcommands go in the table. + * Must determine the target for each. + */ + + Tcl_ListObjGetElements(NULL, subList, &subc, &subv); + if (subList == mapDict) { + /* + * Strange case where explicit list of subcommands is same value + * as the dict mapping to targets. + */ + + for (i = 0; i < subc; i += 2) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(cmdObj); + } + Tcl_SetHashValue(hPtr, subv[i+1]); + Tcl_IncrRefCount(subv[i+1]); + + name = TclGetString(subv[i+1]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (isNew) { + cmdObj = Tcl_NewStringObj(name, -1); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } + } else { + /* Usual case where we can freely act on the list and dict. */ + + for (i = 0; i < subc; i++) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + continue; + } + + /* Lookup target in the dictionary */ + if (mapDict) { + Tcl_DictObjGet(NULL, mapDict, subv[i], &target); + if (target) { + Tcl_SetHashValue(hPtr, target); + Tcl_IncrRefCount(target); + continue; + } + } + + /* + * target was not in the dictionary so map onto the namespace. + * Note in this case that we do not guarantee that the + * command is actually there; that is the programmer's + * responsibility (or [::unknown] of course). + */ + cmdObj = Tcl_NewStringObj(name, -1); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } + } else if (mapDict) { + /* + * No subcmd list, but we do have a mapping dictionary so we should + * use the keys of that. Convert the dictionary's contents into the + * form required for the ensemble's internal hashtable. + */ + + Tcl_DictSearch dictSearch; + Tcl_Obj *keyObj, *valueObj; + int done; + + Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, + &keyObj, &valueObj, &done); + while (!done) { + char *name = TclGetString(keyObj); + + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + Tcl_SetHashValue(hPtr, valueObj); + Tcl_IncrRefCount(valueObj); + Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); + } + } else { + /* + * Discover what commands are actually exported by the namespace. + * What we have is an array of patterns and a hash table whose keys + * are the command names exported by the namespace (the contents do + * not matter here.) We must find out what commands are actually + * exported by filtering each command in the namespace against each of + * the patterns in the export list. Note that we use an intermediate + * hash table to make memory management easier, and because that makes + * exact matching far easier too. + * + * Suggestion for future enhancement: compute the unique prefixes and + * place them in the hash too, which should make for even faster + * matching. + */ + + hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); + for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { + char *nsCmdName = /* Name of command in namespace. */ + Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); + + for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) { + if (Tcl_StringMatch(nsCmdName, + ensemblePtr->nsPtr->exportArrayPtr[i])) { + hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); + + /* + * Remember, hash entries have a full reference to the + * substituted part of the command (as a list) as their + * content! + */ + + if (isNew) { + Tcl_Obj *cmdObj, *cmdPrefixObj; + + cmdObj = Tcl_NewStringObj(nsCmdName, -1); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + break; + } + } + } + } + + if (hash->numEntries == 0) { + ensemblePtr->subcommandArrayPtr = NULL; + return; + } + + /* + * Create a sorted array of all subcommands in the ensemble; hash tables + * are all very well for a quick look for an exact match, but they can't + * determine things like whether a string is a prefix of another (not + * without lots of preparation anyway) and they're no good for when we're + * generating the error message either. + * + * We do this by filling an array with the names (we use the hash keys + * directly to save a copy, since any time we change the array we change + * the hash too, and vice versa) and running quicksort over the array. + */ + + ensemblePtr->subcommandArrayPtr = + ckalloc(sizeof(char *) * hash->numEntries); + + /* + * Fill array from both ends as this makes us less likely to end up with + * performance problems in qsort(), which is good. Note that doing this + * makes this code much more opaque, but the naive alternatve: + * + * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; + * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { + * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr); + * } + * + * can produce long runs of precisely ordered table entries when the + * commands in the namespace are declared in a sorted fashion (an ordering + * some people like) and the hashing functions (or the command names + * themselves) are fairly unfortunate. By filling from both ends, it + * requires active malice (and probably a debugger) to get qsort() to have + * awful runtime behaviour. + */ + + i = 0; + j = hash->numEntries; + hPtr = Tcl_FirstHashEntry(hash, &search); + while (hPtr != NULL) { + ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr); + hPtr = Tcl_NextHashEntry(&search); + if (hPtr == NULL) { + break; + } + ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr); + hPtr = Tcl_NextHashEntry(&search); + } + if (hash->numEntries > 1) { + qsort(ensemblePtr->subcommandArrayPtr, (unsigned) hash->numEntries, + sizeof(char *), NsEnsembleStringOrder); + } +} + +/* + *---------------------------------------------------------------------- + * + * NsEnsembleStringOrder -- + * + * Helper function to compare two pointers to two strings for use with + * qsort(). + * + * Results: + * -1 if the first string is smaller, 1 if the second string is smaller, + * and 0 if they are equal. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +NsEnsembleStringOrder( + const void *strPtr1, + const void *strPtr2) +{ + return strcmp(*(const char **)strPtr1, *(const char **)strPtr2); +} + +/* + *---------------------------------------------------------------------- + * + * FreeEnsembleCmdRep -- + * + * Destroys the internal representation of a Tcl_Obj that has been + * holding information about a command in an ensemble. + * + * Results: + * None. + * + * Side effects: + * Memory is deallocated. If this held the last reference to a + * namespace's main structure, that main structure will also be + * destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +FreeEnsembleCmdRep( + Tcl_Obj *objPtr) +{ + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + + TclCleanupCommandMacro(ensembleCmd->token); + if (ensembleCmd->fix) { + Tcl_DecrRefCount(ensembleCmd->fix); + } + ckfree(ensembleCmd); + objPtr->typePtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DupEnsembleCmdRep -- + * + * Makes one Tcl_Obj into a copy of another that is a subcommand of an + * ensemble. + * + * Results: + * None. + * + * Side effects: + * Memory is allocated, and the namespace that the ensemble is built on + * top of gains another reference. + * + *---------------------------------------------------------------------- + */ + +static void +DupEnsembleCmdRep( + Tcl_Obj *objPtr, + Tcl_Obj *copyPtr) +{ + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); + + copyPtr->typePtr = &ensembleCmdType; + copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; + ensembleCopy->epoch = ensembleCmd->epoch; + ensembleCopy->token = ensembleCmd->token; + ensembleCopy->token->refCount++; + ensembleCopy->fix = ensembleCmd->fix; + if (ensembleCopy->fix) { + Tcl_IncrRefCount(ensembleCopy->fix); + } + ensembleCopy->hPtr = ensembleCmd->hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileEnsemble -- + * + * Procedure called to compile an ensemble command. Note that most + * ensembles are not compiled, since modifying a compiled ensemble causes + * a invalidation of all existing bytecode (expensive!) which is not + * normally warranted. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the subcommands of the + * ensemble at runtime if a compile-time mapping is possible. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileEnsemble( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; + Tcl_Obj *replaced = Tcl_NewObj(), *replacement; + Tcl_Command ensemble = (Tcl_Command) cmdPtr; + Command *oldCmdPtr = cmdPtr, *newCmdPtr; + int len, result, flags = 0, i, depth = 1, invokeAnyway = 0; + int ourResult = TCL_ERROR; + unsigned numBytes; + const char *word; + DefineLineInformation; + + Tcl_IncrRefCount(replaced); + if (parsePtr->numWords < depth + 1) { + goto failed; + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Too hard. + */ + + goto failed; + } + + /* + * This is where we return to if we are parsing multiple nested compiled + * ensembles. [info object] is such a beast. + */ + + checkNextWord: + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + + /* + * There's a sporting chance we'll be able to compile this. But now we + * must check properly. To do that, check that we're compiling an ensemble + * that has a compilable command as its appropriate subcommand. + */ + + if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK + || mapObj == NULL) { + /* + * Either not an ensemble or a mapping isn't installed. Crud. Too hard + * to proceed. + */ + + goto failed; + } + + /* + * 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. + */ + + goto failed; + } + + /* + * Next, get the flags. We need them on several code paths so that we can + * know whether we're to do prefix matching. + */ + + (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags); + + /* + * Check to see if there's also a subcommand list; must check to see if + * the subcommand we are calling is in that list if it exists, since that + * list filters the entries in the map. + */ + + (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj); + if (listObj != NULL) { + int sclen; + const char *str; + Tcl_Obj *matchObj = NULL; + + if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { + goto failed; + } + for (i=0 ; i<len ; i++) { + str = Tcl_GetStringFromObj(elems[i], &sclen); + if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) { + /* + * Exact match! Excellent! + */ + + result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj); + if (result != TCL_OK || targetCmdObj == NULL) { + goto failed; + } + replacement = elems[i]; + goto doneMapLookup; + } + + /* + * Check to see if we've got a prefix match. A single prefix match + * is fine, and allows us to refine our dictionary lookup, but + * multiple prefix matches is a Bad Thing and will prevent us from + * making progress. Note that we cannot do the lookup immediately + * in the prefix case; might be another entry later in the list + * that causes things to fail. + */ + + if ((flags & TCL_ENSEMBLE_PREFIX) + && strncmp(word, str, numBytes) == 0) { + if (matchObj != NULL) { + goto failed; + } + matchObj = elems[i]; + } + } + if (matchObj == NULL) { + goto failed; + } + result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj); + if (result != TCL_OK || targetCmdObj == NULL) { + goto failed; + } + replacement = matchObj; + } else { + Tcl_DictSearch s; + int done, matched; + Tcl_Obj *tmpObj; + + /* + * No map, so check the dictionary directly. + */ + + TclNewStringObj(subcmdObj, word, (int) numBytes); + result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj); + if (result == TCL_OK && targetCmdObj != NULL) { + /* + * Got it. Skip the fiddling around with prefixes. + */ + + replacement = subcmdObj; + goto doneMapLookup; + } + TclDecrRefCount(subcmdObj); + + /* + * We've not literally got a valid subcommand. But maybe we have a + * prefix. Check if prefix matches are allowed. + */ + + if (!(flags & TCL_ENSEMBLE_PREFIX)) { + goto failed; + } + + /* + * Iterate over the keys in the dictionary, checking to see if we're a + * prefix. + */ + + Tcl_DictObjFirst(NULL, mapObj, &s, &subcmdObj, &tmpObj, &done); + matched = 0; + replacement = NULL; /* Silence, fool compiler! */ + while (!done) { + if (strncmp(TclGetString(subcmdObj), word, numBytes) == 0) { + if (matched++) { + /* + * Must have matched twice! Not unique, so no point + * looking further. + */ + + break; + } + replacement = subcmdObj; + targetCmdObj = tmpObj; + } + Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done); + } + Tcl_DictObjDone(&s); + + /* + * If we have anything other than a single match, we've failed the + * unique prefix check. + */ + + if (matched != 1) { + invokeAnyway = 1; + goto failed; + } + } + + /* + * OK, we definitely map to something. But what? + * + * The command we map to is the first word out of the map element. Note + * that we also reject dealing with multi-element rewrites if we are in a + * safe interpreter, as there is otherwise a (highly gnarly!) way to make + * Tcl crash open to exploit. + */ + + doneMapLookup: + Tcl_ListObjAppendElement(NULL, replaced, replacement); + if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) { + goto failed; + } else if (len != 1) { + /* + * Note that at this point we know we can't issue any special + * instruction sequence as the mapping isn't one that we support at + * the compiled level. + */ + + goto cleanup; + } + targetCmdObj = elems[0]; + + oldCmdPtr = cmdPtr; + Tcl_IncrRefCount(targetCmdObj); + newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); + TclDecrRefCount(targetCmdObj); + if (newCmdPtr == NULL || Tcl_IsSafe(interp) + || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION + || newCmdPtr->flags & CMD_HAS_EXEC_TRACES + || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { + /* + * Maps to an undefined command or a command without a compiler. + * Cannot compile. + */ + + goto cleanup; + } + cmdPtr = newCmdPtr; + depth++; + + /* + * See whether we have a nested ensemble. If we do, we can go round the + * mulberry bush again, consuming the next word. + */ + + if (cmdPtr->compileProc == TclCompileEnsemble) { + tokenPtr = TokenAfter(tokenPtr); + if (parsePtr->numWords < depth + 1 + || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Too hard because the user has done something unpleasant like + * omitting the sub-ensemble's command name or used a non-constant + * name for a sub-ensemble's command name; we respond by bailing + * out completely (this is a rare case). [Bug 6d2f249a01] + */ + + goto cleanup; + } + ensemble = (Tcl_Command) cmdPtr; + goto checkNextWord; + } + + /* + * Now we've done the mapping process, can now actually try to compile. + * If there is a subcommand compiler and that successfully produces code, + * we'll use that. Otherwise, we fall back to generating opcodes to do the + * invoke at runtime. + */ + + invokeAnyway = 1; + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr, + envPtr)) { + ourResult = TCL_OK; + goto cleanup; + } + + /* + * Throw out any line information generated by the failed compile attempt. + */ + + while (mapPtr->nuloc - 1 > eclIndex) { + mapPtr->nuloc--; + ckfree(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; + } + + /* + * Reset the index of next command. Toss out any from failed nested + * partial compiles. + */ + + envPtr->numCommands = mapPtr->nuloc; + + /* + * Failed to do a full compile for some reason. Try to do a direct invoke + * instead of going through the ensemble lookup process again. + */ + + failed: + if (depth < 250) { + if (depth > 1) { + if (!invokeAnyway) { + cmdPtr = oldCmdPtr; + depth--; + } + } + /* + * The length of the "replaced" list must be depth-1. Trim back + * any extra elements that might have been appended by failing + * pathways above. + */ + (void) Tcl_ListObjReplace(NULL, replaced, depth-1, LIST_MAX, 0, NULL); + + /* + * TODO: Reconsider whether we ought to call CompileToInvokedCommand() + * when depth==1. In that case we are choosing to emit the + * INST_INVOKE_REPLACE bytecode when there is in fact no replacing + * to be done. It would be equally functional and presumably more + * performant to fall through to cleanup below, return TCL_ERROR, + * and let the compiler harness emit the INST_INVOKE_STK + * implementation for us. + */ + + CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr); + ourResult = TCL_OK; + } + + /* + * Release the memory we allocated. If we've got here, we've either done + * something useful or we're in a case that we can't compile at all and + * we're just giving up. + */ + + cleanup: + Tcl_DecrRefCount(replaced); + return ourResult; +} + +int +TclAttemptCompileProc( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + int depth, + Command *cmdPtr, + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + int result, i; + Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; + int savedStackDepth = envPtr->currStackDepth; + unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; + int savedAuxDataArrayNext = envPtr->auxDataArrayNext; + int savedExceptArrayNext = envPtr->exceptArrayNext; +#ifdef TCL_COMPILE_DEBUG + int savedExceptDepth = envPtr->exceptDepth; +#endif + DefineLineInformation; + + if (cmdPtr->compileProc == NULL) { + return TCL_ERROR; + } + + /* + * Advance parsePtr->tokenPtr so that it points at the last subcommand. + * This will be wrong, but it will not matter, and it will put the + * tokens for the arguments in the right place without the needed to + * allocate a synthetic Tcl_Parse struct, or copy tokens around. + */ + + for (i = 0; i < depth - 1; i++) { + parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr); + } + parsePtr->numWords -= (depth - 1); + + /* + * Shift the line information arrays to account for different word + * index values. + */ + + mapPtr->loc[eclIndex].line += (depth - 1); + mapPtr->loc[eclIndex].next += (depth - 1); + + /* + * Hand off compilation to the subcommand compiler. At last! + */ + + result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr); + + /* + * Undo the shift. + */ + + mapPtr->loc[eclIndex].line -= (depth - 1); + mapPtr->loc[eclIndex].next -= (depth - 1); + + parsePtr->numWords += (depth - 1); + parsePtr->tokenPtr = saveTokenPtr; + + /* + * If our target failed to compile, revert any data from failed partial + * compiles. Note that envPtr->numCommands need not be checked because + * we avoid compiling subcommands that recursively call TclCompileScript(). + */ + +#ifdef TCL_COMPILE_DEBUG + if (envPtr->exceptDepth != savedExceptDepth) { + Tcl_Panic("ExceptionRange Starts and Ends do not balance"); + } +#endif + + if (result != TCL_OK) { + ExceptionAux *auxPtr = envPtr->exceptAuxArrayPtr; + + for (i = 0; i < savedExceptArrayNext; i++) { + while (auxPtr->numBreakTargets > 0 + && auxPtr->breakTargets[auxPtr->numBreakTargets - 1] + >= savedCodeNext) { + auxPtr->numBreakTargets--; + } + while (auxPtr->numContinueTargets > 0 + && auxPtr->continueTargets[auxPtr->numContinueTargets - 1] + >= savedCodeNext) { + auxPtr->numContinueTargets--; + } + auxPtr++; + } + envPtr->exceptArrayNext = savedExceptArrayNext; + + if (savedAuxDataArrayNext != envPtr->auxDataArrayNext) { + AuxData *auxDataPtr = envPtr->auxDataArrayPtr; + AuxData *auxDataEnd = auxDataPtr; + + auxDataPtr += savedAuxDataArrayNext; + auxDataEnd += envPtr->auxDataArrayNext; + + while (auxDataPtr < auxDataEnd) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + envPtr->auxDataArrayNext = savedAuxDataArrayNext; + } + envPtr->currStackDepth = savedStackDepth; + envPtr->codeNext = envPtr->codeStart + savedCodeNext; +#ifdef TCL_COMPILE_DEBUG + } else { + /* + * Confirm that the command compiler generated a single value on + * the stack as its result. This is only done in debugging mode, + * as it *should* be correct and normal users have no reasonable + * way to fix it anyway. + */ + + int diff = envPtr->currStackDepth - savedStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif + } + + return result; +} + +/* + * How to compile a subcommand to a _replacing_ invoke of its implementation + * command. + */ + +static void +CompileToInvokedCommand( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Tcl_Obj *replacements, + Command *cmdPtr, + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokPtr; + Tcl_Obj *objPtr, **words; + char *bytes; + int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; + DefineLineInformation; + + /* + * Push the words of the command. Take care; the command words may be + * scripts that have backslashes in them, and [info frame 0] can see the + * difference. Hence the call to TclContinuationsEnterDerived... + */ + + Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); + for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; + i++, tokPtr = TokenAfter(tokPtr)) { + if (i > 0 && i < numWords+1) { + bytes = Tcl_GetStringFromObj(words[i-1], &length); + PushLiteral(envPtr, bytes, length); + continue; + } + + SetLineInformation(i); + if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { + int literal = TclRegisterNewLiteral(envPtr, + tokPtr[1].start, tokPtr[1].size); + + if (envPtr->clNext) { + TclContinuationsEnterDerived( + TclFetchLiteral(envPtr, literal), + tokPtr[1].start - envPtr->source, + envPtr->clNext); + } + TclEmitPush(literal, envPtr); + } else { + CompileTokens(envPtr, tokPtr, interp); + } + } + + /* + * Push the name of the command we're actually dispatching to as part of + * the implementation. + */ + + objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); + bytes = Tcl_GetStringFromObj(objPtr, &length); + if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { + extraLiteralFlags |= LITERAL_UNSHARED; + } + cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags); + TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); + TclEmitPush(cmdLit, envPtr); + TclDecrRefCount(objPtr); + + /* + * Do the replacing dispatch. + */ + + TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1); +} + +/* + * Helpers that do issuing of instructions for commands that "don't have + * compilers" (well, they do; these). They all work by just generating base + * code to invoke the command; they're intended for ensemble subcommands so + * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out + * that they're not needed. + * + * Note that these are NOT suitable for commands where there's an argument + * that is a script, as an [info level] or [info frame] in the inner context + * can see the difference. + */ + +static int +CompileBasicNArgCommand( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Obj *objPtr = Tcl_NewObj(); + + Tcl_IncrRefCount(objPtr); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); + TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, + parsePtr->numWords, envPtr); + Tcl_DecrRefCount(objPtr); + return TCL_OK; +} + +int +TclCompileBasic0ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic1ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic2ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic3ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic0Or1ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 1 && parsePtr->numWords != 2) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic1Or2ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic2Or3ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic0To2ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 1 || parsePtr->numWords > 3) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic1To3ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasicMin0ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 1) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasicMin1ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasicMin2ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclInt.h b/generic/tclInt.h new file mode 100644 index 0000000..567a28c --- /dev/null +++ b/generic/tclInt.h @@ -0,0 +1,4905 @@ +/* + * tclInt.h -- + * + * Declarations of things used internally by the Tcl interpreter. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1993-1997 Lucent Technologies. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> + * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. + * Copyright (c) 2008 by Miguel Sofer. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef _TCLINT +#define _TCLINT + +/* + * Some numerics configuration options. + */ + +#undef ACCEPT_NAN + +/* + * Common include files needed by most of the Tcl source files are included + * here, so that system-dependent personalizations for the include files only + * have to be made in once place. This results in a few extra includes, but + * greater modularity. The order of the three groups of #includes is + * important. For example, stdio.h is needed by tcl.h. + */ + +#include "tclPort.h" + +#include <stdio.h> + +#include <ctype.h> +#ifdef NO_STDLIB_H +# include "../compat/stdlib.h" +#else +# include <stdlib.h> +#endif +#ifdef NO_STRING_H +#include "../compat/string.h" +#else +#include <string.h> +#endif +#if defined(STDC_HEADERS) || defined(__STDC__) || defined(__C99__FUNC__) \ + || defined(__cplusplus) || defined(_MSC_VER) +#include <stddef.h> +#else +typedef int ptrdiff_t; +#endif + +/* + * Ensure WORDS_BIGENDIAN is defined correctly: + * Needs to happen here in addition to configure to work with fat compiles on + * Darwin (where configure runs only once for multiple architectures). + */ + +#ifdef HAVE_SYS_TYPES_H +# include <sys/types.h> +#endif +#ifdef HAVE_SYS_PARAM_H +# include <sys/param.h> +#endif +#ifdef BYTE_ORDER +# ifdef BIG_ENDIAN +# if BYTE_ORDER == BIG_ENDIAN +# undef WORDS_BIGENDIAN +# define WORDS_BIGENDIAN 1 +# endif +# endif +# ifdef LITTLE_ENDIAN +# if BYTE_ORDER == LITTLE_ENDIAN +# undef WORDS_BIGENDIAN +# endif +# endif +#endif + +/* + * Used to tag functions that are only to be visible within the module being + * built and not outside it (where this is supported by the linker). + */ + +#ifndef MODULE_SCOPE +# ifdef __cplusplus +# define MODULE_SCOPE extern "C" +# else +# define MODULE_SCOPE extern +# endif +#endif + +/* + * Macros used to cast between pointers and integers (e.g. when storing an int + * in ClientData), on 64-bit architectures they avoid gcc warning about "cast + * to/from pointer from/to integer of different size". + */ + +#if !defined(INT2PTR) && !defined(PTR2INT) +# if defined(HAVE_INTPTR_T) || defined(intptr_t) +# define INT2PTR(p) ((void *)(intptr_t)(p)) +# define PTR2INT(p) ((int)(intptr_t)(p)) +# else +# define INT2PTR(p) ((void *)(p)) +# define PTR2INT(p) ((int)(p)) +# endif +#endif +#if !defined(UINT2PTR) && !defined(PTR2UINT) +# if defined(HAVE_UINTPTR_T) || defined(uintptr_t) +# define UINT2PTR(p) ((void *)(uintptr_t)(p)) +# define PTR2UINT(p) ((unsigned int)(uintptr_t)(p)) +# else +# define UINT2PTR(p) ((void *)(p)) +# define PTR2UINT(p) ((unsigned int)(p)) +# endif +#endif + +#if defined(_WIN32) && defined(_MSC_VER) +# define vsnprintf _vsnprintf +#endif + +/* + * The following procedures allow namespaces to be customized to support + * special name resolution rules for commands/variables. + */ + +struct Tcl_ResolvedVarInfo; + +typedef Tcl_Var (Tcl_ResolveRuntimeVarProc)(Tcl_Interp *interp, + struct Tcl_ResolvedVarInfo *vinfoPtr); + +typedef void (Tcl_ResolveVarDeleteProc)(struct Tcl_ResolvedVarInfo *vinfoPtr); + +/* + * The following structure encapsulates the routines needed to resolve a + * variable reference at runtime. Any variable specific state will typically + * be appended to this structure. + */ + +typedef struct Tcl_ResolvedVarInfo { + Tcl_ResolveRuntimeVarProc *fetchProc; + Tcl_ResolveVarDeleteProc *deleteProc; +} Tcl_ResolvedVarInfo; + +typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, + CONST84 char *name, int length, Tcl_Namespace *context, + Tcl_ResolvedVarInfo **rPtr); + +typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name, + Tcl_Namespace *context, int flags, Tcl_Var *rPtr); + +typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, CONST84 char *name, + Tcl_Namespace *context, int flags, Tcl_Command *rPtr); + +typedef struct Tcl_ResolverInfo { + Tcl_ResolveCmdProc *cmdResProc; + /* Procedure handling command name + * resolution. */ + Tcl_ResolveVarProc *varResProc; + /* Procedure handling variable name resolution + * for variables that can only be handled at + * runtime. */ + Tcl_ResolveCompiledVarProc *compiledVarResProc; + /* Procedure handling variable name resolution + * at compile time. */ +} Tcl_ResolverInfo; + +/* + * This flag bit should not interfere with TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable + * lookup is performed for upvar (or similar) purposes, with slightly + * different rules: + * - Bug #696893 - variable is either proc-local or in the current + * namespace; never follow the second (global) resolution path + * - Bug #631741 - do not use special namespace or interp resolvers + * + * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag + * (Bug #835020) + */ + +#define TCL_AVOID_RESOLVERS 0x40000 + +/* + *---------------------------------------------------------------- + * Data structures related to namespaces. + *---------------------------------------------------------------- + */ + +typedef struct Tcl_Ensemble Tcl_Ensemble; +typedef struct NamespacePathEntry NamespacePathEntry; + +/* + * Special hashtable for variables: this is just a Tcl_HashTable with an nsPtr + * field added at the end: in this way variables can find their namespace + * without having to copy a pointer in their struct: they can access it via + * their hPtr->tablePtr. + */ + +typedef struct TclVarHashTable { + Tcl_HashTable table; + struct Namespace *nsPtr; +} TclVarHashTable; + +/* + * This is for itcl - it likes to search our varTables directly :( + */ + +#define TclVarHashFindVar(tablePtr, key) \ + TclVarHashCreateVar((tablePtr), (key), NULL) + +/* + * Define this to reduce the amount of space that the average namespace + * consumes by only allocating the table of child namespaces when necessary. + * Defining it breaks compatibility for Tcl extensions (e.g., itcl) which + * reach directly into the Namespace structure. + */ + +#undef BREAK_NAMESPACE_COMPAT + +/* + * The structure below defines a namespace. + * Note: the first five fields must match exactly the fields in a + * Tcl_Namespace structure (see tcl.h). If you change one, be sure to change + * the other. + */ + +typedef struct Namespace { + char *name; /* The namespace's simple (unqualified) name. + * This contains no ::'s. The name of the + * global namespace is "" although "::" is an + * synonym. */ + char *fullName; /* The namespace's fully qualified name. This + * starts with ::. */ + ClientData clientData; /* An arbitrary value associated with this + * namespace. */ + Tcl_NamespaceDeleteProc *deleteProc; + /* Procedure invoked when deleting the + * namespace to, e.g., free clientData. */ + struct Namespace *parentPtr;/* Points to the namespace that contains this + * one. NULL if this is the global + * namespace. */ +#ifndef BREAK_NAMESPACE_COMPAT + Tcl_HashTable childTable; /* Contains any child namespaces. Indexed by + * strings; values have type (Namespace *). */ +#else + Tcl_HashTable *childTablePtr; + /* Contains any child namespaces. Indexed by + * strings; values have type (Namespace *). If + * NULL, there are no children. */ +#endif + long nsId; /* Unique id for the namespace. */ + Tcl_Interp *interp; /* The interpreter containing this + * namespace. */ + int flags; /* OR-ed combination of the namespace status + * flags NS_DYING and NS_DEAD listed below. */ + int activationCount; /* Number of "activations" or active call + * frames for this namespace that are on the + * Tcl call stack. The namespace won't be + * freed until activationCount becomes zero. */ + int refCount; /* Count of references by namespaceName + * objects. The namespace can't be freed until + * refCount becomes zero. */ + Tcl_HashTable cmdTable; /* Contains all the commands currently + * registered in the namespace. Indexed by + * strings; values have type (Command *). + * Commands imported by Tcl_Import have + * Command structures that point (via an + * ImportedCmdRef structure) to the Command + * structure in the source namespace's command + * table. */ + TclVarHashTable varTable; /* Contains all the (global) variables + * currently in this namespace. Indexed by + * strings; values have type (Var *). */ + char **exportArrayPtr; /* Points to an array of string patterns + * specifying which commands are exported. A + * pattern may include "string match" style + * wildcard characters to specify multiple + * commands; however, no namespace qualifiers + * are allowed. NULL if no export patterns are + * registered. */ + int numExportPatterns; /* Number of export patterns currently + * registered using "namespace export". */ + int maxExportPatterns; /* Mumber of export patterns for which space + * is currently allocated. */ + int cmdRefEpoch; /* Incremented if a newly added command + * shadows a command for which this namespace + * has already cached a Command* pointer; this + * causes all its cached Command* pointers to + * be invalidated. */ + int resolverEpoch; /* Incremented whenever (a) the name + * resolution rules change for this namespace + * or (b) a newly added command shadows a + * command that is compiled to bytecodes. This + * invalidates all byte codes compiled in the + * namespace, causing the code to be + * recompiled under the new rules.*/ + Tcl_ResolveCmdProc *cmdResProc; + /* If non-null, this procedure overrides the + * usual command resolution mechanism in Tcl. + * This procedure is invoked within + * Tcl_FindCommand to resolve all command + * references within the namespace. */ + Tcl_ResolveVarProc *varResProc; + /* If non-null, this procedure overrides the + * usual variable resolution mechanism in Tcl. + * This procedure is invoked within + * Tcl_FindNamespaceVar to resolve all + * variable references within the namespace at + * runtime. */ + Tcl_ResolveCompiledVarProc *compiledVarResProc; + /* If non-null, this procedure overrides the + * usual variable resolution mechanism in Tcl. + * This procedure is invoked within + * LookupCompiledLocal to resolve variable + * references within the namespace at compile + * time. */ + int exportLookupEpoch; /* Incremented whenever a command is added to + * a namespace, removed from a namespace or + * the exports of a namespace are changed. + * Allows TIP#112-driven command lists to be + * validated efficiently. */ + Tcl_Ensemble *ensembles; /* List of structures that contain the details + * of the ensembles that are implemented on + * top of this namespace. */ + Tcl_Obj *unknownHandlerPtr; /* A script fragment to be used when command + * resolution in this namespace fails. TIP + * 181. */ + int commandPathLength; /* The length of the explicit path. */ + NamespacePathEntry *commandPathArray; + /* The explicit path of the namespace as an + * array. */ + NamespacePathEntry *commandPathSourceList; + /* Linked list of path entries that point to + * this namespace. */ + Tcl_NamespaceDeleteProc *earlyDeleteProc; + /* Just like the deleteProc field (and called + * with the same clientData) but called at the + * start of the deletion process, so there is + * a chance for code to do stuff inside the + * namespace before deletion completes. */ +} Namespace; + +/* + * An entry on a namespace's command resolution path. + */ + +struct NamespacePathEntry { + Namespace *nsPtr; /* What does this path entry point to? If it + * is NULL, this path entry points is + * redundant and should be skipped. */ + Namespace *creatorNsPtr; /* Where does this path entry point from? This + * allows for efficient invalidation of + * references when the path entry's target + * updates its current list of defined + * commands. */ + NamespacePathEntry *prevPtr, *nextPtr; + /* Linked list pointers or NULL at either end + * of the list that hangs off Namespace's + * commandPathSourceList field. */ +}; + +/* + * Flags used to represent the status of a namespace: + * + * NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the + * namespace but there are still active call frames on the Tcl + * stack that refer to the namespace. When the last call frame + * referring to it has been popped, it's variables and command + * will be destroyed and it will be marked "dead" (NS_DEAD). The + * namespace can no longer be looked up by name. + * NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the + * namespace and no call frames still refer to it. Its variables + * and command have already been destroyed. This bit allows the + * namespace resolution code to recognize that the namespace is + * "deleted". When the last namespaceName object in any byte code + * unit that refers to the namespace has been freed (i.e., when + * the namespace's refCount is 0), the namespace's storage will + * be freed. + * NS_KILLED - 1 means that TclTeardownNamespace has already been called on + * this namespace and it should not be called again [Bug 1355942] + * NS_SUPPRESS_COMPILATION - + * Marks the commands in this namespace for not being compiled, + * forcing them to be looked up every time. + */ + +#define NS_DYING 0x01 +#define NS_DEAD 0x02 +#define NS_KILLED 0x04 +#define NS_SUPPRESS_COMPILATION 0x08 + +/* + * Flags passed to TclGetNamespaceForQualName: + * + * TCL_GLOBAL_ONLY - (see tcl.h) Look only in the global ns. + * TCL_NAMESPACE_ONLY - (see tcl.h) Look only in the context ns. + * TCL_CREATE_NS_IF_UNKNOWN - Create unknown namespaces. + * TCL_FIND_ONLY_NS - The name sought is a namespace name. + */ + +#define TCL_CREATE_NS_IF_UNKNOWN 0x800 +#define TCL_FIND_ONLY_NS 0x1000 + +/* + * The client data for an ensemble command. This consists of the table of + * commands that are actually exported by the namespace, and an epoch counter + * that, combined with the exportLookupEpoch field of the namespace structure, + * defines whether the table contains valid data or will need to be recomputed + * next time the ensemble command is called. + */ + +typedef struct EnsembleConfig { + Namespace *nsPtr; /* The namespace backing this ensemble up. */ + Tcl_Command token; /* The token for the command that provides + * ensemble support for the namespace, or NULL + * if the command has been deleted (or never + * existed; the global namespace never has an + * ensemble command.) */ + int epoch; /* The epoch at which this ensemble's table of + * exported commands is valid. */ + char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all + * consistent points, this will have the same + * number of entries as there are entries in + * the subcommandTable hash. */ + Tcl_HashTable subcommandTable; + /* Hash table of ensemble subcommand names, + * which are its keys so this also provides + * the storage management for those subcommand + * names. The contents of the entry values are + * object version the prefix lists to use when + * substituting for the command/subcommand to + * build the ensemble implementation command. + * Has to be stored here as well as in + * subcommandDict because that field is NULL + * when we are deriving the ensemble from the + * namespace exports list. FUTURE WORK: use + * object hash table here. */ + struct EnsembleConfig *next;/* The next ensemble in the linked list of + * ensembles associated with a namespace. If + * this field points to this ensemble, the + * structure has already been unlinked from + * all lists, and cannot be found by scanning + * the list from the namespace's ensemble + * field. */ + int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX, + * ENSEMBLE_DEAD and ENSEMBLE_COMPILE. */ + + /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */ + + Tcl_Obj *subcommandDict; /* Dictionary providing mapping from + * subcommands to their implementing command + * prefixes, or NULL if we are to build the + * map automatically from the namespace + * exports. */ + Tcl_Obj *subcmdList; /* List of commands that this ensemble + * actually provides, and whose implementation + * will be built using the subcommandDict (if + * present and defined) and by simple mapping + * to the namespace otherwise. If NULL, + * indicates that we are using the (dynamic) + * list of currently exported commands. */ + Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when + * no match is found (according to the rule + * defined by flag bit TCL_ENSEMBLE_PREFIX) or + * NULL to use the default error-generating + * behaviour. The script execution gets all + * the arguments to the ensemble command + * (including objv[0]) and will have the + * results passed directly back to the caller + * (including the error code) unless the code + * is TCL_CONTINUE in which case the + * 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; + +/* + * Various bits for the EnsembleConfig.flags field. + */ + +#define ENSEMBLE_DEAD 0x1 /* Flag value to say that the ensemble is dead + * and on its way out. */ +#define ENSEMBLE_COMPILE 0x4 /* Flag to enable bytecode compilation of an + * ensemble. */ + +/* + *---------------------------------------------------------------- + * Data structures related to variables. These are used primarily in tclVar.c + *---------------------------------------------------------------- + */ + +/* + * The following structure defines a variable trace, which is used to invoke a + * specific C procedure whenever certain operations are performed on a + * variable. + */ + +typedef struct VarTrace { + Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by + * flags are performed on variable. */ + ClientData clientData; /* Argument to pass to proc. */ + int flags; /* What events the trace procedure is + * interested in: OR-ed combination of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */ + struct VarTrace *nextPtr; /* Next in list of traces associated with a + * particular variable. */ +} VarTrace; + +/* + * The following structure defines a command trace, which is used to invoke a + * specific C procedure whenever certain operations are performed on a + * command. + */ + +typedef struct CommandTrace { + Tcl_CommandTraceProc *traceProc; + /* Procedure to call when operations given by + * flags are performed on command. */ + ClientData clientData; /* Argument to pass to proc. */ + int flags; /* What events the trace procedure is + * interested in: OR-ed combination of + * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ + struct CommandTrace *nextPtr; + /* Next in list of traces associated with a + * particular command. */ + int refCount; /* Used to ensure this structure is not + * deleted too early. Keeps track of how many + * pieces of code have a pointer to this + * structure. */ +} CommandTrace; + +/* + * When a command trace is active (i.e. its associated procedure is executing) + * one of the following structures is linked into a list associated with the + * command's interpreter. The information in the structure is needed in order + * for Tcl to behave reasonably if traces are deleted while traces are active. + */ + +typedef struct ActiveCommandTrace { + struct Command *cmdPtr; /* Command that's being traced. */ + struct ActiveCommandTrace *nextPtr; + /* Next in list of all active command traces + * for the interpreter, or NULL if no more. */ + CommandTrace *nextTracePtr; /* Next trace to check after current trace + * procedure returns; if this trace gets + * deleted, must update pointer to avoid using + * free'd memory. */ + int reverseScan; /* Boolean set true when traces are scanning + * in reverse order. */ +} ActiveCommandTrace; + +/* + * When a variable trace is active (i.e. its associated procedure is + * executing) one of the following structures is linked into a list associated + * with the variable's interpreter. The information in the structure is needed + * in order for Tcl to behave reasonably if traces are deleted while traces + * are active. + */ + +typedef struct ActiveVarTrace { + struct Var *varPtr; /* Variable that's being traced. */ + struct ActiveVarTrace *nextPtr; + /* Next in list of all active variable traces + * for the interpreter, or NULL if no more. */ + VarTrace *nextTracePtr; /* Next trace to check after current trace + * procedure returns; if this trace gets + * deleted, must update pointer to avoid using + * free'd memory. */ +} ActiveVarTrace; + +/* + * The structure below defines a variable, which associates a string name with + * a Tcl_Obj value. These structures are kept in procedure call frames (for + * local variables recognized by the compiler) or in the heap (for global + * variables and any variable not known to the compiler). For each Var + * structure in the heap, a hash table entry holds the variable name and a + * pointer to the Var structure. + */ + +typedef struct Var { + int flags; /* Miscellaneous bits of information about + * variable. See below for definitions. */ + union { + Tcl_Obj *objPtr; /* The variable's object value. Used for + * scalar variables and array elements. */ + TclVarHashTable *tablePtr;/* For array variables, this points to + * information about the hash table used to + * implement the associative array. Points to + * ckalloc-ed data. */ + struct Var *linkPtr; /* If this is a global variable being referred + * to in a procedure, or a variable created by + * "upvar", this field points to the + * referenced variable's Var struct. */ + } value; +} Var; + +typedef struct VarInHash { + Var var; + int refCount; /* Counts number of active uses of this + * variable: 1 for the entry in the hash + * table, 1 for each additional variable whose + * linkPtr points here, 1 for each nested + * trace active on variable, and 1 if the + * variable is a namespace variable. This + * record can't be deleted until refCount + * becomes 0. */ + Tcl_HashEntry entry; /* The hash table entry that refers to this + * variable. This is used to find the name of + * the variable and to delete it from its + * hashtable if it is no longer needed. It + * also holds the variable's name. */ +} VarInHash; + +/* + * Flag bits for variables. The first two (VAR_ARRAY and VAR_LINK) are + * mutually exclusive and give the "type" of the variable. If none is set, + * this is a scalar variable. + * + * VAR_ARRAY - 1 means this is an array variable rather than + * a scalar variable or link. The "tablePtr" + * field points to the array's hashtable for its + * elements. + * VAR_LINK - 1 means this Var structure contains a pointer + * to another Var structure that either has the + * real value or is itself another VAR_LINK + * pointer. Variables like this come about + * through "upvar" and "global" commands, or + * through references to variables in enclosing + * namespaces. + * + * Flags that indicate the type and status of storage; none is set for + * compiled local variables (Var structs). + * + * VAR_IN_HASHTABLE - 1 means this variable is in a hashtable and + * the Var structure is malloced. 0 if it is a + * local variable that was assigned a slot in a + * procedure frame by the compiler so the Var + * storage is part of the call frame. + * VAR_DEAD_HASH 1 means that this var's entry in the hashtable + * has already been deleted. + * VAR_ARRAY_ELEMENT - 1 means that this variable is an array + * element, so it is not legal for it to be an + * array itself (the VAR_ARRAY flag had better + * not be set). + * VAR_NAMESPACE_VAR - 1 means that this variable was declared as a + * namespace variable. This flag ensures it + * persists until its namespace is destroyed or + * until the variable is unset; it will persist + * even if it has not been initialized and is + * marked undefined. The variable's refCount is + * incremented to reflect the "reference" from + * its namespace. + * + * Flag values relating to the variable's trace and search status. + * + * VAR_TRACED_READ + * VAR_TRACED_WRITE + * VAR_TRACED_UNSET + * VAR_TRACED_ARRAY + * VAR_TRACE_ACTIVE - 1 means that trace processing is currently + * underway for a read or write access, so new + * read or write accesses should not cause trace + * procedures to be called and the variable can't + * be deleted. + * VAR_SEARCH_ACTIVE + * + * The following additional flags are used with the CompiledLocal type defined + * below: + * + * VAR_ARGUMENT - 1 means that this variable holds a procedure + * argument. + * VAR_TEMPORARY - 1 if the local variable is an anonymous + * temporary variable. Temporaries have a NULL + * name. + * VAR_RESOLVED - 1 if name resolution has been done for this + * variable. + * VAR_IS_ARGS 1 if this variable is the last argument and is + * named "args". + */ + +/* + * FLAGS RENUMBERED: everything breaks already, make things simpler. + * + * IMPORTANT: skip the values 0x10, 0x20, 0x40, 0x800 corresponding to + * TCL_TRACE_(READS/WRITES/UNSETS/ARRAY): makes code simpler in tclTrace.c + * + * Keep the flag values for VAR_ARGUMENT and VAR_TEMPORARY so that old values + * in precompiled scripts keep working. + */ + +/* Type of value (0 is scalar) */ +#define VAR_ARRAY 0x1 +#define VAR_LINK 0x2 + +/* Type of storage (0 is compiled local) */ +#define VAR_IN_HASHTABLE 0x4 +#define VAR_DEAD_HASH 0x8 +#define VAR_ARRAY_ELEMENT 0x1000 +#define VAR_NAMESPACE_VAR 0x80 /* KEEP OLD VALUE for Itcl */ + +#define VAR_ALL_HASH \ + (VAR_IN_HASHTABLE|VAR_DEAD_HASH|VAR_NAMESPACE_VAR|VAR_ARRAY_ELEMENT) + +/* Trace and search state. */ + +#define VAR_TRACED_READ 0x10 /* TCL_TRACE_READS */ +#define VAR_TRACED_WRITE 0x20 /* TCL_TRACE_WRITES */ +#define VAR_TRACED_UNSET 0x40 /* TCL_TRACE_UNSETS */ +#define VAR_TRACED_ARRAY 0x800 /* TCL_TRACE_ARRAY */ +#define VAR_TRACE_ACTIVE 0x2000 +#define VAR_SEARCH_ACTIVE 0x4000 +#define VAR_ALL_TRACES \ + (VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_ARRAY|VAR_TRACED_UNSET) + +/* Special handling on initialisation (only CompiledLocal). */ +#define VAR_ARGUMENT 0x100 /* KEEP OLD VALUE! See tclProc.c */ +#define VAR_TEMPORARY 0x200 /* KEEP OLD VALUE! See tclProc.c */ +#define VAR_IS_ARGS 0x400 +#define VAR_RESOLVED 0x8000 + +/* + * Macros to ensure that various flag bits are set properly for variables. + * The ANSI C "prototypes" for these macros are: + * + * MODULE_SCOPE void TclSetVarScalar(Var *varPtr); + * MODULE_SCOPE void TclSetVarArray(Var *varPtr); + * MODULE_SCOPE void TclSetVarLink(Var *varPtr); + * MODULE_SCOPE void TclSetVarArrayElement(Var *varPtr); + * MODULE_SCOPE void TclSetVarUndefined(Var *varPtr); + * MODULE_SCOPE void TclClearVarUndefined(Var *varPtr); + */ + +#define TclSetVarScalar(varPtr) \ + (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK) + +#define TclSetVarArray(varPtr) \ + (varPtr)->flags = ((varPtr)->flags & ~VAR_LINK) | VAR_ARRAY + +#define TclSetVarLink(varPtr) \ + (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_LINK + +#define TclSetVarArrayElement(varPtr) \ + (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT + +#define TclSetVarUndefined(varPtr) \ + (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK);\ + (varPtr)->value.objPtr = NULL + +#define TclClearVarUndefined(varPtr) + +#define TclSetVarTraceActive(varPtr) \ + (varPtr)->flags |= VAR_TRACE_ACTIVE + +#define TclClearVarTraceActive(varPtr) \ + (varPtr)->flags &= ~VAR_TRACE_ACTIVE + +#define TclSetVarNamespaceVar(varPtr) \ + if (!TclIsVarNamespaceVar(varPtr)) {\ + (varPtr)->flags |= VAR_NAMESPACE_VAR;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount++;\ + }\ + } + +#define TclClearVarNamespaceVar(varPtr) \ + if (TclIsVarNamespaceVar(varPtr)) {\ + (varPtr)->flags &= ~VAR_NAMESPACE_VAR;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount--;\ + }\ + } + +/* + * Macros to read various flag bits of variables. + * The ANSI C "prototypes" for these macros are: + * + * MODULE_SCOPE int TclIsVarScalar(Var *varPtr); + * MODULE_SCOPE int TclIsVarLink(Var *varPtr); + * MODULE_SCOPE int TclIsVarArray(Var *varPtr); + * MODULE_SCOPE int TclIsVarUndefined(Var *varPtr); + * MODULE_SCOPE int TclIsVarArrayElement(Var *varPtr); + * MODULE_SCOPE int TclIsVarTemporary(Var *varPtr); + * MODULE_SCOPE int TclIsVarArgument(Var *varPtr); + * MODULE_SCOPE int TclIsVarResolved(Var *varPtr); + */ + +#define TclIsVarScalar(varPtr) \ + !((varPtr)->flags & (VAR_ARRAY|VAR_LINK)) + +#define TclIsVarLink(varPtr) \ + ((varPtr)->flags & VAR_LINK) + +#define TclIsVarArray(varPtr) \ + ((varPtr)->flags & VAR_ARRAY) + +#define TclIsVarUndefined(varPtr) \ + ((varPtr)->value.objPtr == NULL) + +#define TclIsVarArrayElement(varPtr) \ + ((varPtr)->flags & VAR_ARRAY_ELEMENT) + +#define TclIsVarNamespaceVar(varPtr) \ + ((varPtr)->flags & VAR_NAMESPACE_VAR) + +#define TclIsVarTemporary(varPtr) \ + ((varPtr)->flags & VAR_TEMPORARY) + +#define TclIsVarArgument(varPtr) \ + ((varPtr)->flags & VAR_ARGUMENT) + +#define TclIsVarResolved(varPtr) \ + ((varPtr)->flags & VAR_RESOLVED) + +#define TclIsVarTraceActive(varPtr) \ + ((varPtr)->flags & VAR_TRACE_ACTIVE) + +#define TclIsVarTraced(varPtr) \ + ((varPtr)->flags & VAR_ALL_TRACES) + +#define TclIsVarInHash(varPtr) \ + ((varPtr)->flags & VAR_IN_HASHTABLE) + +#define TclIsVarDeadHash(varPtr) \ + ((varPtr)->flags & VAR_DEAD_HASH) + +#define TclGetVarNsPtr(varPtr) \ + (TclIsVarInHash(varPtr) \ + ? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \ + : NULL) + +#define VarHashRefCount(varPtr) \ + ((VarInHash *) (varPtr))->refCount + +/* + * Macros for direct variable access by TEBC. + */ + +#define TclIsVarDirectReadable(varPtr) \ + ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ)) \ + && (varPtr)->value.objPtr) + +#define TclIsVarDirectWritable(varPtr) \ + !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_WRITE|VAR_DEAD_HASH)) + +#define TclIsVarDirectUnsettable(varPtr) \ + !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH)) + +#define TclIsVarDirectModifyable(varPtr) \ + ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE)) \ + && (varPtr)->value.objPtr) + +#define TclIsVarDirectReadable2(varPtr, arrayPtr) \ + (TclIsVarDirectReadable(varPtr) &&\ + (!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_READ))) + +#define TclIsVarDirectWritable2(varPtr, arrayPtr) \ + (TclIsVarDirectWritable(varPtr) &&\ + (!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_WRITE))) + +#define TclIsVarDirectModifyable2(varPtr, arrayPtr) \ + (TclIsVarDirectModifyable(varPtr) &&\ + (!(arrayPtr) || !((arrayPtr)->flags & (VAR_TRACED_READ|VAR_TRACED_WRITE)))) + +/* + *---------------------------------------------------------------- + * Data structures related to procedures. These are used primarily in + * tclProc.c, tclCompile.c, and tclExecute.c. + *---------------------------------------------------------------- + */ + +/* + * Forward declaration to prevent an error when the forward reference to + * Command is encountered in the Proc and ImportRef types declared below. + */ + +struct Command; + +/* + * The variable-length structure below describes a local variable of a + * procedure that was recognized by the compiler. These variables have a name, + * an element in the array of compiler-assigned local variables in the + * procedure's call frame, and various other items of information. If the + * local variable is a formal argument, it may also have a default value. The + * compiler can't recognize local variables whose names are expressions (these + * names are only known at runtime when the expressions are evaluated) or + * local variables that are created as a result of an "upvar" or "uplevel" + * command. These other local variables are kept separately in a hash table in + * the call frame. + */ + +typedef struct CompiledLocal { + struct CompiledLocal *nextPtr; + /* Next compiler-recognized local variable for + * this procedure, or NULL if this is the last + * local. */ + int nameLength; /* The number of characters in local + * variable's name. Used to speed up variable + * lookups. */ + int frameIndex; /* Index in the array of compiler-assigned + * variables in the procedure call frame. */ + int flags; /* Flag bits for the local variable. Same as + * the flags for the Var structure above, + * although only VAR_ARGUMENT, VAR_TEMPORARY, + * and VAR_RESOLVED make sense. */ + Tcl_Obj *defValuePtr; /* Pointer to the default value of an + * argument, if any. NULL if not an argument + * or, if an argument, no default value. */ + Tcl_ResolvedVarInfo *resolveInfo; + /* Customized variable resolution info + * supplied by the Tcl_ResolveCompiledVarProc + * associated with a namespace. Each variable + * is marked by a unique ClientData tag during + * compilation, and that same tag is used to + * find the variable at runtime. */ + char name[1]; /* Name of the local variable starts here. If + * the name is NULL, this will just be '\0'. + * The actual size of this field will be large + * enough to hold the name. MUST BE THE LAST + * FIELD IN THE STRUCTURE! */ +} CompiledLocal; + +/* + * The structure below defines a command procedure, which consists of a + * collection of Tcl commands plus information about arguments and other local + * variables recognized at compile time. + */ + +typedef struct Proc { + struct Interp *iPtr; /* Interpreter for which this command is + * defined. */ + int refCount; /* Reference count: 1 if still present in + * command table plus 1 for each call to the + * procedure that is currently active. This + * structure can be freed when refCount + * becomes zero. */ + struct Command *cmdPtr; /* Points to the Command structure for this + * procedure. This is used to get the + * namespace in which to execute the + * procedure. */ + Tcl_Obj *bodyPtr; /* Points to the ByteCode object for + * procedure's body command. */ + int numArgs; /* Number of formal parameters. */ + int numCompiledLocals; /* Count of local variables recognized by the + * compiler including arguments and + * temporaries. */ + CompiledLocal *firstLocalPtr; + /* Pointer to first of the procedure's + * compiler-allocated local variables, or NULL + * if none. The first numArgs entries in this + * list describe the procedure's formal + * arguments. */ + CompiledLocal *lastLocalPtr;/* Pointer to the last allocated local + * variable or NULL if none. This has frame + * index (numCompiledLocals-1). */ +} Proc; + +/* + * The type of functions called to process errors found during the execution + * of a procedure (or lambda term or ...). + */ + +typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); + +/* + * The structure below defines a command trace. This is used to allow Tcl + * clients to find out whenever a command is about to be executed. + */ + +typedef struct Trace { + int level; /* Only trace commands at nesting level less + * than or equal to this. */ + Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ + struct Trace *nextPtr; /* Next in list of traces for this interp. */ + int flags; /* Flags governing the trace - see + * Tcl_CreateObjTrace for details. */ + Tcl_CmdObjTraceDeleteProc *delProc; + /* Procedure to call when trace is deleted. */ +} Trace; + +/* + * When an interpreter trace is active (i.e. its associated procedure is + * executing), one of the following structures is linked into a list + * associated with the interpreter. The information in the structure is needed + * in order for Tcl to behave reasonably if traces are deleted while traces + * are active. + */ + +typedef struct ActiveInterpTrace { + struct ActiveInterpTrace *nextPtr; + /* Next in list of all active command traces + * for the interpreter, or NULL if no more. */ + Trace *nextTracePtr; /* Next trace to check after current trace + * procedure returns; if this trace gets + * deleted, must update pointer to avoid using + * free'd memory. */ + int reverseScan; /* Boolean set true when traces are scanning + * in reverse order. */ +} ActiveInterpTrace; + +/* + * Flag values designating types of execution traces. See tclTrace.c for + * related flag values. + * + * TCL_TRACE_ENTER_EXEC - triggers enter/enterstep traces. + * - passed to Tcl_CreateObjTrace to set up + * "enterstep" traces. + * TCL_TRACE_LEAVE_EXEC - triggers leave/leavestep traces. + * - passed to Tcl_CreateObjTrace to set up + * "leavestep" traces. + */ + +#define TCL_TRACE_ENTER_EXEC 1 +#define TCL_TRACE_LEAVE_EXEC 2 + +/* + * The structure below defines an entry in the assocData hash table which is + * associated with an interpreter. The entry contains a pointer to a function + * to call when the interpreter is deleted, and a pointer to a user-defined + * piece of data. + */ + +typedef struct AssocData { + Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ + ClientData clientData; /* Value to pass to proc. */ +} AssocData; + +/* + * The structure below defines a call frame. A call frame defines a naming + * context for a procedure call: its local naming scope (for local variables) + * and its global naming scope (a namespace, perhaps the global :: namespace). + * A call frame can also define the naming context for a namespace eval or + * namespace inscope command: the namespace in which the command's code should + * execute. The Tcl_CallFrame structures exist only while procedures or + * namespace eval/inscope's are being executed, and provide a kind of Tcl call + * stack. + * + * WARNING!! The structure definition must be kept consistent with the + * Tcl_CallFrame structure in tcl.h. If you change one, change the other. + */ + +/* + * Will be grown to contain: pointers to the varnames (allocated at the end), + * plus the init values for each variable (suitable to be memcopied on init) + */ + +typedef struct LocalCache { + int refCount; + int numVars; + Tcl_Obj *varName0; +} LocalCache; + +#define localName(framePtr, i) \ + ((&((framePtr)->localCachePtr->varName0))[(i)]) + +MODULE_SCOPE void TclFreeLocalCache(Tcl_Interp *interp, + LocalCache *localCachePtr); + +typedef struct CallFrame { + Namespace *nsPtr; /* Points to the namespace used to resolve + * commands and global variables. */ + int isProcCallFrame; /* If 0, the frame was pushed to execute a + * namespace command and var references are + * treated as references to namespace vars; + * varTablePtr and compiledLocals are ignored. + * If FRAME_IS_PROC is set, the frame was + * pushed to execute a Tcl procedure and may + * have local vars. */ + int objc; /* This and objv below describe the arguments + * for this procedure call. */ + Tcl_Obj *const *objv; /* Array of argument objects. */ + struct CallFrame *callerPtr; + /* Value of interp->framePtr when this + * procedure was invoked (i.e. next higher in + * stack of all active procedures). */ + struct CallFrame *callerVarPtr; + /* Value of interp->varFramePtr when this + * procedure was invoked (i.e. determines + * variable scoping within caller). Same as + * callerPtr unless an "uplevel" command or + * something equivalent was active in the + * caller). */ + int level; /* Level of this procedure, for "uplevel" + * purposes (i.e. corresponds to nesting of + * callerVarPtr's, not callerPtr's). 1 for + * outermost procedure, 0 for top-level. */ + Proc *procPtr; /* Points to the structure defining the called + * procedure. Used to get information such as + * the number of compiled local variables + * (local variables assigned entries ["slots"] + * in the compiledLocals array below). */ + TclVarHashTable *varTablePtr; + /* Hash table containing local variables not + * recognized by the compiler, or created at + * execution time through, e.g., upvar. + * Initially NULL and created if needed. */ + int numCompiledLocals; /* Count of local variables recognized by the + * compiler including arguments. */ + Var *compiledLocals; /* Points to the array of local variables + * recognized by the compiler. The compiler + * emits code that refers to these variables + * using an index into this array. */ + ClientData clientData; /* Pointer to some context that is used by + * object systems. The meaning of the contents + * of this field is defined by the code that + * sets it, and it should only ever be set by + * the code that is pushing the frame. In that + * case, the code that sets it should also + * have some means of discovering what the + * meaning of the value is, which we do not + * specify. */ + LocalCache *localCachePtr; + Tcl_Obj *tailcallPtr; + /* NULL if no tailcall is scheduled */ +} CallFrame; + +#define FRAME_IS_PROC 0x1 +#define FRAME_IS_LAMBDA 0x2 +#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's + * clientData field contains a CallContext + * reference. Part of TIP#257. */ +#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of + * the [oo::define] command; the clientData + * field contains an Object reference that has + * been confirmed to refer to a class. Part of + * TIP#257. */ + +/* + * TIP #280 + * The structure below defines a command frame. A command frame provides + * location information for all commands executing a tcl script (source, eval, + * uplevel, procedure bodies, ...). The runtime structure essentially contains + * the stack trace as it would be if the currently executing command were to + * throw an error. + * + * For commands where it makes sense it refers to the associated CallFrame as + * well. + * + * The structures are chained in a single list, with the top of the stack + * anchored in the Interp structure. + * + * Instances can be allocated on the C stack, or the heap, the former making + * cleanup a bit simpler. + */ + +typedef struct CmdFrame { + /* + * General data. Always available. + */ + + int type; /* Values see below. */ + int level; /* Number of frames in stack, prevent O(n) + * scan of list. */ + int *line; /* Lines the words of the command start on. */ + int nline; + CallFrame *framePtr; /* Procedure activation record, may be + * NULL. */ + struct CmdFrame *nextPtr; /* Link to calling frame. */ + /* + * Data needed for Eval vs TEBC + * + * EXECUTION CONTEXTS and usage of CmdFrame + * + * Field TEBC EvalEx + * ======= ==== ====== + * level yes yes + * type BC/PREBC SRC/EVAL + * line0 yes yes + * framePtr yes yes + * ======= ==== ====== + * + * ======= ==== ========= union data + * line1 - yes + * line3 - yes + * path - yes + * ------- ---- ------ + * codePtr yes - + * pc yes - + * ======= ==== ====== + * + * ======= ==== ========= union cmd + * str.cmd yes yes + * str.len yes yes + * ------- ---- ------ + */ + + union { + struct { + Tcl_Obj *path; /* Path of the sourced file the command is + * in. */ + } eval; + struct { + const void *codePtr;/* Byte code currently executed... */ + const char *pc; /* ... and instruction pointer. */ + } tebc; + } data; + Tcl_Obj *cmdObj; + const char *cmd; /* The executed command, if possible... */ + int len; /* ... and its length. */ + const struct CFWordBC *litarg; + /* Link to set of literal arguments which have + * ben pushed on the lineLABCPtr stack by + * TclArgumentBCEnter(). These will be removed + * by TclArgumentBCRelease. */ +} CmdFrame; + +typedef struct CFWord { + CmdFrame *framePtr; /* CmdFrame to access. */ + int word; /* Index of the word in the command. */ + int refCount; /* Number of times the word is on the + * stack. */ +} CFWord; + +typedef struct CFWordBC { + CmdFrame *framePtr; /* CmdFrame to access. */ + int pc; /* Instruction pointer of a command in + * ExtCmdLoc.loc[.] */ + int word; /* Index of word in + * ExtCmdLoc.loc[cmd]->line[.] */ + struct CFWordBC *prevPtr; /* Previous entry in stack for same Tcl_Obj. */ + struct CFWordBC *nextPtr; /* Next entry for same command call. See + * CmdFrame litarg field for the list start. */ + Tcl_Obj *obj; /* Back reference to hashtable key */ +} CFWordBC; + +/* + * Structure to record the locations of invisible continuation lines in + * literal scripts, as character offset from the beginning of the script. Both + * compiler and direct evaluator use this information to adjust their line + * counters when tracking through the script, because when it is invoked the + * continuation line marker as a whole has been removed already, meaning that + * the \n which was part of it is gone as well, breaking regular line + * tracking. + * + * These structures are allocated and filled by both the function + * TclSubstTokens() in the file "tclParse.c" and its caller TclEvalEx() in the + * file "tclBasic.c", and stored in the thread-global hashtable "lineCLPtr" in + * file "tclObj.c". They are used by the functions TclSetByteCodeFromAny() and + * TclCompileScript(), both found in the file "tclCompile.c". Their memory is + * released by the function TclFreeObj(), in the file "tclObj.c", and also by + * the function TclThreadFinalizeObjects(), in the same file. + */ + +#define CLL_END (-1) + +typedef struct ContLineLoc { + int num; /* Number of entries in loc, not counting the + * final -1 marker entry. */ + int loc[1]; /* Table of locations, as character offsets. + * The table is allocated as part of the + * structure, extending behind the nominal end + * of the structure. An entry containing the + * value -1 is put after the last location, as + * end-marker/sentinel. */ +} ContLineLoc; + +/* + * The following macros define the allowed values for the type field of the + * CmdFrame structure above. Some of the values occur only in the extended + * location data referenced via the 'baseLocPtr'. + * + * TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx. + * TCL_LOCATION_BC : Frame is for bytecode. + * TCL_LOCATION_PREBC : Frame is for precompiled bytecode. + * TCL_LOCATION_SOURCE : Frame is for a script evaluated by EvalEx, from a + * sourced file. + * TCL_LOCATION_PROC : Frame is for bytecode of a procedure. + * + * A TCL_LOCATION_BC type in a frame can be overridden by _SOURCE and _PROC + * types, per the context of the byte code in execution. + */ + +#define TCL_LOCATION_EVAL (0) /* Location in a dynamic eval script. */ +#define TCL_LOCATION_BC (2) /* Location in byte code. */ +#define TCL_LOCATION_PREBC (3) /* Location in precompiled byte code, no + * location. */ +#define TCL_LOCATION_SOURCE (4) /* Location in a file. */ +#define TCL_LOCATION_PROC (5) /* Location in a dynamic proc. */ +#define TCL_LOCATION_LAST (6) /* Number of values in the enum. */ + +/* + * Structure passed to describe procedure-like "procedures" that are not + * procedures (e.g. a lambda) so that their details can be reported correctly + * by [info frame]. Contains a sub-structure for each extra field. + */ + +typedef Tcl_Obj * (GetFrameInfoValueProc)(ClientData clientData); +typedef struct { + const char *name; /* Name of this field. */ + GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the + * clientData, or just use the clientData + * directly (after casting) if NULL. */ + ClientData clientData; /* Context for above function, or Tcl_Obj* if + * proc field is NULL. */ +} ExtraFrameInfoField; +typedef struct { + int length; /* Length of array. */ + ExtraFrameInfoField fields[2]; + /* Really as long as necessary, but this is + * long enough for nearly anything. */ +} ExtraFrameInfo; + +/* + *---------------------------------------------------------------- + * Data structures and procedures related to TclHandles, which are a very + * lightweight method of preserving enough information to determine if an + * arbitrary malloc'd block has been deleted. + *---------------------------------------------------------------- + */ + +typedef void **TclHandle; + +/* + *---------------------------------------------------------------- + * Experimental flag value passed to Tcl_GetRegExpFromObj. Intended for use + * only by Expect. It will probably go away in a later release. + *---------------------------------------------------------------- + */ + +#define TCL_REG_BOSONLY 002000 /* Prepend \A to pattern so it only matches at + * the beginning of the string. */ + +/* + * These are a thin layer over TclpThreadKeyDataGet and TclpThreadKeyDataSet + * when threads are used, or an emulation if there are no threads. These are + * really internal and Tcl clients should use Tcl_GetThreadData. + */ + +MODULE_SCOPE void * TclThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr); +MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr, + void *data); + +/* + * This is a convenience macro used to initialize a thread local storage ptr. + */ + +#define TCL_TSD_INIT(keyPtr) \ + (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) + +/* + *---------------------------------------------------------------- + * Data structures related to bytecode compilation and execution. These are + * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c. + *---------------------------------------------------------------- + */ + +/* + * Forward declaration to prevent errors when the forward references to + * Tcl_Parse and CompileEnv are encountered in the procedure type CompileProc + * declared below. + */ + +struct CompileEnv; + +/* + * The type of procedures called by the Tcl bytecode compiler to compile + * commands. Pointers to these procedures are kept in the Command structure + * describing each command. The integer value returned by a CompileProc must + * be one of the following: + * + * TCL_OK Compilation completed normally. + * TCL_ERROR Compilation could not be completed. This can be just a + * judgment by the CompileProc that the command is too + * complex to compile effectively, or it can indicate + * that in the current state of the interp, the command + * would raise an error. The bytecode compiler will not + * do any error reporting at compiler time. Error + * reporting is deferred until the actual runtime, + * because by then changes in the interp state may allow + * the command to be successfully evaluated. + * TCL_OUT_LINE_COMPILE A source-compatible alias for TCL_ERROR, kept for the + * sake of old code only. + */ + +#define TCL_OUT_LINE_COMPILE TCL_ERROR + +typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr, + struct Command *cmdPtr, struct CompileEnv *compEnvPtr); + +/* + * The type of procedure called from the compilation hook point in + * SetByteCodeFromAny. + */ + +typedef int (CompileHookProc)(Tcl_Interp *interp, + struct CompileEnv *compEnvPtr, ClientData clientData); + +/* + * The data structure for a (linked list of) execution stacks. + */ + +typedef struct ExecStack { + struct ExecStack *prevPtr; + struct ExecStack *nextPtr; + Tcl_Obj **markerPtr; + Tcl_Obj **endPtr; + Tcl_Obj **tosPtr; + Tcl_Obj *stackWords[1]; +} ExecStack; + +/* + * The data structure defining the execution environment for ByteCode's. + * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation + * stack that holds command operands and results. The stack grows towards + * increasing addresses. The member stackPtr points to the stackItems of the + * currently active execution stack. + */ + +typedef struct CorContext { + struct CallFrame *framePtr; + struct CallFrame *varFramePtr; + struct CmdFrame *cmdFramePtr; /* See Interp.cmdFramePtr */ + Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */ +} CorContext; + +typedef struct CoroutineData { + struct Command *cmdPtr; /* The command handle for the coroutine. */ + struct ExecEnv *eePtr; /* The special execution environment (stacks, + * etc.) for the coroutine. */ + struct ExecEnv *callerEEPtr;/* The execution environment for the caller of + * the coroutine, which might be the + * interpreter global environment or another + * coroutine. */ + CorContext caller; + CorContext running; + Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */ + void *stackLevel; + int auxNumLevels; /* While the coroutine is running the + * numLevels of the create/resume command is + * stored here; for suspended coroutines it + * holds the nesting numLevels at yield. */ + int nargs; /* Number of args required for resuming this + * coroutine; -2 means "0 or 1" (default), -1 + * means "any" */ +} CoroutineData; + +typedef struct ExecEnv { + ExecStack *execStackPtr; /* Points to the first item in the evaluation + * stack on the heap. */ + Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */ + struct Tcl_Interp *interp; + struct NRE_callback *callbackPtr; + /* Top callback in NRE's stack. */ + struct CoroutineData *corPtr; + int rewind; +} ExecEnv; + +#define COR_IS_SUSPENDED(corPtr) \ + ((corPtr)->stackLevel == NULL) + +/* + * The definitions for the LiteralTable and LiteralEntry structures. Each + * interpreter contains a LiteralTable. It is used to reduce the storage + * needed for all the Tcl objects that hold the literals of scripts compiled + * by the interpreter. A literal's object is shared by all the ByteCodes that + * refer to the literal. Each distinct literal has one LiteralEntry entry in + * the LiteralTable. A literal table is a specialized hash table that is + * indexed by the literal's string representation, which may contain null + * characters. + * + * Note that we reduce the space needed for literals by sharing literal + * objects both within a ByteCode (each ByteCode contains a local + * LiteralTable) and across all an interpreter's ByteCodes (with the + * interpreter's global LiteralTable). + */ + +typedef struct LiteralEntry { + struct LiteralEntry *nextPtr; + /* Points to next entry in this hash bucket or + * NULL if end of chain. */ + Tcl_Obj *objPtr; /* Points to Tcl object that holds the + * literal's bytes and length. */ + int refCount; /* If in an interpreter's global literal + * table, the number of ByteCode structures + * that share the literal object; the literal + * entry can be freed when refCount drops to + * 0. If in a local literal table, -1. */ + Namespace *nsPtr; /* Namespace in which this literal is used. We + * try to avoid sharing literal non-FQ command + * names among different namespaces to reduce + * shimmering. */ +} LiteralEntry; + +typedef struct LiteralTable { + LiteralEntry **buckets; /* Pointer to bucket array. Each element + * points to first entry in bucket's hash + * chain, or NULL. */ + LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; + /* Bucket array used for small tables to avoid + * mallocs and frees. */ + int numBuckets; /* Total number of buckets allocated at + * **buckets. */ + int numEntries; /* Total number of entries present in + * table. */ + int rebuildSize; /* Enlarge table when numEntries gets to be + * this large. */ + int mask; /* Mask value used in hashing function. */ +} LiteralTable; + +/* + * The following structure defines for each Tcl interpreter various + * statistics-related information about the bytecode compiler and + * interpreter's operation in that interpreter. + */ + +#ifdef TCL_COMPILE_STATS +typedef struct ByteCodeStats { + long numExecutions; /* Number of ByteCodes executed. */ + long numCompilations; /* Number of ByteCodes created. */ + long numByteCodesFreed; /* Number of ByteCodes destroyed. */ + long instructionCount[256]; /* Number of times each instruction was + * executed. */ + + double totalSrcBytes; /* Total source bytes ever compiled. */ + double totalByteCodeBytes; /* Total bytes for all ByteCodes. */ + double currentSrcBytes; /* Src bytes for all current ByteCodes. */ + double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */ + + long srcCount[32]; /* Source size distribution: # of srcs of + * size [2**(n-1)..2**n), n in [0..32). */ + long byteCodeCount[32]; /* ByteCode size distribution. */ + long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ + + double currentInstBytes; /* Instruction bytes-current ByteCodes. */ + double currentLitBytes; /* Current literal bytes. */ + double currentExceptBytes; /* Current exception table bytes. */ + double currentAuxBytes; /* Current auxiliary information bytes. */ + double currentCmdMapBytes; /* Current src<->code map bytes. */ + + long numLiteralsCreated; /* Total literal objects ever compiled. */ + double totalLitStringBytes; /* Total string bytes in all literals. */ + double currentLitStringBytes; + /* String bytes in current literals. */ + long literalCount[32]; /* Distribution of literal string sizes. */ +} ByteCodeStats; +#endif /* TCL_COMPILE_STATS */ + +/* + * Structure used in implementation of those core ensembles which are + * partially compiled. Used as an array of these, with a terminating field + * whose 'name' is NULL. + */ + +typedef struct { + const char *name; /* The name of the subcommand. */ + Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */ + CompileProc *compileProc; /* The compiler for the subcommand. */ + Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ + ClientData clientData; /* Any clientData to give the command. */ + int unsafe; /* Whether this command is to be hidden by + * default in a safe interpreter. */ +} EnsembleImplMap; + +/* + *---------------------------------------------------------------- + * Data structures related to commands. + *---------------------------------------------------------------- + */ + +/* + * An imported command is created in an namespace when it imports a "real" + * command from another namespace. An imported command has a Command structure + * that points (via its ClientData value) to the "real" Command structure in + * the source namespace's command table. The real command records all the + * imported commands that refer to it in a list of ImportRef structures so + * that they can be deleted when the real command is deleted. + */ + +typedef struct ImportRef { + struct Command *importedCmdPtr; + /* Points to the imported command created in + * an importing namespace; this command + * redirects its invocations to the "real" + * command. */ + struct ImportRef *nextPtr; /* Next element on the linked list of imported + * commands that refer to the "real" command. + * The real command deletes these imported + * commands on this list when it is + * deleted. */ +} ImportRef; + +/* + * Data structure used as the ClientData of imported commands: commands + * created in an namespace when it imports a "real" command from another + * namespace. + */ + +typedef struct ImportedCmdData { + struct Command *realCmdPtr; /* "Real" command that this imported command + * refers to. */ + struct Command *selfPtr; /* Pointer to this imported command. Needed + * only when deleting it in order to remove it + * from the real command's linked list of + * imported commands that refer to it. */ +} ImportedCmdData; + +/* + * A Command structure exists for each command in a namespace. The Tcl_Command + * opaque type actually refers to these structures. + */ + +typedef struct Command { + Tcl_HashEntry *hPtr; /* Pointer to the hash table entry that refers + * to this command. The hash table is either a + * namespace's command table or an + * interpreter's hidden command table. This + * pointer is used to get a command's name + * from its Tcl_Command handle. NULL means + * that the hash table entry has been removed + * already (this can happen if deleteProc + * causes the command to be deleted or + * recreated). */ + Namespace *nsPtr; /* Points to the namespace containing this + * command. */ + int refCount; /* 1 if in command hashtable plus 1 for each + * reference from a CmdName Tcl object + * representing a command's name in a ByteCode + * instruction sequence. This structure can be + * freed when refCount becomes zero. */ + int cmdEpoch; /* Incremented to invalidate any references + * that point to this command when it is + * renamed, deleted, hidden, or exposed. */ + CompileProc *compileProc; /* Procedure called to compile command. NULL + * if no compile proc exists for command. */ + Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */ + ClientData objClientData; /* Arbitrary value passed to object proc. */ + Tcl_CmdProc *proc; /* String-based command procedure. */ + ClientData clientData; /* Arbitrary value passed to string proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* Procedure invoked when deleting command to, + * e.g., free all client data. */ + ClientData deleteData; /* Arbitrary value passed to deleteProc. */ + int flags; /* Miscellaneous bits of information about + * command. See below for definitions. */ + ImportRef *importRefPtr; /* List of each imported Command created in + * another namespace when this command is + * imported. These imported commands redirect + * invocations back to this command. The list + * is used to remove all those imported + * commands when deleting this "real" + * command. */ + CommandTrace *tracePtr; /* First in list of all traces set for this + * command. */ + Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ +} Command; + +/* + * Flag bits for commands. + * + * CMD_IS_DELETED - Means that the command is in the process of + * being deleted (its deleteProc is currently + * executing). Other attempts to delete the + * command should be ignored. + * CMD_TRACE_ACTIVE - 1 means that trace processing is currently + * underway for a rename/delete change. See the + * two flags below for which is currently being + * processed. + * CMD_HAS_EXEC_TRACES - 1 means that this command has at least one + * execution trace (as opposed to simple + * delete/rename traces) in its tracePtr list. + * CMD_COMPILES_EXPANDED - 1 means that this command has a compiler that + * can handle expansion (provided it is not the + * first word). + * TCL_TRACE_RENAME - A rename trace is in progress. Further + * recursive renames will not be traced. + * TCL_TRACE_DELETE - A delete trace is in progress. Further + * recursive deletes will not be traced. + * (these last two flags are defined in tcl.h) + */ + +#define CMD_IS_DELETED 0x01 +#define CMD_TRACE_ACTIVE 0x02 +#define CMD_HAS_EXEC_TRACES 0x04 +#define CMD_COMPILES_EXPANDED 0x08 +#define CMD_REDEF_IN_PROGRESS 0x10 +#define CMD_VIA_RESOLVER 0x20 + + +/* + *---------------------------------------------------------------- + * Data structures related to name resolution procedures. + *---------------------------------------------------------------- + */ + +/* + * The interpreter keeps a linked list of name resolution schemes. The scheme + * for a namespace is consulted first, followed by the list of schemes in an + * interpreter, followed by the default name resolution in Tcl. Schemes are + * added/removed from the interpreter's list by calling Tcl_AddInterpResolver + * and Tcl_RemoveInterpResolver. + */ + +typedef struct ResolverScheme { + char *name; /* Name identifying this scheme. */ + Tcl_ResolveCmdProc *cmdResProc; + /* Procedure handling command name + * resolution. */ + Tcl_ResolveVarProc *varResProc; + /* Procedure handling variable name resolution + * for variables that can only be handled at + * runtime. */ + Tcl_ResolveCompiledVarProc *compiledVarResProc; + /* Procedure handling variable name resolution + * at compile time. */ + + struct ResolverScheme *nextPtr; + /* Pointer to next record in linked list. */ +} ResolverScheme; + +/* + * Forward declaration of the TIP#143 limit handler structure. + */ + +typedef struct LimitHandler LimitHandler; + +/* + * TIP #268. + * Values for the selection mode, i.e the package require preferences. + */ + +enum PkgPreferOptions { + PKG_PREFER_LATEST, PKG_PREFER_STABLE +}; + +/* + *---------------------------------------------------------------- + * This structure shadows the first few fields of the memory cache for the + * allocator defined in tclThreadAlloc.c; it has to be kept in sync with the + * definition there. + * Some macros require knowledge of some fields in the struct in order to + * avoid hitting the TSD unnecessarily. In order to facilitate this, a pointer + * to the relevant fields is kept in the allocCache field in struct Interp. + *---------------------------------------------------------------- + */ + +typedef struct AllocCache { + struct Cache *nextPtr; /* Linked list of cache entries. */ + Tcl_ThreadId owner; /* Which thread's cache is this? */ + Tcl_Obj *firstObjPtr; /* List of free objects for thread. */ + int numObjects; /* Number of objects for thread. */ +} AllocCache; + +/* + *---------------------------------------------------------------- + * This structure defines an interpreter, which is a collection of commands + * plus other state information related to interpreting commands, such as + * variable storage. Primary responsibility for this data structure is in + * tclBasic.c, but almost every Tcl source file uses something in here. + *---------------------------------------------------------------- + */ + +typedef struct Interp { + /* + * Note: the first three fields must match exactly the fields in a + * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the + * other. + * + * The interpreter's result is held in both the string and the + * objResultPtr fields. These fields hold, respectively, the result's + * string or object value. The interpreter's result is always in the + * result field if that is non-empty, otherwise it is in objResultPtr. + * The two fields are kept consistent unless some C code sets + * interp->result directly. Programs should not access result and + * objResultPtr directly; instead, they should always get and set the + * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and + * Tcl_GetStringResult. See the SetResult man page for details. + */ + + char *result; /* If the last command returned a string + * result, this points to it. Should not be + * accessed directly; see comment above. */ + Tcl_FreeProc *freeProc; /* Zero means a string result is statically + * allocated. TCL_DYNAMIC means string result + * was allocated with ckalloc and should be + * freed with ckfree. Other values give + * address of procedure to invoke to free the + * string result. Tcl_Eval must free it before + * executing next command. */ + int errorLine; /* When TCL_ERROR is returned, this gives the + * line number in the command where the error + * occurred (1 means first line). */ + const struct TclStubs *stubTable; + /* Pointer to the exported Tcl stub table. On + * previous versions of Tcl this is a pointer + * to the objResultPtr or a pointer to a + * buckets array in a hash table. We therefore + * have to do some careful checking before we + * can use this. */ + + TclHandle handle; /* Handle used to keep track of when this + * interp is deleted. */ + + Namespace *globalNsPtr; /* The interpreter's global namespace. */ + Tcl_HashTable *hiddenCmdTablePtr; + /* Hash table used by tclBasic.c to keep track + * of hidden commands on a per-interp + * basis. */ + ClientData interpInfo; /* Information used by tclInterp.c to keep + * track of master/slave interps on a + * per-interp basis. */ + union { + void (*optimizer)(void *envPtr); + Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The + * unused space in interp was repurposed for + * pluggable bytecode optimizers. The core + * contains one optimizer, which can be + * selectively overridden by extensions. */ + } extra; + + /* + * Information related to procedures and variables. See tclProc.c and + * tclVar.c for usage. + */ + + int numLevels; /* Keeps track of how many nested calls to + * Tcl_Eval are in progress for this + * interpreter. It's used to delay deletion of + * the table until all Tcl_Eval invocations + * are completed. */ + int maxNestingDepth; /* If numLevels exceeds this value then Tcl + * assumes that infinite recursion has + * occurred and it generates an error. */ + CallFrame *framePtr; /* Points to top-most in stack of all nested + * procedure invocations. */ + CallFrame *varFramePtr; /* Points to the call frame whose variables + * are currently in use (same as framePtr + * unless an "uplevel" command is + * executing). */ + ActiveVarTrace *activeVarTracePtr; + /* First in list of active traces for interp, + * or NULL if no active traces. */ + int returnCode; /* [return -code] parameter. */ + CallFrame *rootFramePtr; /* Global frame pointer for this + * interpreter. */ + Namespace *lookupNsPtr; /* Namespace to use ONLY on the next + * TCL_EVAL_INVOKE call to Tcl_EvalObjv. */ + + /* + * Information used by Tcl_AppendResult to keep track of partial results. + * See Tcl_AppendResult code for details. + */ + + char *appendResult; /* Storage space for results generated by + * Tcl_AppendResult. Ckalloc-ed. NULL means + * not yet allocated. */ + int appendAvl; /* Total amount of space available at + * partialResult. */ + int appendUsed; /* Number of non-null bytes currently stored + * at partialResult. */ + + /* + * Information about packages. Used only in tclPkg.c. + */ + + Tcl_HashTable packageTable; /* Describes all of the packages loaded in or + * available to this interpreter. Keys are + * package names, values are (Package *) + * pointers. */ + char *packageUnknown; /* Command to invoke during "package require" + * commands for packages that aren't described + * in packageTable. Ckalloc'ed, may be + * NULL. */ + /* + * Miscellaneous information: + */ + + int cmdCount; /* Total number of times a command procedure + * has been called for this interpreter. */ + int evalFlags; /* Flags to control next call to Tcl_Eval. + * Normally zero, but may be set before + * calling Tcl_Eval. See below for valid + * values. */ + int unused1; /* No longer used (was termOffset) */ + LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl + * objects holding literals of scripts + * compiled by the interpreter. Indexed by the + * string representations of literals. Used to + * avoid creating duplicate objects. */ + int compileEpoch; /* Holds the current "compilation epoch" for + * this interpreter. This is incremented to + * invalidate existing ByteCodes when, e.g., a + * command with a compile procedure is + * redefined. */ + Proc *compiledProcPtr; /* If a procedure is being compiled, a pointer + * to its Proc structure; otherwise, this is + * NULL. Set by ObjInterpProc in tclProc.c and + * used by tclCompile.c to process local + * variables appropriately. */ + ResolverScheme *resolverPtr; + /* Linked list of name resolution schemes + * added to this interpreter. Schemes are + * added and removed by calling + * Tcl_AddInterpResolvers and + * Tcl_RemoveInterpResolver respectively. */ + Tcl_Obj *scriptFile; /* NULL means there is no nested source + * command active; otherwise this points to + * pathPtr of the file being sourced. */ + int flags; /* Various flag bits. See below. */ + long randSeed; /* Seed used for rand() function. */ + Trace *tracePtr; /* List of traces for this interpreter. */ + Tcl_HashTable *assocData; /* Hash table for associating data with this + * interpreter. Cleaned up when this + * interpreter is deleted. */ + struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode + * execution. Contains a pointer to the Tcl + * evaluation stack. */ + Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty + * string. Returned by Tcl_ObjSetVar2 when + * variable traces change a variable in a + * gross way. */ + char resultSpace[TCL_RESULT_SIZE+1]; + /* Static space holding small results. */ + Tcl_Obj *objResultPtr; /* If the last command returned an object + * result, this points to it. Should not be + * accessed directly; see comment above. */ + Tcl_ThreadId threadId; /* ID of thread that owns the interpreter. */ + + ActiveCommandTrace *activeCmdTracePtr; + /* First in list of active command traces for + * interp, or NULL if no active traces. */ + ActiveInterpTrace *activeInterpTracePtr; + /* First in list of active traces for interp, + * or NULL if no active traces. */ + + int tracesForbiddingInline; /* Count of traces (in the list headed by + * tracePtr) that forbid inline bytecode + * compilation. */ + + /* + * Fields used to manage extensible return options (TIP 90). + */ + + Tcl_Obj *returnOpts; /* A dictionary holding the options to the + * last [return] command. */ + + Tcl_Obj *errorInfo; /* errorInfo value (now as a Tcl_Obj). */ + Tcl_Obj *eiVar; /* cached ref to ::errorInfo variable. */ + Tcl_Obj *errorCode; /* errorCode value (now as a Tcl_Obj). */ + Tcl_Obj *ecVar; /* cached ref to ::errorInfo variable. */ + int returnLevel; /* [return -level] parameter. */ + + /* + * Resource limiting framework support (TIP#143). + */ + + struct { + int active; /* Flag values defining which limits have been + * set. */ + int granularityTicker; /* Counter used to determine how often to + * check the limits. */ + int exceeded; /* Which limits have been exceeded, described + * as flag values the same as the 'active' + * field. */ + + int cmdCount; /* Limit for how many commands to execute in + * the interpreter. */ + LimitHandler *cmdHandlers; + /* Handlers to execute when the limit is + * reached. */ + int cmdGranularity; /* Mod factor used to determine how often to + * evaluate the limit check. */ + + Tcl_Time time; /* Time limit for execution within the + * interpreter. */ + LimitHandler *timeHandlers; + /* Handlers to execute when the limit is + * reached. */ + int timeGranularity; /* Mod factor used to determine how often to + * evaluate the limit check. */ + Tcl_TimerToken timeEvent; + /* Handle for a timer callback that will occur + * when the time-limit is exceeded. */ + + Tcl_HashTable callbacks;/* Mapping from (interp,type) pair to data + * used to install a limit handler callback to + * run in _this_ interp when the limit is + * exceeded. */ + } limit; + + /* + * Information for improved default error generation from ensembles + * (TIP#112). + */ + + struct { + Tcl_Obj *const *sourceObjs; + /* What arguments were actually input into the + * *root* ensemble command? (Nested ensembles + * don't rewrite this.) NULL if we're not + * processing an ensemble. */ + int numRemovedObjs; /* How many arguments have been stripped off + * because of ensemble processing. */ + int numInsertedObjs; /* How many of the current arguments were + * inserted by an ensemble. */ + } ensembleRewrite; + + /* + * TIP #219: Global info for the I/O system. + */ + + Tcl_Obj *chanMsg; /* Error message set by channel drivers, for + * the propagation of arbitrary Tcl errors. + * This information, if present (chanMsg not + * NULL), takes precedence over a POSIX error + * code returned by a channel operation. */ + + /* + * Source code origin information (TIP #280). + */ + + CmdFrame *cmdFramePtr; /* Points to the command frame containing the + * location information for the current + * command. */ + const CmdFrame *invokeCmdFramePtr; + /* Points to the command frame which is the + * invoking context of the bytecode compiler. + * NULL when the byte code compiler is not + * active. */ + int invokeWord; /* Index of the word in the command which + * is getting compiled. */ + Tcl_HashTable *linePBodyPtr;/* This table remembers for each statically + * defined procedure the location information + * for its body. It is keyed by the address of + * the Proc structure for a procedure. The + * values are "struct CmdFrame*". */ + Tcl_HashTable *lineBCPtr; /* This table remembers for each ByteCode + * object the location information for its + * body. It is keyed by the address of the + * Proc structure for a procedure. The values + * are "struct ExtCmdLoc*". (See + * tclCompile.h) */ + Tcl_HashTable *lineLABCPtr; + Tcl_HashTable *lineLAPtr; /* This table remembers for each argument of a + * command on the execution stack the index of + * the argument in the command, and the + * location data of the command. It is keyed + * by the address of the Tcl_Obj containing + * the argument. The values are "struct + * CFWord*" (See tclBasic.c). This allows + * commands like uplevel, eval, etc. to find + * location information for their arguments, + * if they are a proper literal argument to an + * invoking command. Alt view: An index to the + * CmdFrame stack keyed by command argument + * holders. */ + ContLineLoc *scriptCLLocPtr;/* This table points to the location data for + * invisible continuation lines in the script, + * if any. This pointer is set by the function + * TclEvalObjEx() in file "tclBasic.c", and + * used by function ...() in the same file. + * It does for the eval/direct path of script + * execution what CompileEnv.clLoc does for + * the bytecode compiler. + */ + /* + * TIP #268. The currently active selection mode, i.e. the package require + * preferences. + */ + + int packagePrefer; /* Current package selection mode. */ + + /* + * Hashtables for variable traces and searches. + */ + + Tcl_HashTable varTraces; /* Hashtable holding the start of a variable's + * active trace list; varPtr is the key. */ + Tcl_HashTable varSearches; /* Hashtable holding the start of a variable's + * active searches list; varPtr is the key. */ + /* + * The thread-specific data ekeko: cache pointers or values that + * (a) do not change during the thread's lifetime + * (b) require access to TSD to determine at runtime + * (c) are accessed very often (e.g., at each command call) + * + * Note that these are the same for all interps in the same thread. They + * just have to be initialised for the thread's master interp, slaves + * inherit the value. + * + * They are used by the macros defined below. + */ + + AllocCache *allocCache; + void *pendingObjDataPtr; /* Pointer to the Cache and PendingObjData + * structs for this interp's thread; see + * tclObj.c and tclThreadAlloc.c */ + int *asyncReadyPtr; /* Pointer to the asyncReady indicator for + * this interp's thread; see tclAsync.c */ + /* + * The pointer to the object system root ekeko. c.f. TIP #257. + */ + void *objectFoundation; /* Pointer to the Foundation structure of the + * object system, which contains things like + * references to key namespaces. See + * tclOOInt.h and tclOO.c for real definition + * and setup. */ + + struct NRE_callback *deferredCallbacks; + /* Callbacks that are set previous to a call + * to some Eval function but that actually + * belong to the command that is about to be + * called - i.e., they should be run *before* + * any tailcall is invoked. */ + + /* + * TIP #285, Script cancellation support. + */ + + Tcl_AsyncHandler asyncCancel; + /* Async handler token for Tcl_CancelEval. */ + Tcl_Obj *asyncCancelMsg; /* Error message set by async cancel handler + * for the propagation of arbitrary Tcl + * errors. This information, if present + * (asyncCancelMsg not NULL), takes precedence + * over the default error messages returned by + * a script cancellation operation. */ + + /* + * TIP #348 IMPLEMENTATION - Substituted error stack + */ + Tcl_Obj *errorStack; /* [info errorstack] value (as a Tcl_Obj). */ + Tcl_Obj *upLiteral; /* "UP" literal for [info errorstack] */ + Tcl_Obj *callLiteral; /* "CALL" literal for [info errorstack] */ + Tcl_Obj *innerLiteral; /* "INNER" literal for [info errorstack] */ + Tcl_Obj *innerContext; /* cached list for fast reallocation */ + int resetErrorStack; /* controls cleaning up of ::errorStack */ + +#ifdef TCL_COMPILE_STATS + /* + * Statistical information about the bytecode compiler and interpreter's + * operation. This should be the last field of Interp. + */ + + ByteCodeStats stats; /* Holds compilation and execution statistics + * for this interpreter. */ +#endif /* TCL_COMPILE_STATS */ +} Interp; + +/* + * Macros that use the TSD-ekeko. + */ + +#define TclAsyncReady(iPtr) \ + *((iPtr)->asyncReadyPtr) + +/* + * Macros for script cancellation support (TIP #285). + */ + +#define TclCanceled(iPtr) \ + (((iPtr)->flags & CANCELED) || ((iPtr)->flags & TCL_CANCEL_UNWIND)) + +#define TclSetCancelFlags(iPtr, cancelFlags) \ + (iPtr)->flags |= CANCELED; \ + if ((cancelFlags) & TCL_CANCEL_UNWIND) { \ + (iPtr)->flags |= TCL_CANCEL_UNWIND; \ + } + +#define TclUnsetCancelFlags(iPtr) \ + (iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)) + +/* + * Macros for splicing into and out of doubly linked lists. They assume + * existence of struct items 'prevPtr' and 'nextPtr'. + * + * a = element to add or remove. + * b = list head. + * + * TclSpliceIn adds to the head of the list. + */ + +#define TclSpliceIn(a,b) \ + (a)->nextPtr = (b); \ + if ((b) != NULL) { \ + (b)->prevPtr = (a); \ + } \ + (a)->prevPtr = NULL, (b) = (a); + +#define TclSpliceOut(a,b) \ + if ((a)->prevPtr != NULL) { \ + (a)->prevPtr->nextPtr = (a)->nextPtr; \ + } else { \ + (b) = (a)->nextPtr; \ + } \ + if ((a)->nextPtr != NULL) { \ + (a)->nextPtr->prevPtr = (a)->prevPtr; \ + } + +/* + * EvalFlag bits for Interp structures: + * + * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with a + * code other than TCL_OK or TCL_ERROR; 0 means codes + * other than these should be turned into errors. + */ + +#define TCL_ALLOW_EXCEPTIONS 0x04 +#define TCL_EVAL_FILE 0x02 +#define TCL_EVAL_SOURCE_IN_FRAME 0x10 +#define TCL_EVAL_NORESOLVE 0x20 + +/* + * Flag bits for Interp structures: + * + * DELETED: Non-zero means the interpreter has been deleted: + * don't process any more commands for it, and destroy + * the structure as soon as all nested invocations of + * Tcl_Eval are done. + * ERR_ALREADY_LOGGED: Non-zero means information has already been logged in + * iPtr->errorInfo for the current Tcl_Eval instance, so + * Tcl_Eval needn't log it (used to implement the "error + * message log" command). + * DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler should + * not compile any commands into an inline sequence of + * instructions. This is set 1, for example, when command + * traces are requested. + * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the interp + * has not be initialized. This is set 1 when we first + * use the rand() or srand() functions. + * SAFE_INTERP: Non zero means that the current interp is a safe + * interp (i.e. it has only the safe commands installed, + * less privilege than a regular interp). + * INTERP_DEBUG_FRAME: Used for switching on various extra interpreter + * debug/info mechanisms (e.g. info frame eval/uplevel + * tracing) which are performance intensive. + * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently + * active; so no further trace callbacks should be + * invoked. + * INTERP_ALTERNATE_WRONG_ARGS: Used for listing second and subsequent forms + * of the wrong-num-args string in Tcl_WrongNumArgs. + * Makes it append instead of replacing and uses + * different intermediate text. + * CANCELED: Non-zero means that the script in progress should be + * canceled as soon as possible. This can be checked by + * extensions (and the core itself) by calling + * Tcl_Canceled and checking if TCL_ERROR is returned. + * This is a one-shot flag that is reset immediately upon + * being detected; however, if the TCL_CANCEL_UNWIND flag + * is set Tcl_Canceled will continue to report that the + * script in progress has been canceled thereby allowing + * the evaluation stack for the interp to be fully + * unwound. + * + * WARNING: For the sake of some extensions that have made use of former + * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS) + * or 8 (formerly ERROR_CODE_SET). + */ + +#define DELETED 1 +#define ERR_ALREADY_LOGGED 4 +#define INTERP_DEBUG_FRAME 0x10 +#define DONT_COMPILE_CMDS_INLINE 0x20 +#define RAND_SEED_INITIALIZED 0x40 +#define SAFE_INTERP 0x80 +#define INTERP_TRACE_IN_PROGRESS 0x200 +#define INTERP_ALTERNATE_WRONG_ARGS 0x400 +#define ERR_LEGACY_COPY 0x800 +#define CANCELED 0x1000 + +/* + * Maximum number of levels of nesting permitted in Tcl commands (used to + * catch infinite recursion). + */ + +#define MAX_NESTING_DEPTH 1000 + +/* + * The macro below is used to modify a "char" value (e.g. by casting it to an + * unsigned character) so that it can be used safely with macros such as + * isspace. + */ + +#define UCHAR(c) ((unsigned char) (c)) + +/* + * This macro is used to properly align the memory allocated by Tcl, giving + * the same alignment as the native malloc. + */ + +#if defined(__APPLE__) +#define TCL_ALLOCALIGN 16 +#else +#define TCL_ALLOCALIGN (2*sizeof(void *)) +#endif + +/* + * This macro is used to determine the offset needed to safely allocate any + * data structure in memory. Given a starting offset or size, it "rounds up" + * or "aligns" the offset to the next 8-byte boundary so that any data + * structure can be placed at the resulting offset without fear of an + * alignment error. + * + * WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce the + * wrong result on platforms that allocate addresses that are divisible by 4 + * or 2. Only use it for offsets or sizes. + * + * This macro is only used by tclCompile.c in the core (Bug 926445). It + * however not be made file static, as extensions that touch bytecodes + * (notably tbcload) require it. + */ + +#define TCL_ALIGN(x) (((int)(x) + 7) & ~7) + +/* + * The following enum values are used to specify the runtime platform setting + * of the tclPlatform variable. + */ + +typedef enum { + TCL_PLATFORM_UNIX = 0, /* Any Unix-like OS. */ + TCL_PLATFORM_WINDOWS = 2 /* Any Microsoft Windows OS. */ +} TclPlatformType; + +/* + * The following enum values are used to indicate the translation of a Tcl + * channel. Declared here so that each platform can define + * TCL_PLATFORM_TRANSLATION to the native translation on that platform. + */ + +typedef enum TclEolTranslation { + TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */ + TCL_TRANSLATE_CR, /* Eol == \r. */ + TCL_TRANSLATE_LF, /* Eol == \n. */ + TCL_TRANSLATE_CRLF /* Eol == \r\n. */ +} TclEolTranslation; + +/* + * Flags for TclInvoke: + * + * TCL_INVOKE_HIDDEN Invoke a hidden command; if not set, invokes + * an exposed command. + * TCL_INVOKE_NO_UNKNOWN If set, "unknown" is not invoked if the + * command to be invoked is not found. Only has + * an effect if invoking an exposed command, + * i.e. if TCL_INVOKE_HIDDEN is not also set. + * TCL_INVOKE_NO_TRACEBACK Does not record traceback information if the + * invoked command returns an error. Used if the + * caller plans on recording its own traceback + * information. + */ + +#define TCL_INVOKE_HIDDEN (1<<0) +#define TCL_INVOKE_NO_UNKNOWN (1<<1) +#define TCL_INVOKE_NO_TRACEBACK (1<<2) + +/* + * The structure used as the internal representation of Tcl list objects. This + * struct is grown (reallocated and copied) as necessary to hold all the + * list's element pointers. The struct might contain more slots than currently + * used to hold all element pointers. This is done to make append operations + * faster. + */ + +typedef struct List { + int refCount; + int maxElemCount; /* Total number of element array slots. */ + int elemCount; /* Current number of list elements. */ + int canonicalFlag; /* Set if the string representation was + * derived from the list representation. May + * be ignored if there is no string rep at + * all.*/ + Tcl_Obj *elements; /* First list element; the struct is grown to + * accommodate all elements. */ +} List; + +#define LIST_MAX \ + (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) +#define LIST_SIZE(numElems) \ + (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *))) + +/* + * Macro used to get the elements of a list object. + */ + +#define ListRepPtr(listPtr) \ + ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) + +#define ListSetIntRep(objPtr, listRepPtr) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \ + (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \ + (listRepPtr)->refCount++, \ + (objPtr)->typePtr = &tclListType + +#define ListObjGetElements(listPtr, objc, objv) \ + ((objv) = &(ListRepPtr(listPtr)->elements), \ + (objc) = ListRepPtr(listPtr)->elemCount) + +#define ListObjLength(listPtr, len) \ + ((len) = ListRepPtr(listPtr)->elemCount) + +#define ListObjIsCanonical(listPtr) \ + (((listPtr)->bytes == NULL) || ListRepPtr(listPtr)->canonicalFlag) + +#define TclListObjGetElements(interp, listPtr, objcPtr, objvPtr) \ + (((listPtr)->typePtr == &tclListType) \ + ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\ + : Tcl_ListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr))) + +#define TclListObjLength(interp, listPtr, lenPtr) \ + (((listPtr)->typePtr == &tclListType) \ + ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\ + : Tcl_ListObjLength((interp), (listPtr), (lenPtr))) + +#define TclListObjIsCanonical(listPtr) \ + (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0) + +/* + * Modes for collecting (or not) in the implementations of TclNRForeachCmd, + * TclNRLmapCmd and their compilations. + */ + +#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */ +#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ + +/* + * Macros providing a faster path to integers: Tcl_GetLongFromObj, + * Tcl_GetIntFromObj and TclGetIntForIndex. + * + * WARNING: these macros eval their args more than once. + */ + +#define TclGetLongFromObj(interp, objPtr, longPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) + +#if (LONG_MAX == INT_MAX) +#define TclGetIntFromObj(interp, objPtr, intPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) +#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) +#else +#define TclGetIntFromObj(interp, objPtr, intPtr) \ + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.longValue >= -(Tcl_WideInt)(UINT_MAX) \ + && (objPtr)->internalRep.longValue <= (Tcl_WideInt)(UINT_MAX)) \ + ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) +#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.longValue >= INT_MIN \ + && (objPtr)->internalRep.longValue <= INT_MAX) \ + ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) +#endif + +/* + * Macro used to save a function call for common uses of + * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: + * + * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + * Tcl_WideInt *wideIntPtr); + */ + +#ifdef TCL_WIDE_INT_IS_LONG +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.longValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#else /* !TCL_WIDE_INT_IS_LONG */ +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ + (((objPtr)->typePtr == &tclWideIntType) \ + ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ + ((objPtr)->typePtr == &tclIntType) \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.longValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#endif /* TCL_WIDE_INT_IS_LONG */ + +/* + * Flag values for TclTraceDictPath(). + * + * DICT_PATH_READ indicates that all entries on the path must exist but no + * updates will be needed. + * + * DICT_PATH_UPDATE indicates that we are going to be doing an update at the + * tip of the path, so duplication of shared objects should be done along the + * way. + * + * DICT_PATH_EXISTS indicates that we are performing an existence test and a + * lookup failure should therefore not be an error. If (and only if) this flag + * is set, TclTraceDictPath() will return the special value + * DICT_PATH_NON_EXISTENT if the path is not traceable. + * + * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to be set) + * indicates that we are to create non-existent dictionaries on the path. + */ + +#define DICT_PATH_READ 0 +#define DICT_PATH_UPDATE 1 +#define DICT_PATH_EXISTS 2 +#define DICT_PATH_CREATE 5 + +#define DICT_PATH_NON_EXISTENT ((Tcl_Obj *) (void *) 1) + +/* + *---------------------------------------------------------------- + * Data structures related to the filesystem internals + *---------------------------------------------------------------- + */ + +/* + * The version_2 filesystem is private to Tcl. As and when these changes have + * been thoroughly tested and investigated a new public filesystem interface + * will be released. The aim is more versatile virtual filesystem interfaces, + * more efficiency in 'path' manipulation and usage, and cleaner filesystem + * code internally. + */ + +#define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) +typedef ClientData (TclFSGetCwdProc2)(ClientData clientData); +typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); + +/* + * The following types are used for getting and storing platform-specific file + * attributes in tclFCmd.c and the various platform-versions of that file. + * This is done to have as much common code as possible in the file attributes + * code. For more information about the callbacks, see TclFileAttrsCmd in + * tclFCmd.c. + */ + +typedef int (TclGetFileAttrProc)(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj **attrObjPtrPtr); +typedef int (TclSetFileAttrProc)(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj *attrObjPtr); + +typedef struct TclFileAttrProcs { + TclGetFileAttrProc *getProc;/* The procedure for getting attrs. */ + TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */ +} TclFileAttrProcs; + +/* + * Opaque handle used in pipeline routines to encapsulate platform-dependent + * state. + */ + +typedef struct TclFile_ *TclFile; + +/* + * The "globParameters" argument of the function TclGlob is an or'ed + * combination of the following values: + */ + +#define TCL_GLOBMODE_NO_COMPLAIN 1 +#define TCL_GLOBMODE_JOIN 2 +#define TCL_GLOBMODE_DIR 4 +#define TCL_GLOBMODE_TAILS 8 + +typedef enum Tcl_PathPart { + TCL_PATH_DIRNAME, + TCL_PATH_TAIL, + TCL_PATH_EXTENSION, + TCL_PATH_ROOT +} Tcl_PathPart; + +/* + *---------------------------------------------------------------- + * Data structures related to obsolete filesystem hooks + *---------------------------------------------------------------- + */ + +typedef int (TclStatProc_)(const char *path, struct stat *buf); +typedef int (TclAccessProc_)(const char *path, int mode); +typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp, + const char *fileName, const char *modeString, int permissions); + +/* + *---------------------------------------------------------------- + * Data structures related to procedures + *---------------------------------------------------------------- + */ + +typedef Tcl_CmdProc *TclCmdProcType; +typedef Tcl_ObjCmdProc *TclObjCmdProcType; + +/* + *---------------------------------------------------------------- + * Data structures for process-global values. + *---------------------------------------------------------------- + */ + +typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, + Tcl_Encoding *encodingPtr); + +/* + * A ProcessGlobalValue struct exists for each internal value in Tcl that is + * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of + * the value, and the master is kept as a counted string, with epoch and mutex + * control. Each ProcessGlobalValue struct should be a static variable in some + * file. + */ + +typedef struct ProcessGlobalValue { + int epoch; /* Epoch counter to detect changes in the + * master value. */ + int numBytes; /* Length of the master string. */ + char *value; /* The master string value. */ + Tcl_Encoding encoding; /* system encoding when master string was + * initialized. */ + TclInitProcessGlobalValueProc *proc; + /* A procedure to initialize the master string + * copy when a "get" request comes in before + * any "set" request has been received. */ + Tcl_Mutex mutex; /* Enforce orderly access from multiple + * threads. */ + Tcl_ThreadDataKey key; /* Key for per-thread data holding the + * (Tcl_Obj) copy for each thread. */ +} ProcessGlobalValue; + +/* + *---------------------------------------------------------------------- + * Flags for TclParseNumber + *---------------------------------------------------------------------- + */ + +#define TCL_PARSE_DECIMAL_ONLY 1 + /* Leading zero doesn't denote octal or + * hex. */ +#define TCL_PARSE_OCTAL_ONLY 2 + /* Parse octal even without prefix. */ +#define TCL_PARSE_HEXADECIMAL_ONLY 4 + /* Parse hexadecimal even without prefix. */ +#define TCL_PARSE_INTEGER_ONLY 8 + /* Disable floating point parsing. */ +#define TCL_PARSE_SCAN_PREFIXES 16 + /* Use [scan] rules dealing with 0? + * prefixes. */ +#define TCL_PARSE_NO_WHITESPACE 32 + /* Reject leading/trailing whitespace. */ +#define TCL_PARSE_BINARY_ONLY 64 + /* Parse binary even without prefix. */ + +/* + *---------------------------------------------------------------------- + * Type values TclGetNumberFromObj + *---------------------------------------------------------------------- + */ + +#define TCL_NUMBER_LONG 1 +#define TCL_NUMBER_WIDE 2 +#define TCL_NUMBER_BIG 3 +#define TCL_NUMBER_DOUBLE 4 +#define TCL_NUMBER_NAN 5 + +/* + *---------------------------------------------------------------- + * Variables shared among Tcl modules but not used by the outside world. + *---------------------------------------------------------------- + */ + +MODULE_SCOPE char *tclNativeExecutableName; +MODULE_SCOPE int tclFindExecutableSearchDone; +MODULE_SCOPE char *tclMemDumpFileName; +MODULE_SCOPE TclPlatformType tclPlatform; +MODULE_SCOPE Tcl_NotifierProcs tclNotifierHooks; + +MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; + +/* + * TIP #233 (Virtualized Time) + * Data for the time hooks, if any. + */ + +MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr; +MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; +MODULE_SCOPE ClientData tclTimeClientData; + +/* + * Variables denoting the Tcl object types defined in the core. + */ + +MODULE_SCOPE const Tcl_ObjType tclBignumType; +MODULE_SCOPE const Tcl_ObjType tclBooleanType; +MODULE_SCOPE const Tcl_ObjType tclByteArrayType; +MODULE_SCOPE const Tcl_ObjType tclByteCodeType; +MODULE_SCOPE const Tcl_ObjType tclDoubleType; +MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; +MODULE_SCOPE const Tcl_ObjType tclIntType; +MODULE_SCOPE const Tcl_ObjType tclListType; +MODULE_SCOPE const Tcl_ObjType tclDictType; +MODULE_SCOPE const Tcl_ObjType tclProcBodyType; +MODULE_SCOPE const Tcl_ObjType tclStringType; +MODULE_SCOPE const Tcl_ObjType tclArraySearchType; +MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; +#ifndef TCL_WIDE_INT_IS_LONG +MODULE_SCOPE const Tcl_ObjType tclWideIntType; +#endif +MODULE_SCOPE const Tcl_ObjType tclRegexpType; +MODULE_SCOPE Tcl_ObjType tclCmdNameType; + +/* + * Variables denoting the hash key types defined in the core. + */ + +MODULE_SCOPE const Tcl_HashKeyType tclArrayHashKeyType; +MODULE_SCOPE const Tcl_HashKeyType tclOneWordHashKeyType; +MODULE_SCOPE const Tcl_HashKeyType tclStringHashKeyType; +MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType; + +/* + * The head of the list of free Tcl objects, and the total number of Tcl + * objects ever allocated and freed. + */ + +MODULE_SCOPE Tcl_Obj * tclFreeObjList; + +#ifdef TCL_COMPILE_STATS +MODULE_SCOPE long tclObjsAlloced; +MODULE_SCOPE long tclObjsFreed; +#define TCL_MAX_SHARED_OBJ_STATS 5 +MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; +#endif /* TCL_COMPILE_STATS */ + +/* + * Pointer to a heap-allocated string of length zero that the Tcl core uses as + * the value of an empty string representation for an object. This value is + * shared by all new objects allocated by Tcl_NewObj. + */ + +MODULE_SCOPE char * tclEmptyStringRep; +MODULE_SCOPE char tclEmptyString; + +/* + *---------------------------------------------------------------- + * Procedures shared among Tcl modules but not used by the outside world, + * introduced by/for NRE. + *---------------------------------------------------------------- + */ + +MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; + +MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; +MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback; +MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; +MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval; +MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; +MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues; + +MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); +MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); + +/* These two can be considered for the public api */ +MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp); +MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp); + +/* + * This structure holds the data for the various iteration callbacks used to + * NRE the 'for' and 'while' commands. We need a separate structure because we + * have more than the 4 client data entries we can provide directly thorugh + * the callback API. It is the 'word' information which puts us over the + * limit. It is needed because the loop body is argument 4 of 'for' and + * argument 2 of 'while'. Not providing the correct index confuses the #280 + * code. We TclSmallAlloc/Free this. + */ + +typedef struct ForIterData { + Tcl_Obj *cond; /* Loop condition expression. */ + Tcl_Obj *body; /* Loop body. */ + Tcl_Obj *next; /* Loop step script, NULL for 'while'. */ + const char *msg; /* Error message part. */ + int word; /* Index of the body script in the command */ +} ForIterData; + +/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile + * and Tcl_FindSymbol. This structure corresponds to an opaque + * typedef in tcl.h */ + +typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, + const char* symbol); +struct Tcl_LoadHandle_ { + ClientData clientData; /* Client data is the load handle in the + * native filesystem if a module was loaded + * there, or an opaque pointer to a structure + * for further bookkeeping on load-from-VFS + * and load-from-memory */ + TclFindSymbolProc* findSymbolProcPtr; + /* Procedure that resolves symbols in a + * loaded module */ + Tcl_FSUnloadFileProc* unloadFileProcPtr; + /* Procedure that unloads a loaded module */ +}; + +/* Flags for conversion of doubles to digit strings */ + +#define TCL_DD_SHORTEST 0x4 + /* Use the shortest possible string */ +#define TCL_DD_STEELE 0x5 + /* Use the original Steele&White algorithm */ +#define TCL_DD_E_FORMAT 0x2 + /* Use a fixed-length string of digits, + * suitable for E format*/ +#define TCL_DD_F_FORMAT 0x3 + /* Use a fixed number of digits after the + * decimal point, suitable for F format */ + +#define TCL_DD_SHORTEN_FLAG 0x4 + /* Allow return of a shorter digit string + * if it converts losslessly */ +#define TCL_DD_NO_QUICK 0x8 + /* Debug flag: forbid quick FP conversion */ + +#define TCL_DD_CONVERSION_TYPE_MASK 0x3 + /* Mask to isolate the conversion type */ +#define TCL_DD_STEELE0 0x1 + /* 'Steele&White' after masking */ +#define TCL_DD_SHORTEST0 0x0 + /* 'Shortest possible' after masking */ + +/* + *---------------------------------------------------------------- + * Procedures shared among Tcl modules but not used by the outside world: + *---------------------------------------------------------------- + */ + +MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, + const unsigned char *bytes, int len); +MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, + int flags); +MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next, + int loc); +MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, + const char *end); +MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp, + Tcl_Obj *objv[], int objc, CmdFrame *cf); +MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, + Tcl_Obj *objv[], int objc); +MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, + Tcl_Obj *objv[], int objc, + void *codePtr, CmdFrame *cfPtr, int cmd, int pc); +MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, + CmdFrame *cfPtr); +MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, + CmdFrame **cfPtrPtr, int *wordPtr); +MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj); +MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum); +MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, + int strLen, const unsigned char *pattern, + int ptnLen, int flags); +MODULE_SCOPE double TclCeil(const mp_int *a); +MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); +MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); +MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, + const char *value); +MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, + Tcl_Channel chan); +MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; +MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; +MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, + int *loc); +MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, + int start, int *clNext); +MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); +MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, + Tcl_Obj *originObjPtr); +MODULE_SCOPE int TclConvertElement(const char *src, int length, + char *dst, int flags); +MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); +MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *nameNamespacePtr, + Tcl_Namespace *ensembleNamespacePtr, + int flags); +MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); +MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, + const char *dict, int dictLength, + const char **elementPtr, const char **nextPtr, + int *sizePtr, int *literalPtr); +/* TIP #280 - Modified token based evulation, with line information. */ +MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, + int numBytes, int flags, int line, + int *clNextOuter, const char *outerScript); +MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; +MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, + ClientData clientData); +MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, + ClientData clientData); +MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, + Tcl_Obj *objPtr); +MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, + Tcl_DString *toAppendPtr); +MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); +MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp, + Tcl_Obj *const *objv, int objc, int *objcPtr); +Tcl_Namespace * TclEnsureNamespace( + Tcl_Interp *interp, + Tcl_Namespace *namespacePtr); + +MODULE_SCOPE void TclFinalizeAllocSubsystem(void); +MODULE_SCOPE void TclFinalizeAsync(void); +MODULE_SCOPE void TclFinalizeDoubleConversion(void); +MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); +MODULE_SCOPE void TclFinalizeEnvironment(void); +MODULE_SCOPE void TclFinalizeEvaluation(void); +MODULE_SCOPE void TclFinalizeExecution(void); +MODULE_SCOPE void TclFinalizeIOSubsystem(void); +MODULE_SCOPE void TclFinalizeFilesystem(void); +MODULE_SCOPE void TclResetFilesystem(void); +MODULE_SCOPE void TclFinalizeLoad(void); +MODULE_SCOPE void TclFinalizeLock(void); +MODULE_SCOPE void TclFinalizeMemorySubsystem(void); +MODULE_SCOPE void TclFinalizeNotifier(void); +MODULE_SCOPE void TclFinalizeObjects(void); +MODULE_SCOPE void TclFinalizePreserve(void); +MODULE_SCOPE void TclFinalizeSynchronization(void); +MODULE_SCOPE void TclFinalizeThreadAlloc(void); +MODULE_SCOPE void TclFinalizeThreadAllocThread(void); +MODULE_SCOPE void TclFinalizeThreadData(int quick); +MODULE_SCOPE void TclFinalizeThreadObjects(void); +MODULE_SCOPE double TclFloor(const mp_int *a); +MODULE_SCOPE void TclFormatNaN(double value, char *buffer); +MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, + const char *attributeName, int *indexPtr); +MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + Tcl_ObjCmdProc *nreProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); + +MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, + const char *encodingName); +MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); +MODULE_SCOPE int * TclGetAsyncReadyPtr(void); +MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); +MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Channel *chanPtr, + int *modePtr, int flags); +MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr); +MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, + Tcl_Obj *value, int *code); +MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, ClientData *clientDataPtr, + int *typePtr); +MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, + const char *modeString, int *seekFlagPtr, + int *binaryPtr); +MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); +MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, + unsigned int *sizePtr); +MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, + Tcl_Obj *unquotedPrefix, int globFlags, + Tcl_GlobTypeData *types); +MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, + Tcl_Obj *incrPtr); +MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); +MODULE_SCOPE int TclInfoExistsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int TclInfoCoroutineCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); +MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE void TclInitAlloc(void); +MODULE_SCOPE void TclInitDbCkalloc(void); +MODULE_SCOPE void TclInitDoubleConversion(void); +MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( + Tcl_Interp *interp); +MODULE_SCOPE void TclInitEncodingSubsystem(void); +MODULE_SCOPE void TclInitIOSubsystem(void); +MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); +MODULE_SCOPE void TclInitNamespaceSubsystem(void); +MODULE_SCOPE void TclInitNotifier(void); +MODULE_SCOPE void TclInitObjSubsystem(void); +MODULE_SCOPE void TclInitSubsystems(void); +MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); +MODULE_SCOPE int TclIsSpaceProc(char byte); +MODULE_SCOPE int TclIsBareword(char byte); +MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[]); +MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); +MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); +MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, + Tcl_Obj *listPtr, Tcl_Obj *argPtr); +MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, + int indexCount, Tcl_Obj *const indexArray[]); +/* TIP #280 */ +MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, + int *lines, Tcl_Obj *const *elems); +MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); +MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); +MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, + int indexCount, Tcl_Obj *const indexArray[], + Tcl_Obj *valuePtr); +MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, + const EnsembleImplMap map[]); +MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes, + const char **endPtr); +MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, + int *codePtr, int *levelPtr); +MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); +MODULE_SCOPE int TclNokia770Doubles(void); +MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); +MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, const char *operation, + const char *reason, int index); +MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[], + Tcl_Namespace *nsPtr, int flags); +MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); +MODULE_SCOPE int TclParseBackslash(const char *src, + int numBytes, int *readPtr, char *dst); +MODULE_SCOPE int TclParseHex(const char *src, int numBytes, + int *resultPtr); +MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, + const char *expected, const char *bytes, + int numBytes, const char **endPtrPtr, int flags); +MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, + int numBytes, Tcl_Parse *parsePtr); +MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes); +MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, + int code, int level, Tcl_Obj *returnOpts); +MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); +MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); +MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); +MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, + int len); +MODULE_SCOPE int TclpDeleteFile(const void *path); +MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); +MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); +MODULE_SCOPE void TclpFinalizePipes(void); +MODULE_SCOPE void TclpFinalizeSockets(void); +MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, + struct addrinfo **addrlist, + const char *host, int port, int willBind, + const char **errorMsgPtr); +MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, + Tcl_ThreadCreateProc *proc, ClientData clientData, + int stackSize, int flags); +MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); +MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, + int *lengthPtr, Tcl_Encoding *encodingPtr); +MODULE_SCOPE void TclpInitLock(void); +MODULE_SCOPE void TclpInitPlatform(void); +MODULE_SCOPE void TclpInitUnlock(void); +MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); +MODULE_SCOPE void TclpMasterLock(void); +MODULE_SCOPE void TclpMasterUnlock(void); +MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, + Tcl_DString *dirPtr, char *pattern, char *tail); +MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, + Tcl_Obj *pathPtr, int nextCheckpoint); +MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining); +MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr); +MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, + int *driveNameLengthPtr, Tcl_Obj **driveNameRef); +MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, + Tcl_Obj *source, Tcl_Obj *target); +MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, + Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, + const char *pattern, Tcl_GlobTypeData *types); +MODULE_SCOPE ClientData TclpGetNativeCwd(ClientData clientData); +MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep; +MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, + int linkType); +MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); +MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); +MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_PathPart portion); +MODULE_SCOPE char * TclpReadlink(const char *fileName, + Tcl_DString *linkPtr); +MODULE_SCOPE void TclpSetInterfaces(void); +MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); +MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr); +MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr, + void *data); +MODULE_SCOPE void TclpThreadExit(int status); +MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); +MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); +MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); +MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); +MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, + int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, + int *quantifiersFoundPtr); +MODULE_SCOPE int TclScanElement(const char *string, int length, + char *flagPtr); +MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, + Tcl_Obj *cmdPrefix); +MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, + mp_int *bignumValue); +MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + Command *cmdPtr); +MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); +MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, + Tcl_Obj *newValue, Tcl_Encoding encoding); +MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); +MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, + Tcl_Obj *const *objv, int objc, int subIdx, + Tcl_Obj *bad, Tcl_Obj *fix); +MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, + int numBytes); +MODULE_SCOPE int TclStringMatch(const char *str, int strLen, + const char *pattern, int ptnLen, int flags); +MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, + Tcl_Obj *patternObj, int flags); +MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); +MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, + int numBytes, int flags, int line, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts, + Tcl_Obj *const opts[], int *flagPtr); +MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, + int numBytes, int flags, Tcl_Parse *parsePtr, + Tcl_InterpState *statePtr); +MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, + int count, int *tokensLeftPtr, int line, + int *clNextOuter, const char *outerScript); +MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, + const char *trim, int numTrim); +MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, + const char *trim, int numTrim); +MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); +MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); +MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); +MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr, int flags); +MODULE_SCOPE int TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval); +#ifdef TCL_LOAD_FROM_MEMORY +MODULE_SCOPE void * TclpLoadMemoryGetBuffer(Tcl_Interp *interp, int size); +MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer, + int size, int codeSize, Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr, int flags); +#endif +MODULE_SCOPE void TclInitThreadStorage(void); +MODULE_SCOPE void TclFinalizeThreadDataThread(void); +MODULE_SCOPE void TclFinalizeThreadStorage(void); +#ifdef TCL_WIDE_CLICKS +MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); +MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); +#endif +MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); +MODULE_SCOPE void * TclpThreadCreateKey(void); +MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); +MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); +MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); + +MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length); + +/* + *---------------------------------------------------------------- + * Command procedures in the generic core: + *---------------------------------------------------------------- + */ + +MODULE_SCOPE int Tcl_AfterObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ApplyObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp); +MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); +MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_CdObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclChanPostEventObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclChanPopObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); +MODULE_SCOPE int TclClockOldscanObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ConcatObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ContinueObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( + Tcl_Time *timePtr, Tcl_TimerProc *proc, + ClientData clientData); +MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, int index, int pathc, + Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); +MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, + int pathc, Tcl_Obj *const pathv[]); +MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +/* Assemble command function */ +MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclMakeEncodingCommandSafe(Tcl_Interp *interp); +MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ErrorObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_EvalObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ExecObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ExitObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ExprObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_FblockedObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_FconfigureObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclMakeFileCommandSafe(Tcl_Interp *interp); +MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_FlushObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_GetsObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_GlobalObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_GlobObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_IfObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp); +MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, + Tcl_Interp *interp, int argc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LappendObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LassignObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LindexObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LinsertObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LreplaceObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LreverseObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LsearchObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_OpenObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_PackageObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp); +MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_PwdObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ReadObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_RegexpObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_RepresentationCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ReturnObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ScanObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SeekObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SetObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SplitObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SocketObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SourceObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitStringCmd(Tcl_Interp *interp); +MODULE_SCOPE int Tcl_SubstObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SwitchObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_TellObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_TryObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_UnloadObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_UnsetObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_UpdateObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_UplevelObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_UpvarObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_VariableObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_VwaitObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +/* + *---------------------------------------------------------------- + * Compilation procedures for commands in the generic core: + *---------------------------------------------------------------- + */ + +MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArrayExistsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArraySetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArrayUnsetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileClockClicksCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileClockReadingCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileConcatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictCreateCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictExistsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictMergeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictUnsetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictUpdateCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictWithCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileEnsemble(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileErrorCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileExprCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileFormatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoCommandsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoCoroutineCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectClassCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectIsACmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLinsertCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLmapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceOriginCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceTailCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectNextToCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileRegsubCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringCatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringEqualCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringMapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringReplaceCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToLowerCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToTitleCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToUpperCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimLCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimRCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileTailcallCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileTryCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileUnsetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileUpvarCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileYieldToCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic1ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic2ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic3ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic0Or1ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic1Or2ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic2Or3ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic0To2ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic1To3ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasicMin0ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasicMin1ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); + +MODULE_SCOPE int TclInvertOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclNotOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileNotOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclAddOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileAddOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclMulOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileMulOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclAndOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileAndOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclOrOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileOrOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclXorOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileXorOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclPowOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompilePowOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclLshiftOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileLshiftOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclRshiftOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileRshiftOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclModOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileModOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclNeqOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileNeqOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclStrneqOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileStrneqOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclInOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileInOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclNiOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileNiOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclMinusOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileMinusOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclDivOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileDivOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclLessOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileLessOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclLeqOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileLeqOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclGreaterOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileGreaterOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclGeqOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileGeqOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclEqOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileEqOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclStreqOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); + +MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); + +/* + * Functions defined in generic/tclVar.c and currently exported only for use + * by the bytecode compiler and engine. Some of these could later be placed in + * the public interface. + */ + +MODULE_SCOPE Var * TclObjLookupVarEx(Tcl_Interp * interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, + const char *msg, const int createPart1, + const int createPart2, Var **arrayPtrPtr); +MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp, + Tcl_Obj *arrayNamePtr, Tcl_Obj *elNamePtr, + const int flags, const char *msg, + const int createPart1, const int createPart2, + Var *arrayPtr, int index); +MODULE_SCOPE Tcl_Obj * TclPtrGetVarIdx(Tcl_Interp *interp, + Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, const int flags, int index); +MODULE_SCOPE Tcl_Obj * TclPtrSetVarIdx(Tcl_Interp *interp, + Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, + const int flags, int index); +MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVarIdx(Tcl_Interp *interp, + Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, + const int flags, int index); +MODULE_SCOPE int TclPtrObjMakeUpvarIdx(Tcl_Interp *interp, + Var *otherPtr, Tcl_Obj *myNamePtr, int myFlags, + int index); +MODULE_SCOPE int TclPtrUnsetVarIdx(Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, const int flags, + int index); +MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); +MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, + Tcl_HashTable *tablePtr); + +/* + * The new extended interface to the variable traces. + */ + +MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, + Var *varPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + int flags, int leaveErrMsg, int index); + +/* + * So tclObj.c and tclDictObj.c can share these implementations. + */ + +MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); +MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); +MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); + +MODULE_SCOPE int TclFullFinalizationRequested(void); + +/* + *---------------------------------------------------------------- + * Macros used by the Tcl core to create and release Tcl objects. + * TclNewObj(objPtr) creates a new object denoting an empty string. + * TclDecrRefCount(objPtr) decrements the object's reference count, and frees + * the object if its reference count is zero. These macros are inline versions + * of Tcl_NewObj() and Tcl_DecrRefCount(). Notice that the names differ in not + * having a "_" after the "Tcl". Notice also that these macros reference their + * argument more than once, so you should avoid calling them with an + * expression that is expensive to compute or has side effects. The ANSI C + * "prototypes" for these macros are: + * + * MODULE_SCOPE void TclNewObj(Tcl_Obj *objPtr); + * MODULE_SCOPE void TclDecrRefCount(Tcl_Obj *objPtr); + * + * These macros are defined in terms of two macros that depend on memory + * allocator in use: TclAllocObjStorage, TclFreeObjStorage. They are defined + * below. + *---------------------------------------------------------------- + */ + +/* + * DTrace object allocation probe macros. + */ + +#ifdef USE_DTRACE +#ifndef _TCLDTRACE_H +typedef const char *TclDTraceStr; +#include "tclDTrace.h" +#endif +#define TCL_DTRACE_OBJ_CREATE(objPtr) TCL_OBJ_CREATE(objPtr) +#define TCL_DTRACE_OBJ_FREE(objPtr) TCL_OBJ_FREE(objPtr) +#else /* USE_DTRACE */ +#define TCL_DTRACE_OBJ_CREATE(objPtr) {} +#define TCL_DTRACE_OBJ_FREE(objPtr) {} +#endif /* USE_DTRACE */ + +#ifdef TCL_COMPILE_STATS +# define TclIncrObjsAllocated() \ + tclObjsAlloced++ +# define TclIncrObjsFreed() \ + tclObjsFreed++ +#else +# define TclIncrObjsAllocated() +# define TclIncrObjsFreed() +#endif /* TCL_COMPILE_STATS */ + +# define TclAllocObjStorage(objPtr) \ + TclAllocObjStorageEx(NULL, (objPtr)) + +# define TclFreeObjStorage(objPtr) \ + TclFreeObjStorageEx(NULL, (objPtr)) + +#ifndef TCL_MEM_DEBUG +# define TclNewObj(objPtr) \ + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->length = 0; \ + (objPtr)->typePtr = NULL; \ + TCL_DTRACE_OBJ_CREATE(objPtr) + +/* + * Invalidate the string rep first so we can use the bytes value for our + * pointer chain, and signal an obj deletion (as opposed to shimmering) with + * 'length == -1'. + * Use empty 'if ; else' to handle use in unbraced outer if/else conditions. + */ + +# define TclDecrRefCount(objPtr) \ + if ((objPtr)->refCount-- > 1) ; else { \ + if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \ + TCL_DTRACE_OBJ_FREE(objPtr); \ + if ((objPtr)->bytes \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ + ckfree((char *) (objPtr)->bytes); \ + } \ + (objPtr)->length = -1; \ + TclFreeObjStorage(objPtr); \ + TclIncrObjsFreed(); \ + } else { \ + TclFreeObj(objPtr); \ + } \ + } + +#if defined(PURIFY) + +/* + * The PURIFY mode is like the regular mode, but instead of doing block + * Tcl_Obj allocation and keeping a freed list for efficiency, it always + * allocates and frees a single Tcl_Obj so that tools like Purify can better + * track memory leaks. + */ + +# define TclAllocObjStorageEx(interp, objPtr) \ + (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)) + +# define TclFreeObjStorageEx(interp, objPtr) \ + ckfree((char *) (objPtr)) + +#undef USE_THREAD_ALLOC +#undef USE_TCLALLOC +#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + +/* + * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from + * per-thread caches. + */ + +MODULE_SCOPE Tcl_Obj * TclThreadAllocObj(void); +MODULE_SCOPE void TclThreadFreeObj(Tcl_Obj *); +MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); +MODULE_SCOPE void TclFreeAllocCache(void *); +MODULE_SCOPE void * TclpGetAllocCache(void); +MODULE_SCOPE void TclpSetAllocCache(void *); +MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex); +MODULE_SCOPE void TclpFreeAllocCache(void *); + +/* + * These macros need to be kept in sync with the code of TclThreadAllocObj() + * and TclThreadFreeObj(). + * + * Note that the optimiser should resolve the case (interp==NULL) at compile + * time. + */ + +# define ALLOC_NOBJHIGH 1200 + +# define TclAllocObjStorageEx(interp, objPtr) \ + do { \ + AllocCache *cachePtr; \ + if (((interp) == NULL) || \ + ((cachePtr = ((Interp *)(interp))->allocCache), \ + (cachePtr->numObjects == 0))) { \ + (objPtr) = TclThreadAllocObj(); \ + } else { \ + (objPtr) = cachePtr->firstObjPtr; \ + cachePtr->firstObjPtr = (objPtr)->internalRep.twoPtrValue.ptr1; \ + --cachePtr->numObjects; \ + } \ + } while (0) + +# define TclFreeObjStorageEx(interp, objPtr) \ + do { \ + AllocCache *cachePtr; \ + if (((interp) == NULL) || \ + ((cachePtr = ((Interp *)(interp))->allocCache), \ + ((cachePtr->numObjects == 0) || \ + (cachePtr->numObjects >= ALLOC_NOBJHIGH)))) { \ + TclThreadFreeObj(objPtr); \ + } else { \ + (objPtr)->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; \ + cachePtr->firstObjPtr = objPtr; \ + ++cachePtr->numObjects; \ + } \ + } while (0) + +#else /* not PURIFY or USE_THREAD_ALLOC */ + +#if defined(USE_TCLALLOC) && USE_TCLALLOC + MODULE_SCOPE void TclFinalizeAllocSubsystem(); + MODULE_SCOPE void TclInitAlloc(); +#else +# define USE_TCLALLOC 0 +#endif + +#ifdef TCL_THREADS +/* declared in tclObj.c */ +MODULE_SCOPE Tcl_Mutex tclObjMutex; +#endif + +# define TclAllocObjStorageEx(interp, objPtr) \ + do { \ + Tcl_MutexLock(&tclObjMutex); \ + if (tclFreeObjList == NULL) { \ + TclAllocateFreeObjects(); \ + } \ + (objPtr) = tclFreeObjList; \ + tclFreeObjList = (Tcl_Obj *) \ + tclFreeObjList->internalRep.twoPtrValue.ptr1; \ + Tcl_MutexUnlock(&tclObjMutex); \ + } while (0) + +# define TclFreeObjStorageEx(interp, objPtr) \ + do { \ + Tcl_MutexLock(&tclObjMutex); \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList; \ + tclFreeObjList = (objPtr); \ + Tcl_MutexUnlock(&tclObjMutex); \ + } while (0) +#endif + +#else /* TCL_MEM_DEBUG */ +MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, + int line); + +# define TclDbNewObj(objPtr, file, line) \ + do { \ + TclIncrObjsAllocated(); \ + (objPtr) = (Tcl_Obj *) \ + Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ + TclDbInitNewObj((objPtr), (file), (line)); \ + TCL_DTRACE_OBJ_CREATE(objPtr); \ + } while (0) + +# define TclNewObj(objPtr) \ + TclDbNewObj(objPtr, __FILE__, __LINE__); + +# define TclDecrRefCount(objPtr) \ + Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) + +# define TclNewListObjDirect(objc, objv) \ + TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__) + +#undef USE_THREAD_ALLOC +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to set a Tcl_Obj's string representation to a + * copy of the "len" bytes starting at "bytePtr". This code works even if the + * byte array contains NULLs as long as the length is correct. Because "len" + * is referenced multiple times, it should be as simple an expression as + * possible. The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len); + * + * This macro should only be called on an unshared objPtr where + * objPtr->typePtr->freeIntRepProc == NULL + *---------------------------------------------------------------- + */ + +#define TclInitStringRep(objPtr, bytePtr, len) \ + if ((len) == 0) { \ + (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->length = 0; \ + } else { \ + (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ + memcpy((objPtr)->bytes, (bytePtr), (unsigned) (len)); \ + (objPtr)->bytes[len] = '\0'; \ + (objPtr)->length = (len); \ + } + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to get the string representation's byte array + * pointer from a Tcl_Obj. This is an inline version of Tcl_GetString(). The + * macro's expression result is the string rep's byte pointer which might be + * NULL. The bytes referenced by this pointer must not be modified by the + * caller. The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE char * TclGetString(Tcl_Obj *objPtr); + *---------------------------------------------------------------- + */ + +#define TclGetString(objPtr) \ + ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr))) + +#define TclGetStringFromObj(objPtr, lenPtr) \ + ((objPtr)->bytes \ + ? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \ + : Tcl_GetStringFromObj((objPtr), (lenPtr))) + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to clean out an object's internal + * representation. Does not actually reset the rep's bytes. The ANSI C + * "prototype" for this macro is: + * + * MODULE_SCOPE void TclFreeIntRep(Tcl_Obj *objPtr); + *---------------------------------------------------------------- + */ + +#define TclFreeIntRep(objPtr) \ + if ((objPtr)->typePtr != NULL) { \ + if ((objPtr)->typePtr->freeIntRepProc != NULL) { \ + (objPtr)->typePtr->freeIntRepProc(objPtr); \ + } \ + (objPtr)->typePtr = NULL; \ + } + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to clean out an object's string representation. + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr); + *---------------------------------------------------------------- + */ + +#define TclInvalidateStringRep(objPtr) \ + if (objPtr->bytes != NULL) { \ + if (objPtr->bytes != tclEmptyStringRep) { \ + ckfree((char *) objPtr->bytes); \ + } \ + objPtr->bytes = NULL; \ + } + +/* + *---------------------------------------------------------------- + * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same + * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C + * "prototype" for this macro is: + * + * MODULE_SCOPE void TclGrowTokenArray(Tcl_Token *tokenPtr, int used, + * int available, int append, + * Tcl_Token *staticPtr); + * MODULE_SCOPE void TclGrowParseTokenArray(Tcl_Parse *parsePtr, + * int append); + *---------------------------------------------------------------- + */ + +/* General tuning for minimum growth in Tcl growth algorithms */ +#ifndef TCL_MIN_GROWTH +# ifdef TCL_GROWTH_MIN_ALLOC + /* Support for any legacy tuners */ +# define TCL_MIN_GROWTH TCL_GROWTH_MIN_ALLOC +# else +# define TCL_MIN_GROWTH 1024 +# endif +#endif + +/* Token growth tuning, default to the general value. */ +#ifndef TCL_MIN_TOKEN_GROWTH +#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token) +#endif + +#define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token)) +#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \ + do { \ + int _needed = (used) + (append); \ + if (_needed > TCL_MAX_TOKENS) { \ + Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", \ + TCL_MAX_TOKENS); \ + } \ + if (_needed > (available)) { \ + int allocated = 2 * _needed; \ + Tcl_Token *oldPtr = (tokenPtr); \ + Tcl_Token *newPtr; \ + if (oldPtr == (staticPtr)) { \ + oldPtr = NULL; \ + } \ + if (allocated > TCL_MAX_TOKENS) { \ + allocated = TCL_MAX_TOKENS; \ + } \ + newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \ + (unsigned int) (allocated * sizeof(Tcl_Token))); \ + if (newPtr == NULL) { \ + allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \ + if (allocated > TCL_MAX_TOKENS) { \ + allocated = TCL_MAX_TOKENS; \ + } \ + newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr, \ + (unsigned int) (allocated * sizeof(Tcl_Token))); \ + } \ + (available) = allocated; \ + if (oldPtr == NULL) { \ + memcpy(newPtr, staticPtr, \ + (size_t) ((used) * sizeof(Tcl_Token))); \ + } \ + (tokenPtr) = newPtr; \ + } \ + } while (0) + +#define TclGrowParseTokenArray(parsePtr, append) \ + TclGrowTokenArray((parsePtr)->tokenPtr, (parsePtr)->numTokens, \ + (parsePtr)->tokensAvailable, (append), \ + (parsePtr)->staticTokens) + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core get a unicode char from a utf string. It checks + * to see if we have a one-byte utf char before calling the real + * Tcl_UtfToUniChar, as this will save a lot of time for primarily ASCII + * string handling. The macro's expression result is 1 for the 1-byte case or + * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); + *---------------------------------------------------------------- + */ + +#define TclUtfToUniChar(str, chPtr) \ + ((((unsigned char) *(str)) < 0xC0) ? \ + ((*(chPtr) = (unsigned char) *(str)), 1) \ + : Tcl_UtfToUniChar(str, chPtr)) + +/* + *---------------------------------------------------------------- + * Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed- + * -sensitive points where it pays to avoid a function call in the common case + * of counting along a string of all one-byte characters. The ANSI C + * "prototype" for this macro is: + * + * MODULE_SCOPE void TclNumUtfChars(int numChars, const char *bytes, + * int numBytes); + *---------------------------------------------------------------- + */ + +#define TclNumUtfChars(numChars, bytes, numBytes) \ + do { \ + int _count, _i = (numBytes); \ + unsigned char *_str = (unsigned char *) (bytes); \ + while (_i && (*_str < 0xC0)) { _i--; _str++; } \ + _count = (numBytes) - _i; \ + if (_i) { \ + _count += Tcl_NumUtfChars((bytes) + _count, _i); \ + } \ + (numChars) = _count; \ + } while (0); + +/* + *---------------------------------------------------------------- + * Macro that encapsulates the logic that determines when it is safe to + * interpret a string as a byte array directly. In summary, the object must be + * a byte array and must not have a string representation (as the operations + * that it is used in are defined on strings, not byte arrays). Theoretically + * it is possible to also be efficient in the case where the object's bytes + * field is filled by generation from the byte array (c.f. list canonicality) + * but we don't do that at the moment since this is purely about efficiency. + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); + *---------------------------------------------------------------- + */ + +#define TclIsPureByteArray(objPtr) \ + (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL)) + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to compare Unicode strings. On big-endian + * systems we can use the more efficient memcmp, but this would not be + * lexically correct on little-endian systems. The ANSI C "prototype" for + * this macro is: + * + * MODULE_SCOPE int TclUniCharNcmp(const Tcl_UniChar *cs, + * const Tcl_UniChar *ct, unsigned long n); + *---------------------------------------------------------------- + */ + +#ifdef WORDS_BIGENDIAN +# define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) +#else /* !WORDS_BIGENDIAN */ +# define TclUniCharNcmp Tcl_UniCharNcmp +#endif /* WORDS_BIGENDIAN */ + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to increment a namespace's export epoch + * counter. The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); + *---------------------------------------------------------------- + */ + +#define TclInvalidateNsCmdLookup(nsPtr) \ + if ((nsPtr)->numExportPatterns) { \ + (nsPtr)->exportLookupEpoch++; \ + } \ + if ((nsPtr)->commandPathLength) { \ + (nsPtr)->cmdRefEpoch++; \ + } + +/* + *---------------------------------------------------------------------- + * + * Core procedure added to libtommath for bignum manipulation. + * + *---------------------------------------------------------------------- + */ + +MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init; + +/* + *---------------------------------------------------------------------- + * + * External (platform specific) initialization routine, these declarations + * explicitly don't use EXTERN since this code does not get compiled into the + * library: + * + *---------------------------------------------------------------------- + */ + +MODULE_SCOPE Tcl_PackageInitProc TclplatformtestInit; +MODULE_SCOPE Tcl_PackageInitProc TclObjTest_Init; +MODULE_SCOPE Tcl_PackageInitProc TclThread_Init; +MODULE_SCOPE Tcl_PackageInitProc Procbodytest_Init; +MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to check whether a pattern has any characters + * special to [string match]. The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclMatchIsTrivial(const char *pattern); + *---------------------------------------------------------------- + */ + +#define TclMatchIsTrivial(pattern) \ + (strpbrk((pattern), "*[?\\") == NULL) + +/* + *---------------------------------------------------------------- + * Macros used by the Tcl core to set a Tcl_Obj's numeric representation + * avoiding the corresponding function calls in time critical parts of the + * core. They should only be called on unshared objects. The ANSI C + * "prototypes" for these macros are: + * + * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue); + * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue); + * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue); + * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); + *---------------------------------------------------------------- + */ + +#define TclSetLongObj(objPtr, i) \ + do { \ + TclInvalidateStringRep(objPtr); \ + TclFreeIntRep(objPtr); \ + (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->typePtr = &tclIntType; \ + } while (0) + +#define TclSetIntObj(objPtr, l) \ + TclSetLongObj(objPtr, l) + +/* + * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set + * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1. + * The only "boolean" Tcl_Obj's shall be those holding the cached boolean + * value of strings like: "yes", "no", "true", "false", "on", "off". + */ + +#define TclSetBooleanObj(objPtr, b) \ + TclSetLongObj(objPtr, (b)!=0); + +#ifndef TCL_WIDE_INT_IS_LONG +#define TclSetWideIntObj(objPtr, w) \ + do { \ + TclInvalidateStringRep(objPtr); \ + TclFreeIntRep(objPtr); \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ + (objPtr)->typePtr = &tclWideIntType; \ + } while (0) +#endif + +#define TclSetDoubleObj(objPtr, d) \ + do { \ + TclInvalidateStringRep(objPtr); \ + TclFreeIntRep(objPtr); \ + (objPtr)->internalRep.doubleValue = (double)(d); \ + (objPtr)->typePtr = &tclDoubleType; \ + } while (0) + +/* + *---------------------------------------------------------------- + * Macros used by the Tcl core to create and initialise objects of standard + * types, avoiding the corresponding function calls in time critical parts of + * the core. The ANSI C "prototypes" for these macros are: + * + * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i); + * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l); + * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b); + * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len); + * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral); + * + *---------------------------------------------------------------- + */ + +#ifndef TCL_MEM_DEBUG +#define TclNewLongObj(objPtr, i) \ + do { \ + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = NULL; \ + (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->typePtr = &tclIntType; \ + TCL_DTRACE_OBJ_CREATE(objPtr); \ + } while (0) + +#define TclNewIntObj(objPtr, l) \ + TclNewLongObj(objPtr, l) + +/* + * NOTE: There is to be no such thing as a "pure" boolean. + * See comment above TclSetBooleanObj macro above. + */ +#define TclNewBooleanObj(objPtr, b) \ + TclNewLongObj((objPtr), (b)!=0) + +#define TclNewDoubleObj(objPtr, d) \ + do { \ + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = NULL; \ + (objPtr)->internalRep.doubleValue = (double)(d); \ + (objPtr)->typePtr = &tclDoubleType; \ + TCL_DTRACE_OBJ_CREATE(objPtr); \ + } while (0) + +#define TclNewStringObj(objPtr, s, len) \ + do { \ + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + TclInitStringRep((objPtr), (s), (len)); \ + (objPtr)->typePtr = NULL; \ + TCL_DTRACE_OBJ_CREATE(objPtr); \ + } while (0) + +#else /* TCL_MEM_DEBUG */ +#define TclNewIntObj(objPtr, i) \ + (objPtr) = Tcl_NewIntObj(i) + +#define TclNewLongObj(objPtr, l) \ + (objPtr) = Tcl_NewLongObj(l) + +#define TclNewBooleanObj(objPtr, b) \ + (objPtr) = Tcl_NewBooleanObj(b) + +#define TclNewDoubleObj(objPtr, d) \ + (objPtr) = Tcl_NewDoubleObj(d) + +#define TclNewStringObj(objPtr, s, len) \ + (objPtr) = Tcl_NewStringObj((s), (len)) +#endif /* TCL_MEM_DEBUG */ + +/* + * The sLiteral argument *must* be a string literal; the incantation with + * sizeof(sLiteral "") will fail to compile otherwise. + */ +#define TclNewLiteralStringObj(objPtr, sLiteral) \ + TclNewStringObj((objPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1)) + +/* + *---------------------------------------------------------------- + * Convenience macros for DStrings. + * The ANSI C "prototypes" for these macros are: + * + * MODULE_SCOPE char * TclDStringAppendLiteral(Tcl_DString *dsPtr, + * const char *sLiteral); + * MODULE_SCOPE void TclDStringClear(Tcl_DString *dsPtr); + */ + +#define TclDStringAppendLiteral(dsPtr, sLiteral) \ + Tcl_DStringAppend((dsPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1)) +#define TclDStringClear(dsPtr) \ + Tcl_DStringSetLength((dsPtr), 0) + +/* + *---------------------------------------------------------------- + * Macros used by the Tcl core to test for some special double values. + * The ANSI C "prototypes" for these macros are: + * + * MODULE_SCOPE int TclIsInfinite(double d); + * MODULE_SCOPE int TclIsNaN(double d); + */ + +#ifdef _MSC_VER +# define TclIsInfinite(d) (!(_finite((d)))) +# define TclIsNaN(d) (_isnan((d))) +#else +# define TclIsInfinite(d) ((d) > DBL_MAX || (d) < -DBL_MAX) +# ifdef NO_ISNAN +# define TclIsNaN(d) ((d) != (d)) +# else +# define TclIsNaN(d) (isnan(d)) +# endif +#endif + +/* + * ---------------------------------------------------------------------- + * Macro to use to find the offset of a field in a structure. Computes number + * of bytes from beginning of structure to a given field. + */ + +#ifdef offsetof +#define TclOffset(type, field) ((int) offsetof(type, field)) +#else +#define TclOffset(type, field) ((int) ((char *) &((type *) 0)->field)) +#endif + +/* + *---------------------------------------------------------------- + * Inline version of Tcl_GetCurrentNamespace and Tcl_GetGlobalNamespace. + */ + +#define TclGetCurrentNamespace(interp) \ + (Tcl_Namespace *) ((Interp *)(interp))->varFramePtr->nsPtr + +#define TclGetGlobalNamespace(interp) \ + (Tcl_Namespace *) ((Interp *)(interp))->globalNsPtr + +/* + *---------------------------------------------------------------- + * Inline version of TclCleanupCommand; still need the function as it is in + * the internal stubs, but the core can use the macro instead. + */ + +#define TclCleanupCommandMacro(cmdPtr) \ + if ((cmdPtr)->refCount-- <= 1) { \ + ckfree((char *) (cmdPtr));\ + } + +/* + *---------------------------------------------------------------- + * Inline versions of Tcl_LimitReady() and Tcl_LimitExceeded to limit number + * of calls out of the critical path. Note that this code isn't particularly + * readable; the non-inline version (in tclInterp.c) is much easier to + * understand. Note also that these macros takes different args (iPtr->limit) + * to the non-inline version. + */ + +#define TclLimitExceeded(limit) ((limit).exceeded != 0) + +#define TclLimitReady(limit) \ + (((limit).active == 0) ? 0 : \ + (++(limit).granularityTicker, \ + ((((limit).active & TCL_LIMIT_COMMANDS) && \ + (((limit).cmdGranularity == 1) || \ + ((limit).granularityTicker % (limit).cmdGranularity == 0))) \ + ? 1 : \ + (((limit).active & TCL_LIMIT_TIME) && \ + (((limit).timeGranularity == 1) || \ + ((limit).granularityTicker % (limit).timeGranularity == 0)))\ + ? 1 : 0))) + +/* + * Compile-time assertions: these produce a compile time error if the + * expression is not known to be true at compile time. If the assertion is + * known to be false, the compiler (or optimizer?) will error out with + * "division by zero". If the assertion cannot be evaluated at compile time, + * the compiler will error out with "non-static initializer". + * + * Adapted with permission from + * http://www.pixelbeat.org/programming/gcc/static_assert.html + */ + +#define TCL_CT_ASSERT(e) \ + {enum { ct_assert_value = 1/(!!(e)) };} + +/* + *---------------------------------------------------------------- + * Allocator for small structs (<=sizeof(Tcl_Obj)) using the Tcl_Obj pool. + * Only checked at compile time. + * + * ONLY USE FOR CONSTANT nBytes. + * + * DO NOT LET THEM CROSS THREAD BOUNDARIES + *---------------------------------------------------------------- + */ + +#define TclSmallAlloc(nbytes, memPtr) \ + TclSmallAllocEx(NULL, (nbytes), (memPtr)) + +#define TclSmallFree(memPtr) \ + TclSmallFreeEx(NULL, (memPtr)) + +#ifndef TCL_MEM_DEBUG +#define TclSmallAllocEx(interp, nbytes, memPtr) \ + do { \ + Tcl_Obj *_objPtr; \ + TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ + TclIncrObjsAllocated(); \ + TclAllocObjStorageEx((interp), (_objPtr)); \ + memPtr = (ClientData) (_objPtr); \ + } while (0) + +#define TclSmallFreeEx(interp, memPtr) \ + do { \ + TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr)); \ + TclIncrObjsFreed(); \ + } while (0) + +#else /* TCL_MEM_DEBUG */ +#define TclSmallAllocEx(interp, nbytes, memPtr) \ + do { \ + Tcl_Obj *_objPtr; \ + TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ + TclNewObj(_objPtr); \ + memPtr = (ClientData) _objPtr; \ + } while (0) + +#define TclSmallFreeEx(interp, memPtr) \ + do { \ + Tcl_Obj *_objPtr = (Tcl_Obj *) memPtr; \ + _objPtr->bytes = NULL; \ + _objPtr->typePtr = NULL; \ + _objPtr->refCount = 1; \ + TclDecrRefCount(_objPtr); \ + } while (0) +#endif /* TCL_MEM_DEBUG */ + +/* + * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org> + */ + +#if defined(PURIFY) && defined(__clang__) +#if __has_feature(attribute_analyzer_noreturn) && \ + !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED) +void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); +#endif +#if !defined(CLANG_ASSERT) +#include <assert.h> +#define CLANG_ASSERT(x) assert(x) +#endif +#elif !defined(CLANG_ASSERT) +#define CLANG_ASSERT(x) +#endif /* PURIFY && __clang__ */ + +/* + *---------------------------------------------------------------- + * Parameters, structs and macros for the non-recursive engine (NRE) + *---------------------------------------------------------------- + */ + +#define NRE_USE_SMALL_ALLOC 1 /* Only turn off for debugging purposes. */ +#ifndef NRE_ENABLE_ASSERTS +#define NRE_ENABLE_ASSERTS 0 +#endif + +/* + * This is the main data struct for representing NR commands. It is designed + * to fit in sizeof(Tcl_Obj) in order to exploit the fastest memory allocator + * available. + */ + +typedef struct NRE_callback { + Tcl_NRPostProc *procPtr; + ClientData data[4]; + struct NRE_callback *nextPtr; +} NRE_callback; + +#define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr) + +/* + * Inline version of Tcl_NRAddCallback. + */ + +#define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \ + do { \ + NRE_callback *_callbackPtr; \ + TCLNR_ALLOC((interp), (_callbackPtr)); \ + _callbackPtr->procPtr = (postProcPtr); \ + _callbackPtr->data[0] = (ClientData)(data0); \ + _callbackPtr->data[1] = (ClientData)(data1); \ + _callbackPtr->data[2] = (ClientData)(data2); \ + _callbackPtr->data[3] = (ClientData)(data3); \ + _callbackPtr->nextPtr = TOP_CB(interp); \ + TOP_CB(interp) = _callbackPtr; \ + } while (0) + +#if NRE_USE_SMALL_ALLOC +#define TCLNR_ALLOC(interp, ptr) \ + TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr)) +#define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr)) +#else +#define TCLNR_ALLOC(interp, ptr) \ + (ptr = ((ClientData) ckalloc(sizeof(NRE_callback)))) +#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr)) +#endif + +#if NRE_ENABLE_ASSERTS +#define NRE_ASSERT(expr) assert((expr)) +#else +#define NRE_ASSERT(expr) +#endif + +#include "tclIntDecls.h" +#include "tclIntPlatDecls.h" +#include "tclTomMathDecls.h" + +#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG) +#define Tcl_AttemptAlloc(size) TclpAlloc(size) +#define Tcl_AttemptRealloc(ptr, size) TclpRealloc((ptr), (size)) +#define Tcl_Free(ptr) TclpFree(ptr) +#endif + +#endif /* _TCLINT */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclOO.c b/generic/tclOO.c new file mode 100644 index 0000000..a27f92c --- /dev/null +++ b/generic/tclOO.c @@ -0,0 +1,3073 @@ +/* + * tclOO.c -- + * + * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) + * + * Copyright (c) 2005-2012 by Donal K. Fellows + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "tclInt.h" +#include "tclOOInt.h" + +/* + * Commands in oo::define. + */ + +static const struct { + const char *name; + Tcl_ObjCmdProc *objProc; + int flag; +} defineCmds[] = { + {"constructor", TclOODefineConstructorObjCmd, 0}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, + {"destructor", TclOODefineDestructorObjCmd, 0}, + {"export", TclOODefineExportObjCmd, 0}, + {"forward", TclOODefineForwardObjCmd, 0}, + {"method", TclOODefineMethodObjCmd, 0}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, + {"self", TclOODefineSelfObjCmd, 0}, + {"unexport", TclOODefineUnexportObjCmd, 0}, + {NULL, NULL, 0} +}, objdefCmds[] = { + {"class", TclOODefineClassObjCmd, 1}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, + {"export", TclOODefineExportObjCmd, 1}, + {"forward", TclOODefineForwardObjCmd, 1}, + {"method", TclOODefineMethodObjCmd, 1}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, + {"unexport", TclOODefineUnexportObjCmd, 1}, + {NULL, NULL, 0} +}; + +/* + * What sort of size of things we like to allocate. + */ + +#define ALLOC_CHUNK 8 + +/* + * Function declarations for things defined in this file. + */ + +static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); +static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, + const char *nsNameStr); +static void ClearMixins(Class *clsPtr); +static void ClearSuperclasses(Class *clsPtr); +static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, + Method *mPtr, Tcl_Obj *namePtr, + Method **newMPtrPtr); +static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, + Method *mPtr, Tcl_Obj *namePtr); +static void DeletedDefineNamespace(ClientData clientData); +static void DeletedObjdefNamespace(ClientData clientData); +static void DeletedHelpersNamespace(ClientData clientData); +static Tcl_NRPostProc FinalizeAlloc; +static Tcl_NRPostProc FinalizeNext; +static Tcl_NRPostProc FinalizeObjectCall; +static int InitFoundation(Tcl_Interp *interp); +static void KillFoundation(ClientData clientData, + Tcl_Interp *interp); +static void MyDeleted(ClientData clientData); +static void ObjectNamespaceDeleted(ClientData clientData); +static void ObjectRenamedTrace(ClientData clientData, + Tcl_Interp *interp, const char *oldName, + const char *newName, int flags); +static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); +static inline void SquelchCachedName(Object *oPtr); +static void SquelchedNsFirst(ClientData clientData); + +static int PublicObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +static int PublicNRObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +static int PrivateObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +static int PrivateNRObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); + +/* + * Methods in the oo::object and oo::class classes. First, we define a helper + * macro that makes building the method type declaration structure a lot + * easier. No point in making life harder than it has to be! + * + * Note that the core methods don't need clone or free proc callbacks. + */ + +#define DCM(name,visibility,proc) \ + {name,visibility,\ + {TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}} + +static const DeclaredClassMethod objMethods[] = { + DCM("destroy", 1, TclOO_Object_Destroy), + DCM("eval", 0, TclOO_Object_Eval), + DCM("unknown", 0, TclOO_Object_Unknown), + DCM("variable", 0, TclOO_Object_LinkVar), + DCM("varname", 0, TclOO_Object_VarName), + {NULL, 0, {0, NULL, NULL, NULL, NULL}} +}, clsMethods[] = { + DCM("create", 1, TclOO_Class_Create), + DCM("new", 1, TclOO_Class_New), + DCM("createWithNamespace", 0, TclOO_Class_CreateNs), + {NULL, 0, {0, NULL, NULL, NULL, NULL}} +}; + +/* + * And for the oo::class constructor... + */ + +static const Tcl_MethodType classConstructor = { + TCL_OO_METHOD_VERSION_CURRENT, + "oo::class constructor", + TclOO_Class_Constructor, NULL, NULL +}; + +/* + * Scripted parts of TclOO. First, the master script (cannot be outside this + * file). + */ + +static const char *initScript = +"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" +"namespace eval ::oo { variable version " TCLOO_VERSION " };" +"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; +/* "tcl_findLibrary tcloo $oo::version $oo::version" */ +/* " tcloo.tcl OO_LIBRARY oo::library;"; */ + +/* + * The scripted part of the definitions of slots. + */ + +static const char *slotScript = +"::oo::define ::oo::Slot {\n" +" method Get {} {error unimplemented}\n" +" method Set list {error unimplemented}\n" +" method -set args {\n" +" uplevel 1 [list [namespace which my] Set $args]\n" +" }\n" +" method -append args {\n" +" uplevel 1 [list [namespace which my] Set [list" +" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n" +" }\n" +" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n" +" forward --default-operation my -append\n" +" method unknown {args} {\n" +" set def --default-operation\n" +" if {[llength $args] == 0} {\n" +" return [uplevel 1 [list [namespace which my] $def]]\n" +" } elseif {![string match -* [lindex $args 0]]} {\n" +" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n" +" }\n" +" next {*}$args\n" +" }\n" +" export -set -append -clear\n" +" unexport unknown destroy\n" +"}\n" +"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" +"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" +"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"; + +/* + * The body of the <cloned> method of oo::object. + */ + +static const char *clonedBody = +"foreach p [info procs [info object namespace $originObject]::*] {" +" set args [info args $p];" +" set idx -1;" +" foreach a $args {" +" lset args [incr idx] " +" [if {[info default $p $a d]} {list $a $d} {list $a}]" +" };" +" set b [info body $p];" +" set p [namespace tail $p];" +" proc $p $args $b;" +"};" +"foreach v [info vars [info object namespace $originObject]::*] {" +" upvar 0 $v vOrigin;" +" namespace upvar [namespace current] [namespace tail $v] vNew;" +" if {[info exists vOrigin]} {" +" if {[array exists vOrigin]} {" +" array set vNew [array get vOrigin];" +" } else {" +" set vNew $vOrigin;" +" }" +" }" +"}"; + +/* + * The actual definition of the variable holding the TclOO stub table. + */ + +MODULE_SCOPE const TclOOStubs tclOOStubs; + +/* + * Convenience macro for getting the foundation from an interpreter. + */ + +#define GetFoundation(interp) \ + ((Foundation *)((Interp *)(interp))->objectFoundation) + +/* + * Macros to make inspecting into the guts of an object cleaner. + * + * The ocPtr parameter (only in these macros) is assumed to work fine with + * either an oPtr or a classPtr. Note that the roots oo::object and oo::class + * have _both_ their object and class flags tagged with ROOT_OBJECT and + * ROOT_CLASS respectively. + */ + +#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL) +#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) +#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) +#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) + +/* + * ---------------------------------------------------------------------- + * + * TclOOInit -- + * + * Called to initialise the OO system within an interpreter. + * + * Result: + * TCL_OK if the setup succeeded. Currently assumed to always work. + * + * Side effects: + * Creates namespaces, commands, several classes and a number of + * callbacks. Upon return, the OO system is ready for use. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOInit( + Tcl_Interp *interp) /* The interpreter to install into. */ +{ + /* + * Build the core of the OO system. + */ + + if (InitFoundation(interp) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Run our initialization script and, if that works, declare the package + * to be fully provided. + */ + + if (Tcl_Eval(interp, initScript) != TCL_OK) { + return TCL_ERROR; + } + + return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, + (ClientData) &tclOOStubs); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOGetFoundation -- + * + * Get a reference to the OO core class system. + * + * ---------------------------------------------------------------------- + */ + +Foundation * +TclOOGetFoundation( + Tcl_Interp *interp) +{ + return GetFoundation(interp); +} + +/* + * ---------------------------------------------------------------------- + * + * InitFoundation -- + * + * Set up the core of the OO core class system. This is a structure + * holding references to the magical bits that need to be known about in + * other places, plus the oo::object and oo::class classes. + * + * ---------------------------------------------------------------------- + */ + +static int +InitFoundation( + Tcl_Interp *interp) +{ + static Tcl_ThreadDataKey tsdKey; + ThreadLocalData *tsdPtr = + Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); + Foundation *fPtr = ckalloc(sizeof(Foundation)); + Tcl_Obj *namePtr, *argsPtr, *bodyPtr; + Tcl_DString buffer; + Command *cmdPtr; + int i; + + /* + * Initialize the structure that holds the OO system core. This is + * attached to the interpreter via an assocData entry; not very efficient, + * but the best we can do without hacking the core more. + */ + + memset(fPtr, 0, sizeof(Foundation)); + ((Interp *) interp)->objectFoundation = fPtr; + fPtr->interp = interp; + fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL); + Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1); + fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr, + DeletedDefineNamespace); + fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr, + DeletedObjdefNamespace); + fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr, + DeletedHelpersNamespace); + fPtr->epoch = 0; + fPtr->tsdPtr = tsdPtr; + TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown"); + TclNewLiteralStringObj(fPtr->constructorName, "<constructor>"); + TclNewLiteralStringObj(fPtr->destructorName, "<destructor>"); + TclNewLiteralStringObj(fPtr->clonedName, "<cloned>"); + TclNewLiteralStringObj(fPtr->defineName, "::oo::define"); + Tcl_IncrRefCount(fPtr->unknownMethodNameObj); + Tcl_IncrRefCount(fPtr->constructorName); + Tcl_IncrRefCount(fPtr->destructorName); + Tcl_IncrRefCount(fPtr->clonedName); + Tcl_IncrRefCount(fPtr->defineName); + Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition", + TclOOUnknownDefinition, NULL, NULL); + TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition"); + Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr); + Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr); + + /* + * Create the subcommands in the oo::define and oo::objdefine spaces. + */ + + Tcl_DStringInit(&buffer); + for (i=0 ; defineCmds[i].name ; i++) { + TclDStringAppendLiteral(&buffer, "::oo::define::"); + Tcl_DStringAppend(&buffer, defineCmds[i].name, -1); + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), + defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL); + Tcl_DStringFree(&buffer); + } + for (i=0 ; objdefCmds[i].name ; i++) { + TclDStringAppendLiteral(&buffer, "::oo::objdefine::"); + Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1); + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), + objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL); + Tcl_DStringFree(&buffer); + } + + Tcl_CallWhenDeleted(interp, KillFoundation, NULL); + + /* + * Create the objects at the core of the object system. These need to be + * spliced manually. + */ + + fPtr->objectCls = AllocClass(interp, + AllocObject(interp, "::oo::object", NULL)); + fPtr->classCls = AllocClass(interp, + AllocObject(interp, "::oo::class", NULL)); + fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; + fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; + fPtr->objectCls->flags |= ROOT_OBJECT; + fPtr->objectCls->superclasses.num = 0; + ckfree(fPtr->objectCls->superclasses.list); + fPtr->objectCls->superclasses.list = NULL; + fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + fPtr->classCls->thisPtr->flags |= ROOT_CLASS; + fPtr->classCls->flags |= ROOT_CLASS; + TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); + TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); + TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); + AddRef(fPtr->objectCls->thisPtr); + AddRef(fPtr->objectCls); + + /* + * Basic method declarations for the core classes. + */ + + for (i=0 ; objMethods[i].name ; i++) { + TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); + } + for (i=0 ; clsMethods[i].name ; i++) { + TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); + } + + /* + * Create the default <cloned> method implementation, used when 'oo::copy' + * is called to finish the copying of one object to another. + */ + + TclNewLiteralStringObj(argsPtr, "originObject"); + Tcl_IncrRefCount(argsPtr); + bodyPtr = Tcl_NewStringObj(clonedBody, -1); + TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr, + bodyPtr, NULL); + TclDecrRefCount(argsPtr); + + /* + * Finish setting up the class of classes by marking the 'new' method as + * private; classes, unlike general objects, must have explicit names. We + * also need to create the constructor for classes. + */ + + TclNewLiteralStringObj(namePtr, "new"); + Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, + namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL); + fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, + (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); + + /* + * Create non-object commands and plug ourselves into the Tcl [info] + * ensemble. + */ + + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", + NULL, TclOONextObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextCmd; + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", + NULL, TclOONextToObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextToCmd; + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", + TclOOSelfObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectSelfCmd; + Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL); + TclOOInitInfo(interp); + + /* + * Now make the class of slots. + */ + + if (TclOODefineSlots(fPtr) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_Eval(interp, slotScript); +} + +/* + * ---------------------------------------------------------------------- + * + * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace -- + * + * Simple helpers used to clear fields of the foundation when they no + * longer hold useful information. + * + * ---------------------------------------------------------------------- + */ + +static void +DeletedDefineNamespace( + ClientData clientData) +{ + Foundation *fPtr = clientData; + + fPtr->defineNs = NULL; +} + +static void +DeletedObjdefNamespace( + ClientData clientData) +{ + Foundation *fPtr = clientData; + + fPtr->objdefNs = NULL; +} + +static void +DeletedHelpersNamespace( + ClientData clientData) +{ + Foundation *fPtr = clientData; + + fPtr->helpersNs = NULL; +} + +/* + * ---------------------------------------------------------------------- + * + * KillFoundation -- + * + * Delete those parts of the OO core that are not deleted automatically + * when the objects and classes themselves are destroyed. + * + * ---------------------------------------------------------------------- + */ + +static void +KillFoundation( + ClientData clientData, /* Pointer to the OO system foundation + * structure. */ + Tcl_Interp *interp) /* The interpreter containing the OO system + * foundation. */ +{ + Foundation *fPtr = GetFoundation(interp); + + DelRef(fPtr->objectCls->thisPtr); + DelRef(fPtr->objectCls); + TclDecrRefCount(fPtr->unknownMethodNameObj); + TclDecrRefCount(fPtr->constructorName); + TclDecrRefCount(fPtr->destructorName); + TclDecrRefCount(fPtr->clonedName); + TclDecrRefCount(fPtr->defineName); + ckfree(fPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * AllocObject -- + * + * Allocate an object of basic type. Does not splice the object into its + * class's instance list. The caller must set the classPtr on the object, + * either to a class or to NULL. + * + * ---------------------------------------------------------------------- + */ + +static Object * +AllocObject( + Tcl_Interp *interp, /* Interpreter within which to create the + * object. */ + const char *nameStr, /* The name of the object to create, or NULL + * if the OO system should pick the object + * name itself (equal to the namespace + * name). */ + const char *nsNameStr) /* The name of the namespace to create, or + * NULL if the OO system should pick a unique + * name itself. If this is non-NULL but names + * a namespace that already exists, the effect + * will be the same as if this was NULL. */ +{ + Foundation *fPtr = GetFoundation(interp); + Object *oPtr; + Command *cmdPtr; + CommandTrace *tracePtr; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr; + Tcl_Namespace *inNsPtr; + int creationEpoch, ignored; + const char *simpleName; + + oPtr = ckalloc(sizeof(Object)); + memset(oPtr, 0, sizeof(Object)); + + /* + * Every object has a namespace; make one. Note that this also normally + * computes the creation epoch value for the object, a sequence number + * that is unique to the object (and which allows us to manage method + * caching without comparing pointers). + * + * When creating a namespace, we first check to see if the caller + * specified the name for the namespace. If not, we generate namespace + * names using the epoch until such time as a new namespace is actually + * created. + */ + + if (nsNameStr != NULL) { + oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, + ObjectNamespaceDeleted); + if (oPtr->namespacePtr != NULL) { + creationEpoch = ++fPtr->tsdPtr->nsCount; + goto configNamespace; + } + Tcl_ResetResult(interp); + } + + while (1) { + char objName[10 + TCL_INTEGER_SPACE]; + + sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, + ObjectNamespaceDeleted); + if (oPtr->namespacePtr != NULL) { + creationEpoch = fPtr->tsdPtr->nsCount; + break; + } + + /* + * Could not make that namespace, so we make another. But first we + * have to get rid of the error message from Tcl_CreateNamespace, + * since that's something that should not be exposed to the user. + */ + + Tcl_ResetResult(interp); + } + + /* + * Make the namespace know about the helper commands. This grants access + * to the [self] and [next] commands. + */ + + configNamespace: + if (fPtr->helpersNs != NULL) { + TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs); + } + TclOOSetupVariableResolver(oPtr->namespacePtr); + + /* + * Suppress use of compiled versions of the commands in this object's + * namespace and its children; causes wrong behaviour without expensive + * recompilation. [Bug 2037727] + */ + + ((Namespace *) oPtr->namespacePtr)->flags |= NS_SUPPRESS_COMPILATION; + + /* + * Set up a callback to get notification of the deletion of a namespace + * when enough of the namespace still remains to execute commands and + * access variables in it. [Bug 2950259] + */ + + ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst; + + /* + * Fill in the rest of the non-zero/NULL parts of the structure. + */ + + oPtr->fPtr = fPtr; + oPtr->selfCls = fPtr->objectCls; + oPtr->creationEpoch = creationEpoch; + oPtr->refCount = 1; + oPtr->flags = USE_CLASS_CACHE; + + /* + * Finally, create the object commands and initialize the trace on the + * public command (so that the object structures are deleted when the + * command is deleted). + */ + + if (nameStr) { + inNsPtr = TclGetCurrentNamespace(interp); + } else { + nameStr = oPtr->namespacePtr->name; + inNsPtr = oPtr->namespacePtr; + } + + TclGetNamespaceForQualName(interp, nameStr, (Namespace *) inNsPtr, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); + + oPtr->command = TclCreateObjCommandInNs(interp, simpleName, + (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL); + + /* + * Add the NRE command and trace directly. While this breaks a number of + * abstractions, it is faster and we're inside Tcl here so we're allowed. + */ + + cmdPtr = (Command *) oPtr->command; + cmdPtr->nreProc = PublicNRObjectCmd; + cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace)); + tracePtr->traceProc = ObjectRenamedTrace; + tracePtr->clientData = oPtr; + tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; + tracePtr->nextPtr = NULL; + tracePtr->refCount = 1; + + /* + * Access the namespace command table directly when creating "my" to avoid + * a bottleneck in string manipulation. Another abstraction-buster. + */ + + cmdPtr = ckalloc(sizeof(Command)); + memset(cmdPtr, 0, sizeof(Command)); + cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr; + cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my", + &ignored); + cmdPtr->refCount = 1; + cmdPtr->objProc = PrivateObjectCmd; + cmdPtr->deleteProc = MyDeleted; + cmdPtr->objClientData = cmdPtr->deleteData = oPtr; + cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->clientData = cmdPtr; + cmdPtr->nreProc = PrivateNRObjectCmd; + Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr); + oPtr->myCommand = (Tcl_Command) cmdPtr; + + return oPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * SquelchCachedName -- + * + * Encapsulates how to throw away a cached object name. Called from + * object rename traces and at object destruction. + * + * ---------------------------------------------------------------------- + */ + +static inline void +SquelchCachedName( + Object *oPtr) +{ + if (oPtr->cachedNameObj) { + Tcl_DecrRefCount(oPtr->cachedNameObj); + oPtr->cachedNameObj = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * + * MyDeleted -- + * + * This callback is triggered when the object's [my] command is deleted + * by any mechanism. It just marks the object as not having a [my] + * command, and so prevents cleanup of that when the object itself is + * deleted. + * + * ---------------------------------------------------------------------- + */ + +static void +MyDeleted( + ClientData clientData) /* Reference to the object whose [my] has been + * squelched. */ +{ + register Object *oPtr = clientData; + + oPtr->myCommand = NULL; +} + +/* + * ---------------------------------------------------------------------- + * + * SquelchedNsFirst -- + * + * This callback is triggered when the object's namespace is deleted by + * any mechanism. It deletes the object's public command if it has not + * already been deleted, so ensuring that destructors get run at an + * appropriate time. [Bug 2950259] + * + * ---------------------------------------------------------------------- + */ + +static void +SquelchedNsFirst( + ClientData clientData) +{ + Object *oPtr = clientData; + + if (oPtr->command) { + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); + } +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectRenamedTrace -- + * + * This callback is triggered when the object is deleted by any + * mechanism. It runs the destructors and arranges for the actual cleanup + * of the object's namespace, which in turn triggers cleansing of the + * object data structures. + * + * ---------------------------------------------------------------------- + */ + +static void +ObjectRenamedTrace( + ClientData clientData, /* The object being deleted. */ + Tcl_Interp *interp, /* The interpreter containing the object. */ + const char *oldName, /* What the object was (last) called. */ + const char *newName, /* What it's getting renamed to. (unused) */ + int flags) /* Why was the object deleted? */ +{ + Object *oPtr = clientData; + Foundation *fPtr = oPtr->fPtr; + + /* + * If this is a rename and not a delete of the object, we just flush the + * cache of the object name. + */ + + if (flags & TCL_TRACE_RENAME) { + SquelchCachedName(oPtr); + return; + } + + /* + * Oh dear, the object really is being deleted. Handle this by running the + * destructors and deleting the object's namespace, which in turn causes + * the real object structures to be deleted. + * + * Note that it is possible for the namespace to be deleted before the + * command. Because of that case, we must take care here to mark the + * command as being deleted so that if we return here we don't run into + * reentrancy problems. + * + * We also do not run destructors on the core class objects when the + * interpreter is being deleted; their incestuous nature causes problems + * in that case when the destructor is partially deleted before the uses + * of it have gone. [Bug 2949397] + */ + + AddRef(oPtr); + AddRef(fPtr->classCls); + AddRef(fPtr->objectCls); + AddRef(fPtr->classCls->thisPtr); + AddRef(fPtr->objectCls->thisPtr); + oPtr->command = NULL; + + if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) { + CallContext *contextPtr = + TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + int result; + Tcl_InterpState state; + + oPtr->flags |= DESTRUCTOR_CALLED; + if (contextPtr != NULL) { + contextPtr->callPtr->flags |= DESTRUCTOR; + contextPtr->skip = 0; + state = Tcl_SaveInterpState(interp, TCL_OK); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, + contextPtr, 0, NULL); + if (result != TCL_OK) { + Tcl_BackgroundException(interp, result); + } + Tcl_RestoreInterpState(interp, state); + TclOODeleteContext(contextPtr); + } + } + + /* + * OK, the destructor's been run. Time to splat the class data (if any) + * and nuke the namespace (which triggers the final crushing of the object + * structure itself). + * + * The class of objects needs some special care; if it is deleted (and + * we're not killing the whole interpreter) we force the delete of the + * class of classes now as well. Due to the incestuous nature of those two + * classes, if one goes the other must too and yet the tangle can + * sometimes not go away automatically; we force it here. [Bug 2962664] + */ + + if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) + && !Deleted(fPtr->classCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); + } + + if (oPtr->classPtr != NULL) { + AddRef(oPtr->classPtr); + ReleaseClassContents(interp, oPtr); + } + + /* + * The namespace is only deleted if it hasn't already been deleted. [Bug + * 2950259] + */ + + if (oPtr->namespacePtr && ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { + Tcl_DeleteNamespace(oPtr->namespacePtr); + } + if (oPtr->classPtr) { + DelRef(oPtr->classPtr); + } + DelRef(fPtr->classCls->thisPtr); + DelRef(fPtr->objectCls->thisPtr); + DelRef(fPtr->classCls); + DelRef(fPtr->objectCls); + DelRef(oPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * ClearMixins, ClearSuperclasses -- + * + * Utility functions for correctly clearing the list of mixins or + * superclasses of a class. Will ckfree() the list storage. + * + * ---------------------------------------------------------------------- + */ + +static void +ClearMixins( + Class *clsPtr) +{ + int i; + Class *mixinPtr; + + if (clsPtr->mixins.num == 0) { + return; + } + + FOREACH(mixinPtr, clsPtr->mixins) { + TclOORemoveFromMixinSubs(clsPtr, mixinPtr); + } + ckfree(clsPtr->mixins.list); + clsPtr->mixins.list = NULL; + clsPtr->mixins.num = 0; +} + +static void +ClearSuperclasses( + Class *clsPtr) +{ + int i; + Class *superPtr; + + if (clsPtr->superclasses.num == 0) { + return; + } + + FOREACH(superPtr, clsPtr->superclasses) { + TclOORemoveFromSubclasses(clsPtr, superPtr); + } + ckfree(clsPtr->superclasses.list); + clsPtr->superclasses.list = NULL; + clsPtr->superclasses.num = 0; +} + +/* + * ---------------------------------------------------------------------- + * + * ReleaseClassContents -- + * + * Tear down the special class data structure, including deleting all + * dependent classes and objects. + * + * ---------------------------------------------------------------------- + */ + +static void +ReleaseClassContents( + Tcl_Interp *interp, /* The interpreter containing the class. */ + Object *oPtr) /* The object representing the class. */ +{ + FOREACH_HASH_DECLS; + int i; + Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr; + Object *instancePtr; + Foundation *fPtr = oPtr->fPtr; + + /* + * Sanity check! + */ + + if (!Deleted(oPtr)) { + if (IsRootClass(oPtr)) { + Tcl_Panic("deleting class structure for non-deleted %s", + "::oo::class"); + } else if (IsRootObject(oPtr)) { + Tcl_Panic("deleting class structure for non-deleted %s", + "::oo::object"); + } else { + Tcl_Panic("deleting class structure for non-deleted %s", + "general object"); + } + } + + /* + * Lock a number of dependent objects until we've stopped putting our + * fingers in them. + */ + + FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { + if (mixinSubclassPtr != NULL) { + AddRef(mixinSubclassPtr); + AddRef(mixinSubclassPtr->thisPtr); + } + } + FOREACH(subclassPtr, clsPtr->subclasses) { + if (subclassPtr != NULL && !IsRoot(subclassPtr)) { + AddRef(subclassPtr); + AddRef(subclassPtr->thisPtr); + } + } + if (!IsRootClass(oPtr)) { + FOREACH(instancePtr, clsPtr->instances) { + int j; + if (instancePtr->selfCls == clsPtr) { + instancePtr->flags |= CLASS_GONE; + } + for(j=0 ; j<instancePtr->mixins.num ; j++) { + Class *mixin = instancePtr->mixins.list[j]; + Class *nextMixin = NULL; + if (mixin == clsPtr) { + if (j < instancePtr->mixins.num - 1) { + nextMixin = instancePtr->mixins.list[j+1]; + } + if (j == 0) { + instancePtr->mixins.num = 0; + instancePtr->mixins.list = NULL; + } else { + instancePtr->mixins.list[j-1] = nextMixin; + } + instancePtr->mixins.num -= 1; + } + } + if (instancePtr != NULL && !IsRoot(instancePtr)) { + AddRef(instancePtr); + } + } + } + + /* + * Squelch classes that this class has been mixed into. + */ + + FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { + if (!Deleted(mixinSubclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, + mixinSubclassPtr->thisPtr->command); + } + ClearMixins(mixinSubclassPtr); + DelRef(mixinSubclassPtr->thisPtr); + DelRef(mixinSubclassPtr); + } + if (clsPtr->mixinSubs.list != NULL) { + ckfree(clsPtr->mixinSubs.list); + clsPtr->mixinSubs.list = NULL; + clsPtr->mixinSubs.num = 0; + } + + /* + * Squelch subclasses of this class. + */ + + FOREACH(subclassPtr, clsPtr->subclasses) { + if (IsRoot(subclassPtr)) { + continue; + } + if (!Deleted(subclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); + } + ClearSuperclasses(subclassPtr); + DelRef(subclassPtr->thisPtr); + DelRef(subclassPtr); + } + if (clsPtr->subclasses.list != NULL) { + ckfree(clsPtr->subclasses.list); + clsPtr->subclasses.list = NULL; + clsPtr->subclasses.num = 0; + } + + /* + * Squelch instances of this class (includes objects we're mixed into). + */ + + if (!IsRootClass(oPtr)) { + FOREACH(instancePtr, clsPtr->instances) { + if (instancePtr == NULL || IsRoot(instancePtr)) { + continue; + } + if (!Deleted(instancePtr)) { + Tcl_DeleteCommandFromToken(interp, instancePtr->command); + /* + * Tcl_DeleteCommandFromToken() may have done to whole + * job for us. Roll back and check again. + */ + i--; + continue; + } + DelRef(instancePtr); + } + } + if (clsPtr->instances.list != NULL) { + ckfree(clsPtr->instances.list); + clsPtr->instances.list = NULL; + clsPtr->instances.num = 0; + } + + /* + * Special: We delete these after everything else. + */ + + if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); + } + + /* + * Squelch method implementation chain caches. + */ + + if (clsPtr->constructorChainPtr) { + TclOODeleteChain(clsPtr->constructorChainPtr); + clsPtr->constructorChainPtr = NULL; + } + if (clsPtr->destructorChainPtr) { + TclOODeleteChain(clsPtr->destructorChainPtr); + clsPtr->destructorChainPtr = NULL; + } + if (clsPtr->classChainCache) { + CallChain *callPtr; + + FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) { + TclOODeleteChain(callPtr); + } + Tcl_DeleteHashTable(clsPtr->classChainCache); + ckfree(clsPtr->classChainCache); + clsPtr->classChainCache = NULL; + } + + /* + * Squelch our filter list. + */ + + if (clsPtr->filters.num) { + Tcl_Obj *filterObj; + + FOREACH(filterObj, clsPtr->filters) { + TclDecrRefCount(filterObj); + } + ckfree(clsPtr->filters.list); + clsPtr->filters.num = 0; + } + + /* + * Squelch our metadata. + */ + + if (clsPtr->metadataPtr != NULL) { + Tcl_ObjectMetadataType *metadataTypePtr; + ClientData value; + + FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { + metadataTypePtr->deleteProc(value); + } + Tcl_DeleteHashTable(clsPtr->metadataPtr); + ckfree(clsPtr->metadataPtr); + clsPtr->metadataPtr = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectNamespaceDeleted -- + * + * Callback when the object's namespace is deleted. Used to clean up the + * data structures associated with the object. The complicated bit is + * that this can sometimes happen before the object's command is deleted + * (interpreter teardown is complex!) + * + * ---------------------------------------------------------------------- + */ + +static void +ObjectNamespaceDeleted( + ClientData clientData) /* Pointer to the class whose namespace is + * being deleted. */ +{ + Object *oPtr = clientData; + FOREACH_HASH_DECLS; + Class *clsPtr = oPtr->classPtr, *mixinPtr; + Method *mPtr; + Tcl_Obj *filterObj, *variableObj; + int deleteAlreadyInProgress = 0, i; + + /* + * Instruct everyone to no longer use any allocated fields of the object. + * Also delete the commands that refer to the object at this point (if + * they still exist) because otherwise their references to the object + * point into freed memory, allowing crashes. + */ + + if (oPtr->command) { + if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { + /* + * Namespace deletion must have been triggered by a trace on command + * deletion , meaning that ObjectRenamedTrace() is eventually going + * to be called . + */ + deleteAlreadyInProgress = 1; + } + + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); + } + if (oPtr->myCommand) { + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); + } + + /* + * Splice the object out of its context. After this, we must *not* call + * methods on the object. + */ + + if (!IsRootObject(oPtr) && !(oPtr->flags & CLASS_GONE)) { + TclOORemoveFromInstances(oPtr, oPtr->selfCls); + } + + FOREACH(mixinPtr, oPtr->mixins) { + if (mixinPtr) { + TclOORemoveFromInstances(oPtr, mixinPtr); + } + } + if (i) { + ckfree(oPtr->mixins.list); + } + + FOREACH(filterObj, oPtr->filters) { + TclDecrRefCount(filterObj); + } + if (i) { + ckfree(oPtr->filters.list); + } + + if (oPtr->methodsPtr) { + FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) { + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashTable(oPtr->methodsPtr); + ckfree(oPtr->methodsPtr); + } + + FOREACH(variableObj, oPtr->variables) { + TclDecrRefCount(variableObj); + } + if (i) { + ckfree(oPtr->variables.list); + } + + if (oPtr->chainCache) { + TclOODeleteChainCache(oPtr->chainCache); + } + + SquelchCachedName(oPtr); + + if (oPtr->metadataPtr != NULL) { + Tcl_ObjectMetadataType *metadataTypePtr; + ClientData value; + + FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) { + metadataTypePtr->deleteProc(value); + } + Tcl_DeleteHashTable(oPtr->metadataPtr); + ckfree(oPtr->metadataPtr); + oPtr->metadataPtr = NULL; + } + + /* + * If this was a class, there's additional deletion work to do. + */ + + if (clsPtr != NULL) { + Tcl_ObjectMetadataType *metadataTypePtr; + ClientData value; + + if (clsPtr->metadataPtr != NULL) { + FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { + metadataTypePtr->deleteProc(value); + } + Tcl_DeleteHashTable(clsPtr->metadataPtr); + ckfree(clsPtr->metadataPtr); + clsPtr->metadataPtr = NULL; + } + + FOREACH(filterObj, clsPtr->filters) { + TclDecrRefCount(filterObj); + } + if (i) { + ckfree(clsPtr->filters.list); + clsPtr->filters.num = 0; + } + + ClearMixins(clsPtr); + + ClearSuperclasses(clsPtr); + + if (clsPtr->subclasses.list) { + ckfree(clsPtr->subclasses.list); + clsPtr->subclasses.list = NULL; + clsPtr->subclasses.num = 0; + } + if (clsPtr->instances.list) { + ckfree(clsPtr->instances.list); + clsPtr->instances.list = NULL; + clsPtr->instances.num = 0; + } + if (clsPtr->mixinSubs.list) { + ckfree(clsPtr->mixinSubs.list); + clsPtr->mixinSubs.list = NULL; + clsPtr->mixinSubs.num = 0; + } + + FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashTable(&clsPtr->classMethods); + TclOODelMethodRef(clsPtr->constructorPtr); + TclOODelMethodRef(clsPtr->destructorPtr); + + FOREACH(variableObj, clsPtr->variables) { + TclDecrRefCount(variableObj); + } + if (i) { + ckfree(clsPtr->variables.list); + } + + DelRef(clsPtr); + } + + /* + * Delete the object structure itself. + */ + + if (deleteAlreadyInProgress) { + oPtr->classPtr = NULL; + oPtr->namespacePtr = NULL; + } else { + DelRef(oPtr); + } + +} + +/* + * ---------------------------------------------------------------------- + * + * TclOORemoveFromInstances -- + * + * Utility function to remove an object from the list of instances within + * a class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOORemoveFromInstances( + Object *oPtr, /* The instance to remove. */ + Class *clsPtr) /* The class (possibly) containing the + * reference to the instance. */ +{ + int i; + Object *instPtr; + + FOREACH(instPtr, clsPtr->instances) { + if (oPtr == instPtr) { + goto removeInstance; + } + } + return; + + removeInstance: + if (Deleted(clsPtr->thisPtr)) { + if (!IsRootClass(clsPtr)) { + DelRef(clsPtr->instances.list[i]); + } + clsPtr->instances.list[i] = NULL; + } else { + clsPtr->instances.num--; + if (i < clsPtr->instances.num) { + clsPtr->instances.list[i] = + clsPtr->instances.list[clsPtr->instances.num]; + } + clsPtr->instances.list[clsPtr->instances.num] = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOAddToInstances -- + * + * Utility function to add an object to the list of instances within a + * class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOOAddToInstances( + Object *oPtr, /* The instance to add. */ + Class *clsPtr) /* The class to add the instance to. It is + * assumed that the class is not already + * present as an instance in the class. */ +{ + if (Deleted(clsPtr->thisPtr)) { + return; + } + if (clsPtr->instances.num >= clsPtr->instances.size) { + clsPtr->instances.size += ALLOC_CHUNK; + if (clsPtr->instances.size == ALLOC_CHUNK) { + clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK); + } else { + clsPtr->instances.list = ckrealloc(clsPtr->instances.list, + sizeof(Object *) * clsPtr->instances.size); + } + } + clsPtr->instances.list[clsPtr->instances.num++] = oPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOORemoveFromSubclasses -- + * + * Utility function to remove a class from the list of subclasses within + * another class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOORemoveFromSubclasses( + Class *subPtr, /* The subclass to remove. */ + Class *superPtr) /* The superclass to (possibly) remove the + * subclass reference from. */ +{ + int i; + Class *subclsPtr; + + FOREACH(subclsPtr, superPtr->subclasses) { + if (subPtr == subclsPtr) { + goto removeSubclass; + } + } + return; + + removeSubclass: + if (!Deleted(superPtr->thisPtr)) { + superPtr->subclasses.num--; + if (i < superPtr->subclasses.num) { + superPtr->subclasses.list[i] = + superPtr->subclasses.list[superPtr->subclasses.num]; + } + superPtr->subclasses.list[superPtr->subclasses.num] = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOAddToSubclasses -- + * + * Utility function to add a class to the list of subclasses within + * another class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOOAddToSubclasses( + Class *subPtr, /* The subclass to add. */ + Class *superPtr) /* The superclass to add the subclass to. It + * is assumed that the class is not already + * present as a subclass in the superclass. */ +{ + if (Deleted(superPtr->thisPtr)) { + return; + } + if (superPtr->subclasses.num >= superPtr->subclasses.size) { + superPtr->subclasses.size += ALLOC_CHUNK; + if (superPtr->subclasses.size == ALLOC_CHUNK) { + superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK); + } else { + superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, + sizeof(Class *) * superPtr->subclasses.size); + } + } + superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOORemoveFromMixinSubs -- + * + * Utility function to remove a class from the list of mixinSubs within + * another class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOORemoveFromMixinSubs( + Class *subPtr, /* The subclass to remove. */ + Class *superPtr) /* The superclass to (possibly) remove the + * subclass reference from. */ +{ + int i; + Class *subclsPtr; + + FOREACH(subclsPtr, superPtr->mixinSubs) { + if (subPtr == subclsPtr) { + goto removeSubclass; + } + } + return; + + removeSubclass: + if (!Deleted(superPtr->thisPtr)) { + superPtr->mixinSubs.num--; + if (i < superPtr->mixinSubs.num) { + superPtr->mixinSubs.list[i] = + superPtr->mixinSubs.list[superPtr->mixinSubs.num]; + } + superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOAddToMixinSubs -- + * + * Utility function to add a class to the list of mixinSubs within + * another class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOOAddToMixinSubs( + Class *subPtr, /* The subclass to add. */ + Class *superPtr) /* The superclass to add the subclass to. It + * is assumed that the class is not already + * present as a subclass in the superclass. */ +{ + if (Deleted(superPtr->thisPtr)) { + return; + } + if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) { + superPtr->mixinSubs.size += ALLOC_CHUNK; + if (superPtr->mixinSubs.size == ALLOC_CHUNK) { + superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); + } else { + superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list, + sizeof(Class *) * superPtr->mixinSubs.size); + } + } + superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * AllocClass -- + * + * Allocate a basic class. Does not splice the class object into its + * class's instance list. + * + * ---------------------------------------------------------------------- + */ + +static Class * +AllocClass( + Tcl_Interp *interp, /* Interpreter within which to allocate the + * class. */ + Object *useThisObj) /* Object that is to act as the class + * representation, or NULL if a new object + * (with automatic name) is to be used. */ +{ + Foundation *fPtr = GetFoundation(interp); + Class *clsPtr = ckalloc(sizeof(Class)); + + /* + * Make an object if we haven't been given one. + */ + + memset(clsPtr, 0, sizeof(Class)); + if (useThisObj == NULL) { + clsPtr->thisPtr = AllocObject(interp, NULL, NULL); + } else { + clsPtr->thisPtr = useThisObj; + } + + /* + * Configure the namespace path for the class's object. + */ + + if (fPtr->helpersNs != NULL) { + Tcl_Namespace *path[2]; + + path[0] = fPtr->helpersNs; + path[1] = fPtr->ooNs; + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); + } else { + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, + &fPtr->ooNs); + } + + /* + * Class objects inherit from the class of classes unless they inherit + * from some subclass of it. Enforce this right now. + */ + + clsPtr->thisPtr->selfCls = fPtr->classCls; + + /* + * Classes are subclasses of oo::object, i.e. the objects they create are + * objects. + */ + + clsPtr->superclasses.num = 1; + clsPtr->superclasses.list = ckalloc(sizeof(Class *)); + clsPtr->superclasses.list[0] = fPtr->objectCls; + + /* + * Finish connecting the class structure to the object structure. + */ + + clsPtr->thisPtr->classPtr = clsPtr; + + /* + * That's the complicated bit. Now fill in the rest of the non-zero/NULL + * fields. + */ + + clsPtr->refCount = 1; + Tcl_InitObjHashTable(&clsPtr->classMethods); + return clsPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_NewObjectInstance -- + * + * Allocate a new instance of an object. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Object +Tcl_NewObjectInstance( + Tcl_Interp *interp, /* Interpreter context. */ + Tcl_Class cls, /* Class to create an instance of. */ + const char *nameStr, /* Name of object to create, or NULL to ask + * the code to pick its own unique name. */ + const char *nsNameStr, /* Name of namespace to create inside object, + * or NULL to ask the code to pick its own + * unique name. */ + int objc, /* Number of arguments. Negative value means + * do not call constructor. */ + Tcl_Obj *const *objv, /* Argument list. */ + int skip) /* Number of arguments to _not_ pass to the + * constructor. */ +{ + register Class *classPtr = (Class *) cls; + Foundation *fPtr = GetFoundation(interp); + Object *oPtr; + + /* + * Check if we're going to create an object over an existing command; + * that's not allowed. + */ + + if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, + TCL_NAMESPACE_ONLY)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + return NULL; + } + + /* + * Create the object. + */ + + oPtr = AllocObject(interp, nameStr, nsNameStr); + oPtr->selfCls = classPtr; + TclOOAddToInstances(oPtr, classPtr); + + /* + * Check to see if we're really creating a class. If so, allocate the + * class structure as well. + */ + + if (TclOOIsReachable(fPtr->classCls, classPtr)) { + /* + * Is a class, so attach a class structure. Note that the AllocClass + * function splices the structure into the object, so we don't have + * to. Once that's done, we need to repatch the object to have the + * right class since AllocClass interferes with that. + */ + + AllocClass(interp, oPtr); + oPtr->selfCls = classPtr; + TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } else { + oPtr->classPtr = NULL; + } + + /* + * Run constructors, except when objc < 0 (a special flag case used for + * object cloning only). + */ + + if (objc >= 0) { + CallContext *contextPtr = + TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + + if (contextPtr != NULL) { + int isRoot, result; + Tcl_InterpState state; + + state = Tcl_SaveInterpState(interp, TCL_OK); + contextPtr->callPtr->flags |= CONSTRUCTOR; + contextPtr->skip = skip; + + /* + * Adjust the ensmble tracking record if necessary. [Bug 3514761] + */ + + isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, + objc, objv); + + if (isRoot) { + TclResetRewriteEnsemble(interp, 1); + } + + /* + * It's an error if the object was whacked in the constructor. + * Force this if it isn't already an error (don't want to lose + * errors by accident...) [Bug 2903011] + */ + + if (result != TCL_ERROR && Deleted(oPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object deleted in constructor", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); + result = TCL_ERROR; + } + TclOODeleteContext(contextPtr); + if (result != TCL_OK) { + Tcl_DiscardInterpState(state); + + /* + * Take care to not delete a deleted object; that would be + * bad. [Bug 2903011] Also take care to make sure that we have + * the name of the command before we delete it. [Bug + * 9dd1bd7a74] + */ + + if (!Deleted(oPtr)) { + (void) TclOOObjectName(interp, oPtr); + Tcl_DeleteCommandFromToken(interp, oPtr->command); + } + return NULL; + } + Tcl_RestoreInterpState(interp, state); + } + } + + return (Tcl_Object) oPtr; +} + +int +TclNRNewObjectInstance( + Tcl_Interp *interp, /* Interpreter context. */ + Tcl_Class cls, /* Class to create an instance of. */ + const char *nameStr, /* Name of object to create, or NULL to ask + * the code to pick its own unique name. */ + const char *nsNameStr, /* Name of namespace to create inside object, + * or NULL to ask the code to pick its own + * unique name. */ + int objc, /* Number of arguments. Negative value means + * do not call constructor. */ + Tcl_Obj *const *objv, /* Argument list. */ + int skip, /* Number of arguments to _not_ pass to the + * constructor. */ + Tcl_Object *objectPtr) /* Place to write the object reference upon + * successful allocation. */ +{ + register Class *classPtr = (Class *) cls; + Foundation *fPtr = GetFoundation(interp); + CallContext *contextPtr; + Tcl_InterpState state; + Object *oPtr; + + /* + * Protect classPtr from getting cleaned up when the command is created. + */ + AddRef(classPtr); + + /* + * Check if we're going to create an object over an existing command; + * that's not allowed. + */ + + if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, + TCL_NAMESPACE_ONLY)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + return TCL_ERROR; + } + + /* + * Create the object. + */ + + oPtr = AllocObject(interp, nameStr, nsNameStr); + oPtr->selfCls = classPtr; + TclOOAddToInstances(oPtr, classPtr); + + /* + * Check to see if we're really creating a class. If so, allocate the + * class structure as well. + */ + + if (TclOOIsReachable(fPtr->classCls, classPtr)) { + /* + * Is a class, so attach a class structure. Note that the AllocClass + * function splices the structure into the object, so we don't have + * to. Once that's done, we need to repatch the object to have the + * right class since AllocClass interferes with that. + */ + + AllocClass(interp, oPtr); + oPtr->selfCls = classPtr; + TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } + + /* + * Run constructors, except when objc < 0 (a special flag case used for + * object cloning only). If there aren't any constructors, we do nothing. + */ + + if (objc < 0) { + *objectPtr = (Tcl_Object) oPtr; + DelRef(classPtr); + return TCL_OK; + } + contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + if (contextPtr == NULL) { + *objectPtr = (Tcl_Object) oPtr; + DelRef(classPtr); + return TCL_OK; + } + + state = Tcl_SaveInterpState(interp, TCL_OK); + contextPtr->callPtr->flags |= CONSTRUCTOR; + contextPtr->skip = skip; + + /* + * Adjust the ensmble tracking record if necessary. [Bug 3514761] + */ + + if (TclInitRewriteEnsemble(interp, skip, skip, objv)) { + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); + } + + /* + * Fire off the constructors non-recursively. + */ + + AddRef(oPtr); + TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, + objectPtr); + TclPushTailcallPoint(interp); + DelRef(classPtr); + return TclOOInvokeContext(contextPtr, interp, objc, objv); +} + +static int +FinalizeAlloc( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CallContext *contextPtr = data[0]; + Object *oPtr = data[1]; + Tcl_InterpState state = data[2]; + Tcl_Object *objectPtr = data[3]; + + /* + * It's an error if the object was whacked in the constructor. Force this + * if it isn't already an error (don't want to lose errors by accident...) + * [Bug 2903011] + */ + + if (result != TCL_ERROR && Deleted(oPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object deleted in constructor", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); + result = TCL_ERROR; + } + TclOODeleteContext(contextPtr); + if (result != TCL_OK) { + Tcl_DiscardInterpState(state); + + /* + * Take care to not delete a deleted object; that would be bad. [Bug + * 2903011] Also take care to make sure that we have the name of the + * command before we delete it. [Bug 9dd1bd7a74] + */ + + if (!Deleted(oPtr)) { + (void) TclOOObjectName(interp, oPtr); + Tcl_DeleteCommandFromToken(interp, oPtr->command); + } + DelRef(oPtr); + return TCL_ERROR; + } + Tcl_RestoreInterpState(interp, state); + *objectPtr = (Tcl_Object) oPtr; + DelRef(oPtr); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_CopyObjectInstance -- + * + * Creates a copy of an object. Does not copy the backing namespace, + * since the correct way to do that (e.g., shallow/deep) depends on the + * object/class's own policies. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Object +Tcl_CopyObjectInstance( + Tcl_Interp *interp, + Tcl_Object sourceObject, + const char *targetName, + const char *targetNamespaceName) +{ + Object *oPtr = (Object *) sourceObject, *o2Ptr; + FOREACH_HASH_DECLS; + Method *mPtr; + Class *mixinPtr; + CallContext *contextPtr; + Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; + int i, result; + + /* + * Sanity check. + */ + + if (IsRootClass(oPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not clone the class of classes", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL); + return NULL; + } + + /* + * Build the instance. Note that this does not run any constructors. + */ + + o2Ptr = (Object *) Tcl_NewObjectInstance(interp, + (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, -1, + NULL, -1); + if (o2Ptr == NULL) { + return NULL; + } + + /* + * Copy the object-local methods to the new object. + */ + + if (oPtr->methodsPtr) { + FOREACH_HASH(keyPtr, mPtr, oPtr->methodsPtr) { + if (CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + } + + /* + * Copy the object's mixin references to the new object. + */ + + FOREACH(mixinPtr, o2Ptr->mixins) { + if (mixinPtr && mixinPtr != o2Ptr->selfCls) { + TclOORemoveFromInstances(o2Ptr, mixinPtr); + } + } + DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *); + FOREACH(mixinPtr, o2Ptr->mixins) { + if (mixinPtr && mixinPtr != o2Ptr->selfCls) { + TclOOAddToInstances(o2Ptr, mixinPtr); + } + } + + /* + * Copy the object's filter list to the new object. + */ + + DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *); + FOREACH(filterObj, o2Ptr->filters) { + Tcl_IncrRefCount(filterObj); + } + + /* + * Copy the object's variable resolution list to the new object. + */ + + DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *); + FOREACH(variableObj, o2Ptr->variables) { + Tcl_IncrRefCount(variableObj); + } + + /* + * Copy the object's flags to the new object, clearing those that must be + * kept object-local. The duplicate is never deleted at this point, nor is + * it the root of the object system or in the midst of processing a filter + * call. + */ + + o2Ptr->flags = oPtr->flags & ~( + OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); + + /* + * Copy the object's metadata. + */ + + if (oPtr->metadataPtr != NULL) { + Tcl_ObjectMetadataType *metadataTypePtr; + ClientData value, duplicate; + + FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) { + if (metadataTypePtr->cloneProc == NULL) { + duplicate = value; + } else { + if (metadataTypePtr->cloneProc(interp, value, + &duplicate) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + if (duplicate != NULL) { + Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr, + duplicate); + } + } + } + + /* + * Copy the class, if present. Note that if there is a class present in + * the source object, there must also be one in the copy. + */ + + if (oPtr->classPtr != NULL) { + Class *clsPtr = oPtr->classPtr; + Class *cls2Ptr = o2Ptr->classPtr; + Class *superPtr; + + /* + * Copy the class flags across. + */ + + cls2Ptr->flags = clsPtr->flags; + + /* + * Ensure that the new class's superclass structure is the same as the + * old class's. + */ + + FOREACH(superPtr, cls2Ptr->superclasses) { + TclOORemoveFromSubclasses(cls2Ptr, superPtr); + } + if (cls2Ptr->superclasses.num) { + cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list, + sizeof(Class *) * clsPtr->superclasses.num); + } else { + cls2Ptr->superclasses.list = + ckalloc(sizeof(Class *) * clsPtr->superclasses.num); + } + memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list, + sizeof(Class *) * clsPtr->superclasses.num); + cls2Ptr->superclasses.num = clsPtr->superclasses.num; + FOREACH(superPtr, cls2Ptr->superclasses) { + TclOOAddToSubclasses(cls2Ptr, superPtr); + } + + /* + * Duplicate the source class's filters. + */ + + DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *); + FOREACH(filterObj, cls2Ptr->filters) { + Tcl_IncrRefCount(filterObj); + } + + /* + * Copy the source class's variable resolution list. + */ + + DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *); + FOREACH(variableObj, cls2Ptr->variables) { + Tcl_IncrRefCount(variableObj); + } + + /* + * Duplicate the source class's mixins (which cannot be circular + * references to the duplicate). + */ + + FOREACH(mixinPtr, cls2Ptr->mixins) { + TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); + } + if (cls2Ptr->mixins.num != 0) { + ckfree(clsPtr->mixins.list); + } + DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); + FOREACH(mixinPtr, cls2Ptr->mixins) { + TclOOAddToMixinSubs(cls2Ptr, mixinPtr); + } + + /* + * Duplicate the source class's methods, constructor and destructor. + */ + + FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) { + if (CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr, + NULL) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + if (clsPtr->constructorPtr) { + if (CloneClassMethod(interp, cls2Ptr, clsPtr->constructorPtr, + NULL, &cls2Ptr->constructorPtr) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + if (clsPtr->destructorPtr) { + if (CloneClassMethod(interp, cls2Ptr, clsPtr->destructorPtr, NULL, + &cls2Ptr->destructorPtr) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + + /* + * Duplicate the class's metadata. + */ + + if (clsPtr->metadataPtr != NULL) { + Tcl_ObjectMetadataType *metadataTypePtr; + ClientData value, duplicate; + + FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { + if (metadataTypePtr->cloneProc == NULL) { + duplicate = value; + } else { + if (metadataTypePtr->cloneProc(interp, value, + &duplicate) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + if (duplicate != NULL) { + Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr, + duplicate); + } + } + } + } + + TclResetRewriteEnsemble(interp, 1); + contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); + if (contextPtr) { + args[0] = TclOOObjectName(interp, o2Ptr); + args[1] = oPtr->fPtr->clonedName; + args[2] = TclOOObjectName(interp, oPtr); + Tcl_IncrRefCount(args[0]); + Tcl_IncrRefCount(args[1]); + Tcl_IncrRefCount(args[2]); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3, + args); + TclDecrRefCount(args[0]); + TclDecrRefCount(args[1]); + TclDecrRefCount(args[2]); + TclOODeleteContext(contextPtr); + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (while performing post-copy callback)"); + } + if (result != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + + return (Tcl_Object) o2Ptr; +} + +/* + * ---------------------------------------------------------------------- + * + * CloneObjectMethod, CloneClassMethod -- + * + * Helper functions used for cloning methods. They work identically to + * each other, except for the difference between them in how they + * register the cloned method on a successful clone. + * + * ---------------------------------------------------------------------- + */ + +static int +CloneObjectMethod( + Tcl_Interp *interp, + Object *oPtr, + Method *mPtr, + Tcl_Obj *namePtr) +{ + if (mPtr->typePtr == NULL) { + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, NULL, NULL); + } else if (mPtr->typePtr->cloneProc) { + ClientData newClientData; + + if (mPtr->typePtr->cloneProc(interp, mPtr->clientData, + &newClientData) != TCL_OK) { + return TCL_ERROR; + } + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData); + } else { + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); + } + return TCL_OK; +} + +static int +CloneClassMethod( + Tcl_Interp *interp, + Class *clsPtr, + Method *mPtr, + Tcl_Obj *namePtr, + Method **m2PtrPtr) +{ + Method *m2Ptr; + + if (mPtr->typePtr == NULL) { + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); + } else if (mPtr->typePtr->cloneProc) { + ClientData newClientData; + + if (mPtr->typePtr->cloneProc(interp, mPtr->clientData, + &newClientData) != TCL_OK) { + return TCL_ERROR; + } + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, + newClientData); + } else { + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, + mPtr->clientData); + } + if (m2PtrPtr != NULL) { + *m2PtrPtr = m2Ptr; + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_ObjectGetMetadata, + * Tcl_ObjectSetMetadata -- + * + * Metadata management API. The metadata system allows code in extensions + * to attach arbitrary non-NULL pointers to objects and classes without + * the different things that might be interested being able to interfere + * with each other. Apart from non-NULL-ness, these routines attach no + * interpretation to the meaning of the metadata pointers. + * + * The Tcl_*GetMetadata routines get the metadata pointer attached that + * has been related with a particular type, or NULL if no metadata + * associated with the given type has been attached. + * + * The Tcl_*SetMetadata routines set or delete the metadata pointer that + * is related to a particular type. The value associated with the type is + * deleted (if present; no-op otherwise) if the value is NULL, and + * attached (replacing the previous value, which is deleted if present) + * otherwise. This means it is impossible to attach a NULL value for any + * metadata type. + * + * ---------------------------------------------------------------------- + */ + +ClientData +Tcl_ClassGetMetadata( + Tcl_Class clazz, + const Tcl_ObjectMetadataType *typePtr) +{ + Class *clsPtr = (Class *) clazz; + Tcl_HashEntry *hPtr; + + /* + * If there's no metadata store attached, the type in question has + * definitely not been attached either! + */ + + if (clsPtr->metadataPtr == NULL) { + return NULL; + } + + /* + * There is a metadata store, so look in it for the given type. + */ + + hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); + + /* + * Return the metadata value if we found it, otherwise NULL. + */ + + if (hPtr == NULL) { + return NULL; + } + return Tcl_GetHashValue(hPtr); +} + +void +Tcl_ClassSetMetadata( + Tcl_Class clazz, + const Tcl_ObjectMetadataType *typePtr, + ClientData metadata) +{ + Class *clsPtr = (Class *) clazz; + Tcl_HashEntry *hPtr; + int isNew; + + /* + * Attach the metadata store if not done already. + */ + + if (clsPtr->metadataPtr == NULL) { + if (metadata == NULL) { + return; + } + clsPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS); + } + + /* + * If the metadata is NULL, we're deleting the metadata for the type. + */ + + if (metadata == NULL) { + hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); + if (hPtr != NULL) { + typePtr->deleteProc(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); + } + return; + } + + /* + * Otherwise we're attaching the metadata. Note that if there was already + * some metadata attached of this type, we delete that first. + */ + + hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew); + if (!isNew) { + typePtr->deleteProc(Tcl_GetHashValue(hPtr)); + } + Tcl_SetHashValue(hPtr, metadata); +} + +ClientData +Tcl_ObjectGetMetadata( + Tcl_Object object, + const Tcl_ObjectMetadataType *typePtr) +{ + Object *oPtr = (Object *) object; + Tcl_HashEntry *hPtr; + + /* + * If there's no metadata store attached, the type in question has + * definitely not been attached either! + */ + + if (oPtr->metadataPtr == NULL) { + return NULL; + } + + /* + * There is a metadata store, so look in it for the given type. + */ + + hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); + + /* + * Return the metadata value if we found it, otherwise NULL. + */ + + if (hPtr == NULL) { + return NULL; + } + return Tcl_GetHashValue(hPtr); +} + +void +Tcl_ObjectSetMetadata( + Tcl_Object object, + const Tcl_ObjectMetadataType *typePtr, + ClientData metadata) +{ + Object *oPtr = (Object *) object; + Tcl_HashEntry *hPtr; + int isNew; + + /* + * Attach the metadata store if not done already. + */ + + if (oPtr->metadataPtr == NULL) { + if (metadata == NULL) { + return; + } + oPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS); + } + + /* + * If the metadata is NULL, we're deleting the metadata for the type. + */ + + if (metadata == NULL) { + hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); + if (hPtr != NULL) { + typePtr->deleteProc(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); + } + return; + } + + /* + * Otherwise we're attaching the metadata. Note that if there was already + * some metadata attached of this type, we delete that first. + */ + + hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew); + if (!isNew) { + typePtr->deleteProc(Tcl_GetHashValue(hPtr)); + } + Tcl_SetHashValue(hPtr, metadata); +} + +/* + * ---------------------------------------------------------------------- + * + * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- + * + * Main entry point for object invocations. The Public* and Private* + * wrapper functions (implementations of both object instance commands + * and [my]) are just thin wrappers round the main TclOOObjectCmdCore + * function. Note that the core is function is NRE-aware. + * + * ---------------------------------------------------------------------- + */ + +static int +PublicObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv); +} + +static int +PublicNRObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD, + NULL); +} + +static int +PrivateObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv); +} + +static int +PrivateNRObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL); +} + +int +TclOOInvokeObject( + Tcl_Interp *interp, /* Interpreter for commands, variables, + * results, error reporting, etc. */ + Tcl_Object object, /* The object to invoke. */ + Tcl_Class startCls, /* Where in the class chain to start the + * invoke from, or NULL to traverse the whole + * chain including filters. */ + int publicPrivate, /* Whether this is an invoke from a public + * context (PUBLIC_METHOD), a private context + * (PRIVATE_METHOD), or a *really* private + * context (any other value; conventionally + * 0). */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Array of argument objects. It is assumed + * that the name of the method to invoke will + * be at index 1. */ +{ + switch (publicPrivate) { + case PUBLIC_METHOD: + return TclOOObjectCmdCore((Object *) object, interp, objc, objv, + PUBLIC_METHOD, (Class *) startCls); + case PRIVATE_METHOD: + return TclOOObjectCmdCore((Object *) object, interp, objc, objv, + PRIVATE_METHOD, (Class *) startCls); + default: + return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0, + (Class *) startCls); + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOObjectCmdCore, FinalizeObjectCall -- + * + * Main function for object invocations. Does call chain creation, + * management and invocation. The function FinalizeObjectCall exists to + * clean up after the non-recursive processing of TclOOObjectCmdCore. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOObjectCmdCore( + Object *oPtr, /* The object being invoked. */ + Tcl_Interp *interp, /* The interpreter containing the object. */ + int objc, /* How many arguments are being passed in. */ + Tcl_Obj *const *objv, /* The array of arguments. */ + int flags, /* Whether this is an invocation through the + * public or the private command interface. */ + Class *startCls) /* Where to start in the call chain, or NULL + * if we are to start at the front with + * filters and the object's methods (which is + * the normal case). */ +{ + CallContext *contextPtr; + Tcl_Obj *methodNamePtr; + int result; + + /* + * If we've no method name, throw this directly into the unknown + * processing. + */ + + if (objc < 2) { + flags |= FORCE_UNKNOWN; + methodNamePtr = NULL; + goto noMapping; + } + + /* + * Give plugged in code a chance to remap the method name. + */ + + methodNamePtr = objv[1]; + if (oPtr->mapMethodNameProc != NULL) { + register Class **startClsPtr = &startCls; + Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr); + + result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr, + (Tcl_Class *) startClsPtr, mappedMethodName); + if (result != TCL_OK) { + TclDecrRefCount(mappedMethodName); + if (result == TCL_BREAK) { + goto noMapping; + } else if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (while mapping method name)"); + } + return result; + } + + /* + * Get the call chain for the remapped name. + */ + + Tcl_IncrRefCount(mappedMethodName); + contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, + flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); + TclDecrRefCount(mappedMethodName); + if (contextPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "impossible to invoke method \"%s\": no defined method or" + " unknown method", TclGetString(methodNamePtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED", + TclGetString(methodNamePtr), NULL); + return TCL_ERROR; + } + } else { + /* + * Get the call chain. + */ + + noMapping: + contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, + flags | (oPtr->flags & FILTER_HANDLING), NULL); + if (contextPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "impossible to invoke method \"%s\": no defined method or" + " unknown method", TclGetString(methodNamePtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(methodNamePtr), NULL); + return TCL_ERROR; + } + } + + /* + * Check to see if we need to apply magical tricks to start part way + * through the call chain. + */ + + if (startCls != NULL) { + for (; contextPtr->index < contextPtr->callPtr->numChain; + contextPtr->index++) { + register struct MInvoke *miPtr = + &contextPtr->callPtr->chain[contextPtr->index]; + + if (miPtr->isFilter) { + continue; + } + if (miPtr->mPtr->declaringClassPtr == startCls) { + break; + } + } + if (contextPtr->index >= contextPtr->callPtr->numChain) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no valid method implementation", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(methodNamePtr), NULL); + TclOODeleteContext(contextPtr); + return TCL_ERROR; + } + } + + /* + * Invoke the call chain, locking the object structure against deletion + * for the duration. + */ + + TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL); + return TclOOInvokeContext(contextPtr, interp, objc, objv); +} + +static int +FinalizeObjectCall( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + /* + * Dispose of the call chain, which drops the lock on the object's + * structure. + */ + + TclOODeleteContext(data[0]); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext, FinalizeNext -- + * + * Invokes the next stage of the call chain described in an object + * context. This is the core of the implementation of the [next] command. + * Does not do management of the call-frame stack. Available in public + * (standard API) and private (NRE-aware) forms. FinalizeNext is a + * private function used to clean up in the NRE case. + * + * ---------------------------------------------------------------------- + */ + +int +Tcl_ObjectContextInvokeNext( + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv, + int skip) +{ + CallContext *contextPtr = (CallContext *) context; + int savedIndex = contextPtr->index; + int savedSkip = contextPtr->skip; + int result; + + if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + /* + * We're at the end of the chain; generate an error message unless the + * interpreter is being torn down, in which case we might be getting + * here because of methods/destructors doing a [next] (or equivalent) + * unexpectedly. + */ + + const char *methodType; + + if (Tcl_InterpDeleted(interp)) { + return TCL_OK; + } + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + return TCL_ERROR; + } + + /* + * Advance to the next method implementation in the chain in the method + * call context while we process the body. However, need to adjust the + * argument-skip control because we're guaranteed to have a single prefix + * arg (i.e., 'next') and not the variable amount that can happen because + * method invocations (i.e., '$obj meth' and 'my meth'), constructors + * (i.e., '$cls new' and '$cls create obj') and destructors (no args at + * all) come through the same code. + */ + + contextPtr->index++; + contextPtr->skip = skip; + + /* + * Invoke the (advanced) method call context in the caller context. + */ + + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc, + objv); + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = savedIndex; + contextPtr->skip = savedSkip; + + return result; +} + +int +TclNRObjectContextInvokeNext( + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv, + int skip) +{ + register CallContext *contextPtr = (CallContext *) context; + + if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + /* + * We're at the end of the chain; generate an error message unless the + * interpreter is being torn down, in which case we might be getting + * here because of methods/destructors doing a [next] (or equivalent) + * unexpectedly. + */ + + const char *methodType; + + if (Tcl_InterpDeleted(interp)) { + return TCL_OK; + } + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + return TCL_ERROR; + } + + /* + * Advance to the next method implementation in the chain in the method + * call context while we process the body. However, need to adjust the + * argument-skip control because we're guaranteed to have a single prefix + * arg (i.e., 'next') and not the variable amount that can happen because + * method invocations (i.e., '$obj meth' and 'my meth'), constructors + * (i.e., '$cls new' and '$cls create obj') and destructors (no args at + * all) come through the same code. + */ + + TclNRAddCallback(interp, FinalizeNext, contextPtr, + INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip), NULL); + contextPtr->index++; + contextPtr->skip = skip; + + /* + * Invoke the (advanced) method call context in the caller context. + */ + + return TclOOInvokeContext(contextPtr, interp, objc, objv); +} + +static int +FinalizeNext( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CallContext *contextPtr = data[0]; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = PTR2INT(data[1]); + contextPtr->skip = PTR2INT(data[2]); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_GetObjectFromObj -- + * + * Utility function to get an object from a Tcl_Obj containing its name. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Object +Tcl_GetObjectFromObj( + Tcl_Interp *interp, /* Interpreter in which to locate the object. + * Will have an error message placed in it if + * the name does not refer to an object. */ + Tcl_Obj *objPtr) /* The name of the object to look up, which is + * exactly the name of its public command. */ +{ + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); + + if (cmdPtr == NULL) { + goto notAnObject; + } + if (cmdPtr->objProc != PublicObjectCmd) { + cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) { + goto notAnObject; + } + } + return cmdPtr->objClientData; + + notAnObject: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s does not refer to an object", TclGetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr), + NULL); + return NULL; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOIsReachable -- + * + * Utility function that tests whether a class is a subclass (whether + * directly or indirectly) of another class. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOIsReachable( + Class *targetPtr, + Class *startPtr) +{ + int i; + Class *superPtr; + + tailRecurse: + if (startPtr == targetPtr) { + return 1; + } + if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) { + startPtr = startPtr->superclasses.list[0]; + goto tailRecurse; + } + FOREACH(superPtr, startPtr->superclasses) { + if (TclOOIsReachable(targetPtr, superPtr)) { + return 1; + } + } + FOREACH(superPtr, startPtr->mixins) { + if (TclOOIsReachable(targetPtr, superPtr)) { + return 1; + } + } + return 0; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOObjectName, Tcl_GetObjectName -- + * + * Utility function that returns the name of the object. Note that this + * simplifies cache management by keeping the code to do it in one place + * and not sprayed all over. The value returned always has a reference + * count of at least one. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclOOObjectName( + Tcl_Interp *interp, + Object *oPtr) +{ + Tcl_Obj *namePtr; + + if (oPtr->cachedNameObj) { + return oPtr->cachedNameObj; + } + namePtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, oPtr->command, namePtr); + Tcl_IncrRefCount(namePtr); + oPtr->cachedNameObj = namePtr; + return namePtr; +} + +Tcl_Obj * +Tcl_GetObjectName( + Tcl_Interp *interp, + Tcl_Object object) +{ + return TclOOObjectName(interp, (Object *) object); +} + +/* + * ---------------------------------------------------------------------- + * + * assorted trivial 'getter' functions + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +Tcl_ObjectContextMethod( + Tcl_ObjectContext context) +{ + CallContext *contextPtr = (CallContext *) context; + return (Tcl_Method) contextPtr->callPtr->chain[contextPtr->index].mPtr; +} + +int +Tcl_ObjectContextIsFiltering( + Tcl_ObjectContext context) +{ + CallContext *contextPtr = (CallContext *) context; + return contextPtr->callPtr->chain[contextPtr->index].isFilter; +} + +Tcl_Object +Tcl_ObjectContextObject( + Tcl_ObjectContext context) +{ + return (Tcl_Object) ((CallContext *)context)->oPtr; +} + +int +Tcl_ObjectContextSkippedArgs( + Tcl_ObjectContext context) +{ + return ((CallContext *)context)->skip; +} + +Tcl_Namespace * +Tcl_GetObjectNamespace( + Tcl_Object object) +{ + return ((Object *)object)->namespacePtr; +} + +Tcl_Command +Tcl_GetObjectCommand( + Tcl_Object object) +{ + return ((Object *)object)->command; +} + +Tcl_Class +Tcl_GetObjectAsClass( + Tcl_Object object) +{ + return (Tcl_Class) ((Object *)object)->classPtr; +} + +int +Tcl_ObjectDeleted( + Tcl_Object object) +{ + return Deleted(object) ? 1 : 0; +} + +Tcl_Object +Tcl_GetClassAsObject( + Tcl_Class clazz) +{ + return (Tcl_Object) ((Class *)clazz)->thisPtr; +} + +Tcl_ObjectMapMethodNameProc * +Tcl_ObjectGetMethodNameMapper( + Tcl_Object object) +{ + return ((Object *) object)->mapMethodNameProc; +} + +void +Tcl_ObjectSetMethodNameMapper( + Tcl_Object object, + Tcl_ObjectMapMethodNameProc *mapMethodNameProc) +{ + ((Object *) object)->mapMethodNameProc = mapMethodNameProc; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclProc.c b/generic/tclProc.c index 28b6033..dc58cb0 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -124,8 +124,8 @@ Tcl_ProcObjCmd( { register Interp *iPtr = (Interp *) interp; Proc *procPtr; - const char *fullName; - const char *procName, *procArgs, *procBody; + const char *procName; + const char *simpleName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; @@ -140,21 +140,21 @@ Tcl_ProcObjCmd( * namespace. */ - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } @@ -163,15 +163,15 @@ Tcl_ProcObjCmd( * Create the data structure to represent the procedure. */ - if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], + if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3], &procPtr) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (creating proc \""); - Tcl_AddErrorInfo(interp, procName); + Tcl_AddErrorInfo(interp, simpleName); Tcl_AddErrorInfo(interp, "\")"); return TCL_ERROR; } - cmd = tclNRCreateCommandInNs(interp, procName, (Tcl_Namespace *) nsPtr, + cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr, TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc); /* |