summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c1876
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclListObj.c108
-rw-r--r--generic/tclUtil.c11
4 files changed, 1038 insertions, 963 deletions
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);
}