diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tclBasic.c | 1876 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 | ||||
| -rw-r--r-- | generic/tclListObj.c | 108 | ||||
| -rw-r--r-- | generic/tclUtil.c | 11 | ||||
| -rw-r--r-- | tests/eval.test | 25 |
6 files changed, 1071 insertions, 964 deletions
@@ -1,3 +1,12 @@ +2005-09-06 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + * generic/tclInt.h (List): Added flag to keep track of whether a list + * generic/tclListObj.c: with a string rep is provably canonical. + * generic/tclUtil.c (Tcl_ConcatObj): Do efficient concatenation and + * generic/tclBasic.c (Tcl_EvalObjEx): evaluation when the list is + canonical, and not just when the list is pure. This should make the + "pure list" hacking introduced in 8.3 much more robust. + 2005-09-05 Donal K. Fellows <donal.k.fellows@man.ac.uk> * generic/tclObj.c (pendingObjDataKey): Added missing 'static' to stop diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a259130..e9c12d9 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2,18 +2,18 @@ * tclBasic.c -- * * Contains the basic facilities for TCL command interpretation, - * including interpreter creation and deletion, command creation - * and deletion, and command/script execution. + * including interpreter creation and deletion, command creation and + * deletion, and command/script execution. * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.168 2005/08/29 16:18:59 kennykb Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.169 2005/09/06 14:40:10 dkf Exp $ */ #include "tclInt.h" @@ -37,47 +37,46 @@ typedef struct OldMathFuncData { * Static procedures in this file: */ -static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr, Command *cmdPtr, - CONST char *oldName, CONST char* newName, int flags)); -static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); -static void ProcessUnexpectedResult _ANSI_ARGS_((Tcl_Interp *interp, - int returnCode)); - -static int OldMathFuncProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); - -static void OldMathFuncDeleteProc _ANSI_ARGS_((ClientData)); - -static int ExprAbsFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); -static int ExprBinaryFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); -static int ExprBoolFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); -static int ExprDoubleFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); -static int ExprIntFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); -static int ExprRandFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); -static int ExprRoundFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); -static int ExprSrandFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); -static int ExprUnaryFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); -static int ExprWideFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); -static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); - -static void MathFuncWrongNumArgs _ANSI_ARGS_((Tcl_Interp* interp, - int expected, int actual, Tcl_Obj *CONST *objv)); +static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, + CONST char *oldName, CONST char* newName, int flags); +static void DeleteInterpProc(Tcl_Interp *interp); +static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); + +static int OldMathFuncProc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); + +static void OldMathFuncDeleteProc(ClientData clientData); + +static int ExprAbsFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprBinaryFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprBoolFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprDoubleFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprIntFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprRandFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprRoundFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprSrandFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprUnaryFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprWideFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int VerifyExprObjType(Tcl_Interp *interp, Tcl_Obj *objPtr); + +static void MathFuncWrongNumArgs(Tcl_Interp* interp, int expected, + int actual, Tcl_Obj *CONST *objv); #ifndef TCL_WIDE_INT_IS_LONG /* * Extract a double value from a general numeric object. */ + #define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ if ((typePtr) == &tclIntType) { \ (doubleVar) = (double) (objPtr)->internalRep.longValue; \ @@ -110,8 +109,8 @@ static void MathFuncWrongNumArgs _ANSI_ARGS_((Tcl_Interp* interp, /* * Macros for testing floating-point values for certain special cases. Test - * for not-a-number by comparing a value against itself; test for infinity - * by comparing against the largest floating-point value. + * for not-a-number by comparing a value against itself; test for infinity by + * comparing against the largest floating-point value. */ #ifdef _MSC_VER @@ -132,9 +131,9 @@ typedef struct { char *name; /* Name of object-based command. */ Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */ CompileProc *compileProc; /* Procedure called to compile command. */ - int isSafe; /* If non-zero, command will be present - * in safe interpreter. Otherwise it will - * be hidden. */ + int isSafe; /* If non-zero, command will be present in + * safe interpreter. Otherwise it will be + * hidden. */ } CmdInfo; /* @@ -143,7 +142,7 @@ typedef struct { static CmdInfo builtInCmds[] = { /* - * Commands in the generic core. + * Commands in the generic core. */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1}, @@ -285,13 +284,12 @@ static BuiltinFuncDef BuiltinFuncTable[] = { * Create a new TCL command interpreter. * * Results: - * The return value is a token for the interpreter, which may be - * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or - * Tcl_DeleteInterp. + * The return value is a token for the interpreter, which may be used in + * calls to procedures like Tcl_CreateCmd, Tcl_Eval, or Tcl_DeleteInterp. * * Side effects: - * The command interpreter is initialized with the built-in commands - * and with the variables documented in tclvars(n). + * The command interpreter is initialized with the built-in commands and + * with the variables documented in tclvars(n). * *---------------------------------------------------------------------- */ @@ -317,9 +315,9 @@ Tcl_CreateInterp() TclInitSubsystems(); /* - * Panic if someone updated the CallFrame structure without - * also updating the Tcl_CallFrame structure (or vice versa). - */ + * Panic if someone updated the CallFrame structure without also updating + * the Tcl_CallFrame structure (or vice versa). + */ if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) { /*NOTREACHED*/ @@ -328,8 +326,8 @@ Tcl_CreateInterp() /* * Initialize support for namespaces and create the global namespace - * (whose name is ""; an alias is "::"). This also initializes the - * Tcl object type table and other object management code. + * (whose name is ""; an alias is "::"). This also initializes the Tcl + * object type table and other object management code. */ iPtr = (Interp *) ckalloc(sizeof(Interp)); @@ -385,7 +383,7 @@ Tcl_CreateInterp() Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->resultSpace[0] = 0; - iPtr->globalNsPtr = NULL; /* force creation of global ns below */ + iPtr->globalNsPtr = NULL; /* force creation of global ns below */ iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (iPtr->globalNsPtr == NULL) { @@ -401,7 +399,10 @@ Tcl_CreateInterp() iPtr->execEnvPtr = TclCreateExecEnv(interp); - /* TIP #219, Tcl Channel Reflection API */ + /* + * TIP #219, Tcl Channel Reflection API support. + */ + iPtr->chanMsg = NULL; /* @@ -437,7 +438,7 @@ Tcl_CreateInterp() statsPtr->totalLitStringBytes = 0.0; statsPtr->currentLitStringBytes = 0.0; (VOID *) memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); -#endif /* TCL_COMPILE_STATS */ +#endif /* TCL_COMPILE_STATS */ /* * Initialise the stub table pointer. @@ -461,13 +462,13 @@ Tcl_CreateInterp() /* * Create the core commands. Do it here, rather than calling - * Tcl_CreateCommand, because it's faster (there's no need to check for - * a pre-existing command by the same name). If a command has a - * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to - * TclInvokeStringCommand. This is an object-based wrapper procedure - * that extracts strings, calls the string procedure, and creates an - * object for the result. Similarly, if a command has a Tcl_ObjCmdProc - * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. + * Tcl_CreateCommand, because it's faster (there's no need to check for a + * pre-existing command by the same name). If a command has a Tcl_CmdProc + * but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to + * TclInvokeStringCommand. This is an object-based wrapper procedure that + * extracts strings, calls the string procedure, and creates an object for + * the result. Similarly, if a command has a Tcl_ObjCmdProc but no + * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. */ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { @@ -502,7 +503,7 @@ Tcl_CreateInterp() } /* - * Register the clock commands. These *do* go through + * Register clock and chan subcommands. These *do* go through * Tcl_CreateObjCommand, since they aren't in the global namespace. */ @@ -548,13 +549,18 @@ Tcl_CreateInterp() */ - /* Register the default [interp bgerror] handler. */ + /* + * Register the default [interp bgerror] handler. + */ Tcl_CreateObjCommand(interp, "::tcl::Bgerror", TclDefaultBgErrorHandlerObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); - /* Register the unsupported encoding search path command */ + /* + * Register the unsupported encoding search path command. + */ + Tcl_CreateObjCommand(interp, "::tcl::unsupported::EncodingDirs", TclEncodingDirsObjCmd, NULL, NULL); @@ -623,15 +629,14 @@ Tcl_CreateInterp() #ifdef TCL_THREADS /* - * The existence of the "threaded" element of the tcl_platform array indicates - * that this particular Tcl shell has been compiled with threads turned on. - * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the - * interpreter level of thread safety. + * The existence of the "threaded" element of the tcl_platform array + * indicates that this particular Tcl shell has been compiled with threads + * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can + * introspect on the interpreter level of thread safety. */ - Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", - TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY); #endif /* @@ -653,8 +658,7 @@ Tcl_CreateInterp() * * TclHideUnsafeCommands -- * - * Hides base commands that are not marked as safe from this - * interpreter. + * Hides base commands that are not marked as safe from this interpreter. * * Results: * TCL_OK if it succeeds, TCL_ERROR else. @@ -687,20 +691,18 @@ TclHideUnsafeCommands(interp) * * Tcl_CallWhenDeleted -- * - * Arrange for a procedure to be called before a given - * interpreter is deleted. The procedure is called as soon - * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is - * called on an interpreter that has already been deleted, - * the procedure will be called when the last Tcl_Release is - * done on the interpreter. + * Arrange for a procedure to be called before a given interpreter is + * deleted. The procedure is called as soon as Tcl_DeleteInterp is + * called; if Tcl_CallWhenDeleted is called on an interpreter that has + * already been deleted, the procedure will be called when the last + * Tcl_Release is done on the interpreter. * * Results: * None. * * Side effects: - * When Tcl_DeleteInterp is invoked to delete interp, - * proc will be invoked. See the manual entry for - * details. + * When Tcl_DeleteInterp is invoked to delete interp, proc will be + * invoked. See the manual entry for details. * *-------------------------------------------------------------- */ @@ -708,8 +710,8 @@ TclHideUnsafeCommands(interp) void Tcl_CallWhenDeleted(interp, proc, clientData) Tcl_Interp *interp; /* Interpreter to watch. */ - Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter - * is about to be deleted. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter is about + * to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; @@ -739,17 +741,16 @@ Tcl_CallWhenDeleted(interp, proc, clientData) * * Tcl_DontCallWhenDeleted -- * - * Cancel the arrangement for a procedure to be called when - * a given interpreter is deleted. + * Cancel the arrangement for a procedure to be called when a given + * interpreter is deleted. * * Results: * None. * * Side effects: - * If proc and clientData were previously registered as a - * callback via Tcl_CallWhenDeleted, they are unregistered. - * If they weren't previously registered then nothing - * happens. + * If proc and clientData were previously registered as a callback via + * Tcl_CallWhenDeleted, they are unregistered. If they weren't previously + * registered then nothing happens. * *-------------------------------------------------------------- */ @@ -757,8 +758,8 @@ Tcl_CallWhenDeleted(interp, proc, clientData) void Tcl_DontCallWhenDeleted(interp, proc, clientData) Tcl_Interp *interp; /* Interpreter to watch. */ - Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter - * is about to be deleted. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter is about + * to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; @@ -788,9 +789,9 @@ Tcl_DontCallWhenDeleted(interp, proc, clientData) * Tcl_SetAssocData -- * * Creates a named association between user-specified data, a delete - * function and this interpreter. If the association already exists - * the data is overwritten with the new data. The delete function will - * be invoked when the interpreter is deleted. + * function and this interpreter. If the association already exists the + * data is overwritten with the new data. The delete function will be + * invoked when the interpreter is deleted. * * Results: * None. @@ -805,8 +806,8 @@ void Tcl_SetAssocData(interp, name, proc, clientData) Tcl_Interp *interp; /* Interpreter to associate with. */ CONST char *name; /* Name for association. */ - Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is - * about to be deleted. */ + Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is about to + * be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; @@ -835,8 +836,8 @@ Tcl_SetAssocData(interp, name, proc, clientData) * * Tcl_DeleteAssocData -- * - * Deletes a named association of user-specified data with - * the specified interpreter. + * Deletes a named association of user-specified data with the specified + * interpreter. * * Results: * None. @@ -849,8 +850,8 @@ Tcl_SetAssocData(interp, name, proc, clientData) void Tcl_DeleteAssocData(interp, name) - Tcl_Interp *interp; /* Interpreter to associate with. */ - CONST char *name; /* Name of association. */ + Tcl_Interp *interp; /* Interpreter to associate with. */ + CONST char *name; /* Name of association. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; @@ -876,8 +877,8 @@ Tcl_DeleteAssocData(interp, name) * * Tcl_GetAssocData -- * - * Returns the client data associated with this name in the - * specified interpreter. + * Returns the client data associated with this name in the specified + * interpreter. * * Results: * The client data in the AssocData record denoted by the named @@ -891,10 +892,11 @@ Tcl_DeleteAssocData(interp, name) ClientData Tcl_GetAssocData(interp, name, procPtr) - Tcl_Interp *interp; /* Interpreter associated with. */ - CONST char *name; /* Name of association. */ - Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address - * of current deletion callback. */ + Tcl_Interp *interp; /* Interpreter associated with. */ + CONST char *name; /* Name of association. */ + Tcl_InterpDeleteProc **procPtr; + /* Pointer to place to store address of + * current deletion callback. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; @@ -919,8 +921,8 @@ Tcl_GetAssocData(interp, name, procPtr) * * Tcl_InterpDeleted -- * - * Returns nonzero if the interpreter has been deleted with a call - * to Tcl_DeleteInterp. + * Returns nonzero if the interpreter has been deleted with a call to + * Tcl_DeleteInterp. * * Results: * Nonzero if the interpreter is deleted, zero otherwise. @@ -943,11 +945,11 @@ Tcl_InterpDeleted(interp) * * Tcl_DeleteInterp -- * - * Ensures that the interpreter will be deleted eventually. If there - * are no Tcl_Preserve calls in effect for this interpreter, it is - * deleted immediately, otherwise the interpreter is deleted when - * the last Tcl_Preserve is matched by a call to Tcl_Release. In either - * case, the procedure runs the currently registered deletion callbacks. + * Ensures that the interpreter will be deleted eventually. If there are + * no Tcl_Preserve calls in effect for this interpreter, it is deleted + * immediately, otherwise the interpreter is deleted when the last + * Tcl_Preserve is matched by a call to Tcl_Release. In either case, the + * procedure runs the currently registered deletion callbacks. * * Results: * None. @@ -963,8 +965,8 @@ Tcl_InterpDeleted(interp) void Tcl_DeleteInterp(interp) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by a previous call to Tcl_CreateInterp). */ + Tcl_Interp *interp; /* Token for command interpreter (returned by + * a previous call to Tcl_CreateInterp). */ { Interp *iPtr = (Interp *) interp; @@ -984,8 +986,8 @@ Tcl_DeleteInterp(interp) iPtr->flags |= DELETED; iPtr->compileEpoch++; - /* TIP #219, Tcl Channel Reflection API. - * Discard a leftover state. + /* + * TIP #219, Tcl Channel Reflection API. Discard a leftover state. */ if (iPtr->chanMsg != NULL) { @@ -1005,25 +1007,25 @@ Tcl_DeleteInterp(interp) * * DeleteInterpProc -- * - * Helper procedure to delete an interpreter. This procedure is - * called when the last call to Tcl_Preserve on this interpreter - * is matched by a call to Tcl_Release. The procedure cleans up - * all resources used in the interpreter and calls all currently - * registered interpreter deletion callbacks. + * Helper procedure to delete an interpreter. This procedure is called + * when the last call to Tcl_Preserve on this interpreter is matched by a + * call to Tcl_Release. The procedure cleans up all resources used in the + * interpreter and calls all currently registered interpreter deletion + * callbacks. * * Results: * None. * * Side effects: - * Whatever the interpreter deletion callbacks do. Frees resources - * used by the interpreter. + * Whatever the interpreter deletion callbacks do. Frees resources used + * by the interpreter. * *---------------------------------------------------------------------- */ static void DeleteInterpProc(interp) - Tcl_Interp *interp; /* Interpreter to delete. */ + Tcl_Interp *interp; /* Interpreter to delete. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; @@ -1040,8 +1042,8 @@ DeleteInterpProc(interp) } /* - * The interpreter should already be marked deleted; otherwise how - * did we get here? + * The interpreter should already be marked deleted; otherwise how did we + * get here? */ if (!(iPtr->flags & DELETED)) { @@ -1049,9 +1051,8 @@ DeleteInterpProc(interp) } /* - * Shut down all limit handler callback scripts that call back - * into this interpreter. Then eliminate all limit handlers for - * this interpreter. + * Shut down all limit handler callback scripts that call back into this + * interpreter. Then eliminate all limit handlers for this interpreter. */ TclRemoveScriptLimitCallbacks(interp); @@ -1077,8 +1078,8 @@ DeleteInterpProc(interp) hTablePtr = iPtr->hiddenCmdTablePtr; if (hTablePtr != NULL) { /* - * Non-pernicious deletion. The deletion callbacks will not be - * allowed to create any new hidden or non-hidden commands. + * Non-pernicious deletion. The deletion callbacks will not be allowed + * to create any new hidden or non-hidden commands. * Tcl_DeleteCommandFromToken() will remove the entry from the * hiddenCmdTablePtr. */ @@ -1123,9 +1124,8 @@ DeleteInterpProc(interp) Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); /* - * Free up the result *after* deleting variables, since variable - * deletion could have transferred ownership of the result string - * to Tcl. + * Free up the result *after* deleting variables, since variable deletion + * could have transferred ownership of the result string to Tcl. */ Tcl_FreeResult(interp); @@ -1181,16 +1181,16 @@ DeleteInterpProc(interp) * * Tcl_HideCommand -- * - * Makes a command hidden so that it cannot be invoked from within - * an interpreter, only from within an ancestor. + * Makes a command hidden so that it cannot be invoked from within an + * interpreter, only from within an ancestor. * * Results: - * A standard Tcl result; also leaves a message in the interp's result - * if an error occurs. + * A standard Tcl result; also leaves a message in the interp's result if + * an error occurs. * * Side effects: - * Removes a command from the command table and create an entry - * into the hidden command table under the specified token name. + * Removes a command from the command table and create an entry into the + * hidden command table under the specified token name. * *--------------------------------------------------------------------------- */ @@ -1211,8 +1211,8 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) if (iPtr->flags & DELETED) { /* - * The interpreter is being deleted. Do not create any new - * structures, because it is not safe to modify the interpreter. + * The interpreter is being deleted. Do not create any new structures, + * because it is not safe to modify the interpreter. */ return TCL_ERROR; @@ -1220,13 +1220,12 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) /* * Disallow hiding of commands that are currently in a namespace or - * renaming (as part of hiding) into a namespace. - * - * (because the current implementation with a single global table - * and the needed uniqueness of names cause problems with namespaces) + * renaming (as part of hiding) into a namespace (because the current + * implementation with a single global table and the needed uniqueness of + * names cause problems with namespaces). * - * we don't need to check for "::" in cmdName because the real check is - * on the nsPtr below. + * We don't need to check for "::" in cmdName because the real check is on + * the nsPtr below. * * hiddenCmdToken is just a string which is not interpreted in any way. * It may contain :: but the string is not interpreted as a namespace @@ -1235,9 +1234,9 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * application always uses the same strings it will get consistent * behaviour. * - * But as we currently limit ourselves to the global namespace only - * for the source, in order to avoid potential confusion, - * lets prevent "::" in the token too. --dl + * But as we currently limit ourselves to the global namespace only for + * the source, in order to avoid potential confusion, lets prevent "::" in + * the token too. - dl */ if (strstr(hiddenCmdToken, "::") != NULL) { @@ -1248,9 +1247,9 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) } /* - * Find the command to hide. An error is returned if cmdName can't - * be found. Look up the command only from the global namespace. - * Full path of the command must be given if using namespaces. + * Find the command to hide. An error is returned if cmdName can't be + * found. Look up the command only from the global namespace. Full path of + * the command must be given if using namespaces. */ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, @@ -1297,9 +1296,8 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) /* * Nb : This code is currently 'like' a rename to a specialy set apart - * name table. Changes here and in TclRenameCommand must - * be kept in synch untill the common parts are actually - * factorized out. + * name table. Changes here and in TclRenameCommand must be kept in synch + * untill the common parts are actually factorized out. */ /* @@ -1315,16 +1313,16 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) } /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just yet; - * next time we need the info will be soon enough. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we need + * the info will be soon enough. */ TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* - * Now link the hash table entry with the command structure. - * We ensured above that the nsPtr was right. + * Now link the hash table entry with the command structure. We ensured + * above that the nsPtr was right. */ cmdPtr->hPtr = hPtr; @@ -1332,11 +1330,11 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) /* * If the command being hidden has a compile procedure, increment the - * interpreter's compileEpoch to invalidate its compiled code. This - * makes sure that we don't later try to execute old code compiled with - * command-specific (i.e., inline) bytecodes for the now-hidden - * command. This field is checked in Tcl_EvalObj and ObjInterpProc, - * and code whose compilation epoch doesn't match is recompiled. + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled with + * command-specific (i.e., inline) bytecodes for the now-hidden command. + * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose + * compilation epoch doesn't match is recompiled. */ if (cmdPtr->compileProc != NULL) { @@ -1350,12 +1348,12 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * * Tcl_ExposeCommand -- * - * Makes a previously hidden command callable from inside the - * interpreter instead of only by its ancestors. + * Makes a previously hidden command callable from inside the interpreter + * instead of only by its ancestors. * * Results: - * A standard Tcl result. If an error occurs, a message is left - * in the interp's result. + * A standard Tcl result. If an error occurs, a message is left in the + * interp's result. * * Side effects: * Moves commands from one hash table to another. @@ -1379,17 +1377,17 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) if (iPtr->flags & DELETED) { /* - * The interpreter is being deleted. Do not create any new - * structures, because it is not safe to modify the interpreter. + * The interpreter is being deleted. Do not create any new structures, + * because it is not safe to modify the interpreter. */ return TCL_ERROR; } /* - * Check that we have a regular name for the command - * (that the user is not trying to do an expose and a rename - * (to another namespace) at the same time) + * Check that we have a regular name for the command (that the user is not + * trying to do an expose and a rename (to another namespace) at the same + * time). */ if (strstr(cmdName, "::") != NULL) { @@ -1415,16 +1413,17 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) cmdPtr = (Command *) Tcl_GetHashValue(hPtr); /* - * Check that we have a true global namespace - * command (enforced by Tcl_HideCommand() but let's double - * check. (If it was not, we would not really know how to - * handle it). + * Check that we have a true global namespace command (enforced by + * Tcl_HideCommand() but let's double check. (If it was not, we would not + * really know how to handle it). */ + if (cmdPtr->nsPtr != iPtr->globalNsPtr) { - /* - * This case is theoritically impossible, - * we might rather Tcl_Panic() than 'nicely' erroring out ? + /* + * This case is theoritically impossible, we might rather Tcl_Panic() + * than 'nicely' erroring out ? */ + Tcl_AppendResult(interp, "trying to expose a non global command name space command", (char *) NULL); @@ -1435,8 +1434,8 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) nsPtr = cmdPtr->nsPtr; /* - * It is an error to overwrite an existing exposed command as a result - * of exposing a previously hidden command. + * It is an error to overwrite an existing exposed command as a result of + * exposing a previously hidden command. */ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new); @@ -1447,9 +1446,9 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) } /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just yet; - * next time we need the info will be soon enough. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we need + * the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); @@ -1465,9 +1464,9 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) } /* - * Now link the hash table entry with the command structure. - * This is like creating a new command, so deal with any shadowing - * of commands in the global namespace. + * Now link the hash table entry with the command structure. This is like + * creating a new command, so deal with any shadowing of commands in the + * global namespace. */ cmdPtr->hPtr = hPtr; @@ -1475,18 +1474,18 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); /* - * Not needed as we are only in the global namespace - * (but would be needed again if we supported namespace command hiding) + * Not needed as we are only in the global namespace (but would be needed + * again if we supported namespace command hiding) * * TclResetShadowedCmdRefs(interp, cmdPtr); */ /* * If the command being exposed has a compile procedure, increment - * interpreter's compileEpoch to invalidate its compiled code. This - * makes sure that we don't later try to execute old code compiled - * assuming the command is hidden. This field is checked in Tcl_EvalObj - * and ObjInterpProc, and code whose compilation epoch doesn't match is + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled assuming the + * command is hidden. This field is checked in Tcl_EvalObj and + * ObjInterpProc, and code whose compilation epoch doesn't match is * recompiled. */ @@ -1504,34 +1503,34 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) * Define a new command in a command table. * * Results: - * The return value is a token for the command, which can - * be used in future calls to Tcl_GetCommandName. + * The return value is a token for the command, which can be used in + * future calls to Tcl_GetCommandName. * * Side effects: * If a command named cmdName already exists for interp, it is deleted. * In the future, when cmdName is seen as the name of a command by * Tcl_Eval, proc will be called. To support the bytecode interpreter, * the command is created with a wrapper Tcl_ObjCmdProc - * (TclInvokeStringCommand) that eventially calls proc. When the - * command is deleted from the table, deleteProc will be called. - * See the manual entry for details on the calling sequence. + * (TclInvokeStringCommand) that eventially calls proc. When the command + * is deleted from the table, deleteProc will be called. See the manual + * entry for details on the calling sequence. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) - Tcl_Interp *interp; /* Token for command interpreter returned by - * a previous call to Tcl_CreateInterp. */ + Tcl_Interp *interp; /* Token for command interpreter returned by a + * previous call to Tcl_CreateInterp. */ CONST char *cmdName; /* Name of command. If it contains namespace * qualifiers, the new command is put in the - * specified namespace; otherwise it is put - * in the global namespace. */ + * specified namespace; otherwise it is put in + * the global namespace. */ Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */ ClientData clientData; /* Arbitrary value passed to string proc. */ Tcl_CmdDeleteProc *deleteProc; - /* If not NULL, gives a procedure to call - * when this command is deleted. */ + /* If not NULL, gives a procedure to call when + * this command is deleted. */ { Interp *iPtr = (Interp *) interp; ImportRef *oldRefPtr = NULL; @@ -1544,17 +1543,17 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) if (iPtr->flags & DELETED) { /* - * The interpreter is being deleted. Don't create any new - * commands; it's not safe to muck with the interpreter anymore. + * The interpreter is being deleted. Don't create any new commands; + * it's not safe to muck with the interpreter anymore. */ return (Tcl_Command) NULL; } /* - * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; - * otherwise, we always put it in the global namespace. + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; otherwise, + * we always put it in the global namespace. */ if (strstr(cmdName, "::") != NULL) { @@ -1571,10 +1570,10 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* - * Command already exists. Delete the old one. - * Be careful to preserve any existing import links so we can - * restore them down below. That way, you can redefine a - * command and its import status will remain intact. + * Command already exists. Delete the old one. Be careful to preserve + * any existing import links so we can restore them down below. That + * way, you can redefine a command and its import status will remain + * intact. */ cmdPtr = (Command *) Tcl_GetHashValue(hPtr); @@ -1585,18 +1584,18 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* - * If the deletion callback recreated the command, just throw - * away the new command (if we try to delete it again, we - * could get stuck in an infinite loop). + * If the deletion callback recreated the command, just throw away + * the new command (if we try to delete it again, we could get + * stuck in an infinite loop). */ ckfree((char*) Tcl_GetHashValue(hPtr)); } } else { /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just - * yet; next time we need the info will be soon enough. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we + * need the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); @@ -1620,8 +1619,8 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->tracePtr = NULL; /* - * Plug in any existing import references found above. Be sure - * to update all of these references to point to the new command. + * Plug in any existing import references found above. Be sure to update + * all of these references to point to the new command. */ if (oldRefPtr != NULL) { @@ -1653,41 +1652,41 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) * Define a new object-based command in a command table. * * Results: - * The return value is a token for the command, which can - * be used in future calls to Tcl_GetCommandName. + * The return value is a token for the command, which can be used in + * future calls to Tcl_GetCommandName. * * Side effects: * If no command named "cmdName" already exists for interp, one is - * created. Otherwise, if a command does exist, then if the - * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume - * Tcl_CreateCommand was called previously for the same command and - * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we - * delete the old command. + * created. Otherwise, if a command does exist, then if the object-based + * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand + * was called previously for the same command and just set its + * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old + * command. * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based * Tcl_ObjCmdProc proc will be called. When the command is deleted from - * the table, deleteProc will be called. See the manual entry for - * details on the calling sequence. + * the table, deleteProc will be called. See the manual entry for details + * on the calling sequence. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by previous call to Tcl_CreateInterp). */ + Tcl_Interp *interp; /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ CONST char *cmdName; /* Name of command. If it contains namespace * qualifiers, the new command is put in the - * specified namespace; otherwise it is put - * in the global namespace. */ + * specified namespace; otherwise it is put in + * the global namespace. */ Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with * name. */ ClientData clientData; /* Arbitrary value to pass to object * procedure. */ Tcl_CmdDeleteProc *deleteProc; - /* If not NULL, gives a procedure to call - * when this command is deleted. */ + /* If not NULL, gives a procedure to call when + * this command is deleted. */ { Interp *iPtr = (Interp *) interp; ImportRef *oldRefPtr = NULL; @@ -1700,17 +1699,17 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) if (iPtr->flags & DELETED) { /* - * The interpreter is being deleted. Don't create any new - * commands; it's not safe to muck with the interpreter anymore. + * The interpreter is being deleted. Don't create any new commands; + * it's not safe to muck with the interpreter anymore. */ return (Tcl_Command) NULL; } /* - * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; - * otherwise, we always put it in the global namespace. + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; otherwise, + * we always put it in the global namespace. */ if (strstr(cmdName, "::") != NULL) { @@ -1732,7 +1731,7 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) /* * Command already exists. If its object-based Tcl_ObjCmdProc is * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the - * argument "proc". Otherwise, we delete the old command. + * argument "proc". Otherwise, we delete the old command. */ if (cmdPtr->objProc == TclInvokeStringCommand) { @@ -1744,10 +1743,10 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) } /* - * Otherwise, we delete the old command. Be careful to preserve - * any existing import links so we can restore them down below. - * That way, you can redefine a command and its import status - * will remain intact. + * Otherwise, we delete the old command. Be careful to preserve any + * existing import links so we can restore them down below. That way, + * you can redefine a command and its import status will remain + * intact. */ oldRefPtr = cmdPtr->importRefPtr; @@ -1757,18 +1756,18 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* - * If the deletion callback recreated the command, just throw - * away the new command (if we try to delete it again, we - * could get stuck in an infinite loop). + * If the deletion callback recreated the command, just throw away + * the new command (if we try to delete it again, we could get + * stuck in an infinite loop). */ ckfree((char *) Tcl_GetHashValue(hPtr)); } } else { /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just - * yet; next time we need the info will be soon enough. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we + * need the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); @@ -1792,8 +1791,8 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->tracePtr = NULL; /* - * Plug in any existing import references found above. Be sure - * to update all of these references to point to the new command. + * Plug in any existing import references found above. Be sure to update + * all of these references to point to the new command. */ if (oldRefPtr != NULL) { @@ -1824,9 +1823,9 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) * * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based * Tcl_CmdProc if no object-based procedure exists for a command. A - * pointer to this procedure is stored as the Tcl_ObjCmdProc in a - * Command structure. It simply turns around and calls the string - * Tcl_CmdProc in the Command structure. + * pointer to this procedure is stored as the Tcl_ObjCmdProc in a Command + * structure. It simply turns around and calls the string Tcl_CmdProc in + * the Command structure. * * Results: * A standard Tcl object result value. @@ -1860,9 +1859,8 @@ TclInvokeStringCommand(clientData, interp, objc, objv) CONST char **argv = argStorage; /* - * Create the string argument array "argv". Make sure argv is large - * enough to hold the objc arguments plus 1 extra for the zero - * end-of-argv word. + * Create the string argument array "argv". Make sure argv is large enough + * to hold the objc arguments plus 1 extra for the zero end-of-argv word. */ if ((objc + 1) > NUM_ARGS) { @@ -1897,10 +1895,10 @@ TclInvokeStringCommand(clientData, interp, objc, objv) * TclInvokeObjectCommand -- * * "Wrapper" Tcl_CmdProc used to call an existing object-based - * Tcl_ObjCmdProc if no string-based procedure exists for a command. - * A pointer to this procedure is stored as the Tcl_CmdProc in a - * Command structure. It simply turns around and calls the object - * Tcl_ObjCmdProc in the Command structure. + * Tcl_ObjCmdProc if no string-based procedure exists for a command. A + * pointer to this procedure is stored as the Tcl_CmdProc in a Command + * structure. It simply turns around and calls the object Tcl_ObjCmdProc + * in the Command structure. * * Results: * A standard Tcl string result value. @@ -1935,9 +1933,8 @@ TclInvokeObjectCommand(clientData, interp, argc, argv) register Tcl_Obj **objv = argStorage; /* - * Create the object argument array "objv". Make sure objv is large - * enough to hold the objc arguments plus 1 extra for the zero - * end-of-objv word. + * Create the object argument array "objv". Make sure objv is large enough + * to hold the objc arguments plus 1 extra for the zero end-of-objv word. */ if (argc > NUM_ARGS) { @@ -1958,15 +1955,15 @@ TclInvokeObjectCommand(clientData, interp, argc, argv) result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); /* - * Move the interpreter's object result to the string result, - * then reset the object result. + * Move the interpreter's object result to the string result, then reset + * the object result. */ (void) Tcl_GetStringResult(interp); /* - * Decrement the ref counts for the argument objects created above, - * then free the objv array if malloc'ed storage was used. + * Decrement the ref counts for the argument objects created above, then + * free the objv array if malloc'ed storage was used. */ for (i = 0; i < argc; i++) { @@ -1985,11 +1982,11 @@ TclInvokeObjectCommand(clientData, interp, argc, argv) * * TclRenameCommand -- * - * Called to give an existing Tcl command a different name. Both the - * old command name and the new command name can have "::" namespace - * qualifiers. If the new command has a different namespace context, - * the command will be moved to that namespace and will execute in - * the context of that new namespace. + * Called to give an existing Tcl command a different name. Both the old + * command name and the new command name can have "::" namespace + * qualifiers. If the new command has a different namespace context, the + * command will be moved to that namespace and will execute in the + * context of that new namespace. * * If the new command name is NULL or the null string, the command is * deleted. @@ -2021,8 +2018,8 @@ TclRenameCommand(interp, oldName, newName) Tcl_DString newFullName; /* - * Find the existing command. An error is returned if cmdName can't - * be found. + * Find the existing command. An error is returned if cmdName can't be + * found. */ cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL, @@ -2051,10 +2048,9 @@ TclRenameCommand(interp, oldName, newName) } /* - * Make sure that the destination command does not already exist. - * The rename operation is like creating a command, so we should - * automatically create the containing namespaces just like - * Tcl_CreateCommand would. + * Make sure that the destination command does not already exist. The + * rename operation is like creating a command, so we should automatically + * create the containing namespaces just like Tcl_CreateCommand would. */ TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, @@ -2074,15 +2070,15 @@ TclRenameCommand(interp, oldName, newName) } /* - * Warning: any changes done in the code here are likely - * to be needed in Tcl_HideCommand() code too. - * (until the common parts are extracted out) --dl + * Warning: any changes done in the code here are likely to be needed in + * Tcl_HideCommand() code too (until the common parts are extracted out). + * - dl */ /* - * Put the command in the new namespace so we can check for an alias - * loop. Since we are adding a new command to a namespace, we must - * handle any shadowing of the global commands that this might create. + * Put the command in the new namespace so we can check for an alias loop. + * Since we are adding a new command to a namespace, we must handle any + * shadowing of the global commands that this might create. */ oldHPtr = cmdPtr->hPtr; @@ -2093,8 +2089,8 @@ TclRenameCommand(interp, oldName, newName) TclResetShadowedCmdRefs(interp, cmdPtr); /* - * Now check for an alias loop. If we detect one, put everything back - * the way it was and report the error. + * Now check for an alias loop. If we detect one, put everything back the + * way it was and report the error. */ result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); @@ -2106,25 +2102,25 @@ TclRenameCommand(interp, oldName, newName) } /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just yet; - * next time we need the info will be soon enough. These might - * refer to the same variable, but that's no big deal. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we need + * the info will be soon enough. These might refer to the same variable, + * but that's no big deal. */ TclInvalidateNsCmdLookup(cmdNsPtr); TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* - * Script for rename traces can delete the command "oldName". - * Therefore increment the reference count for cmdPtr so that - * it's Command structure is freed only towards the end of this - * function by calling TclCleanupCommand. + * Script for rename traces can delete the command "oldName". Therefore + * increment the reference count for cmdPtr so that it's Command structure + * is freed only towards the end of this function by calling + * TclCleanupCommand. * - * The trace procedure needs to get a fully qualified name for - * old and new commands [Tcl bug #651271], or else there's no way - * for the trace procedure to get the namespace from which the old - * command is being renamed! + * The trace procedure needs to get a fully qualified name for old and new + * commands [Tcl bug #651271], or else there's no way for the trace + * procedure to get the namespace from which the old command is being + * renamed! */ Tcl_DStringInit(&newFullName); @@ -2139,9 +2135,9 @@ TclRenameCommand(interp, oldName, newName) Tcl_DStringFree(&newFullName); /* - * The new command name is okay, so remove the command from its - * current namespace. This is like deleting the command, so bump - * the cmdEpoch to invalidate any cached references to the command. + * The new command name is okay, so remove the command from its current + * namespace. This is like deleting the command, so bump the cmdEpoch to + * invalidate any cached references to the command. */ Tcl_DeleteHashEntry(oldHPtr); @@ -2149,9 +2145,9 @@ TclRenameCommand(interp, oldName, newName) /* * If the command being renamed has a compile procedure, increment the - * interpreter's compileEpoch to invalidate its compiled code. This - * makes sure that we don't later try to execute old code compiled for - * the now-renamed command. + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled for the + * now-renamed command. */ if (cmdPtr->compileProc != NULL) { @@ -2159,13 +2155,14 @@ TclRenameCommand(interp, oldName, newName) } /* - * Now free the Command structure, if the "oldName" command has - * been deleted by invocation of rename traces. + * Now free the Command structure, if the "oldName" command has been + * deleted by invocation of rename traces. */ + TclCleanupCommand(cmdPtr); result = TCL_OK; - done: + done: TclDecrRefCount(oldFullName); return result; } @@ -2175,16 +2172,15 @@ TclRenameCommand(interp, oldName, newName) * * Tcl_SetCommandInfo -- * - * Modifies various information about a Tcl command. Note that - * this procedure will not change a command's namespace; use - * TclRenameCommand to do that. Also, the isNativeObjectProc - * member of *infoPtr is ignored. + * Modifies various information about a Tcl command. Note that this + * procedure will not change a command's namespace; use TclRenameCommand + * to do that. Also, the isNativeObjectProc member of *infoPtr is + * ignored. * * Results: - * If cmdName exists in interp, then the information at *infoPtr - * is stored with the command in place of the current information - * and 1 is returned. If the command doesn't exist then 0 is - * returned. + * If cmdName exists in interp, then the information at *infoPtr is + * stored with the command in place of the current information and 1 is + * returned. If the command doesn't exist then 0 is returned. * * Side effects: * None. @@ -2194,11 +2190,11 @@ TclRenameCommand(interp, oldName, newName) int Tcl_SetCommandInfo(interp, cmdName, infoPtr) - Tcl_Interp *interp; /* Interpreter in which to look - * for command. */ - CONST char *cmdName; /* Name of desired command. */ - CONST Tcl_CmdInfo *infoPtr; /* Where to find information - * to store in the command. */ + Tcl_Interp *interp; /* Interpreter in which to look for + * command. */ + CONST char *cmdName; /* Name of desired command. */ + CONST Tcl_CmdInfo *infoPtr; /* Where to find information to store in the + * command. */ { Tcl_Command cmd; @@ -2214,16 +2210,15 @@ Tcl_SetCommandInfo(interp, cmdName, infoPtr) * * Tcl_SetCommandInfoFromToken -- * - * Modifies various information about a Tcl command. Note that - * this procedure will not change a command's namespace; use - * TclRenameCommand to do that. Also, the isNativeObjectProc - * member of *infoPtr is ignored. + * Modifies various information about a Tcl command. Note that this + * procedure will not change a command's namespace; use TclRenameCommand + * to do that. Also, the isNativeObjectProc member of *infoPtr is + * ignored. * * Results: - * If cmdName exists in interp, then the information at *infoPtr - * is stored with the command in place of the current information - * and 1 is returned. If the command doesn't exist then 0 is - * returned. + * If cmdName exists in interp, then the information at *infoPtr is + * stored with the command in place of the current information and 1 is + * returned. If the command doesn't exist then 0 is returned. * * Side effects: * None. @@ -2269,10 +2264,9 @@ Tcl_SetCommandInfoFromToken(cmd, infoPtr) * Returns various information about a Tcl command. * * Results: - * If cmdName exists in interp, then *infoPtr is modified to - * hold information about cmdName and 1 is returned. If the - * command doesn't exist then 0 is returned and *infoPtr isn't - * modified. + * If cmdName exists in interp, then *infoPtr is modified to hold + * information about cmdName and 1 is returned. If the command doesn't + * exist then 0 is returned and *infoPtr isn't modified. * * Side effects: * None. @@ -2282,11 +2276,11 @@ Tcl_SetCommandInfoFromToken(cmd, infoPtr) int Tcl_GetCommandInfo(interp, cmdName, infoPtr) - Tcl_Interp *interp; /* Interpreter in which to look - * for command. */ - CONST char *cmdName; /* Name of desired command. */ - Tcl_CmdInfo *infoPtr; /* Where to store information about - * command. */ + Tcl_Interp *interp; /* Interpreter in which to look for + * command. */ + CONST char *cmdName; /* Name of desired command. */ + Tcl_CmdInfo *infoPtr; /* Where to store information about + * command. */ { Tcl_Command cmd; @@ -2305,9 +2299,9 @@ Tcl_GetCommandInfo(interp, cmdName, infoPtr) * Returns various information about a Tcl command. * * Results: - * Copies information from the command identified by 'cmd' into - * a caller-supplied structure and returns 1. If the 'cmd' is - * NULL, leaves the structure untouched and returns 0. + * Copies information from the command identified by 'cmd' into a + * caller-supplied structure and returns 1. If the 'cmd' is NULL, leaves + * the structure untouched and returns 0. * * Side effects: * None. @@ -2320,7 +2314,6 @@ Tcl_GetCommandInfoFromToken(cmd, infoPtr) Tcl_Command cmd; Tcl_CmdInfo* infoPtr; { - Command* cmdPtr; /* Internal representation of the command */ if (cmd == (Tcl_Command) NULL) { @@ -2352,9 +2345,9 @@ Tcl_GetCommandInfoFromToken(cmd, infoPtr) * * Tcl_GetCommandName -- * - * Given a token returned by Tcl_CreateCommand, this procedure - * returns the current name of the command (which may have changed - * due to renaming). + * Given a token returned by Tcl_CreateCommand, this procedure returns + * the current name of the command (which may have changed due to + * renaming). * * Results: * The return value is the name of the given command. @@ -2369,21 +2362,21 @@ CONST char * Tcl_GetCommandName(interp, command) Tcl_Interp *interp; /* Interpreter containing the command. */ Tcl_Command command; /* Token for command returned by a previous - * call to Tcl_CreateCommand. The command - * must not have been deleted. */ + * call to Tcl_CreateCommand. The command must + * not have been deleted. */ { Command *cmdPtr = (Command *) command; if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { - /* * This should only happen if command was "created" after the - * interpreter began to be deleted, so there isn't really any - * command. Just return an empty string. + * interpreter began to be deleted, so there isn't really any command. + * Just return an empty string. */ return ""; } + return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); } @@ -2392,17 +2385,17 @@ Tcl_GetCommandName(interp, command) * * Tcl_GetCommandFullName -- * - * Given a token returned by, e.g., Tcl_CreateCommand or - * Tcl_FindCommand, this procedure appends to an object the command's - * full name, qualified by a sequence of parent namespace names. The - * command's fully-qualified name may have changed due to renaming. + * Given a token returned by, e.g., Tcl_CreateCommand or Tcl_FindCommand, + * this procedure appends to an object the command's full name, qualified + * by a sequence of parent namespace names. The command's fully-qualified + * name may have changed due to renaming. * * Results: * None. * * Side effects: * The command's fully-qualified name is appended to the string - * representation of objPtr. + * representation of objPtr. * *---------------------------------------------------------------------- */ @@ -2411,8 +2404,8 @@ void Tcl_GetCommandFullName(interp, command, objPtr) Tcl_Interp *interp; /* Interpreter containing the command. */ Tcl_Command command; /* Token for command returned by a previous - * call to Tcl_CreateCommand. The command - * must not have been deleted. */ + * call to Tcl_CreateCommand. The command must + * not have been deleted. */ Tcl_Obj *objPtr; /* Points to the object onto which the * command's full name is appended. */ @@ -2448,20 +2441,19 @@ Tcl_GetCommandFullName(interp, command, objPtr) * Remove the given command from the given interpreter. * * Results: - * 0 is returned if the command was deleted successfully. - * -1 is returned if there didn't exist a command by that name. + * 0 is returned if the command was deleted successfully. -1 is returned + * if there didn't exist a command by that name. * * Side effects: - * cmdName will no longer be recognized as a valid command for - * interp. + * cmdName will no longer be recognized as a valid command for interp. * *---------------------------------------------------------------------- */ int Tcl_DeleteCommand(interp, cmdName) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by a previous Tcl_CreateInterp call). */ + Tcl_Interp *interp; /* Token for command interpreter (returned by + * a previous Tcl_CreateInterp call). */ CONST char *cmdName; /* Name of command to remove. */ { Tcl_Command cmd; @@ -2484,24 +2476,24 @@ Tcl_DeleteCommand(interp, cmdName) * Tcl_DeleteCommandFromToken -- * * Removes the given command from the given interpreter. This procedure - * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead - * of a command name for efficiency. + * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead of + * a command name for efficiency. * * Results: - * 0 is returned if the command was deleted successfully. - * -1 is returned if there didn't exist a command by that name. + * 0 is returned if the command was deleted successfully. -1 is returned + * if there didn't exist a command by that name. * * Side effects: - * The command specified by "cmd" will no longer be recognized as a - * valid command for "interp". + * The command specified by "cmd" will no longer be recognized as a valid + * command for "interp". * *---------------------------------------------------------------------- */ int Tcl_DeleteCommandFromToken(interp, cmd) - Tcl_Interp *interp; /* Token for command interpreter returned by - * a previous call to Tcl_CreateInterp. */ + Tcl_Interp *interp; /* Token for command interpreter returned by a + * previous call to Tcl_CreateInterp. */ Tcl_Command cmd; /* Token for command to delete. */ { Interp *iPtr = (Interp *) interp; @@ -2510,22 +2502,21 @@ Tcl_DeleteCommandFromToken(interp, cmd) Tcl_Command importCmd; /* - * The code here is tricky. We can't delete the hash table entry - * before invoking the deletion callback because there are cases - * where the deletion callback needs to invoke the command (e.g. - * object systems such as OTcl). However, this means that the - * callback could try to delete or rename the command. The deleted - * flag allows us to detect these cases and skip nested deletes. + * The code here is tricky. We can't delete the hash table entry before + * invoking the deletion callback because there are cases where the + * deletion callback needs to invoke the command (e.g. object systems such + * as OTcl). However, this means that the callback could try to delete or + * rename the command. The deleted flag allows us to detect these cases + * and skip nested deletes. */ if (cmdPtr->flags & CMD_IS_DELETED) { /* - * Another deletion is already in progress. Remove the hash - * table entry now, but don't invoke a callback or free the - * command structure. Take care to only remove the hash entry - * if it has not already been removed; otherwise if we manage - * to hit this function three times, everything goes up in - * smoke. [Bug 1220058] + * Another deletion is already in progress. Remove the hash table + * entry now, but don't invoke a callback or free the command + * structure. Take care to only remove the hash entry if it has not + * already been removed; otherwise if we manage to hit this function + * three times, everything goes up in smoke. [Bug 1220058] */ if (cmdPtr->hPtr != NULL) { @@ -2535,24 +2526,29 @@ Tcl_DeleteCommandFromToken(interp, cmd) return 0; } - /* - * We must delete this command, even though both traces and - * delete procs may try to avoid this (renaming the command etc). - * Also traces and delete procs may try to delete the command - * themsevles. This flag declares that a delete is in progress - * and that recursive deletes should be ignored. + /* + * We must delete this command, even though both traces and delete procs + * may try to avoid this (renaming the command etc). Also traces and + * delete procs may try to delete the command themsevles. This flag + * declares that a delete is in progress and that recursive deletes should + * be ignored. */ + cmdPtr->flags |= CMD_IS_DELETED; /* - * Call trace procedures for the command being deleted. Then delete - * its traces. + * Call trace procedures for the command being deleted. Then delete its + * traces. */ if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); - /* Now delete these traces */ + + /* + * Now delete these traces. + */ + tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; @@ -2565,20 +2561,20 @@ Tcl_DeleteCommandFromToken(interp, cmd) } /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just yet; - * next time we need the info will be soon enough. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we need + * the info will be soon enough. */ TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* * If the command being deleted has a compile procedure, increment the - * interpreter's compileEpoch to invalidate its compiled code. This - * makes sure that we don't later try to execute old code compiled with - * command-specific (i.e., inline) bytecodes for the now-deleted - * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and - * code whose compilation epoch doesn't match is recompiled. + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled with + * command-specific (i.e., inline) bytecodes for the now-deleted command. + * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose + * compilation epoch doesn't match is recompiled. */ if (cmdPtr->compileProc != NULL) { @@ -2595,12 +2591,12 @@ Tcl_DeleteCommandFromToken(interp, cmd) /* * If you are getting a crash during the call to deleteProc and - * cmdPtr->deleteProc is a pointer to the function free(), the - * most likely cause is that your extension allocated memory - * for the clientData argument to Tcl_CreateObjCommand() with - * the ckalloc() macro and you are now trying to deallocate - * this memory with free() instead of ckfree(). You should - * pass a pointer to your own method that calls ckfree(). + * cmdPtr->deleteProc is a pointer to the function free(), the most + * likely cause is that your extension allocated memory for the + * clientData argument to Tcl_CreateObjCommand() with the ckalloc() + * macro and you are now trying to deallocate this memory with free() + * instead of ckfree(). You should pass a pointer to your own method + * that calls ckfree(). */ (*cmdPtr->deleteProc)(cmdPtr->deleteData); @@ -2627,10 +2623,10 @@ Tcl_DeleteCommandFromToken(interp, cmd) } /* - * Don't use hPtr to delete the hash entry here, because it's - * possible that the deletion callback renamed the command. - * Instead, use cmdPtr->hptr, and make sure that no-one else - * has already deleted the hash entry. + * Don't use hPtr to delete the hash entry here, because it's possible + * that the deletion callback renamed the command. Instead, use + * cmdPtr->hptr, and make sure that no-one else has already deleted the + * hash entry. */ if (cmdPtr->hPtr != NULL) { @@ -2641,19 +2637,19 @@ Tcl_DeleteCommandFromToken(interp, cmd) * Mark the Command structure as no longer valid. This allows * TclExecuteByteCode to recognize when a Command has logically been * deleted and a pointer to this Command structure cached in a CmdName - * object is invalid. TclExecuteByteCode will look up the command again - * in the interpreter's command hashtable. + * object is invalid. TclExecuteByteCode will look up the command again in + * the interpreter's command hashtable. */ cmdPtr->objProc = NULL; /* - * Now free the Command structure, unless there is another reference to - * it from a CmdName Tcl object in some ByteCode code sequence. In that - * case, delay the cleanup until all references are either discarded - * (when a ByteCode is freed) or replaced by a new reference (when a - * cached CmdName Command reference is found to be invalid and - * TclExecuteByteCode looks up the command in the command hashtable). + * Now free the Command structure, unless there is another reference to it + * from a CmdName Tcl object in some ByteCode code sequence. In that case, + * delay the cleanup until all references are either discarded (when a + * ByteCode is freed) or replaced by a new reference (when a cached + * CmdName Command reference is found to be invalid and TclExecuteByteCode + * looks up the command in the command hashtable). */ TclCleanupCommand(cmdPtr); @@ -2663,15 +2659,14 @@ Tcl_DeleteCommandFromToken(interp, cmd) static char * CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) Interp *iPtr; /* Interpreter containing command. */ - Command *cmdPtr; /* Command whose traces are to be - * invoked. */ - CONST char *oldName; /* Command's old name, or NULL if we - * must get the name from cmdPtr */ - CONST char *newName; /* Command's new name, or NULL if - * the command is not being renamed */ - int flags; /* Flags indicating the type of traces - * to trigger, either TCL_TRACE_DELETE - * or TCL_TRACE_RENAME. */ + Command *cmdPtr; /* Command whose traces are to be invoked. */ + CONST char *oldName; /* Command's old name, or NULL if we must get + * the name from cmdPtr */ + CONST char *newName; /* Command's new name, or NULL if the command + * is not being renamed */ + int flags; /* Flags indicating the type of traces to + * trigger, either TCL_TRACE_DELETE or + * TCL_TRACE_RENAME. */ { register CommandTrace *tracePtr; ActiveCommandTrace active; @@ -2679,16 +2674,17 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) Tcl_Obj *oldNamePtr = NULL; if (cmdPtr->flags & CMD_TRACE_ACTIVE) { - /* - * While a rename trace is active, we will not process any more - * rename traces; while a delete trace is active we will never - * reach here -- because Tcl_DeleteCommandFromToken checks for the - * condition (cmdPtr->flags & CMD_IS_DELETED) and returns immediately - * when a command deletion is in progress. For all other traces, - * delete traces will not be invoked but a call to TraceCommandProc - * will ensure that tracePtr->clientData is freed whenever the - * command "oldName" is deleted. + /* + * While a rename trace is active, we will not process any more rename + * traces; while a delete trace is active we will never reach here - + * because Tcl_DeleteCommandFromToken checks for the condition + * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a + * command deletion is in progress. For all other traces, delete + * traces will not be invoked but a call to TraceCommandProc will + * ensure that tracePtr->clientData is freed whenever the command + * "oldName" is deleted. */ + if (cmdPtr->flags & TCL_TRACE_RENAME) { flags &= ~TCL_TRACE_RENAME; } @@ -2721,7 +2717,7 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) if (oldName == NULL) { TclNewObj(oldNamePtr); Tcl_IncrRefCount(oldNamePtr); - Tcl_GetCommandFullName((Tcl_Interp *) iPtr, + Tcl_GetCommandFullName((Tcl_Interp *) iPtr, (Tcl_Command) cmdPtr, oldNamePtr); oldName = TclGetString(oldNamePtr); } @@ -2735,8 +2731,7 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) } /* - * If a new object was created to hold the full oldName, - * free it now. + * If a new object was created to hold the full oldName, free it now. */ if (oldNamePtr != NULL) { @@ -2744,8 +2739,8 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) } /* - * Restore the variable's flags, remove the record of our active - * traces, and then return. + * Restore the variable's flags, remove the record of our active traces, + * and then return. */ cmdPtr->flags &= ~CMD_TRACE_ACTIVE; @@ -2763,7 +2758,7 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) * This procedure frees up a Command structure unless it is still * referenced from an interpreter's command hashtable or from a CmdName * Tcl object representing the name of a command in a ByteCode - * instruction sequence. + * instruction sequence. * * Results: * None. @@ -2792,18 +2787,17 @@ TclCleanupCommand(cmdPtr) * * Tcl_CreateMathFunc -- * - * Creates a new math function for expressions in a given - * interpreter. + * Creates a new math function for expressions in a given interpreter. * * Results: * None. * * Side effects: * The function defined by "name" is created or redefined. If the - * function already exists then its definition is replaced; this - * includes the builtin functions. Redefining a builtin function forces - * all existing code to be invalidated since that code may be compiled - * using an instruction specific to the replaced function. In addition, + * function already exists then its definition is replaced; this includes + * the builtin functions. Redefining a builtin function forces all + * existing code to be invalidated since that code may be compiled using + * an instruction specific to the replaced function. In addition, * redefioning a non-builtin function will force existing code to be * invalidated if the number of arguments has changed. * @@ -2812,23 +2806,23 @@ TclCleanupCommand(cmdPtr) void Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which function is - * to be available. */ - CONST char *name; /* Name of function (e.g. "sin"). */ - int numArgs; /* Nnumber of arguments required by - * function. */ - Tcl_ValueType *argTypes; /* Array of types acceptable for - * each argument. */ - Tcl_MathProc *proc; /* Procedure that implements the - * math function. */ - ClientData clientData; /* Additional value to pass to the - * function. */ + Tcl_Interp *interp; /* Interpreter in which function is to be + * available. */ + CONST char *name; /* Name of function (e.g. "sin"). */ + int numArgs; /* Nnumber of arguments required by + * function. */ + Tcl_ValueType *argTypes; /* Array of types acceptable for each + * argument. */ + Tcl_MathProc *proc; /* Procedure that implements the math + * function. */ + ClientData clientData; /* Additional value to pass to the + * function. */ { Tcl_DString bigName; - OldMathFuncData* data = (OldMathFuncData*) - Tcl_Alloc(sizeof(OldMathFuncData)); + OldMathFuncData *data = (OldMathFuncData *) + ckalloc(sizeof(OldMathFuncData)); if (numArgs > MAX_MATH_ARGS) { Tcl_Panic("attempt to create a math function with too many args"); @@ -2868,11 +2862,11 @@ Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) static int OldMathFuncProc(clientData, interp, objc, objv) - ClientData clientData; /* Ponter to OldMathFuncData describing - * the function being called */ - Tcl_Interp* interp; /* Tcl interpreter */ - int objc; /* Actual parameter count */ - Tcl_Obj *CONST *objv; /* Parameter vector */ + ClientData clientData; /* Ponter to OldMathFuncData describing the + * function being called */ + Tcl_Interp *interp; /* Tcl interpreter */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Parameter vector */ { Tcl_Obj* valuePtr; OldMathFuncData* dataPtr = (OldMathFuncData*) clientData; @@ -2882,14 +2876,18 @@ OldMathFuncProc(clientData, interp, objc, objv) int i, j, k; double d; - /* Check argument count */ + /* + * Check argument count. + */ if (objc != dataPtr->numArgs + 1) { MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv); return TCL_ERROR; } - /* Convert arguments from Tcl_Obj's to Tcl_Value's */ + /* + * Convert arguments from Tcl_Obj's to Tcl_Value's. + */ for (j = 1, k = 0; j < objc; ++j, ++k) { valuePtr = objv[j]; @@ -2898,8 +2896,8 @@ OldMathFuncProc(clientData, interp, objc, objv) } /* - * Copy the object's numeric value to the argument record, - * converting it if necessary. + * Copy the object's numeric value to the argument record, converting + * it if necessary. */ if (valuePtr->typePtr == &tclIntType) { @@ -2942,15 +2940,18 @@ OldMathFuncProc(clientData, interp, objc, objv) } } - /* Call the function */ + /* + * Call the function. + */ - result = (*dataPtr->proc)(dataPtr->clientData, interp, args, - &funcResult); + result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult); if (result != TCL_OK) { return result; } - /* Return the result of the call */ + /* + * Return the result of the call. + */ if (funcResult.type == TCL_INT) { TclNewLongObj(valuePtr, funcResult.intValue); @@ -3004,24 +3005,24 @@ OldMathFuncDeleteProc(clientData) * interpreter. * * Results: - * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message - * in the interpreter result if that happens.) + * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the + * interpreter result if that happens.) * * Side effects: - * If this function succeeds, the variables pointed to by the - * numArgsPtr and argTypePtr arguments will be updated to detail the - * arguments allowed by the function. The variable pointed to by the - * procPtr argument will be set to NULL if the function is a builtin - * function, and will be set to the address of the C function used to - * implement the math function otherwise (in which case the variable - * pointed to by the clientDataPtr argument will also be updated.) + * If this function succeeds, the variables pointed to by the numArgsPtr + * and argTypePtr arguments will be updated to detail the arguments + * allowed by the function. The variable pointed to by the procPtr + * argument will be set to NULL if the function is a builtin function, + * and will be set to the address of the C function used to implement the + * math function otherwise (in which case the variable pointed to by the + * clientDataPtr argument will also be updated.) * *---------------------------------------------------------------------- */ int Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, - clientDataPtr) + clientDataPtr) Tcl_Interp *interp; CONST char *name; int *numArgsPtr; @@ -3029,11 +3030,12 @@ Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, Tcl_MathProc **procPtr; ClientData *clientDataPtr; { - Tcl_Obj* cmdNameObj; Command* cmdPtr; - /* Get the command that implements the math function */ + /* + * Get the command that implements the math function. + */ cmdNameObj = Tcl_NewStringObj("tcl::mathfunc::", -1); Tcl_AppendToObj(cmdNameObj, name, -1); @@ -3041,22 +3043,24 @@ Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, cmdPtr = (Command*) Tcl_GetCommandFromObj(interp, cmdNameObj); Tcl_DecrRefCount(cmdNameObj); - /* Report unknown functions */ + /* + * Report unknown functions. + */ if (cmdPtr == NULL) { Tcl_Obj* message; message = Tcl_NewStringObj("unknown math function \"", -1); Tcl_AppendToObj(message, name, -1); Tcl_AppendToObj(message, "\"", 1); - *numArgsPtr = -1; *argTypesPtr = NULL; + *numArgsPtr = -1; *argTypesPtr = NULL; *procPtr = NULL; *clientDataPtr = NULL; return TCL_ERROR; } - /* - * Retrieve function info for user defined functions; return - * dummy information for builtins. + /* + * Retrieve function info for user defined functions; return dummy + * information for builtins. */ if (cmdPtr->objProc == &OldMathFuncProc) { @@ -3085,9 +3089,9 @@ Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, * interpreter. * * Results: - * A pointer to a Tcl_Obj structure with a reference count of zero, - * or NULL in the case of an error (in which case a suitable error - * message will be left in the interpreter result.) + * A pointer to a Tcl_Obj structure with a reference count of zero, or + * NULL in the case of an error (in which case a suitable error message + * will be left in the interpreter result.) * * Side effects: * None. @@ -3140,13 +3144,12 @@ Tcl_ListMathFuncs(interp, pattern) * * TclInterpReady -- * - * Check if an interpreter is ready to eval commands or scripts, - * i.e., if it was not deleted and if the nesting level is not - * too high. + * Check if an interpreter is ready to eval commands or scripts, i.e., if + * it was not deleted and if the nesting level is not too high. * * Results: - * The return value is TCL_OK if it the interpreter is ready, - * TCL_ERROR otherwise. + * The return value is TCL_OK if it the interpreter is ready, TCL_ERROR + * otherwise. * * Side effects: * The interpreters object and string results are cleared. @@ -3154,15 +3157,15 @@ Tcl_ListMathFuncs(interp, pattern) *---------------------------------------------------------------------- */ -int +int TclInterpReady(interp) Tcl_Interp *interp; { register Interp *iPtr = (Interp *) interp; /* - * Reset both the interpreter's string and object results and clear - * out any previous error information. + * Reset both the interpreter's string and object results and clear out + * any previous error information. */ Tcl_ResetResult(interp); @@ -3181,14 +3184,14 @@ TclInterpReady(interp) } /* - * Check depth of nested calls to Tcl_Eval: if this gets too large, - * it's probably because of an infinite loop somewhere. + * Check depth of nested calls to Tcl_Eval: if this gets too large, it's + * probably because of an infinite loop somewhere. */ - if (((iPtr->numLevels) > iPtr->maxNestingDepth) + if (((iPtr->numLevels) > iPtr->maxNestingDepth) || (TclpCheckStackSpace() == 0)) { Tcl_AppendResult(interp, - "too many nested evaluations (infinite loop?)", (char *) NULL); + "too many nested evaluations (infinite loop?)", (char *) NULL); return TCL_ERROR; } @@ -3200,15 +3203,15 @@ TclInterpReady(interp) * * TclEvalObjvInternal -- * - * This procedure evaluates a Tcl command that has already been - * parsed into words, with one Tcl_Obj holding each word. The caller - * is responsible for managing the iPtr->numLevels. + * This procedure evaluates a Tcl command that has already been parsed + * into words, with one Tcl_Obj holding each word. The caller is + * responsible for managing the iPtr->numLevels. * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. If an error occurs, this procedure does - * NOT add any information to the errorInfo variable. + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR. A result or error message is left in interp's result. If an + * error occurs, this procedure does NOT add any information to the + * errorInfo variable. * * Side effects: * Depends on the command. @@ -3219,23 +3222,21 @@ TclInterpReady(interp) int TclEvalObjvInternal(interp, objc, objv, command, length, flags) Tcl_Interp *interp; /* Interpreter in which to evaluate the - * command. Also used for error - * reporting. */ + * command. Also used for error reporting. */ int objc; /* Number of words in command. */ Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are * the words that make up the command. */ CONST char *command; /* Points to the beginning of the string - * representation of the command; this - * is used for traces. If the string - * representation of the command is - * unknown, an empty string should be - * supplied. If it is NULL, no traces will - * be called. */ + * representation of the command; this is used + * for traces. If the string representation of + * the command is unknown, an empty string + * should be supplied. If it is NULL, no + * traces will be called. */ int length; /* Number of bytes in command; if -1, all * characters up to the first null byte are * used. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only + int flags; /* Collection of OR-ed bits that control the + * evaluation of the script. Only * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are * currently supported. */ @@ -3244,8 +3245,8 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) Interp *iPtr = (Interp *) interp; Tcl_Obj **newObjv; int i; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ + CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case + * TCL_EVAL_GLOBAL was set. */ int code = TCL_OK; int traceCode = TCL_OK; int checkTraces = 1; @@ -3259,18 +3260,17 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) } /* - * Find the procedure to execute this command. If there isn't one, - * then see if there is a command "unknown". If so, create a new - * word array with "unknown" as the first word and the original - * command words as arguments. Then call ourselves recursively to - * execute it. + * Find the procedure to execute this command. If there isn't one, then + * see if there is a command "unknown". If so, create a new word array + * with "unknown" as the first word and the original command words as + * arguments. Then call ourselves recursively to execute it. * * If caller requests, or if we're resolving the target end of an * interpeter alias (TCL_EVAL_INVOKE), be sure to do command name * resolution in the global namespace. * - * If any execution traces rename or delete the current command, - * we may need (at most) two passes here. + * If any execution traces rename or delete the current command, we may + * need (at most) two passes here. */ reparseBecauseOfTraces: @@ -3282,8 +3282,8 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) iPtr->varFramePtr = savedVarFramePtr; if (cmdPtr == NULL) { - newObjv = (Tcl_Obj **) ckalloc((unsigned) - ((objc + 1) * sizeof(Tcl_Obj *))); + newObjv = (Tcl_Obj **) + ckalloc((unsigned) ((objc + 1) * sizeof(Tcl_Obj *))); for (i = objc-1; i >= 0; i--) { newObjv[i+1] = objv[i]; } @@ -3308,14 +3308,17 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) /* * Call trace procedures if needed. */ + if ((checkTraces) && (command != NULL)) { int cmdEpoch = cmdPtr->cmdEpoch; cmdPtr->refCount++; - /* - * If the first set of traces modifies/deletes the command or - * any existing traces, then the set checkTraces to 0 and go - * through this while loop one more time. + + /* + * If the first set of traces modifies/deletes the command or any + * existing traces, then the set checkTraces to 0 and go through this + * while loop one more time. */ + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { traceCode = TclCheckInterpTraces(interp, command, length, cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); @@ -3326,7 +3329,10 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) } cmdPtr->refCount--; if (cmdEpoch != cmdPtr->cmdEpoch) { - /* The command has been modified in some way */ + /* + * The command has been modified in some way. + */ + checkTraces = 0; goto reparseBecauseOfTraces; } @@ -3335,6 +3341,7 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) /* * Finally, invoke the command's Tcl_ObjCmdProc. */ + cmdPtr->refCount++; iPtr->cmdCount++; if (code == TCL_OK && traceCode == TCL_OK && !Tcl_LimitExceeded(interp)) { @@ -3360,6 +3367,7 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) /* * Call 'leave' command traces */ + if (!(cmdPtr->flags & CMD_IS_DELETED)) { if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { traceCode = TclCheckExecutionTraces(interp, command, length, @@ -3373,10 +3381,9 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) TclCleanupCommand(cmdPtr); /* - * If one of the trace invocation resulted in error, then - * change the result code accordingly. Note, that the - * interp->result should already be set correctly by the - * call to TraceExecutionProc. + * If one of the trace invocation resulted in error, then change the + * result code accordingly. Note, that the interp->result should already + * be set correctly by the call to TraceExecutionProc. */ if (traceCode != TCL_OK) { @@ -3384,17 +3391,17 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) } /* - * If the interpreter has a non-empty string result, the result - * object is either empty or stale because some procedure set - * interp->result directly. If so, move the string result to the - * result object, then reset the string result. + * If the interpreter has a non-empty string result, the result object is + * either empty or stale because some procedure set interp->result + * directly. If so, move the string result to the result object, then + * reset the string result. */ if (*(iPtr->result) != 0) { (void) Tcl_GetObjResult(interp); } - done: + done: return code; } @@ -3403,13 +3410,12 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) * * Tcl_EvalObjv -- * - * This procedure evaluates a Tcl command that has already been - * parsed into words, with one Tcl_Obj holding each word. + * This procedure evaluates a Tcl command that has already been parsed + * into words, with one Tcl_Obj holding each word. * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: * Depends on the command. @@ -3420,15 +3426,14 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) int Tcl_EvalObjv(interp, objc, objv, flags) Tcl_Interp *interp; /* Interpreter in which to evaluate the - * command. Also used for error - * reporting. */ + * command. Also used for error reporting. */ int objc; /* Number of words in command. */ Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are * the words that make up the command. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only - * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE - * are currently supported. */ + int flags; /* Collection of OR-ed bits that control the + * evaluation of the script. Only + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are + * currently supported. */ { Interp *iPtr = (Interp *)interp; Trace *tracePtr; @@ -3446,7 +3451,7 @@ Tcl_EvalObjv(interp, objc, objv, flags) for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) { /* - * The command may be needed for an execution trace. Generate a + * The command may be needed for an execution trace. Generate a * command string. */ @@ -3465,8 +3470,8 @@ Tcl_EvalObjv(interp, objc, objv, flags) iPtr->numLevels--; /* - * If we are again at the top level, process any unusual - * return code returned by the evaluated code. + * If we are again at the top level, process any unusual return code + * returned by the evaluated code. */ if (iPtr->numLevels == 0) { @@ -3482,8 +3487,8 @@ Tcl_EvalObjv(interp, objc, objv, flags) if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { - /* - * If there was an error, a command string will be needed for the + /* + * If there was an error, a command string will be needed for the * error log: generate it now if it was not done previously. */ @@ -3509,16 +3514,16 @@ Tcl_EvalObjv(interp, objc, objv, flags) * * Tcl_LogCommandInfo -- * - * This procedure is invoked after an error occurs in an interpreter. - * It adds information to iPtr->errorInfo field to describe the - * command that was being executed when the error occurred. + * This procedure is invoked after an error occurs in an interpreter. It + * adds information to iPtr->errorInfo field to describe the command that + * was being executed when the error occurred. * * Results: * None. * * Side effects: - * Information about the command is added to errorInfo and the - * line number stored internally in the interpreter is set. + * Information about the command is added to errorInfo and the line + * number stored internally in the interpreter is set. * *---------------------------------------------------------------------- */ @@ -3528,10 +3533,10 @@ Tcl_LogCommandInfo(interp, script, command, length) Tcl_Interp *interp; /* Interpreter in which to log information. */ CONST char *script; /* First character in script containing * command (must be <= command). */ - CONST char *command; /* First character in command that - * generated the error. */ - int length; /* Number of bytes in command (-1 means - * use all bytes up to first null byte). */ + CONST char *command; /* First character in command that generated + * the error. */ + int length; /* Number of bytes in command (-1 means use + * all bytes up to first null byte). */ { register CONST char *p; Interp *iPtr = (Interp *) interp; @@ -3539,8 +3544,8 @@ Tcl_LogCommandInfo(interp, script, command, length) if (iPtr->flags & ERR_ALREADY_LOGGED) { /* - * Someone else has already logged error information for this - * command; we shouldn't add anything more. + * Someone else has already logged error information for this command; + * we shouldn't add anything more. */ return; @@ -3574,15 +3579,14 @@ Tcl_LogCommandInfo(interp, script, command, length) * * Tcl_EvalTokensStandard -- * - * Given an array of tokens parsed from a Tcl command (e.g., the - * tokens that make up a word or the index for an array variable) - * this procedure evaluates the tokens and concatenates their - * values to form a single result value. - * + * Given an array of tokens parsed from a Tcl command (e.g., the tokens + * that make up a word or the index for an array variable) this procedure + * evaluates the tokens and concatenates their values to form a single + * result value. + * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: * Depends on the array of tokens being evaled. @@ -3592,11 +3596,11 @@ Tcl_LogCommandInfo(interp, script, command, length) int Tcl_EvalTokensStandard(interp, tokenPtr, count) - Tcl_Interp *interp; /* Interpreter in which to lookup - * variables, execute nested commands, - * and report errors. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * to evaluate and concatenate. */ + Tcl_Interp *interp; /* Interpreter in which to lookup variables, + * execute nested commands, and report + * errors. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to + * evaluate and concatenate. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { @@ -3609,35 +3613,35 @@ Tcl_EvalTokensStandard(interp, tokenPtr, count) * * Tcl_EvalTokens -- * - * Given an array of tokens parsed from a Tcl command (e.g., the - * tokens that make up a word or the index for an array variable) - * this procedure evaluates the tokens and concatenates their - * values to form a single result value. + * Given an array of tokens parsed from a Tcl command (e.g., the tokens + * that make up a word or the index for an array variable) this procedure + * evaluates the tokens and concatenates their values to form a single + * result value. * * Results: - * The return value is a pointer to a newly allocated Tcl_Obj - * containing the value of the array of tokens. The reference - * count of the returned object has been incremented. If an error - * occurs in evaluating the tokens then a NULL value is returned - * and an error message is left in interp's result. + * The return value is a pointer to a newly allocated Tcl_Obj containing + * the value of the array of tokens. The reference count of the returned + * object has been incremented. If an error occurs in evaluating the + * tokens then a NULL value is returned and an error message is left in + * interp's result. * * Side effects: * A new object is allocated to hold the result. * *---------------------------------------------------------------------- * - * This uses a non-standard return convention; its use is now deprecated. - * It is a wrapper for the new function Tcl_EvalTokensStandard, and is not - * used in the core any longer. It is only kept for backward compatibility. + * This uses a non-standard return convention; its use is now deprecated. It + * is a wrapper for the new function Tcl_EvalTokensStandard, and is not used + * in the core any longer. It is only kept for backward compatibility. */ Tcl_Obj * Tcl_EvalTokens(interp, tokenPtr, count) - Tcl_Interp *interp; /* Interpreter in which to lookup - * variables, execute nested commands, - * and report errors. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * to evaluate and concatenate. */ + Tcl_Interp *interp; /* Interpreter in which to lookup variables, + * execute nested commands, and report + * errors. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to + * evaluate and concatenate. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { @@ -3661,15 +3665,14 @@ Tcl_EvalTokens(interp, tokenPtr, count) * * Tcl_EvalEx -- * - * This procedure evaluates a Tcl script without using the compiler - * or byte-code interpreter. It just parses the script, creates - * values for each word of each command, then calls EvalObjv - * to execute each command. + * This procedure evaluates a Tcl script without using the compiler or + * byte-code interpreter. It just parses the script, creates values for + * each word of each command, then calls EvalObjv to execute each + * command. * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: * Depends on the script. @@ -3680,15 +3683,14 @@ Tcl_EvalTokens(interp, tokenPtr, count) int Tcl_EvalEx(interp, script, numBytes, flags) Tcl_Interp *interp; /* Interpreter in which to evaluate the - * script. Also used for error reporting. */ + * script. Also used for error reporting. */ CONST char *script; /* First character of script to evaluate. */ - int numBytes; /* Number of bytes in script. If < 0, the + int numBytes; /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only - * TCL_EVAL_GLOBAL is currently - * supported. */ + int flags; /* Collection of OR-ed bits that control the + * evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently supported. */ { Interp *iPtr = (Interp *) interp; CONST char *p, *next; @@ -3698,14 +3700,14 @@ Tcl_EvalEx(interp, script, numBytes, flags) int expandStatic[NUM_STATIC_OBJS], *expand; Tcl_Token *tokenPtr; int i, code, commandLength, bytesLeft, expandRequested; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ + CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case + * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); /* - * The variables below keep track of how much state has been - * allocated while evaluating the script, so that it can be freed - * properly if an error occurs. + * The variables below keep track of how much state has been allocated + * while evaluating the script, so that it can be freed properly if an + * error occurs. */ int gotParse = 0, objectsUsed = 0; @@ -3721,8 +3723,8 @@ Tcl_EvalEx(interp, script, numBytes, flags) } /* - * Each iteration through the following loop parses the next - * command from the script and then executes it. + * Each iteration through the following loop parses the next command from + * the script and then executes it. */ objv = objvSpace = staticObjArray; @@ -3735,25 +3737,26 @@ Tcl_EvalEx(interp, script, numBytes, flags) code = TCL_ERROR; goto error; } - gotParse = 1; + gotParse = 1; if (parse.numWords > 0) { /* * Generate an array of objects for the words of the command. */ + int objectsNeeded = 0; if (parse.numWords > NUM_STATIC_OBJS) { - expand = (int *) ckalloc((unsigned) - (parse.numWords * sizeof(int))); - objvSpace = (Tcl_Obj **) ckalloc((unsigned) - (parse.numWords * sizeof(Tcl_Obj *))); + expand = (int *) + ckalloc((unsigned) (parse.numWords * sizeof(int))); + objvSpace = (Tcl_Obj **) + ckalloc((unsigned) (parse.numWords*sizeof(Tcl_Obj *))); } expandRequested = 0; objv = objvSpace; for (objectsUsed = 0, tokenPtr = parse.tokenPtr; objectsUsed < parse.numWords; objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { - code = TclSubstTokens(interp, tokenPtr+1, + code = TclSubstTokens(interp, tokenPtr+1, tokenPtr->numComponents, NULL); if (code != TCL_OK) { goto error; @@ -3766,9 +3769,13 @@ Tcl_EvalEx(interp, script, numBytes, flags) code = Tcl_ListObjLength(interp, objv[objectsUsed], &numElements); if (code == TCL_ERROR) { - /* Attempt to expand a non-list */ + /* + * Attempt to expand a non-list. + */ + Tcl_Obj *msg; Tcl_Obj *wordNum; + msg = Tcl_NewStringObj("\n (expanding word ", -1); TclNewIntObj(wordNum, objectsUsed); Tcl_IncrRefCount(wordNum); @@ -3790,7 +3797,10 @@ Tcl_EvalEx(interp, script, numBytes, flags) } } if (expandRequested) { - /* Some word expansion was requested. Check for objv resize */ + /* + * Some word expansion was requested. Check for objv resize. + */ + Tcl_Obj **copy = objvSpace; int wordIdx = parse.numWords; int objIdx = objectsNeeded - 1; @@ -3806,6 +3816,7 @@ Tcl_EvalEx(interp, script, numBytes, flags) if (expand[wordIdx]) { int numElements; Tcl_Obj **elements, *temp = copy[wordIdx]; + Tcl_ListObjGetElements(NULL, temp, &numElements, &elements); objectsUsed += numElements; @@ -3830,8 +3841,8 @@ Tcl_EvalEx(interp, script, numBytes, flags) * Execute the command and free the objects for its words. */ - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objectsUsed, objv, + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objectsUsed, objv, parse.commandStart, parse.commandSize, 0); iPtr->numLevels--; if (code != TCL_OK) { @@ -3845,10 +3856,12 @@ Tcl_EvalEx(interp, script, numBytes, flags) ckfree((char *) objvSpace); objvSpace = staticObjArray; } - /* + + /* * Free expand separately since objvSpace could have been - * reallocated above. + * reallocated above. */ + if (expand != expandStatic) { ckfree((char *) expand); expand = expandStatic; @@ -3868,18 +3881,20 @@ Tcl_EvalEx(interp, script, numBytes, flags) iPtr->varFramePtr = savedVarFramePtr; return TCL_OK; - error: - /* Generate and log various pieces of error information. */ - if (iPtr->numLevels == 0) { - if (code == TCL_RETURN) { - code = TclUpdateReturnInfo(iPtr); - } - if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { - ProcessUnexpectedResult(interp, code); - code = TCL_ERROR; - } + error: + /* + * Generate and log various pieces of error information. + */ + if (iPtr->numLevels == 0) { + if (code == TCL_RETURN) { + code = TclUpdateReturnInfo(iPtr); + } + if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { + ProcessUnexpectedResult(interp, code); + code = TCL_ERROR; } - if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + } + if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { commandLength = parse.commandSize; if (parse.term == parse.commandStart + commandLength - 1) { /* @@ -3895,7 +3910,9 @@ Tcl_EvalEx(interp, script, numBytes, flags) } iPtr->flags &= ~ERR_ALREADY_LOGGED; - /* Then free resources that had been allocated to the command. */ + /* + * Then free resources that had been allocated to the command. + */ for (i = 0; i < objectsUsed; i++) { Tcl_DecrRefCount(objv[i]); @@ -3918,18 +3935,16 @@ Tcl_EvalEx(interp, script, numBytes, flags) * * Tcl_Eval -- * - * Execute a Tcl command in a string. This procedure executes the - * script directly, rather than compiling it to bytecodes. Before - * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was - * the main procedure used for executing Tcl commands, but nowadays - * it isn't used much. + * Execute a Tcl command in a string. This procedure executes the script + * directly, rather than compiling it to bytecodes. Before the arrival of + * the bytecode compiler in Tcl 8.0 Tcl_Eval was the main procedure used + * for executing Tcl commands, but nowadays it isn't used much. * * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and interp's result contains a value - * to supplement the return code. The value of the result - * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: - * you must copy it or lose it! + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and interp's result contains a value to supplement the return + * code. The value of the result will persist only until the next call to + * Tcl_Eval or Tcl_EvalObj: you must copy it or lose it! * * Side effects: * Can be almost arbitrary, depending on the commands in the script. @@ -3939,16 +3954,16 @@ Tcl_EvalEx(interp, script, numBytes, flags) int Tcl_Eval(interp, script) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by previous call to Tcl_CreateInterp). */ + Tcl_Interp *interp; /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ CONST char *script; /* Pointer to TCL command to execute. */ { int code = Tcl_EvalEx(interp, script, -1, 0); /* - * For backwards compatibility with old C code that predates the - * object system in Tcl 8.0, we have to mirror the object result - * back into the string result (some callers may expect it there). + * For backwards compatibility with old C code that predates the object + * system in Tcl 8.0, we have to mirror the object result back into the + * string result (some callers may expect it there). */ (void) Tcl_GetStringResult(interp); @@ -3996,42 +4011,38 @@ Tcl_GlobalEvalObj(interp, objPtr) * Tcl_EvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are - * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT - * is specified. + * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is + * specified. * * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and the interpreter's result contains a value - * to supplement the return code. + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and the interpreter's result contains a value to supplement + * the return code. * * Side effects: - * The object is converted, if necessary, to a ByteCode object that - * holds the bytecode instructions for the commands. Executing the - * commands will almost certainly have side effects that depend - * on those commands. + * The object is converted, if necessary, to a ByteCode object that holds + * the bytecode instructions for the commands. Executing the commands + * will almost certainly have side effects that depend on those commands. * *---------------------------------------------------------------------- */ int Tcl_EvalObjEx(interp, objPtr, flags) - Tcl_Interp *interp; /* Token for command interpreter - * (returned by a previous call to - * Tcl_CreateInterp). */ - register Tcl_Obj *objPtr; /* Pointer to object containing - * commands to execute. */ - int flags; /* Collection of OR-ed bits that - * control the evaluation of the - * script. Supported values are - * TCL_EVAL_GLOBAL and - * TCL_EVAL_DIRECT. */ + Tcl_Interp *interp; /* Token for command interpreter (returned by + * a previous call to Tcl_CreateInterp). */ + register Tcl_Obj *objPtr; /* Pointer to object containing commands to + * execute. */ + int flags; /* Collection of OR-ed bits that control the + * evaluation of the script. Supported values + * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ { register Interp *iPtr = (Interp *) interp; char *script; int numSrcBytes; int result; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ + CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case + * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); Tcl_IncrRefCount(objPtr); @@ -4039,46 +4050,58 @@ Tcl_EvalObjEx(interp, objPtr, flags) if (flags & TCL_EVAL_DIRECT) { /* * We're not supposed to use the compiler or byte-code interpreter. - * Let Tcl_EvalEx evaluate the command directly (and probably - * more slowly). + * Let Tcl_EvalEx evaluate the command directly (and probably more + * slowly). * - * Pure List Optimization (no string representation). In this - * case, we can safely use Tcl_EvalObjv instead and get an - * appreciable improvement in execution speed. This is because it - * allows us to avoid a setFromAny step that would just pack - * everything into a string and back out again. + * Pure List Optimization (no string representation). In this case, we + * can safely use Tcl_EvalObjv instead and get an appreciable + * improvement in execution speed. This is because it allows us to + * avoid a setFromAny step that would just pack everything into a + * string and back out again. + * + * This restriction has been relaxed a bit by storing in lists whether + * they are "canonical" or not (a canonical list being one that is + * either pure or that has its string rep derived by + * UpdateStringOfList from the internal rep). */ - if ((objPtr->typePtr == &tclListType) && /* is a list... */ - (objPtr->bytes == NULL) /* ...without a string rep */) { - List *listRepPtr; - /* - * Increase the reference count of the List structure, to avoid a - * segfault if objPtr loses its List internal rep [Bug 1119369] - */ + if (objPtr->typePtr == &tclListType) { /* is a list... */ + List *listRepPtr; listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; - listRepPtr->refCount++; - result = Tcl_EvalObjv(interp, listRepPtr->elemCount, - &listRepPtr->elements, flags); + if (objPtr->bytes == NULL || /* ...without a string rep */ + listRepPtr->canonicalFlag) {/* ...or that is canonical */ - /* - * If we are the last users of listRepPtr, free it. - */ + /* + * Increase the reference count of the List structure, to + * avoid a segfault if objPtr loses its List internal rep [Bug + * 1119369] + */ + + listRepPtr->refCount++; + + result = Tcl_EvalObjv(interp, listRepPtr->elemCount, + &listRepPtr->elements, flags); + + /* + * If we are the last users of listRepPtr, free it. + */ - if (--listRepPtr->refCount <= 0) { - int i, elemCount = listRepPtr->elemCount; - Tcl_Obj **elements = &listRepPtr->elements; - for (i=0; i<elemCount; i++) { - Tcl_DecrRefCount(elements[i]); + if (--listRepPtr->refCount <= 0) { + int i, elemCount = listRepPtr->elemCount; + Tcl_Obj **elements = &listRepPtr->elements; + + for (i=0; i<elemCount; i++) { + Tcl_DecrRefCount(elements[i]); + } + ckfree((char *) listRepPtr); } - ckfree((char *) listRepPtr); + goto done; } - } else { - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); } + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); } else { /* * Let the compiler/engine subsystem do the evaluation. @@ -4092,15 +4115,15 @@ Tcl_EvalObjEx(interp, objPtr, flags) result = TclCompEvalObj(interp, objPtr); /* - * If we are again at the top level, process any unusual - * return code returned by the evaluated code. + * If we are again at the top level, process any unusual return code + * returned by the evaluated code. */ if (iPtr->numLevels == 0) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } - if ((result != TCL_OK) && (result != TCL_ERROR) + if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { ProcessUnexpectedResult(interp, result); result = TCL_ERROR; @@ -4109,9 +4132,10 @@ Tcl_EvalObjEx(interp, objPtr, flags) } } iPtr->evalFlags = 0; - iPtr->varFramePtr = savedVarFramePtr; + iPtr->varFramePtr = savedVarFramePtr; } + done: TclDecrRefCount(objPtr); return result; } @@ -4121,17 +4145,17 @@ Tcl_EvalObjEx(interp, objPtr, flags) * * ProcessUnexpectedResult -- * - * Procedure called by Tcl_EvalObj to set the interpreter's result - * value to an appropriate error message when the code it evaluates - * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to - * the topmost evaluation level. + * Procedure called by Tcl_EvalObj to set the interpreter's result value + * to an appropriate error message when the code it evaluates returns an + * unexpected result code (not TCL_OK and not TCL_ERROR) to the topmost + * evaluation level. * * Results: * None. * * Side effects: - * The interpreter result is set to an error message appropriate to - * the result code. + * The interpreter result is set to an error message appropriate to the + * result code. * *---------------------------------------------------------------------- */ @@ -4168,9 +4192,9 @@ ProcessUnexpectedResult(interp, returnCode) * Results: * Each of the procedures below returns a standard Tcl result. If an * error occurs then an error message is left in the interp's result. - * Otherwise the value of the expression, in the appropriate form, - * is stored at *ptr. If the expression had a result that was - * incompatible with the desired form then an error is returned. + * Otherwise the value of the expression, in the appropriate form, is + * stored at *ptr. If the expression had a result that was incompatible + * with the desired form then an error is returned. * * Side effects: * None. @@ -4182,7 +4206,7 @@ int Tcl_ExprLong(interp, exprstring, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ - CONST char *exprstring; /* Expression to evaluate. */ + CONST char *exprstring; /* Expression to evaluate. */ long *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; @@ -4208,7 +4232,9 @@ Tcl_ExprLong(interp, exprstring, ptr) /* * See Tcl_GetIntFromObj for conversion comments. */ + Tcl_WideInt w = resultPtr->internalRep.wideValue; + if ((w >= -(Tcl_WideInt)(ULONG_MAX)) && (w <= (Tcl_WideInt)(ULONG_MAX))) { *ptr = Tcl_WideAsLong(w); @@ -4226,16 +4252,16 @@ Tcl_ExprLong(interp, exprstring, ptr) "expression didn't have numeric value", TCL_STATIC); result = TCL_ERROR; } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ + Tcl_DecrRefCount(resultPtr);/* discard the result object */ } else { /* - * Move the interpreter's object result to the string result, - * then reset the object result. + * Move the interpreter's object result to the string result, then + * reset the object result. */ (void) Tcl_GetStringResult(interp); } - Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ } else { /* * An empty string. Just set the result integer to 0. @@ -4250,7 +4276,7 @@ int Tcl_ExprDouble(interp, exprstring, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ - CONST char *exprstring; /* Expression to evaluate. */ + CONST char *exprstring; /* Expression to evaluate. */ double *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; @@ -4264,7 +4290,7 @@ Tcl_ExprDouble(interp, exprstring, ptr) result = Tcl_ExprObj(interp, exprPtr, &resultPtr); if (result == TCL_OK) { /* - * Store a double based on the expression result. + * Store a double based on the expression result. */ if (resultPtr->typePtr == &tclIntType) { @@ -4276,7 +4302,9 @@ Tcl_ExprDouble(interp, exprstring, ptr) /* * See Tcl_GetIntFromObj for conversion comments. */ + Tcl_WideInt w = resultPtr->internalRep.wideValue; + if ((w >= -(Tcl_WideInt)(ULONG_MAX)) && (w <= (Tcl_WideInt)(ULONG_MAX))) { *ptr = (double) Tcl_WideAsLong(w); @@ -4294,16 +4322,16 @@ Tcl_ExprDouble(interp, exprstring, ptr) "expression didn't have numeric value", TCL_STATIC); result = TCL_ERROR; } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ + Tcl_DecrRefCount(resultPtr);/* discard the result object */ } else { /* - * Move the interpreter's object result to the string result, - * then reset the object result. + * Move the interpreter's object result to the string result, then + * reset the object result. */ (void) Tcl_GetStringResult(interp); } - Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ } else { /* * An empty string. Just set the result double to 0.0. @@ -4331,13 +4359,14 @@ Tcl_ExprBoolean(interp, exprstring, ptr) } else { int result; Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); + Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); if (result != TCL_OK) { /* - * Move the interpreter's object result to the string result, - * then reset the object result. + * Move the interpreter's object result to the string result, then + * reset the object result. */ (void) Tcl_GetStringResult(interp); @@ -4351,16 +4380,15 @@ Tcl_ExprBoolean(interp, exprstring, ptr) * * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- * - * Procedures to evaluate an expression in an object and return its - * value in a particular form. + * Procedures to evaluate an expression in an object and return its value + * in a particular form. * * Results: - * Each of the procedures below returns a standard Tcl result - * object. If an error occurs then an error message is left in the - * interpreter's result. Otherwise the value of the expression, in the - * appropriate form, is stored at *ptr. If the expression had a result - * that was incompatible with the desired form then an error is - * returned. + * Each of the procedures below returns a standard Tcl result object. If + * an error occurs then an error message is left in the interpreter's + * result. Otherwise the value of the expression, in the appropriate + * form, is stored at *ptr. If the expression had a result that was + * incompatible with the desired form then an error is returned. * * Side effects: * None. @@ -4370,10 +4398,10 @@ Tcl_ExprBoolean(interp, exprstring, ptr) int Tcl_ExprLongObj(interp, objPtr, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - register Tcl_Obj *objPtr; /* Expression to evaluate. */ - long *ptr; /* Where to store long result. */ + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + long *ptr; /* Where to store long result. */ { Tcl_Obj *resultPtr; int result; @@ -4397,10 +4425,10 @@ Tcl_ExprLongObj(interp, objPtr, ptr) int Tcl_ExprDoubleObj(interp, objPtr, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - register Tcl_Obj *objPtr; /* Expression to evaluate. */ - double *ptr; /* Where to store double result. */ + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + double *ptr; /* Where to store double result. */ { Tcl_Obj *resultPtr; int result; @@ -4424,10 +4452,10 @@ Tcl_ExprDoubleObj(interp, objPtr, ptr) int Tcl_ExprBooleanObj(interp, objPtr, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - register Tcl_Obj *objPtr; /* Expression to evaluate. */ - int *ptr; /* Where to store 0/1 result. */ + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + int *ptr; /* Where to store 0/1 result. */ { Tcl_Obj *resultPtr; int result; @@ -4445,12 +4473,11 @@ Tcl_ExprBooleanObj(interp, objPtr, ptr) * * TclObjInvokeNamespace -- * - * Object version: Invokes a Tcl command, given an objv/objc, from - * either the exposed or hidden set of commands in the given - * interpreter. + * Object version: Invokes a Tcl command, given an objv/objc, from either + * the exposed or hidden set of commands in the given interpreter. * NOTE: The command is invoked in the global stack frame of the - * interpreter or namespace, thus it cannot see any current state on - * the stack of that interpreter. + * interpreter or namespace, thus it cannot see any current state on the + * stack of that interpreter. * * Results: * A standard Tcl result. @@ -4469,17 +4496,16 @@ TclObjInvokeNamespace(interp, objc, objv, nsPtr, flags) Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the * name of the command to invoke. */ Tcl_Namespace *nsPtr; /* The namespace to use. */ - int flags; /* Combination of flags controlling the - * call: TCL_INVOKE_HIDDEN, - * TCL_INVOKE_NO_UNKNOWN, or - * TCL_INVOKE_NO_TRACEBACK. */ + int flags; /* Combination of flags controlling the call: + * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, + * or TCL_INVOKE_NO_TRACEBACK. */ { int result; Tcl_CallFrame *framePtr; /* - * Make the specified namespace the current namespace and invoke - * the command. + * Make the specified namespace the current namespace and invoke the + * command. */ result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcCallFrame*/ 0); @@ -4498,8 +4524,8 @@ TclObjInvokeNamespace(interp, objc, objv, nsPtr, flags) * * TclObjInvoke -- * - * Invokes a Tcl command, given an objv/objc, from either the - * exposed or the hidden sets of commands in the given interpreter. + * Invokes a Tcl command, given an objv/objc, from either the exposed or + * the hidden sets of commands in the given interpreter. * * Results: * A standard Tcl object result. @@ -4517,10 +4543,9 @@ TclObjInvoke(interp, objc, objv, flags) int objc; /* Count of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the * name of the command to invoke. */ - int flags; /* Combination of flags controlling the - * call: TCL_INVOKE_HIDDEN, - * TCL_INVOKE_NO_UNKNOWN, or - * TCL_INVOKE_NO_TRACEBACK. */ + int flags; /* Combination of flags controlling the call: + * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, + * or TCL_INVOKE_NO_TRACEBACK. */ { register Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ @@ -4558,14 +4583,16 @@ TclObjInvoke(interp, objc, objv, flags) } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - /* Invoke the command procedure. */ + /* + * Invoke the command procedure. + */ iPtr->cmdCount++; result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); /* - * If an error occurred, record information about what was being - * executed when the error occurred. + * If an error occurred, record information about what was being executed + * when the error occurred. */ if ((result == TCL_ERROR) @@ -4574,6 +4601,7 @@ TclObjInvoke(interp, objc, objv, flags) int length; Tcl_Obj *command = Tcl_NewListObj(objc, objv); CONST char* cmdString; + Tcl_IncrRefCount(command); cmdString = Tcl_GetStringFromObj(command, &length); Tcl_LogCommandInfo(interp, cmdString, cmdString, length); @@ -4593,13 +4621,12 @@ TclObjInvoke(interp, objc, objv, flags) * * Results: * A standard Tcl result. If the result is TCL_OK, then the interp's - * result is set to the string value of the expression. If the result - * is TCL_ERROR, then the interp's result contains an error message. + * result is set to the string value of the expression. If the result is + * TCL_ERROR, then the interp's result contains an error message. * * Side effects: * A Tcl object is allocated to hold a copy of the expression string. - * This expression object is passed to Tcl_ExprObj and then - * deallocated. + * This expression object is passed to Tcl_ExprObj and then deallocated. * *--------------------------------------------------------------------------- */ @@ -4611,11 +4638,16 @@ Tcl_ExprString(interp, expr) CONST char *expr; /* Expression to evaluate. */ { int code = TCL_OK; + if (expr[0] == '\0') { - /* An empty string. Just set the interpreter's result to 0. */ + /* + * An empty string. Just set the interpreter's result to 0. + */ + Tcl_SetResult(interp, "0", TCL_VOLATILE); } else { Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); + Tcl_IncrRefCount(exprObj); code = Tcl_ExprObj(interp, exprObj, &resultPtr); Tcl_DecrRefCount(exprObj); @@ -4624,7 +4656,10 @@ Tcl_ExprString(interp, expr) Tcl_DecrRefCount(resultPtr); } - /* Force the string rep of the interp result */ + /* + * Force the string rep of the interp result. + */ + (void) Tcl_GetStringResult(interp); } return code; @@ -4635,16 +4670,16 @@ Tcl_ExprString(interp, expr) * * TclAppendObjToErrorInfo -- * - * Add a Tcl_Obj value to the errorInfo field that describes the - * current error. + * Add a Tcl_Obj value to the errorInfo field that describes the current + * error. * * Results: * None. * * Side effects: - * The value of the Tcl_obj is appended to the errorInfo field. - * If we are just starting to log an error, errorInfo is initialized - * from the error message in the interpreter's result. + * The value of the Tcl_obj is appended to the errorInfo field. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. * *---------------------------------------------------------------------- */ @@ -4657,6 +4692,7 @@ TclAppendObjToErrorInfo(interp, objPtr) { int length; CONST char *message = Tcl_GetStringFromObj(objPtr, &length); + Tcl_AddObjErrorInfo(interp, message, length); } @@ -4665,16 +4701,16 @@ TclAppendObjToErrorInfo(interp, objPtr) * * Tcl_AddErrorInfo -- * - * Add information to the errorInfo field that describes the - * current error. + * Add information to the errorInfo field that describes the current + * error. * * Results: * None. * * Side effects: - * The contents of message are appended to the errorInfo field. - * If we are just starting to log an error, errorInfo is initialized - * from the error message in the interpreter's result. + * The contents of message are appended to the errorInfo field. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. * *---------------------------------------------------------------------- */ @@ -4693,18 +4729,18 @@ Tcl_AddErrorInfo(interp, message) * * Tcl_AddObjErrorInfo -- * - * Add information to the errorInfo field that describes the - * current error. This routine differs from Tcl_AddErrorInfo by - * taking a byte pointer and length. + * Add information to the errorInfo field that describes the current + * error. This routine differs from Tcl_AddErrorInfo by taking a byte + * pointer and length. * * Results: * None. * * Side effects: - * "length" bytes from "message" are appended to the errorInfo field. - * If "length" is negative, use bytes up to the first NULL byte. - * If we are just starting to log an error, errorInfo is initialized - * from the error message in the interpreter's result. + * "length" bytes from "message" are appended to the errorInfo field. If + * "length" is negative, use bytes up to the first NULL byte. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. * *---------------------------------------------------------------------- */ @@ -4715,26 +4751,26 @@ Tcl_AddObjErrorInfo(interp, message, length) * pertains. */ CONST char *message; /* Points to the first byte of an array of * bytes of the message. */ - int length; /* The number of bytes in the message. - * If < 0, then append all bytes up to a - * NULL byte. */ + int length; /* The number of bytes in the message. If < 0, + * then append all bytes up to a NULL byte. */ { register Interp *iPtr = (Interp *) interp; /* - * If we are just starting to log an error, errorInfo is initialized - * from the error message in the interpreter's result. + * If we are just starting to log an error, errorInfo is initialized from + * the error message in the interpreter's result. */ if (iPtr->errorInfo == NULL) { /* just starting to log error */ if (iPtr->result[0] != 0) { /* - * The interp's string result is set, apparently by some - * extension making a deprecated direct write to it. - * That extension may expect interp->result to continue - * to be set, so we'll take special pains to avoid clearing - * it, until we drop support for interp->result completely. + * The interp's string result is set, apparently by some extension + * making a deprecated direct write to it. That extension may + * expect interp->result to continue to be set, so we'll take + * special pains to avoid clearing it, until we drop support for + * interp->result completely. */ + iPtr->errorInfo = Tcl_NewStringObj(interp->result, -1); } else { iPtr->errorInfo = iPtr->objResultPtr; @@ -4764,12 +4800,12 @@ Tcl_AddObjErrorInfo(interp, message, length) * * Tcl_VarEvalVA -- * - * Given a variable number of string arguments, concatenate them - * all together and execute the result as a Tcl command. + * Given a variable number of string arguments, concatenate them all + * together and execute the result as a Tcl command. * * Results: - * A standard Tcl return result. An error message or other result may - * be left in the interp's result. + * A standard Tcl return result. An error message or other result may be + * left in the interp's result. * * Side effects: * Depends on what was done by the command. @@ -4787,10 +4823,9 @@ Tcl_VarEvalVA(interp, argList) int result; /* - * Copy the strings one after the other into a single larger - * string. Use stack-allocated space for small commands, but if - * the command gets too large than call ckalloc to create the - * space. + * Copy the strings one after the other into a single larger string. Use + * stack-allocated space for small commands, but if the command gets too + * large than call ckalloc to create the space. */ Tcl_DStringInit(&buf); @@ -4812,12 +4847,12 @@ Tcl_VarEvalVA(interp, argList) * * Tcl_VarEval -- * - * Given a variable number of string arguments, concatenate them - * all together and execute the result as a Tcl command. + * Given a variable number of string arguments, concatenate them all + * together and execute the result as a Tcl command. * * Results: - * A standard Tcl return result. An error message or other - * result may be left in interp->result. + * A standard Tcl return result. An error message or other result may be + * left in interp->result. * * Side effects: * Depends on what was done by the command. @@ -4847,14 +4882,13 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) * Evaluate a command at global level in an interpreter. * * Results: - * A standard Tcl result is returned, and the interp's result is - * modified accordingly. + * A standard Tcl result is returned, and the interp's result is modified + * accordingly. * * Side effects: - * The command string is executed in interp, and the execution - * is carried out in the variable context of global level (no - * procedures active), just as if an "uplevel #0" command were - * being executed. + * The command string is executed in interp, and the execution is carried + * out in the variable context of global level (no procedures active), + * just as if an "uplevel #0" command were being executed. * --------------------------------------------------------------------------- */ @@ -4880,8 +4914,8 @@ Tcl_GlobalEval(interp, command) * * Tcl_SetRecursionLimit -- * - * Set the maximum number of recursive calls that may be active - * for an interpreter at once. + * Set the maximum number of recursive calls that may be active for an + * interpreter at once. * * Results: * The return value is the old limit on nesting for interp. @@ -4894,9 +4928,9 @@ Tcl_GlobalEval(interp, command) int Tcl_SetRecursionLimit(interp, depth) - Tcl_Interp *interp; /* Interpreter whose nesting limit - * is to be set. */ - int depth; /* New value for maximimum depth. */ + Tcl_Interp *interp; /* Interpreter whose nesting limit is to be + * set. */ + int depth; /* New value for maximimum depth. */ { Interp *iPtr = (Interp *) interp; int old; @@ -4913,17 +4947,15 @@ Tcl_SetRecursionLimit(interp, depth) * * Tcl_AllowExceptions -- * - * Sets a flag in an interpreter so that exceptions can occur - * in the next call to Tcl_Eval without them being turned into - * errors. + * Sets a flag in an interpreter so that exceptions can occur in the next + * call to Tcl_Eval without them being turned into errors. * * Results: * None. * * Side effects: - * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's - * evalFlags structure. See the reference documentation for - * more details. + * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's evalFlags + * structure. See the reference documentation for more details. * *---------------------------------------------------------------------- */ @@ -4936,16 +4968,15 @@ Tcl_AllowExceptions(interp) iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; } - /* *---------------------------------------------------------------------- * * Tcl_GetVersion -- * - * Get the Tcl major, minor, and patchlevel version numbers and - * the release type. A patch is a release type TCL_FINAL_RELEASE - * with a patchLevel > 0. + * Get the Tcl major, minor, and patchlevel version numbers and the + * release type. A patch is a release type TCL_FINAL_RELEASE with a + * patchLevel > 0. * * Results: * None. @@ -4982,13 +5013,13 @@ Tcl_GetVersion(majorV, minorV, patchLevelV, type) * * Math Functions -- * - * This page contains the procedures that implement all of the - * built-in math functions for expressions. + * This page contains the procedures that implement all of the built-in + * math functions for expressions. * * Results: - * Each procedure returns TCL_OK if it succeeds and pushes an - * Tcl object holding the result. If it fails it returns TCL_ERROR - * and leaves an error message in the interpreter's result. + * Each procedure returns TCL_OK if it succeeds and pushes an Tcl object + * holding the result. If it fails it returns TCL_ERROR and leaves an + * error message in the interpreter's result. * * Side effects: * None. @@ -5009,18 +5040,19 @@ ExprUnaryFunc(clientData, interp, objc, objv) double d, dResult; Tcl_Obj* oResult; - double (*func) _ANSI_ARGS_((double)) = - (double (*)_ANSI_ARGS_((double))) clientData; + double (*func)(double) = (double (*)(double)) clientData; /* * Convert the function's argument to a double if necessary. - */ + */ if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d) == TCL_OK) { - /* Evaluate the function */ + /* + * Evaluate the function. + */ dResult = (*func)(d); if ((errno != 0) || IS_NAN(dResult)) { @@ -5040,8 +5072,8 @@ ExprUnaryFunc(clientData, interp, objc, objv) static int ExprBinaryFunc(clientData, interp, objc, objv) ClientData clientData; /* Contains the address of a procedure that - * takes two double arguments and - * returns a double result. */ + * takes two double arguments and returns a + * double result. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ @@ -5050,8 +5082,7 @@ ExprBinaryFunc(clientData, interp, objc, objv) double d1, d2, dResult; Tcl_Obj* oResult; - double (*func) _ANSI_ARGS_((double, double)) = - (double (*)_ANSI_ARGS_((double, double))) clientData; + double (*func)(double, double) = (double (*)(double, double)) clientData; /* * Convert the function's two arguments to doubles if necessary. @@ -5061,8 +5092,9 @@ ExprBinaryFunc(clientData, interp, objc, objv) MathFuncWrongNumArgs(interp, 3, objc, objv); } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d1) == TCL_OK && Tcl_GetDoubleFromObj(interp, objv[2], &d2) == TCL_OK) { - - /* Evaluate the function */ + /* + * Evaluate the function. + */ errno = 0; dResult = (*func)(d1, d2); @@ -5107,6 +5139,7 @@ ExprAbsFunc(clientData, interp, objc, objv) /* * Derive the absolute value according to the arg type. */ + if (valuePtr->typePtr == &tclIntType) { i = valuePtr->internalRep.longValue; if (i < 0) { @@ -5118,7 +5151,7 @@ ExprAbsFunc(clientData, interp, objc, objv) Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", (char *) NULL); return TCL_ERROR; -#else +#else /* * Special case: abs(MIN_INT) must promote to wide. */ @@ -5129,12 +5162,13 @@ ExprAbsFunc(clientData, interp, objc, objv) } } else { iResult = i; - } + } TclNewLongObj(oResult, iResult); Tcl_SetObjResult(interp, oResult); } else if (valuePtr->typePtr == &tclWideIntType) { Tcl_WideInt wResult, w; - TclGetWide(w,valuePtr); + + TclGetWide(w, valuePtr); if (w < (Tcl_WideInt)0) { wResult = -w; if (wResult < 0) { @@ -5146,7 +5180,7 @@ ExprAbsFunc(clientData, interp, objc, objv) } } else { wResult = w; - } + } TclNewWideIntObj(oResult, wResult); Tcl_SetObjResult(interp, oResult); } else { @@ -5344,7 +5378,7 @@ ExprRandFunc(clientData, interp, objc, objv) if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { iPtr->flags |= RAND_SEED_INITIALIZED; - /* + /* * Take into consideration the thread this interp is running in order * to insure different seeds in different threads (bug #416643) */ @@ -5352,7 +5386,7 @@ ExprRandFunc(clientData, interp, objc, objv) iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12); /* - * Make sure 1 <= randSeed <= (2^31) - 2. See below. + * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ iPtr->randSeed &= (unsigned long) 0x7fffffff; @@ -5362,30 +5396,29 @@ ExprRandFunc(clientData, interp, objc, objv) } /* - * Generate the random number using the linear congruential - * generator defined by the following recurrence: + * Generate the random number using the linear congruential generator + * defined by the following recurrence: * seed = ( IA * seed ) mod IM - * where IA is 16807 and IM is (2^31) - 1. The recurrence maps - * a seed in the range [1, IM - 1] to a new seed in that same range. - * The recurrence maps IM to 0, and maps 0 back to 0, so those two - * values must not be allowed as initial values of seed. + * where IA is 16807 and IM is (2^31) - 1. The recurrence maps a seed in + * the range [1, IM - 1] to a new seed in that same range. The recurrence + * maps IM to 0, and maps 0 back to 0, so those two values must not be + * allowed as initial values of seed. * * In order to avoid potential problems with integer overflow, the - * recurrence is implemented in terms of additional constants - * IQ and IR such that + * recurrence is implemented in terms of additional constants IQ and IR + * such that * IM = IA*IQ + IR - * None of the operations in the implementation overflows a 32-bit - * signed integer, and the C type long is guaranteed to be at least - * 32 bits wide. + * None of the operations in the implementation overflows a 32-bit signed + * integer, and the C type long is guaranteed to be at least 32 bits wide. * * For more details on how this algorithm works, refer to the following - * papers: + * papers: * - * S.K. Park & K.W. Miller, "Random number generators: good ones - * are hard to find," Comm ACM 31(10):1192-1201, Oct 1988 + * S.K. Park & K.W. Miller, "Random number generators: good ones are hard + * to find," Comm ACM 31(10):1192-1201, Oct 1988 * - * W.H. Press & S.A. Teukolsky, "Portable random number - * generators," Computers in Physics 6(5):522-524, Sep/Oct 1992. + * W.H. Press & S.A. Teukolsky, "Portable random number generators," + * Computers in Physics 6(5):522-524, Sep/Oct 1992. */ #define RAND_IA 16807 @@ -5427,7 +5460,9 @@ ExprRoundFunc(clientData, interp, objc, objv) Tcl_Obj *valuePtr, *resPtr; double d, i, f; - /* Check the argument count. */ + /* + * Check the argument count. + */ if (objc != 2) { MathFuncWrongNumArgs(interp, 1, objc, objv); @@ -5435,7 +5470,9 @@ ExprRoundFunc(clientData, interp, objc, objv) } valuePtr = objv[1]; - /* Coerce the argument to a number. Integers are already rounded. */ + /* + * Coerce the argument to a number. Integers are already rounded. + */ if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { return TCL_ERROR; @@ -5447,9 +5484,9 @@ ExprRoundFunc(clientData, interp, objc, objv) } GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr); - /* - * Round the number to the nearest integer. I'd like to use round(), - * but it's C99 (or BSD), and not yet universal. + /* + * Round the number to the nearest integer. I'd like to use round(), but + * it's C99 (or BSD), and not yet universal. */ d = valuePtr->internalRep.doubleValue; @@ -5464,7 +5501,7 @@ ExprRoundFunc(clientData, interp, objc, objv) resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i)); } else { resPtr = Tcl_NewLongObj((long) i); - } + } } else { if (f >= 0.5) { i += 1.0; @@ -5530,8 +5567,8 @@ ExprSrandFunc(clientData, interp, objc, objv) } /* - * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. - * See comments in ExprRandFunc() for more details. + * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in + * ExprRandFunc() for more details. */ iPtr->flags |= RAND_SEED_INITIALIZED; @@ -5542,9 +5579,9 @@ ExprSrandFunc(clientData, interp, objc, objv) } /* - * To avoid duplicating the random number generation code we simply - * clean up our state and call the real random number function. That - * function will always succeed. + * To avoid duplicating the random number generation code we simply clean + * up our state and call the real random number function. That function + * will always succeed. */ return ExprRandFunc(clientData, interp, 1, objv); @@ -5556,10 +5593,10 @@ ExprSrandFunc(clientData, interp, objc, objv) * * VerifyExprObjType -- * - * This procedure is called by the math functions to verify that - * the object is either an int or double, coercing it if necessary. - * If an error occurs during conversion, an error message is left - * in the interpreter's result unless "interp" is NULL. + * This procedure is called by the math functions to verify that the + * object is either an int or double, coercing it if necessary. If an + * error occurs during conversion, an error message is left in the + * interpreter's result unless "interp" is NULL. * * Results: * TCL_OK if it was int or double, TCL_ERROR otherwise @@ -5611,14 +5648,14 @@ VerifyExprObjType(interp, objPtr) * * MathFuncWrongNumArgs -- * - * Generate an error message when a math function presents the - * wrong number of arguments + * Generate an error message when a math function presents the wrong + * number of arguments. * * Results: * None. * * Side effects: - * An error message is stored in the interpreter result + * An error message is stored in the interpreter result. * *---------------------------------------------------------------------- */ @@ -5633,6 +5670,7 @@ MathFuncWrongNumArgs(interp, expected, found, objv) Tcl_Obj* errorMessage; CONST char* name = Tcl_GetString(objv[0]); CONST char* tail = name + strlen(name); + while (tail > name+1) { --tail; if (*tail == ':' && tail[-1] == ':') { @@ -5651,3 +5689,11 @@ MathFuncWrongNumArgs(interp, expected, found, objv) Tcl_AppendToObj(errorMessage, "\"", -1); Tcl_SetObjResult(interp, errorMessage); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 04a8096..4ec4f71 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.247 2005/08/26 14:43:28 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.248 2005/09/06 14:40:11 dkf Exp $ */ #ifndef _TCLINT @@ -1712,6 +1712,10 @@ 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 * accomodate all elements. */ } List; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 1488ecb..e83a8f4 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclListObj.c,v 1.26 2005/09/02 19:23:46 andreas_kupries Exp $ + * RCS: @(#) $Id: tclListObj.c,v 1.27 2005/09/06 14:40:11 dkf Exp $ */ #include "tclInt.h" @@ -19,14 +19,11 @@ * Prototypes for functions defined later in this file: */ -static List* NewListIntRep _ANSI_ARGS_((int objc, - Tcl_Obj *CONST objv[])); -static void DupListInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); -static void FreeListInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr)); -static int SetListFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static void UpdateStringOfList _ANSI_ARGS_((Tcl_Obj *listPtr)); +static List * NewListIntRep(int objc, Tcl_Obj *CONST objv[]); +static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeListInternalRep(Tcl_Obj *listPtr); +static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfList(Tcl_Obj *listPtr); /* * The structure below defines the list Tcl object type by means of functions @@ -42,11 +39,11 @@ static void UpdateStringOfList _ANSI_ARGS_((Tcl_Obj *listPtr)); */ Tcl_ObjType tclListType = { - "list", /* name */ - FreeListInternalRep, /* freeIntRepProc */ - DupListInternalRep, /* dupIntRepProc */ - UpdateStringOfList, /* updateStringProc */ - NULL /* setFromAnyProc */ + "list", /* name */ + FreeListInternalRep, /* freeIntRepProc */ + DupListInternalRep, /* dupIntRepProc */ + UpdateStringOfList, /* updateStringProc */ + NULL /* setFromAnyProc */ }; @@ -89,7 +86,7 @@ NewListIntRep(objc, objv) /* * First check to see if we'd overflow and try to allocate an object - * larger than our memory allocator allows. Note that this is actually a + * larger than our memory allocator allows. Note that this is actually a * fairly small value when you're on a serious 64-bit machine, but that * requires API changes to fix. */ @@ -104,6 +101,7 @@ NewListIntRep(objc, objv) return NULL; } + listRepPtr->canonicalFlag = 0; listRepPtr->refCount = 0; listRepPtr->maxElemCount = objc; @@ -771,7 +769,7 @@ Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv) elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; - if (first < 0) { + if (first < 0) { first = 0; } if (first >= numElems) { @@ -954,8 +952,8 @@ Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv) * * Tcl_LsetFlat and related functions maintain a linked list of Tcl_Obj's * whose string representations must be spoilt by threading via 'ptr2' of - * the two-pointer internal representation. On entry to Tcl_LsetList, - * the values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any + * the two-pointer internal representation. On entry to Tcl_LsetList, the + * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * *---------------------------------------------------------------------- @@ -993,7 +991,7 @@ TclLsetList(interp, listPtr, indexArgPtr, valuePtr) &indices) != TCL_OK) { /* * indexArgPtr designates something that is neither an index nor a - * well formed list. Report the error via TclLsetFlat. + * well formed list. Report the error via TclLsetFlat. */ return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); @@ -1041,7 +1039,7 @@ TclLsetList(interp, listPtr, indexArgPtr, valuePtr) * * TclLsetFlat -- * - * Core of the 'lset' command when objc>=5. Objv[2], ... , objv[objc-2] + * Core of the 'lset' command when objc>=5. Objv[2], ... , objv[objc-2] * contain scalar indices. * * Results: @@ -1064,18 +1062,18 @@ TclLsetList(interp, listPtr, indexArgPtr, valuePtr) * * If no error occurs, the reference count of the original object is * incremented if the object has not been duplicated, and nothing is done - * to a reference count of the duplicate. Now the reference count of an + * to a reference count of the duplicate. Now the reference count of an * unduplicated object is 2 (the returned pointer, plus the one stored in - * the variable). The reference count of a duplicate object is 1, + * the variable). The reference count of a duplicate object is 1, * reflecting that the returned pointer is the only active reference. * The caller is expected to store the returned value back in the - * variable and decrement its reference count. (INST_STORE_* does - * exactly this.) + * variable and decrement its reference count. (INST_STORE_* does exactly + * this.) * * Tcl_LsetList and related functions maintain a linked list of Tcl_Obj's * whose string representations must be spoilt by threading via 'ptr2' of - * the two-pointer internal representation. On entry to Tcl_LsetList, - * the values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any + * the two-pointer internal representation. On entry to Tcl_LsetList, the + * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * *---------------------------------------------------------------------- @@ -1292,7 +1290,9 @@ TclListObjSetElement(interp, listPtr, index, valuePtr) int elemCount; /* Number of elements in the list */ int i; - /* Ensure that the listPtr parameter designates an unshared list */ + /* + * Ensure that the listPtr parameter designates an unshared list. + */ if (Tcl_IsShared(listPtr)) { Tcl_Panic("Tcl_ListObjSetElement called with shared object"); @@ -1316,7 +1316,9 @@ TclListObjSetElement(interp, listPtr, index, valuePtr) elemCount = listRepPtr->elemCount; elemPtrs = &listRepPtr->elements; - /* Ensure that the index is in bounds. */ + /* + * Ensure that the index is in bounds. + */ if (index<0 || index>=elemCount) { if (interp != NULL) { @@ -1335,6 +1337,7 @@ TclListObjSetElement(interp, listPtr, index, valuePtr) Tcl_Obj **oldElemPtrs = elemPtrs; listRepPtr = NewListIntRep(listRepPtr->maxElemCount, NULL); + listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag; elemPtrs = &listRepPtr->elements; for (i=0; i < elemCount; i++) { elemPtrs[i] = oldElemPtrs[i]; @@ -1346,15 +1349,21 @@ TclListObjSetElement(interp, listPtr, index, valuePtr) oldListRepPtr->refCount--; } - /* Add a reference to the new list element */ + /* + * Add a reference to the new list element. + */ Tcl_IncrRefCount(valuePtr); - /* Remove a reference from the old list element */ + /* + * Remove a reference from the old list element. + */ Tcl_DecrRefCount(elemPtrs[index]); - /* Stash the new object in the list */ + /* + * Stash the new object in the list. + */ elemPtrs[index] = valuePtr; @@ -1473,11 +1482,10 @@ SetListFromAny(interp, objPtr) /* * Parse the string into separate string objects, and create a List - * structure that points to the element string objects. We use a - * modified version of Tcl_SplitList's implementation to avoid one - * malloc and a string copy for each list element. First, estimate the - * number of elements by counting the number of space characters in the - * list. + * structure that points to the element string objects. We use a modified + * version of Tcl_SplitList's implementation to avoid one malloc and a + * string copy for each list element. First, estimate the number of + * elements by counting the number of space characters in the list. */ limit = (string + length); @@ -1489,14 +1497,14 @@ SetListFromAny(interp, objPtr) } /* - * Allocate a new List structure with enough room for "estCount" - * elements. Each element is a pointer to a Tcl_Obj with the appropriate - * string rep. The initial "estCount" elements are set using the - * corresponding "argv" strings. + * Allocate a new List structure with enough room for "estCount" elements. + * Each element is a pointer to a Tcl_Obj with the appropriate string rep. + * The initial "estCount" elements are set using the corresponding "argv" + * strings. */ listRepPtr = NewListIntRep(estCount, NULL); - if(!listRepPtr) { + if (!listRepPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Not enough memory to allocate the list internal rep", -1)); return TCL_ERROR; @@ -1530,20 +1538,20 @@ SetListFromAny(interp, objPtr) s = ckalloc((unsigned) elemSize + 1); if (hasBrace) { - memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); + memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); s[elemSize] = 0; } else { elemSize = TclCopyAndCollapse(elemSize, elemStart, s); } TclNewObj(elemPtr); - elemPtr->bytes = s; + elemPtr->bytes = s; elemPtr->length = elemSize; elemPtrs[i] = elemPtr; - Tcl_IncrRefCount(elemPtr); /* since list now holds ref to it */ + Tcl_IncrRefCount(elemPtr); /* since list now holds ref to it */ } - listRepPtr->elemCount = i; + listRepPtr->elemCount = i; /* * Free the old internalRep before setting the new one. We do this as late @@ -1613,9 +1621,11 @@ UpdateStringOfList(listPtr) elem = Tcl_GetStringFromObj(elemPtrs[i], &length); listPtr->length += Tcl_ScanCountedElement(elem, length, &flagPtr[i]) + 1; + /* * Check for continued sanity. [Bug 1267380] */ + if (listPtr->length < 1) { Tcl_Panic("string representation size exceeds sane bounds"); } @@ -1644,6 +1654,14 @@ UpdateStringOfList(listPtr) *dst = 0; } listPtr->length = dst - listPtr->bytes; + + /* + * Mark the list as being canonical; although it has a string rep, it is + * one we derived through proper "canonical" quoting and so it's known to + * be free from nasties relating to [concat] and [eval]. + */ + + listRepPtr->canonicalFlag = 1; } /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 30cf775..0654f65 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtil.c,v 1.63 2005/07/27 18:24:02 dgp Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.64 2005/09/06 14:40:11 dkf Exp $ */ #include "tclInt.h" @@ -1057,8 +1057,14 @@ Tcl_ConcatObj(objc, objv) */ for (i = 0; i < objc; i++) { + List *listRepPtr; + objPtr = objv[i]; - if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) { + if (objPtr->typePtr != &tclListType) { + break; + } + listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; + if (objPtr->bytes != NULL && !listRepPtr->canonicalFlag) { break; } } @@ -1074,6 +1080,7 @@ Tcl_ConcatObj(objc, objv) * INT_MAX tells us to always put the new stuff on the end. It * will be set right in Tcl_ListObjReplace. */ + Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv); Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv); } diff --git a/tests/eval.test b/tests/eval.test index 22de6af..eefa96f 100644 --- a/tests/eval.test +++ b/tests/eval.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: eval.test,v 1.6 2004/05/19 12:23:13 dkf Exp $ +# RCS: @(#) $Id: eval.test,v 1.7 2005/09/06 14:40:11 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -58,6 +58,29 @@ test eval-2.5 {error in eval'ed command: setting errorInfo} { error \"test error\" }\"" +test eval-3.1 {eval and pure lists} { + eval [list list 1 2 3 4 5] +} {1 2 3 4 5} +test eval-3.2 {concatenating eval and pure lists} { + eval [list list 1] [list 2 3 4 5] +} {1 2 3 4 5} +test eval-3.3 {eval and canonical lists} { + set cmd [list list 1 2 3 4 5] + # Force existance of utf-8 rep + set dummy($cmd) $cmd + unset dummy($cmd) + eval $cmd +} {1 2 3 4 5} +test eval-3.4 {concatenating eval and canonical lists} { + set cmd [list list 1] + set cmd2 [list 2 3 4 5] + # Force existance of utf-8 rep + set dummy($cmd) $cmd + set dummy($cmd2) $cmd2 + unset dummy($cmd) dummy($cmd2) + eval $cmd $cmd2 +} {1 2 3 4 5} + # cleanup ::tcltest::cleanupTests return |