diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 7568 |
1 files changed, 3933 insertions, 3635 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 134deac..cfb5c43 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1,9 +1,9 @@ -/* +/* * 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. @@ -11,256 +11,353 @@ * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * - * 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. */ #include "tclInt.h" #include "tclCompile.h" -#ifndef TCL_GENERIC_ONLY -# include "tclPort.h" -#endif +#include <float.h> +#include <limits.h> +#include <math.h> +#include "tommath.h" /* - * Static procedures in this file: + * Determine whether we're using IEEE floating point */ -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 StringTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp* interp, - int level, - CONST char* command, - Tcl_Command commandInfo, - int objc, - Tcl_Obj *CONST objv[])); -static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); - -#ifdef TCL_TIP280 -/* TIP #280 - Modified token based evaluation, with line information */ -static int EvalEx _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, - int numBytes, int flags, int line, - int* clNextOuter, CONST char* outerScript)); - -static int EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Token *tokenPtr, - int count, int line, - int* clNextOuter, CONST char* outerScript)); +#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) +# define IEEE_FLOATING_POINT +/* Largest odd integer that can be represented exactly in a double */ +# define MAX_EXACT 9007199254740991.0 #endif +/* + * The following structure defines the client data for a math function + * registered with Tcl_CreateMathFunc + */ + +typedef struct OldMathFuncData { + Tcl_MathProc *proc; /* Handler function */ + int numArgs; /* Number of args expected */ + Tcl_ValueType *argTypes; /* Types of the args */ + ClientData clientData; /* Client data for the handler function */ +} OldMathFuncData; + +/* + * Static functions in this file: + */ + +static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, + const char *oldName, const char *newName, int flags); +static int CheckDoubleResult(Tcl_Interp *interp, double dResult); +static void DeleteInterpProc(Tcl_Interp *interp); +static void DeleteOpCmdClientData(ClientData clientData); +static Tcl_Obj *GetCommandSource(Interp *iPtr, const char *command, + int numChars, int objc, Tcl_Obj *const objv[]); +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 ExprCeilFunc(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 ExprEntierFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprFloorFunc(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 ExprIsqrtFunc(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 ExprSqrtFunc(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 void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, + int actual, Tcl_Obj *const *objv); #ifdef USE_DTRACE static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); #endif extern TclStubs tclStubs; /* - * The following structure defines the commands in the Tcl core. + * The following structure define the commands in the Tcl core. */ typedef struct { - CONST char *name; /* Name of object-based command. */ - Tcl_CmdProc *proc; /* String-based procedure for 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. */ + const char *name; /* Name of object-based command. */ + Tcl_ObjCmdProc *objProc; /* Object-based function for command. */ + CompileProc *compileProc; /* Function called to compile command. */ + int isSafe; /* If non-zero, command will be present in + * safe interpreter. Otherwise it will be + * hidden. */ } CmdInfo; /* - * The built-in commands, and the procedures that implement them: + * The built-in commands, and the functions that implement them: */ -static CONST CmdInfo builtInCmds[] = { - /* - * Commands in the generic core. Note that at least one of the proc or - * objProc members should be non-NULL. This avoids infinitely recursive - * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a - * command name is computed at runtime and results in the name of a - * compiled command. - */ - - {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd, - TclCompileAppendCmd, 1}, - {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd, - (CompileProc *) NULL, 1}, - {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, - (CompileProc *) NULL, 1}, - {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd, - TclCompileBreakCmd, 1}, - {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, - (CompileProc *) NULL, 1}, - {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd, - TclCompileCatchCmd, 1}, - {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd, - (CompileProc *) NULL, 1}, - {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, - (CompileProc *) NULL, 1}, - {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd, - TclCompileContinueCmd, 1}, - {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd, - (CompileProc *) NULL, 0}, - {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, - (CompileProc *) NULL, 1}, - {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd, - (CompileProc *) NULL, 1}, - {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd, - (CompileProc *) NULL, 0}, - {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd, - TclCompileExprCmd, 1}, - {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, - (CompileProc *) NULL, 1}, - {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd, - (CompileProc *) NULL, 1}, - {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd, - TclCompileForCmd, 1}, - {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, - TclCompileForeachCmd, 1}, - {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd, - (CompileProc *) NULL, 1}, - {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, - (CompileProc *) NULL, 1}, - {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd, - TclCompileIfCmd, 1}, - {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd, - TclCompileIncrCmd, 1}, - {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, - (CompileProc *) NULL, 1}, - {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, - (CompileProc *) NULL, 1}, - {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, - TclCompileLappendCmd, 1}, - {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, - TclCompileLindexCmd, 1}, - {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, - (CompileProc *) NULL, 1}, - {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd, - TclCompileListCmd, 1}, - {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, - TclCompileLlengthCmd, 1}, - {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd, - (CompileProc *) NULL, 0}, - {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, - (CompileProc *) NULL, 1}, - {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd, - (CompileProc *) NULL, 1}, - {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd, - (CompileProc *) NULL, 1}, - {"lset", (Tcl_CmdProc *) NULL, Tcl_LsetObjCmd, - TclCompileLsetCmd, 1}, - {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd, - (CompileProc *) NULL, 1}, - {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, - (CompileProc *) NULL, 1}, - {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd, - (CompileProc *) NULL, 1}, - {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, - (CompileProc *) NULL, 1}, - {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd, - TclCompileRegexpCmd, 1}, - {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd, - (CompileProc *) NULL, 1}, - {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, - (CompileProc *) NULL, 1}, - {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, - TclCompileReturnCmd, 1}, - {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, - (CompileProc *) NULL, 1}, - {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, - TclCompileSetCmd, 1}, - {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, - (CompileProc *) NULL, 1}, - {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, - TclCompileStringCmd, 1}, - {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, - (CompileProc *) NULL, 1}, - {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, - (CompileProc *) NULL, 1}, - {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd, - (CompileProc *) NULL, 1}, - {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, - (CompileProc *) NULL, 1}, - {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd, - (CompileProc *) NULL, 1}, - {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd, - (CompileProc *) NULL, 1}, - {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, - (CompileProc *) NULL, 1}, - {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd, - TclCompileWhileCmd, 1}, - - /* - * Commands in the UNIX core: - */ - -#ifndef TCL_GENERIC_ONLY - {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd, - (CompileProc *) NULL, 1}, - {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd, - (CompileProc *) NULL, 0}, - {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd, - (CompileProc *) NULL, 1}, - {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd, - (CompileProc *) NULL, 1}, - {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, - (CompileProc *) NULL, 1}, - {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd, - (CompileProc *) NULL, 0}, - {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, - (CompileProc *) NULL, 0}, - {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd, - (CompileProc *) NULL, 1}, - {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, - (CompileProc *) NULL, 1}, - {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd, - (CompileProc *) NULL, 0}, - {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd, - (CompileProc *) NULL, 0}, - {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd, - (CompileProc *) NULL, 1}, - {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, - (CompileProc *) NULL, 1}, - {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd, - (CompileProc *) NULL, 0}, - {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, - (CompileProc *) NULL, 1}, - {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd, - (CompileProc *) NULL, 1}, - {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd, - (CompileProc *) NULL, 0}, - {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd, - (CompileProc *) NULL, 1}, - {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, - (CompileProc *) NULL, 1}, - {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd, - (CompileProc *) NULL, 1}, - {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd, - (CompileProc *) NULL, 1}, - {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd, - (CompileProc *) NULL, 0}, - {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, - (CompileProc *) NULL, 0}, - -#endif /* TCL_GENERIC_ONLY */ - {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, - (CompileProc *) NULL, 0} +static const CmdInfo builtInCmds[] = { + /* + * Commands in the generic core. + */ + + {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1}, + {"apply", Tcl_ApplyObjCmd, NULL, 1}, + {"array", Tcl_ArrayObjCmd, NULL, 1}, + {"binary", Tcl_BinaryObjCmd, NULL, 1}, + {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, +#ifndef EXCLUDE_OBSOLETE_COMMANDS + {"case", Tcl_CaseObjCmd, NULL, 1}, +#endif + {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, 1}, + {"concat", Tcl_ConcatObjCmd, NULL, 1}, + {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, 1}, + {"error", Tcl_ErrorObjCmd, NULL, 1}, + {"eval", Tcl_EvalObjCmd, NULL, 1}, + {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, 1}, + {"for", Tcl_ForObjCmd, TclCompileForCmd, 1}, + {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, 1}, + {"format", Tcl_FormatObjCmd, NULL, 1}, + {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, 1}, + {"if", Tcl_IfObjCmd, TclCompileIfCmd, 1}, + {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, 1}, + {"join", Tcl_JoinObjCmd, NULL, 1}, + {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, 1}, + {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, 1}, + {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, 1}, + {"linsert", Tcl_LinsertObjCmd, NULL, 1}, + {"list", Tcl_ListObjCmd, TclCompileListCmd, 1}, + {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, 1}, + {"lrange", Tcl_LrangeObjCmd, NULL, 1}, + {"lrepeat", Tcl_LrepeatObjCmd, NULL, 1}, + {"lreplace", Tcl_LreplaceObjCmd, NULL, 1}, + {"lreverse", Tcl_LreverseObjCmd, NULL, 1}, + {"lsearch", Tcl_LsearchObjCmd, NULL, 1}, + {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, 1}, + {"lsort", Tcl_LsortObjCmd, NULL, 1}, + {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, 1}, + {"package", Tcl_PackageObjCmd, NULL, 1}, + {"proc", Tcl_ProcObjCmd, NULL, 1}, + {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, 1}, + {"regsub", Tcl_RegsubObjCmd, NULL, 1}, + {"rename", Tcl_RenameObjCmd, NULL, 1}, + {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, 1}, + {"scan", Tcl_ScanObjCmd, NULL, 1}, + {"set", Tcl_SetObjCmd, TclCompileSetCmd, 1}, + {"split", Tcl_SplitObjCmd, NULL, 1}, + {"subst", Tcl_SubstObjCmd, NULL, 1}, + {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, 1}, + {"trace", Tcl_TraceObjCmd, NULL, 1}, + {"unset", Tcl_UnsetObjCmd, NULL, 1}, + {"uplevel", Tcl_UplevelObjCmd, NULL, 1}, + {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, 1}, + {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, 1}, + {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, 1}, + + /* + * Commands in the OS-interface. Note that many of these are unsafe. + */ + + {"after", Tcl_AfterObjCmd, NULL, 1}, + {"cd", Tcl_CdObjCmd, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, 1}, + {"eof", Tcl_EofObjCmd, NULL, 1}, + {"encoding", Tcl_EncodingObjCmd, NULL, 0}, + {"exec", Tcl_ExecObjCmd, NULL, 0}, + {"exit", Tcl_ExitObjCmd, NULL, 0}, + {"fblocked", Tcl_FblockedObjCmd, NULL, 1}, + {"fconfigure", Tcl_FconfigureObjCmd, NULL, 0}, + {"fcopy", Tcl_FcopyObjCmd, NULL, 1}, + {"file", Tcl_FileObjCmd, NULL, 0}, + {"fileevent", Tcl_FileEventObjCmd, NULL, 1}, + {"flush", Tcl_FlushObjCmd, NULL, 1}, + {"gets", Tcl_GetsObjCmd, NULL, 1}, + {"glob", Tcl_GlobObjCmd, NULL, 0}, + {"load", Tcl_LoadObjCmd, NULL, 0}, + {"open", Tcl_OpenObjCmd, NULL, 0}, + {"pid", Tcl_PidObjCmd, NULL, 1}, + {"puts", Tcl_PutsObjCmd, NULL, 1}, + {"pwd", Tcl_PwdObjCmd, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, 1}, + {"seek", Tcl_SeekObjCmd, NULL, 1}, + {"socket", Tcl_SocketObjCmd, NULL, 0}, + {"source", Tcl_SourceObjCmd, NULL, 0}, + {"tell", Tcl_TellObjCmd, NULL, 1}, + {"time", Tcl_TimeObjCmd, NULL, 1}, + {"unload", Tcl_UnloadObjCmd, NULL, 0}, + {"update", Tcl_UpdateObjCmd, NULL, 1}, + {"vwait", Tcl_VwaitObjCmd, NULL, 1}, + {NULL, NULL, NULL, 0} }; /* - * The following structure holds the client data for string-based - * trace procs + * Math functions. All are safe. + */ + +typedef struct { + const char *name; /* Name of the function. The full name is + * "::tcl::mathfunc::<name>". */ + Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */ + ClientData clientData; /* Client data for the function */ +} BuiltinFuncDef; +static const BuiltinFuncDef BuiltinFuncTable[] = { + { "abs", ExprAbsFunc, NULL }, + { "acos", ExprUnaryFunc, (ClientData) acos }, + { "asin", ExprUnaryFunc, (ClientData) asin }, + { "atan", ExprUnaryFunc, (ClientData) atan }, + { "atan2", ExprBinaryFunc, (ClientData) atan2 }, + { "bool", ExprBoolFunc, NULL }, + { "ceil", ExprCeilFunc, NULL }, + { "cos", ExprUnaryFunc, (ClientData) cos }, + { "cosh", ExprUnaryFunc, (ClientData) cosh }, + { "double", ExprDoubleFunc, NULL }, + { "entier", ExprEntierFunc, NULL }, + { "exp", ExprUnaryFunc, (ClientData) exp }, + { "floor", ExprFloorFunc, NULL }, + { "fmod", ExprBinaryFunc, (ClientData) fmod }, + { "hypot", ExprBinaryFunc, (ClientData) hypot }, + { "int", ExprIntFunc, NULL }, + { "isqrt", ExprIsqrtFunc, NULL }, + { "log", ExprUnaryFunc, (ClientData) log }, + { "log10", ExprUnaryFunc, (ClientData) log10 }, + { "pow", ExprBinaryFunc, (ClientData) pow }, + { "rand", ExprRandFunc, NULL }, + { "round", ExprRoundFunc, NULL }, + { "sin", ExprUnaryFunc, (ClientData) sin }, + { "sinh", ExprUnaryFunc, (ClientData) sinh }, + { "sqrt", ExprSqrtFunc, NULL }, + { "srand", ExprSrandFunc, NULL }, + { "tan", ExprUnaryFunc, (ClientData) tan }, + { "tanh", ExprUnaryFunc, (ClientData) tanh }, + { "wide", ExprWideFunc, NULL }, + { NULL, NULL, NULL } +}; + +/* + * TIP#174's math operators. All are safe. + */ + +typedef struct { + const char *name; /* Name of object-based command. */ + Tcl_ObjCmdProc *objProc; /* Object-based function for command. */ + CompileProc *compileProc; /* Function called to compile command. */ + union { + int numArgs; + int identity; + } i; + const char *expected; /* For error message, what argument(s) + * were expected. */ +} OpCmdInfo; +static const OpCmdInfo mathOpCmds[] = { + { "~", TclSingleOpCmd, TclCompileInvertOpCmd, + /* numArgs */ {1}, "integer"}, + { "!", TclSingleOpCmd, TclCompileNotOpCmd, + /* numArgs */ {1}, "boolean"}, + { "+", TclVariadicOpCmd, TclCompileAddOpCmd, + /* identity */ {0}, NULL}, + { "*", TclVariadicOpCmd, TclCompileMulOpCmd, + /* identity */ {1}, NULL}, + { "&", TclVariadicOpCmd, TclCompileAndOpCmd, + /* identity */ {-1}, NULL}, + { "|", TclVariadicOpCmd, TclCompileOrOpCmd, + /* identity */ {0}, NULL}, + { "^", TclVariadicOpCmd, TclCompileXorOpCmd, + /* identity */ {0}, NULL}, + { "**", TclVariadicOpCmd, TclCompilePowOpCmd, + /* identity */ {1}, NULL}, + { "<<", TclSingleOpCmd, TclCompileLshiftOpCmd, + /* numArgs */ {2}, "integer shift"}, + { ">>", TclSingleOpCmd, TclCompileRshiftOpCmd, + /* numArgs */ {2}, "integer shift"}, + { "%", TclSingleOpCmd, TclCompileModOpCmd, + /* numArgs */ {2}, "integer integer"}, + { "!=", TclSingleOpCmd, TclCompileNeqOpCmd, + /* numArgs */ {2}, "value value"}, + { "ne", TclSingleOpCmd, TclCompileStrneqOpCmd, + /* numArgs */ {2}, "value value"}, + { "in", TclSingleOpCmd, TclCompileInOpCmd, + /* numArgs */ {2}, "value list"}, + { "ni", TclSingleOpCmd, TclCompileNiOpCmd, + /* numArgs */ {2}, "value list"}, + { "-", TclNoIdentOpCmd, TclCompileMinusOpCmd, + /* unused */ {0}, "value ?value ...?"}, + { "/", TclNoIdentOpCmd, TclCompileDivOpCmd, + /* unused */ {0}, "value ?value ...?"}, + { "<", TclSortingOpCmd, TclCompileLessOpCmd, + /* unused */ {0}, NULL}, + { "<=", TclSortingOpCmd, TclCompileLeqOpCmd, + /* unused */ {0}, NULL}, + { ">", TclSortingOpCmd, TclCompileGreaterOpCmd, + /* unused */ {0}, NULL}, + { ">=", TclSortingOpCmd, TclCompileGeqOpCmd, + /* unused */ {0}, NULL}, + { "==", TclSortingOpCmd, TclCompileEqOpCmd, + /* unused */ {0}, NULL}, + { "eq", TclSortingOpCmd, TclCompileStreqOpCmd, + /* unused */ {0}, NULL}, + { NULL, NULL, NULL, + {0}, NULL} +}; + +/* + * Macros for stack checks. The goal of these macros is to allow the size of + * the stack to be checked (so preventing overflow) in a *cheap* way. Note + * that the check needs to be (amortized) cheap since it is on the critical + * path for recursion. + */ + +#if defined(TCL_NO_STACK_CHECK) +/* + * Stack check disabled: make them noops. */ -typedef struct StringTraceData { - ClientData clientData; /* Client data from Tcl_CreateTrace */ - Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */ -} StringTraceData; +# define CheckCStack(interp, localIntPtr) 1 +# define GetCStackParams(iPtr) /* do nothing */ +#elif defined(TCL_CROSS_COMPILE) + +/* + * This variable is static and only set *once*, during library initialization. + * It therefore needs no thread guards. + */ + +static int stackGrowsDown = 1; +# define GetCStackParams(iPtr) \ + stackGrowsDown = TclpGetCStackParams(&((iPtr)->stackBound)) +# define CheckCStack(iPtr, localIntPtr) \ + (stackGrowsDown \ + ? ((localIntPtr) > (iPtr)->stackBound) \ + : ((localIntPtr) < (iPtr)->stackBound) \ + ) +#else /* !TCL_NO_STACK_CHECK && !TCL_CROSS_COMPILE */ +# define GetCStackParams(iPtr) \ + TclpGetCStackParams(&((iPtr)->stackBound)) +# ifdef TCL_STACK_GROWS_UP +# define CheckCStack(iPtr, localIntPtr) \ + (!(iPtr)->stackBound || (localIntPtr) < (iPtr)->stackBound) +# else /* TCL_STACK_GROWS_UP */ +# define CheckCStack(iPtr, localIntPtr) \ + ((localIntPtr) > (iPtr)->stackBound) +# endif /* TCL_STACK_GROWS_UP */ +#endif /* TCL_NO_STACK_CHECK/TCL_CROSS_COMPILE */ /* *---------------------------------------------------------------------- @@ -270,28 +367,26 @@ typedef struct StringTraceData { * 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 functions 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). * *---------------------------------------------------------------------- */ Tcl_Interp * -Tcl_CreateInterp() +Tcl_CreateInterp(void) { Interp *iPtr; Tcl_Interp *interp; Command *cmdPtr; - BuiltinFunc *builtinFuncPtr; - MathFunc *mathFuncPtr; - Tcl_HashEntry *hPtr; - CONST CmdInfo *cmdInfoPtr; - int i; + const BuiltinFuncDef *builtinFuncPtr; + const OpCmdInfo *opcmdInfoPtr; + const CmdInfo *cmdInfoPtr; + Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr; union { char c[sizeof(short)]; short s; @@ -299,65 +394,76 @@ Tcl_CreateInterp() #ifdef TCL_COMPILE_STATS ByteCodeStats *statsPtr; #endif /* TCL_COMPILE_STATS */ + char mathFuncName[32]; + CallFrame *framePtr; + int result; - TclInitSubsystems(NULL); + 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*/ - panic("Tcl_CallFrame must not be smaller than CallFrame"); + Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } /* * 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)); interp = (Tcl_Interp *) iPtr; - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = NULL; - iPtr->errorLine = 0; - iPtr->objResultPtr = Tcl_NewObj(); + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = NULL; + iPtr->errorLine = 0; + iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); - iPtr->handle = TclHandleCreate(iPtr); - iPtr->globalNsPtr = NULL; - iPtr->hiddenCmdTablePtr = NULL; - iPtr->interpInfo = NULL; - Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); + iPtr->handle = TclHandleCreate(iPtr); + iPtr->globalNsPtr = NULL; + iPtr->hiddenCmdTablePtr = NULL; + iPtr->interpInfo = NULL; iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; - iPtr->framePtr = NULL; - iPtr->varFramePtr = NULL; + iPtr->framePtr = NULL; /* Initialise as soon as :: is available */ + iPtr->varFramePtr = NULL; /* Initialise as soon as :: is available */ -#ifdef TCL_TIP280 /* * TIP #280 - Initialize the arrays used to extend the ByteCode and * Proc structures. */ - iPtr->cmdFramePtr = NULL; - iPtr->linePBodyPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); - iPtr->lineBCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); - iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); - iPtr->lineLABCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); + + iPtr->cmdFramePtr = NULL; + iPtr->linePBodyPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); + iPtr->lineLABCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); iPtr->scriptCLLocPtr = NULL; -#endif iPtr->activeVarTracePtr = NULL; - iPtr->returnCode = TCL_OK; + + iPtr->returnOpts = NULL; iPtr->errorInfo = NULL; + TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo"); + Tcl_IncrRefCount(iPtr->eiVar); iPtr->errorCode = NULL; + TclNewLiteralStringObj(iPtr->ecVar, "::errorCode"); + Tcl_IncrRefCount(iPtr->ecVar); + iPtr->returnLevel = 1; + iPtr->returnCode = TCL_OK; + + iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ + iPtr->lookupNsPtr = NULL; iPtr->appendResult = NULL; iPtr->appendAvl = 0; @@ -365,14 +471,15 @@ Tcl_CreateInterp() Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; -#ifdef TCL_TIP268 + /* TIP #268 */ - iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ? - PKG_PREFER_STABLE : - PKG_PREFER_LATEST); -#endif + if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { + iPtr->packagePrefer = PKG_PREFER_STABLE; + } else { + iPtr->packagePrefer = PKG_PREFER_LATEST; + } + iPtr->cmdCount = 0; - iPtr->termOffset = 0; TclInitLiteralTable(&(iPtr->literalTable)); iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; @@ -384,21 +491,58 @@ Tcl_CreateInterp() iPtr->tracesForbiddingInline = 0; iPtr->activeCmdTracePtr = NULL; iPtr->activeInterpTracePtr = NULL; - iPtr->assocData = (Tcl_HashTable *) NULL; - iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ - iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ + iPtr->assocData = NULL; + iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ + iPtr->emptyObjPtr = Tcl_NewObj(); + /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->resultSpace[0] = 0; iPtr->threadId = Tcl_GetCurrentThread(); - iPtr->globalNsPtr = NULL; /* force creation of global ns below */ + /* TIP #378 */ +#ifdef TCL_INTERP_DEBUG_FRAME + iPtr->flags |= INTERP_DEBUG_FRAME; +#else + if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) { + iPtr->flags |= INTERP_DEBUG_FRAME; + } +#endif + + /* + * Initialise the tables for variable traces and searches *before* + * creating the global ns - so that the trace on errorInfo can be + * recorded. + */ + + Tcl_InitHashTable(&iPtr->varTraces, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&iPtr->varSearches, TCL_ONE_WORD_KEYS); + + iPtr->globalNsPtr = NULL; /* Force creation of global ns below. */ iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", - (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); + NULL, NULL); if (iPtr->globalNsPtr == NULL) { - panic("Tcl_CreateInterp: can't create global namespace"); + Tcl_Panic("Tcl_CreateInterp: can't create global namespace"); } /* + * Initialise the rootCallframe. It cannot be allocated on the stack, as + * it has to be in place before TclCreateExecEnv tries to use a variable. + */ + + /* This is needed to satisfy GCC 3.3's strict aliasing rules */ + framePtr = (CallFrame *) ckalloc(sizeof(CallFrame)); + result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); + if (result != TCL_OK) { + Tcl_Panic("Tcl_CreateInterp: failed to push the root stack frame"); + } + framePtr->objc = 0; + + iPtr->framePtr = framePtr; + iPtr->varFramePtr = framePtr; + iPtr->rootFramePtr = framePtr; + + /* * Initialize support for code compilation and execution. We call * TclCreateExecEnv after initializing namespaces since it tries to * reference a Tcl variable (it links to the Tcl "tcl_traceExec" @@ -408,6 +552,12 @@ Tcl_CreateInterp() iPtr->execEnvPtr = TclCreateExecEnv(interp); /* + * TIP #219, Tcl Channel Reflection API support. + */ + + iPtr->chanMsg = NULL; + + /* * Initialize the compilation and execution statistics kept for this * interpreter. */ @@ -417,31 +567,28 @@ Tcl_CreateInterp() statsPtr->numExecutions = 0; statsPtr->numCompilations = 0; statsPtr->numByteCodesFreed = 0; - (VOID *) memset(statsPtr->instructionCount, 0, + (void) memset(statsPtr->instructionCount, 0, sizeof(statsPtr->instructionCount)); statsPtr->totalSrcBytes = 0.0; statsPtr->totalByteCodeBytes = 0.0; statsPtr->currentSrcBytes = 0.0; statsPtr->currentByteCodeBytes = 0.0; - (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); - (VOID *) memset(statsPtr->byteCodeCount, 0, - sizeof(statsPtr->byteCodeCount)); - (VOID *) memset(statsPtr->lifetimeCount, 0, - sizeof(statsPtr->lifetimeCount)); - - statsPtr->currentInstBytes = 0.0; - statsPtr->currentLitBytes = 0.0; + (void) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); + (void) memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount)); + (void) memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount)); + + statsPtr->currentInstBytes = 0.0; + statsPtr->currentLitBytes = 0.0; statsPtr->currentExceptBytes = 0.0; - statsPtr->currentAuxBytes = 0.0; + statsPtr->currentAuxBytes = 0.0; statsPtr->currentCmdMapBytes = 0.0; - - statsPtr->numLiteralsCreated = 0; - statsPtr->totalLitStringBytes = 0.0; + + statsPtr->numLiteralsCreated = 0; + statsPtr->totalLitStringBytes = 0.0; statsPtr->currentLitStringBytes = 0.0; - (VOID *) memset(statsPtr->literalCount, 0, - sizeof(statsPtr->literalCount)); -#endif /* TCL_COMPILE_STATS */ + (void) memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); +#endif /* TCL_COMPILE_STATS */ /* * Initialise the stub table pointer. @@ -449,54 +596,74 @@ Tcl_CreateInterp() iPtr->stubTable = &tclStubs; - + /* + * Initialize the ensemble error message rewriting support. + */ + + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + + /* + * TIP#143: Initialise the resource limit support. + */ + + TclInitLimitSupport(interp); + + /* + * Initialise the thread-specific data ekeko. + */ + +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + iPtr->allocCache = TclpGetAllocCache(); +#else + iPtr->allocCache = NULL; +#endif + iPtr->pendingObjDataPtr = NULL; + iPtr->asyncReadyPtr = TclGetAsyncReadyPtr(); + + /* + * Insure that the stack checking mechanism for this interp is + * initialized. + */ + + GetCStackParams(iPtr); + /* * 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. - */ - - for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; - cmdInfoPtr++) { - int new; + * 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 function that + * extracts strings, calls the string function, 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++) { + int isNew; Tcl_HashEntry *hPtr; - if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) - && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) - && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { - panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n"); + if ((cmdInfoPtr->objProc == NULL) + && (cmdInfoPtr->compileProc == NULL)) { + Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc"); } - + hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, - cmdInfoPtr->name, &new); - if (new) { + cmdInfoPtr->name, &isNew); + if (isNew) { cmdPtr = (Command *) ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = cmdInfoPtr->compileProc; - if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) { - cmdPtr->proc = TclInvokeObjectCommand; - cmdPtr->clientData = (ClientData) cmdPtr; - } else { - cmdPtr->proc = cmdInfoPtr->proc; - cmdPtr->clientData = (ClientData) NULL; - } - if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { - cmdPtr->objProc = TclInvokeStringCommand; - cmdPtr->objClientData = (ClientData) cmdPtr; - } else { - cmdPtr->objProc = cmdInfoPtr->objProc; - cmdPtr->objClientData = (ClientData) NULL; - } + cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->clientData = cmdPtr; + cmdPtr->objProc = cmdInfoPtr->objProc; + cmdPtr->objClientData = NULL; cmdPtr->deleteProc = NULL; - cmdPtr->deleteData = (ClientData) NULL; + cmdPtr->deleteData = NULL; cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; @@ -504,6 +671,44 @@ Tcl_CreateInterp() } } + /* + * Create the "chan", "dict", "info" and "string" ensembles. Note that all + * these commands (and their subcommands that are not present in the + * global namespace) are wholly safe. + */ + + TclInitChanCmd(interp); + TclInitDictCmd(interp); + TclInitInfoCmd(interp); + TclInitStringCmd(interp); + + /* + * Register "clock" subcommands. These *do* go through + * Tcl_CreateObjCommand, since they aren't in the global namespace and + * involve ensembles. + */ + + TclClockInit(interp); + + /* + * Register the built-in functions. This is empty now that they are + * implemented as commands in the ::tcl::mathfunc namespace. + */ + + /* + * Register the default [interp bgerror] handler. + */ + + Tcl_CreateObjCommand(interp, "::tcl::Bgerror", + TclDefaultBgErrorHandlerObjCmd, NULL, NULL); + + /* + * Create an unsupported command for debugging bytecode. + */ + + Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", + Tcl_DisassembleObjCmd, NULL, NULL); + #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -516,57 +721,61 @@ Tcl_CreateInterp() * Register the builtin math functions. */ - i = 0; - for (builtinFuncPtr = tclBuiltinFuncTable; builtinFuncPtr->name != NULL; + mathfuncNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL); + if (mathfuncNSPtr == NULL) { + Tcl_Panic("Can't create math function namespace"); + } + strcpy(mathFuncName, "::tcl::mathfunc::"); +#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */ + for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL; builtinFuncPtr++) { - Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name, - builtinFuncPtr->numArgs, builtinFuncPtr->argTypes, - (Tcl_MathProc *) NULL, (ClientData) 0); - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, - builtinFuncPtr->name); - if (hPtr == NULL) { - panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name); - return NULL; + strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name); + Tcl_CreateObjCommand(interp, mathFuncName, + builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL); + Tcl_Export(interp, mathfuncNSPtr, builtinFuncPtr->name, 0); + } + + /* + * Register the mathematical "operator" commands. [TIP #174] + */ + + mathopNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL); +#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ + if (mathopNSPtr == NULL) { + Tcl_Panic("can't create math operator namespace"); + } + (void) Tcl_Export(interp, mathopNSPtr, "*", 1); + strcpy(mathFuncName, "::tcl::mathop::"); + for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){ + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *) + ckalloc(sizeof(TclOpCmdClientData)); + + occdPtr->op = opcmdInfoPtr->name; + occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs; + occdPtr->expected = opcmdInfoPtr->expected; + strcpy(mathFuncName + MATH_OP_PREFIX_LEN, opcmdInfoPtr->name); + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, mathFuncName, + opcmdInfoPtr->objProc, occdPtr, DeleteOpCmdClientData); + if (cmdPtr == NULL) { + Tcl_Panic("failed to create math operator %s", + opcmdInfoPtr->name); + } else if (opcmdInfoPtr->compileProc != NULL) { + cmdPtr->compileProc = opcmdInfoPtr->compileProc; } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - mathFuncPtr->builtinFuncIndex = i; - i++; } - iPtr->flags |= EXPR_INITIALIZED; /* * Do Multiple/Safe Interps Tcl init stuff */ TclInterpInit(interp); + TclSetupEnv(interp); /* - * We used to create the "errorInfo" and "errorCode" global vars at this - * point because so much of the Tcl implementation assumes they already - * exist. This is not quite enough, however, since they can be unset - * at any time. - * - * There are 2 choices: - * + Check every place where a GetVar of those is used - * and the NULL result is not checked (like in tclLoad.c) - * + Make SetVar,... NULL friendly - * We choose the second option because : - * + It is easy and low cost to check for NULL pointer before - * calling strlen() - * + It can be helpfull to other people using those API - * + Passing a NULL value to those closest 'meaning' is empty string - * (specially with the new objects where 0 bytes strings are ok) - * So the following init is commented out: -- dl - * - * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, - * "", TCL_GLOBAL_ONLY); - * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, - * "NONE", TCL_GLOBAL_ONLY); + * TIP #59: Make embedded configuration information available. */ -#ifndef TCL_GENERIC_ONLY - TclSetupEnv(interp); -#endif + TclInitEmbeddedConfigurationInformation(interp); /* * Compute the byte order of this machine. @@ -580,62 +789,66 @@ Tcl_CreateInterp() Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize", Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY); + /* TIP #291 */ + Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize", + Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY); + /* * Set up other variables such as tcl_version and tcl_library */ Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL, + Tcl_TraceVar2(interp, "tcl_precision", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - TclPrecTraceProc, (ClientData) NULL); + TclPrecTraceProc, NULL); TclpSetVariables(interp); #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 /* * Register Tcl's version number. - * TIP#268: Expose information about its status, - * for runtime switches in the core library - * and tests. + * TIP #268: Full patchlevel instead of just major.minor */ - Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); + Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); -#ifdef TCL_TIP268 - Tcl_SetVar2(interp, "tcl_platform", "tip,268", "1", - TCL_GLOBAL_ONLY); -#endif -#ifdef TCL_TIP280 - Tcl_SetVar2(interp, "tcl_platform", "tip,280", "1", - TCL_GLOBAL_ONLY); -#endif #ifdef Tcl_InitStubs #undef Tcl_InitStubs #endif Tcl_InitStubs(interp, TCL_VERSION, 1); + if (TclTommath_Init(interp) != TCL_OK) { + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + } + return interp; } + +static void +DeleteOpCmdClientData( + ClientData clientData) +{ + TclOpCmdClientData *occdPtr = clientData; + + ckfree((char *) occdPtr); +} /* *---------------------------------------------------------------------- * * 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. @@ -647,18 +860,18 @@ Tcl_CreateInterp() */ int -TclHideUnsafeCommands(interp) - Tcl_Interp *interp; /* Hide commands in this interpreter. */ +TclHideUnsafeCommands( + Tcl_Interp *interp) /* Hide commands in this interpreter. */ { - register CONST CmdInfo *cmdInfoPtr; + register const CmdInfo *cmdInfoPtr; - if (interp == (Tcl_Interp *) NULL) { - return TCL_ERROR; + if (interp == NULL) { + return TCL_ERROR; } for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { - if (!cmdInfoPtr->isSafe) { - Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); - } + if (!cmdInfoPtr->isSafe) { + Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); + } } return TCL_OK; } @@ -668,36 +881,34 @@ 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 + * Arrange for a function to be called before a given interpreter is + * deleted. The function is called as soon as Tcl_DeleteInterp is called; + * if Tcl_CallWhenDeleted is called on an interpreter that has already + * been deleted, the function 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. * *-------------------------------------------------------------- */ 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. */ - ClientData clientData; /* One-word value to pass to proc. */ +Tcl_CallWhenDeleted( + Tcl_Interp *interp, /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about + * to be deleted. */ + ClientData clientData) /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; static Tcl_ThreadDataKey assocDataCounterKey; int *assocDataCounterPtr = Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); - int new; + int isNew; char buffer[32 + TCL_INTEGER_SPACE]; AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; @@ -705,11 +916,11 @@ Tcl_CallWhenDeleted(interp, proc, clientData) sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr); (*assocDataCounterPtr)++; - if (iPtr->assocData == (Tcl_HashTable *) NULL) { - iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + if (iPtr->assocData == NULL) { + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } - hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); + hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew); dPtr->proc = proc; dPtr->clientData = clientData; Tcl_SetHashValue(hPtr, dPtr); @@ -720,27 +931,26 @@ 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 function 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. * *-------------------------------------------------------------- */ 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. */ - ClientData clientData; /* One-word value to pass to proc. */ +Tcl_DontCallWhenDeleted( + Tcl_Interp *interp, /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about + * to be deleted. */ + ClientData clientData) /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTablePtr; @@ -749,17 +959,17 @@ Tcl_DontCallWhenDeleted(interp, proc, clientData) AssocData *dPtr; hTablePtr = iPtr->assocData; - if (hTablePtr == (Tcl_HashTable *) NULL) { - return; + if (hTablePtr == NULL) { + return; } for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); - if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { - ckfree((char *) dPtr); - Tcl_DeleteHashEntry(hPtr); - return; - } + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); + return; + } } } @@ -769,9 +979,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. @@ -783,27 +993,27 @@ Tcl_DontCallWhenDeleted(interp, proc, clientData) */ 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. */ - ClientData clientData; /* One-word value to pass to proc. */ +Tcl_SetAssocData( + 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. */ + ClientData clientData) /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; - int new; + int isNew; - if (iPtr->assocData == (Tcl_HashTable *) NULL) { - iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + if (iPtr->assocData == NULL) { + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } - hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); - if (new == 0) { - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew); + if (isNew == 0) { + dPtr = Tcl_GetHashValue(hPtr); } else { - dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + dPtr = (AssocData *) ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; @@ -816,8 +1026,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. @@ -829,24 +1039,24 @@ 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_DeleteAssocData( + Tcl_Interp *interp, /* Interpreter to associate with. */ + const char *name) /* Name of association. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; - if (iPtr->assocData == (Tcl_HashTable *) NULL) { - return; + if (iPtr->assocData == NULL) { + return; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); - if (hPtr == (Tcl_HashEntry *) NULL) { - return; + if (hPtr == NULL) { + return; } - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + dPtr = Tcl_GetHashValue(hPtr); if (dPtr->proc != NULL) { - (dPtr->proc) (dPtr->clientData, interp); + dPtr->proc(dPtr->clientData, interp); } ckfree((char *) dPtr); Tcl_DeleteHashEntry(hPtr); @@ -857,8 +1067,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 @@ -871,26 +1081,27 @@ 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_GetAssocData( + 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; Tcl_HashEntry *hPtr; - if (iPtr->assocData == (Tcl_HashTable *) NULL) { - return (ClientData) NULL; + if (iPtr->assocData == NULL) { + return NULL; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); - if (hPtr == (Tcl_HashEntry *) NULL) { - return (ClientData) NULL; + if (hPtr == NULL) { + return NULL; } - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); - if (procPtr != (Tcl_InterpDeleteProc **) NULL) { - *procPtr = dPtr->proc; + dPtr = Tcl_GetHashValue(hPtr); + if (procPtr != NULL) { + *procPtr = dPtr->proc; } return dPtr->clientData; } @@ -900,8 +1111,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. @@ -913,8 +1124,8 @@ Tcl_GetAssocData(interp, name, procPtr) */ int -Tcl_InterpDeleted(interp) - Tcl_Interp *interp; +Tcl_InterpDeleted( + Tcl_Interp *interp) { return (((Interp *) interp)->flags & DELETED) ? 1 : 0; } @@ -924,11 +1135,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 + * function runs the currently registered deletion callbacks. * * Results: * None. @@ -943,9 +1154,9 @@ Tcl_InterpDeleted(interp) */ void -Tcl_DeleteInterp(interp) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by a previous call to Tcl_CreateInterp). */ +Tcl_DeleteInterp( + Tcl_Interp *interp) /* Token for command interpreter (returned by + * a previous call to Tcl_CreateInterp). */ { Interp *iPtr = (Interp *) interp; @@ -954,21 +1165,22 @@ Tcl_DeleteInterp(interp) */ if (iPtr->flags & DELETED) { - return; + return; } - + /* * Mark the interpreter as deleted. No further evals will be allowed. + * Increase the compileEpoch as a signal to compiled bytecodes. */ iPtr->flags |= DELETED; + iPtr->compileEpoch++; /* * Ensure that the interpreter is eventually deleted. */ - Tcl_EventuallyFree((ClientData) interp, - (Tcl_FreeProc *) DeleteInterpProc); + Tcl_EventuallyFree(interp, (Tcl_FreeProc *) DeleteInterpProc); } /* @@ -976,25 +1188,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 function to delete an interpreter. This function is called when + * the last call to Tcl_Preserve on this interpreter is matched by a call + * to Tcl_Release. The function 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. */ +DeleteInterpProc( + Tcl_Interp *interp) /* Interpreter to delete. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; @@ -1005,120 +1217,137 @@ DeleteInterpProc(interp) /* * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. */ - + if (iPtr->numLevels > 0) { - panic("DeleteInterpProc called with active evals"); + Tcl_Panic("DeleteInterpProc called with active evals"); } /* - * 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)) { - panic("DeleteInterpProc called on interpreter not marked deleted"); + Tcl_Panic("DeleteInterpProc called on interpreter not marked deleted"); } - TclHandleFree(iPtr->handle); + /* + * TIP #219, Tcl Channel Reflection API. Discard a leftover state. + */ + + if (iPtr->chanMsg != NULL) { + Tcl_DecrRefCount(iPtr->chanMsg); + iPtr->chanMsg = NULL; + } + + /* + * Shut down all limit handler callback scripts that call back into this + * interpreter. Then eliminate all limit handlers for this interpreter. + */ + + TclRemoveScriptLimitCallbacks(interp); + TclLimitRemoveAllHandlers(interp); /* - * Dismantle everything in the global namespace except for the - * "errorInfo" and "errorCode" variables. These remain until the - * namespace is actually destroyed, in case any errors occur. - * * Dismantle the namespace here, before we clear the assocData. If any * background errors occur here, they will be deleted below. + * + * Dismantle the namespace after freeing the iPtr->handle so that each + * bytecode releases its literals without caring to update the literal + * table, as it will be freed later in this function without further use. */ - + + TclHandleFree(iPtr->handle); TclTeardownNamespace(iPtr->globalNsPtr); /* * Delete all the hidden commands. */ - + 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. */ - + hPtr = Tcl_FirstHashEntry(hTablePtr, &search); - for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_DeleteCommandFromToken(interp, (Tcl_Command) Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); ckfree((char *) hTablePtr); } + /* - * Tear down the math function table. + * Invoke deletion callbacks; note that a callback can create new + * callbacks, so we iterate. */ - for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - ckfree((char *) Tcl_GetHashValue(hPtr)); + while (iPtr->assocData != NULL) { + AssocData *dPtr; + + hTablePtr = iPtr->assocData; + iPtr->assocData = NULL; + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { + dPtr = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (dPtr->proc != NULL) { + dPtr->proc(dPtr->clientData, interp); + } + ckfree((char *) dPtr); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree((char *) hTablePtr); } - Tcl_DeleteHashTable(&iPtr->mathFuncTable); /* - * Invoke deletion callbacks; note that a callback can create new - * callbacks, so we iterate. + * Pop the root frame pointer and finish deleting the global + * namespace. The order is important [Bug 1658572]. */ - while (iPtr->assocData != (Tcl_HashTable *) NULL) { - AssocData *dPtr; - - hTablePtr = iPtr->assocData; - iPtr->assocData = (Tcl_HashTable *) NULL; - for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); - if (dPtr->proc != NULL) { - (*dPtr->proc)(dPtr->clientData, interp); - } - ckfree((char *) dPtr); - } - Tcl_DeleteHashTable(hTablePtr); - ckfree((char *) hTablePtr); - } - - /* - * Finish deleting the global namespace. - */ - + if (iPtr->framePtr != iPtr->rootFramePtr) { + Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); + } + Tcl_PopCallFrame(interp); + ckfree((char *) iPtr->rootFramePtr); + iPtr->rootFramePtr = NULL; 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); interp->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; - if (iPtr->errorInfo != NULL) { - ckfree(iPtr->errorInfo); - iPtr->errorInfo = NULL; + Tcl_DecrRefCount(iPtr->ecVar); + if (iPtr->errorCode) { + Tcl_DecrRefCount(iPtr->errorCode); + iPtr->errorCode = NULL; } - if (iPtr->errorCode != NULL) { - ckfree(iPtr->errorCode); - iPtr->errorCode = NULL; + Tcl_DecrRefCount(iPtr->eiVar); + if (iPtr->errorInfo) { + Tcl_DecrRefCount(iPtr->errorInfo); + iPtr->errorInfo = NULL; + } + if (iPtr->returnOpts) { + Tcl_DecrRefCount(iPtr->returnOpts); } if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; + iPtr->appendResult = NULL; } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { - Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr); + Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); } if (iPtr->execEnvPtr != NULL) { TclDeleteExecEnv(iPtr->execEnvPtr); @@ -1135,9 +1364,9 @@ DeleteInterpProc(interp) nextResPtr = resPtr->nextPtr; ckfree(resPtr->name); ckfree((char *) resPtr); - resPtr = nextResPtr; + resPtr = nextResPtr; } - + /* * Free up literal objects created for scripts compiled by the * interpreter. @@ -1145,60 +1374,62 @@ DeleteInterpProc(interp) TclDeleteLiteralTable(interp, &(iPtr->literalTable)); -#ifdef TCL_TIP280 - /* TIP #280 - Release the arrays for ByteCode/Proc extension, and contents. + /* + * TIP #280 - Release the arrays for ByteCode/Proc extension, and + * contents. */ + { - Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; - CmdFrame* cfPtr; - ExtCmdLoc* eclPtr; - int i; + int i; for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - - cfPtr = (CmdFrame*) Tcl_GetHashValue (hPtr); - - if (cfPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount (cfPtr->data.eval.path); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + CmdFrame *cfPtr = Tcl_GetHashValue(hPtr); + Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr); + procPtr->iPtr = NULL; + if (cfPtr) { + if (cfPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(cfPtr->data.eval.path); + } + ckfree((char *) cfPtr->line); + ckfree((char *) cfPtr); } - ckfree ((char*) cfPtr->line); - ckfree ((char*) cfPtr); - Tcl_DeleteHashEntry (hPtr); - + Tcl_DeleteHashEntry(hPtr); } - Tcl_DeleteHashTable (iPtr->linePBodyPtr); - ckfree ((char*) iPtr->linePBodyPtr); + Tcl_DeleteHashTable(iPtr->linePBodyPtr); + ckfree((char *) iPtr->linePBodyPtr); iPtr->linePBodyPtr = NULL; - /* See also tclCompile.c, TclCleanupByteCode */ + /* + * See also tclCompile.c, TclCleanupByteCode + */ for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - - eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hPtr); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + ExtCmdLoc *eclPtr = (ExtCmdLoc *) Tcl_GetHashValue(hPtr); if (eclPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount (eclPtr->path); + Tcl_DecrRefCount(eclPtr->path); } for (i=0; i< eclPtr->nuloc; i++) { - ckfree ((char*) eclPtr->loc[i].line); + ckfree((char *) eclPtr->loc[i].line); } - if (eclPtr->loc != NULL) { - ckfree ((char*) eclPtr->loc); + if (eclPtr->loc != NULL) { + ckfree((char *) eclPtr->loc); } Tcl_DeleteHashTable (&eclPtr->litInfo); - ckfree ((char*) eclPtr); - Tcl_DeleteHashEntry (hPtr); + ckfree((char *) eclPtr); + Tcl_DeleteHashEntry(hPtr); } - Tcl_DeleteHashTable (iPtr->lineBCPtr); - ckfree((char*) iPtr->lineBCPtr); + Tcl_DeleteHashTable(iPtr->lineBCPtr); + ckfree((char *) iPtr->lineBCPtr); iPtr->lineBCPtr = NULL; /* @@ -1234,7 +1465,10 @@ DeleteInterpProc(interp) ckfree((char*) iPtr->lineLABCPtr); iPtr->lineLABCPtr = NULL; } -#endif + + Tcl_DeleteHashTable(&iPtr->varTraces); + Tcl_DeleteHashTable(&iPtr->varSearches); + ckfree((char *) iPtr); } @@ -1243,79 +1477,77 @@ 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. * *--------------------------------------------------------------------------- */ int -Tcl_HideCommand(interp, cmdName, hiddenCmdToken) - Tcl_Interp *interp; /* Interpreter in which to hide command. */ - CONST char *cmdName; /* Name of command to hide. */ - CONST char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ +Tcl_HideCommand( + Tcl_Interp *interp, /* Interpreter in which to hide command. */ + const char *cmdName, /* Name of command to hide. */ + const char *hiddenCmdToken) /* Token name of the to-be-hidden command. */ { Interp *iPtr = (Interp *) interp; Tcl_Command cmd; Command *cmdPtr; Tcl_HashTable *hiddenCmdTablePtr; Tcl_HashEntry *hPtr; - int new; + int isNew; 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; + return TCL_ERROR; } /* * 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 + * hiddenCmdToken is just a string which is not interpreted in any way. It + * may contain :: but the string is not interpreted as a namespace * qualifier command name. Thus, hiding foo::bar to foo::bar and then * trying to expose or invoke ::foo::bar will NOT work; but if the * 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) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "cannot use namespace qualifiers in hidden command", - " token (rename)", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, + "cannot use namespace qualifiers in hidden command" + " token (rename)", NULL); + return TCL_ERROR; } /* - * 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, + cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); if (cmd == (Tcl_Command) NULL) { return TCL_ERROR; @@ -1326,22 +1558,21 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * Check that the command is really in global namespace */ - if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can only hide global namespace commands", - " (use rename then hide)", (char *) NULL); - return TCL_ERROR; + if (cmdPtr->nsPtr != iPtr->globalNsPtr) { + Tcl_AppendResult(interp, "can only hide global namespace commands" + " (use rename then hide)", NULL); + return TCL_ERROR; } - + /* * Initialize the hidden command table if necessary. */ hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr == NULL) { - hiddenCmdTablePtr = (Tcl_HashTable *) - ckalloc((unsigned) sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); + hiddenCmdTablePtr = (Tcl_HashTable *) + ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } @@ -1350,20 +1581,18 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * hiddenCmdToken if a hidden command with the name hiddenCmdToken already * exists. */ - - hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new); - if (!new) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "hidden command named \"", hiddenCmdToken, "\" already exists", - (char *) NULL); - return TCL_ERROR; + + hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew); + if (!isNew) { + Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken, + "\" already exists", NULL); + return TCL_ERROR; } /* - * 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. + * 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 until + * the common parts are actually factorized out. */ /* @@ -1373,26 +1602,34 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) */ if (cmdPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = (Tcl_HashEntry *) NULL; + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; cmdPtr->cmdEpoch++; } /* - * Now link the hash table entry with the command structure. - * We ensured above that the nsPtr was right. + * 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. + */ + cmdPtr->hPtr = hPtr; - Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); + Tcl_SetHashValue(hPtr, cmdPtr); /* - * 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. + * If the command being hidden has a compile function, 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. */ if (cmdPtr->compileProc != NULL) { @@ -1406,12 +1643,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. @@ -1420,40 +1657,38 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) */ int -Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) - Tcl_Interp *interp; /* Interpreter in which to make command - * callable. */ - CONST char *hiddenCmdToken; /* Name of hidden command. */ - CONST char *cmdName; /* Name of to-be-exposed command. */ +Tcl_ExposeCommand( + Tcl_Interp *interp, /* Interpreter in which to make command + * callable. */ + const char *hiddenCmdToken, /* Name of hidden command. */ + const char *cmdName) /* Name of to-be-exposed command. */ { Interp *iPtr = (Interp *) interp; Command *cmdPtr; Namespace *nsPtr; Tcl_HashEntry *hPtr; Tcl_HashTable *hiddenCmdTablePtr; - int new; + int isNew; if (iPtr->flags & DELETED) { - /* - * The interpreter is being deleted. Do not create any new - * structures, because it is not safe to modify the interpreter. - */ - - return TCL_ERROR; + /* + * 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) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can not expose to a namespace ", - "(use expose to toplevel, then rename)", - (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "cannot expose to a namespace " + "(use expose to toplevel, then rename)", NULL); + return TCL_ERROR; } /* @@ -1465,82 +1700,90 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) if (hiddenCmdTablePtr != NULL) { hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); } - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown hidden command \"", hiddenCmdToken, - "\"", (char *) NULL); - return TCL_ERROR; + if (hPtr == NULL) { + Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken, + "\"", NULL); + return TCL_ERROR; } - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - + cmdPtr = 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 panic() than 'nicely' erroring out ? + + if (cmdPtr->nsPtr != iPtr->globalNsPtr) { + /* + * This case is theoritically impossible, we might rather Tcl_Panic() + * than 'nicely' erroring out ? */ - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "trying to expose a non global command name space command", - (char *) NULL); - return TCL_ERROR; + + Tcl_AppendResult(interp, + "trying to expose a non global command name space command", + NULL); + return TCL_ERROR; } - - /* This is the global table */ + + /* + * This is the global table. + */ + 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); - if (!new) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "exposed command \"", cmdName, - "\" already exists", (char *) NULL); - return TCL_ERROR; + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); + if (!isNew) { + Tcl_AppendResult(interp, "exposed command \"", cmdName, + "\" already exists", NULL); + return TCL_ERROR; } /* + * 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); + + /* * Remove the hash entry for the command from the interpreter hidden * command table. */ if (cmdPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = NULL; + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; } /* - * 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; - Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); + Tcl_SetHashValue(hPtr, 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 + * If the command being exposed has a compile function, 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 * recompiled. */ @@ -1558,94 +1801,103 @@ 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. */ - CONST char *cmdName; /* Name of command. If it contains namespace +Tcl_CreateCommand( + 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. */ - 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. */ + * specified namespace; otherwise it is put in + * the global namespace. */ + Tcl_CmdProc *proc, /* Function to associate with cmdName. */ + ClientData clientData, /* Arbitrary value passed to string proc. */ + Tcl_CmdDeleteProc *deleteProc) + /* If not NULL, gives a function to call when + * this command is deleted. */ { Interp *iPtr = (Interp *) interp; ImportRef *oldRefPtr = NULL; Namespace *nsPtr, *dummy1, *dummy2; Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; - CONST char *tail; - int new; + const char *tail; + int isNew; ImportedCmdData *dataPtr; 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) { - TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, - CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((nsPtr == NULL) || (tail == NULL)) { + TclGetNamespaceForQualName(interp, cmdName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { nsPtr = iPtr->globalNsPtr; tail = cmdName; } - - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); - if (!new) { + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + if (!isNew) { /* - * 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); + cmdPtr = Tcl_GetHashValue(hPtr); oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); - if (!new) { + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + if (!isNew) { /* - * 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)); + 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. + */ + + TclInvalidateNsCmdLookup(nsPtr); + TclInvalidateNsPath(nsPtr); } cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); @@ -1653,9 +1905,9 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; - cmdPtr->compileProc = (CompileProc *) NULL; + cmdPtr->compileProc = NULL; cmdPtr->objProc = TclInvokeStringCommand; - cmdPtr->objClientData = (ClientData) cmdPtr; + cmdPtr->objClientData = cmdPtr; cmdPtr->proc = proc; cmdPtr->clientData = clientData; cmdPtr->deleteProc = deleteProc; @@ -1665,15 +1917,15 @@ 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) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { refCmdPtr = oldRefPtr->importedCmdPtr; - dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; + dataPtr = refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } @@ -1685,7 +1937,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) * shadowed commands are found, invalidate all cached command references * in the affected namespaces. */ - + TclResetShadowedCmdRefs(interp, cmdPtr); return (Tcl_Command) cmdPtr; } @@ -1698,70 +1950,70 @@ 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). */ - CONST char *cmdName; /* Name of command. If it contains namespace +Tcl_CreateObjCommand( + 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. */ - Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with + * specified namespace; otherwise it is put in + * the global namespace. */ + Tcl_ObjCmdProc *proc, /* Object-based function 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. */ + ClientData clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc) + /* If not NULL, gives a function to call when + * this command is deleted. */ { Interp *iPtr = (Interp *) interp; ImportRef *oldRefPtr = NULL; Namespace *nsPtr, *dummy1, *dummy2; Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; - CONST char *tail; - int new; + const char *tail; + int isNew; ImportedCmdData *dataPtr; 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) { - TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, - CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((nsPtr == NULL) || (tail == NULL)) { + TclGetNamespaceForQualName(interp, cmdName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { @@ -1769,45 +2021,54 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) tail = cmdName; } - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); - if (!new) { - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + TclInvalidateNsPath(nsPtr); + if (!isNew) { + cmdPtr = Tcl_GetHashValue(hPtr); /* * 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) { cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; - cmdPtr->deleteProc = deleteProc; - cmdPtr->deleteData = clientData; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; return (Tcl_Command) cmdPtr; } /* - * 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; cmdPtr->importRefPtr = NULL; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); - if (!new) { + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + if (!isNew) { /* - * 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)); + ckfree(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. + */ + + TclInvalidateNsCmdLookup(nsPtr); } cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); @@ -1815,11 +2076,11 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; - cmdPtr->compileProc = (CompileProc *) NULL; + cmdPtr->compileProc = NULL; cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; cmdPtr->proc = TclInvokeObjectCommand; - cmdPtr->clientData = (ClientData) cmdPtr; + cmdPtr->clientData = cmdPtr; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; cmdPtr->flags = 0; @@ -1827,27 +2088,27 @@ 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) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { refCmdPtr = oldRefPtr->importedCmdPtr; - dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; + dataPtr = refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } } - + /* * We just created a command, so in its namespace and all of its parent * namespaces, it may shadow global commands with the same name. If any * shadowed commands are found, invalidate all cached command references * in the affected namespaces. */ - + TclResetShadowedCmdRefs(interp, cmdPtr); return (Tcl_Command) cmdPtr; } @@ -1858,10 +2119,10 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) * TclInvokeStringCommand -- * * "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. + * Tcl_CmdProc if no object-based function exists for a command. A + * pointer to this function 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. @@ -1874,35 +2135,16 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) */ int -TclInvokeStringCommand(clientData, interp, objc, objv) - ClientData clientData; /* Points to command's Command structure. */ - Tcl_Interp *interp; /* Current interpreter. */ - register int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +TclInvokeStringCommand( + ClientData clientData, /* Points to command's Command structure. */ + Tcl_Interp *interp, /* Current interpreter. */ + register int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - register Command *cmdPtr = (Command *) clientData; - register int i; - int result; - - /* - * This procedure generates an argv array for the string arguments. It - * starts out with stack-allocated space but uses dynamically-allocated - * storage if needed. - */ - -#define NUM_ARGS 20 - CONST char *(argStorage[NUM_ARGS]); - 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. - */ - - if ((objc + 1) > NUM_ARGS) { - argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); - } + Command *cmdPtr = clientData; + int i, result; + const char **argv = (const char **) + TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); @@ -1915,15 +2157,8 @@ TclInvokeStringCommand(clientData, interp, objc, objv) result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); - /* - * Free the argv array if malloc'ed storage was used. - */ - - if (argv != argStorage) { - ckfree((char *) argv); - } + TclStackFree(interp, (void *) argv); return result; -#undef NUM_ARGS } /* @@ -1932,10 +2167,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 function exists for a command. A + * pointer to this function 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. @@ -1948,42 +2183,21 @@ TclInvokeStringCommand(clientData, interp, objc, objv) */ int -TclInvokeObjectCommand(clientData, interp, argc, argv) - ClientData clientData; /* Points to command's Command structure. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - register CONST char **argv; /* Argument strings. */ +TclInvokeObjectCommand( + ClientData clientData, /* Points to command's Command structure. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + register const char **argv) /* Argument strings. */ { Command *cmdPtr = (Command *) clientData; - register Tcl_Obj *objPtr; - register int i; - int length, result; - - /* - * This procedure generates an objv array for object arguments that hold - * the argv strings. It starts out with stack-allocated space but uses - * dynamically-allocated storage if needed. - */ - -#define NUM_ARGS 20 - Tcl_Obj *(argStorage[NUM_ARGS]); - 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. - */ - - if (argc > NUM_ARGS) { - objv = (Tcl_Obj **) - ckalloc((unsigned)(argc * sizeof(Tcl_Obj *))); - } + Tcl_Obj *objPtr; + int i, length, result; + Tcl_Obj **objv = (Tcl_Obj **) + TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *))); for (i = 0; i < argc; i++) { length = strlen(argv[i]); - TclNewObj(objPtr); - TclInitStringRep(objPtr, argv[i], length); + TclNewStringObj(objPtr, argv[i], length); Tcl_IncrRefCount(objPtr); objv[i] = objPtr; } @@ -1995,27 +2209,23 @@ 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. */ - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); - + (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++) { objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } - if (objv != argStorage) { - ckfree((char *) objv); - } + TclStackFree(interp, objv); return result; -#undef NUM_ARGS } /* @@ -2023,65 +2233,64 @@ 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. + * If the new command name is NULL or the null string, the command is + * deleted. * * Results: - * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * If anything goes wrong, an error message is returned in the - * interpreter's result object. + * If anything goes wrong, an error message is returned in the + * interpreter's result object. * *---------------------------------------------------------------------- */ int -TclRenameCommand(interp, oldName, newName) - Tcl_Interp *interp; /* Current interpreter. */ - char *oldName; /* Existing command name. */ - char *newName; /* New command name. */ +TclRenameCommand( + Tcl_Interp *interp, /* Current interpreter. */ + const char *oldName, /* Existing command name. */ + const char *newName) /* New command name. */ { Interp *iPtr = (Interp *) interp; - CONST char *newTail; + const char *newTail; Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; Tcl_Command cmd; Command *cmdPtr; Tcl_HashEntry *hPtr, *oldHPtr; - int new, result; - Tcl_Obj* oldFullName; + int isNew, result; + Tcl_Obj *oldFullName; 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, - /*flags*/ 0); + cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ", - ((newName == NULL)||(*newName == '\0'))? "delete":"rename", - " \"", oldName, "\": command doesn't exist", (char *) NULL); + Tcl_AppendResult(interp, "can't ", + ((newName == NULL)||(*newName == '\0'))? "delete":"rename", + " \"", oldName, "\": command doesn't exist", NULL); return TCL_ERROR; } cmdNsPtr = cmdPtr->nsPtr; oldFullName = Tcl_NewObj(); - Tcl_IncrRefCount( oldFullName ); - Tcl_GetCommandFullName( interp, cmd, oldFullName ); + Tcl_IncrRefCount(oldFullName); + Tcl_GetCommandFullName(interp, cmd, oldFullName); /* * If the new command name is NULL or empty, delete the command. Do this * with Tcl_DeleteCommandFromToken, since we already have the command. */ - + if ((newName == NULL) || (*newName == '\0')) { Tcl_DeleteCommandFromToken(interp, cmd); result = TCL_OK; @@ -2089,101 +2298,106 @@ 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, - CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); + TclGetNamespaceForQualName(interp, newName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); if ((newNsPtr == NULL) || (newTail == NULL)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can't rename to \"", newName, "\": bad command name", - (char *) NULL); + Tcl_AppendResult(interp, "can't rename to \"", newName, + "\": bad command name", NULL); result = TCL_ERROR; goto done; } if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can't rename to \"", newName, - "\": command already exists", (char *) NULL); + Tcl_AppendResult(interp, "can't rename to \"", newName, + "\": command already exists", NULL); result = TCL_ERROR; goto done; } /* - * 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; - hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new); - Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); + hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &isNew); + Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = newNsPtr; 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); if (result != TCL_OK) { - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = oldHPtr; - cmdPtr->nsPtr = cmdNsPtr; + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = oldHPtr; + cmdPtr->nsPtr = cmdNsPtr; goto done; } /* - * 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 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. * - * 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 function needs to get a fully qualified name for old and new + * commands [Tcl bug #651271], or else there's no way for the trace + * function to get the namespace from which the old command is being + * renamed! */ - Tcl_DStringInit( &newFullName ); - Tcl_DStringAppend( &newFullName, newNsPtr->fullName, -1 ); - if ( newNsPtr != iPtr->globalNsPtr ) { - Tcl_DStringAppend( &newFullName, "::", 2 ); + Tcl_DStringInit(&newFullName); + Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1); + if (newNsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&newFullName, "::", 2); } - Tcl_DStringAppend( &newFullName, newTail, -1 ); + Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; - CallCommandTraces( iPtr, cmdPtr, - Tcl_GetString( oldFullName ), - Tcl_DStringValue( &newFullName ), - TCL_TRACE_RENAME); - Tcl_DStringFree( &newFullName ); + CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), + Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); + 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); cmdPtr->cmdEpoch++; /* - * 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. + * If the command being renamed has a compile function, 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. */ if (cmdPtr->compileProc != NULL) { @@ -2191,14 +2405,15 @@ 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); + + TclCleanupCommandMacro(cmdPtr); result = TCL_OK; - done: - TclDecrRefCount( oldFullName ); + done: + TclDecrRefCount(oldFullName); return result; } @@ -2207,16 +2422,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 - * Tcl_RenameCommand to do that. Also, the isNativeObjectProc - * member of *infoPtr is ignored. + * Modifies various information about a Tcl command. Note that this + * function 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. @@ -2225,20 +2439,17 @@ 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_SetCommandInfo( + 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; - cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, - /*flags*/ 0); - - return Tcl_SetCommandInfoFromToken( cmd, infoPtr ); - + cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); + return Tcl_SetCommandInfoFromToken(cmd, infoPtr); } /* @@ -2246,16 +2457,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 - * Tcl_RenameCommand to do that. Also, the isNativeObjectProc - * member of *infoPtr is ignored. + * Modifies various information about a Tcl command. Note that this + * function 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. @@ -2264,11 +2474,11 @@ Tcl_SetCommandInfo(interp, cmdName, infoPtr) */ int -Tcl_SetCommandInfoFromToken( cmd, infoPtr ) - Tcl_Command cmd; - CONST Tcl_CmdInfo* infoPtr; +Tcl_SetCommandInfoFromToken( + Tcl_Command cmd, + const Tcl_CmdInfo *infoPtr) { - Command* cmdPtr; /* Internal representation of the command */ + Command *cmdPtr; /* Internal representation of the command */ if (cmd == (Tcl_Command) NULL) { return 0; @@ -2277,13 +2487,13 @@ Tcl_SetCommandInfoFromToken( cmd, infoPtr ) /* * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. */ - + cmdPtr = (Command *) cmd; cmdPtr->proc = infoPtr->proc; cmdPtr->clientData = infoPtr->clientData; - if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { + if (infoPtr->objProc == NULL) { cmdPtr->objProc = TclInvokeStringCommand; - cmdPtr->objClientData = (ClientData) cmdPtr; + cmdPtr->objClientData = cmdPtr; } else { cmdPtr->objProc = infoPtr->objProc; cmdPtr->objClientData = infoPtr->objClientData; @@ -2301,10 +2511,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. @@ -2313,20 +2522,17 @@ 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_GetCommandInfo( + 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; - cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, - /*flags*/ 0); - - return Tcl_GetCommandInfoFromToken( cmd, infoPtr ); - + cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); + return Tcl_GetCommandInfoFromToken(cmd, infoPtr); } /* @@ -2337,9 +2543,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. @@ -2348,14 +2554,13 @@ Tcl_GetCommandInfo(interp, cmdName, infoPtr) */ int -Tcl_GetCommandInfoFromToken( cmd, infoPtr ) - Tcl_Command cmd; - Tcl_CmdInfo* infoPtr; +Tcl_GetCommandInfoFromToken( + Tcl_Command cmd, + Tcl_CmdInfo *infoPtr) { + Command *cmdPtr; /* Internal representation of the command */ - Command* cmdPtr; /* Internal representation of the command */ - - if ( cmd == (Tcl_Command) NULL ) { + if (cmd == (Tcl_Command) NULL) { return 0; } @@ -2376,7 +2581,6 @@ Tcl_GetCommandInfoFromToken( cmd, infoPtr ) infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; return 1; - } /* @@ -2384,9 +2588,8 @@ 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 function 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. @@ -2397,25 +2600,25 @@ Tcl_GetCommandInfoFromToken( cmd, infoPtr ) *---------------------------------------------------------------------- */ -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. */ +const char * +Tcl_GetCommandName( + 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. */ { 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); } @@ -2424,28 +2627,28 @@ 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 function 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. * *---------------------------------------------------------------------- */ 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. */ - Tcl_Obj *objPtr; /* Points to the object onto which the +Tcl_GetCommandFullName( + 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. */ + Tcl_Obj *objPtr) /* Points to the object onto which the * command's full name is appended. */ { @@ -2468,7 +2671,7 @@ Tcl_GetCommandFullName(interp, command, objPtr) if (cmdPtr->hPtr != NULL) { name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); Tcl_AppendToObj(objPtr, name, -1); - } + } } } @@ -2480,30 +2683,28 @@ 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). */ - CONST char *cmdName; /* Name of command to remove. */ +Tcl_DeleteCommand( + 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; /* - * Find the desired command and delete it. + * Find the desired command and delete it. */ - cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, - /*flags*/ 0); + cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); if (cmd == (Tcl_Command) NULL) { return -1; } @@ -2515,26 +2716,26 @@ 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. + * Removes the given command from the given interpreter. This function + * 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_Command cmd; /* Token for command to delete. */ +Tcl_DeleteCommandFromToken( + 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; Command *cmdPtr = (Command *) cmd; @@ -2542,73 +2743,90 @@ 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. + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + + /* + * 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. + * 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] */ - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = NULL; + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + } 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. - */ - cmdPtr->flags |= CMD_IS_DELETED; - /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. + * 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->cmdEpoch++; + + cmdPtr->flags |= CMD_IS_DELETED; /* - * Call trace procedures for the command being deleted. Then delete - * its traces. + * Call trace functions 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; if ((--tracePtr->refCount) <= 0) { - ckfree((char*)tracePtr); + ckfree((char *) tracePtr); } tracePtr = nextPtr; } cmdPtr->tracePtr = NULL; } - + /* - * 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. + * 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 function, 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. */ if (cmdPtr->compileProc != NULL) { - iPtr->compileEpoch++; + iPtr->compileEpoch++; } if (cmdPtr->deleteProc != NULL) { @@ -2618,15 +2836,15 @@ Tcl_DeleteCommandFromToken(interp, cmd) * data will be a pointer to a ImportedCmdData structure describing * the "real" command that this imported command refers to. */ - + /* * 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); @@ -2639,78 +2857,77 @@ Tcl_DeleteCommandFromToken(interp, cmd) */ for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; - refPtr = nextRefPtr) { + refPtr = nextRefPtr) { nextRefPtr = refPtr->nextPtr; importCmd = (Tcl_Command) refPtr->importedCmdPtr; - Tcl_DeleteCommandFromToken(interp, importCmd); + Tcl_DeleteCommandFromToken(interp, importCmd); } /* - * 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) { Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; } /* * 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); + + TclCleanupCommandMacro(cmdPtr); return 0; } 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. */ +CallCommandTraces( + 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. */ { register CommandTrace *tracePtr; ActiveCommandTrace active; char *result; Tcl_Obj *oldNamePtr = NULL; - int mask = (TCL_TRACE_DELETE | TCL_TRACE_RENAME); /* Safety */ - - flags &= mask; + Tcl_InterpState state = 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; } @@ -2720,7 +2937,7 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) } cmdPtr->flags |= CMD_TRACE_ACTIVE; cmdPtr->refCount++; - + result = NULL; active.nextPtr = iPtr->activeCmdTracePtr; active.reverseScan = 0; @@ -2730,37 +2947,41 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) flags |= TCL_TRACE_DESTROYED; } active.cmdPtr = cmdPtr; - - Tcl_Preserve((ClientData) iPtr); - - for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { - int traceFlags = (tracePtr->flags & mask); + Tcl_Preserve(iPtr); + + for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; - if (!(traceFlags & flags)) { + if (!(tracePtr->flags & flags)) { continue; } - cmdPtr->flags |= traceFlags; + cmdPtr->flags |= tracePtr->flags; if (oldName == NULL) { TclNewObj(oldNamePtr); Tcl_IncrRefCount(oldNamePtr); - Tcl_GetCommandFullName((Tcl_Interp *) iPtr, - (Tcl_Command) cmdPtr, oldNamePtr); + Tcl_GetCommandFullName((Tcl_Interp *) iPtr, + (Tcl_Command) cmdPtr, oldNamePtr); oldName = TclGetString(oldNamePtr); } tracePtr->refCount++; + if (state == NULL) { + state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK); + } (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, oldName, newName, flags); - cmdPtr->flags &= ~traceFlags; + cmdPtr->flags &= ~tracePtr->flags; if ((--tracePtr->refCount) <= 0) { - ckfree((char*)tracePtr); + ckfree((char *) tracePtr); } } + if (state) { + Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state); + } + /* - * 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) { @@ -2768,26 +2989,55 @@ 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; cmdPtr->refCount--; iPtr->activeCmdTracePtr = active.nextPtr; - Tcl_Release((ClientData) iPtr); + Tcl_Release(iPtr); return result; } + +/* + *---------------------------------------------------------------------- + * + * GetCommandSource -- + * + * This function returns a Tcl_Obj with the full source string for the + * command. This insures that traces get a correct NUL-terminated command + * string. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +GetCommandSource( + Interp *iPtr, + const char *command, + int numChars, + int objc, + Tcl_Obj *const objv[]) +{ + if (!command) { + return Tcl_NewListObj(objc, objv); + } + if (command == (char *) -1) { + command = TclGetSrcInfoForCmd(iPtr, &numChars); + } + return Tcl_NewStringObj(command, numChars); +} /* *---------------------------------------------------------------------- * * TclCleanupCommand -- * - * This procedure frees up a Command structure unless it is still + * This function 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. @@ -2801,8 +3051,8 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) */ void -TclCleanupCommand(cmdPtr) - register Command *cmdPtr; /* Points to the Command structure to +TclCleanupCommand( + register Command *cmdPtr) /* Points to the Command structure to * be freed. */ { cmdPtr->refCount--; @@ -2816,18 +3066,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, + * The Tcl 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, * redefioning a non-builtin function will force existing code to be * invalidated if the number of arguments has changed. * @@ -2835,65 +3084,205 @@ 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_CreateMathFunc( + 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, /* C function that implements the math + * function. */ + ClientData clientData) /* Additional value to pass to the + * function. */ { - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int new, i; + Tcl_DString bigName; + OldMathFuncData *data = (OldMathFuncData *) + ckalloc(sizeof(OldMathFuncData)); + + data->proc = proc; + data->numArgs = numArgs; + data->argTypes = (Tcl_ValueType *) + ckalloc(numArgs * sizeof(Tcl_ValueType)); + memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); + data->clientData = clientData; + + Tcl_DStringInit(&bigName); + Tcl_DStringAppend(&bigName, "::tcl::mathfunc::", -1); + Tcl_DStringAppend(&bigName, name, -1); + + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName), + OldMathFuncProc, data, OldMathFuncDeleteProc); + Tcl_DStringFree(&bigName); +} + +/* + *---------------------------------------------------------------------- + * + * OldMathFuncProc -- + * + * Dispatch to a math function created with Tcl_CreateMathFunc + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Whatever the math function does. + * + *---------------------------------------------------------------------- + */ - hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); - if (new) { - Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); +static int +OldMathFuncProc( + 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 = clientData; + Tcl_Value funcResult, *args; + int result; + int j, k; + double d; + + /* + * Check argument count. + */ + + if (objc != dataPtr->numArgs + 1) { + MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv); + return TCL_ERROR; } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - if (!new) { - if (mathFuncPtr->builtinFuncIndex >= 0) { - /* - * We are redefining a builtin math function. Invalidate the - * interpreter's existing code by incrementing its - * compileEpoch member. This field is checked in Tcl_EvalObj - * and ObjInterpProc, and code whose compilation epoch doesn't - * match is recompiled. Newly compiled code will no longer - * treat the function as builtin. - */ + /* + * Convert arguments from Tcl_Obj's to Tcl_Value's. + */ - iPtr->compileEpoch++; - } else { + args = (Tcl_Value *) ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); + for (j = 1, k = 0; j < objc; ++j, ++k) { + + /* TODO: Convert to TclGetNumberFromObj() ? */ + valuePtr = objv[j]; + result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); +#ifdef ACCEPT_NAN + if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) { + d = valuePtr->internalRep.doubleValue; + result = TCL_OK; + } +#endif + if (result != TCL_OK) { /* - * A non-builtin function is being redefined. We must invalidate - * existing code if the number of arguments has changed. This - * is because existing code was compiled assuming that number. + * We have a non-numeric argument. */ - if (numArgs != mathFuncPtr->numArgs) { - iPtr->compileEpoch++; + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "argument to math function didn't have numeric value",-1)); + TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); + ckfree((char *)args); + return TCL_ERROR; + } + + /* + * Copy the object's numeric value to the argument record, converting + * it if necessary. + * + * NOTE: no bignum support; use the new mathfunc interface for that. + */ + + args[k].type = dataPtr->argTypes[k]; + switch (args[k].type) { + case TCL_EITHER: + if (Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue)) + == TCL_OK) { + args[k].type = TCL_INT; + break; + } + if (Tcl_GetWideIntFromObj(interp, valuePtr, &(args[k].wideValue)) + == TCL_OK) { + args[k].type = TCL_WIDE_INT; + break; + } + args[k].type = TCL_DOUBLE; + /* FALLTHROUGH */ + + case TCL_DOUBLE: + args[k].doubleValue = d; + break; + case TCL_INT: + if (ExprIntFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) { + ckfree((char *)args); + return TCL_ERROR; + } + valuePtr = Tcl_GetObjResult(interp); + Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue)); + Tcl_ResetResult(interp); + break; + case TCL_WIDE_INT: + if (ExprWideFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) { + ckfree((char *)args); + return TCL_ERROR; } + valuePtr = Tcl_GetObjResult(interp); + Tcl_GetWideIntFromObj(NULL, valuePtr, &(args[k].wideValue)); + Tcl_ResetResult(interp); + break; } } - - mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ - if (numArgs > MAX_MATH_ARGS) { - numArgs = MAX_MATH_ARGS; + + /* + * Call the function. + */ + + errno = 0; + result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult); + ckfree((char *)args); + if (result != TCL_OK) { + return result; } - mathFuncPtr->numArgs = numArgs; - for (i = 0; i < numArgs; i++) { - mathFuncPtr->argTypes[i] = argTypes[i]; + + /* + * Return the result of the call. + */ + + if (funcResult.type == TCL_INT) { + TclNewLongObj(valuePtr, funcResult.intValue); + } else if (funcResult.type == TCL_WIDE_INT) { + valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); + } else { + return CheckDoubleResult(interp, funcResult.doubleValue); } - mathFuncPtr->proc = proc; - mathFuncPtr->clientData = clientData; + Tcl_SetObjResult(interp, valuePtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * OldMathFuncDeleteProc -- + * + * Cleans up after deleting a math function registered with + * Tcl_CreateMathFunc + * + * Results: + * None. + * + * Side effects: + * Frees allocated memory. + * + *---------------------------------------------------------------------- + */ + +static void +OldMathFuncDeleteProc( + ClientData clientData) +{ + OldMathFuncData *dataPtr = clientData; + + ckfree((void *) dataPtr->argTypes); + ckfree((void *) dataPtr); } /* @@ -2905,64 +3294,80 @@ Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, 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) - Tcl_Interp *interp; - CONST char *name; - int *numArgsPtr; - Tcl_ValueType **argTypesPtr; - Tcl_MathProc **procPtr; - ClientData *clientDataPtr; +Tcl_GetMathFuncInfo( + Tcl_Interp *interp, + const char *name, + int *numArgsPtr, + Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, + ClientData *clientDataPtr) { - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - Tcl_ValueType *argTypes; - int i,numArgs; + Tcl_Obj *cmdNameObj; + Command *cmdPtr; - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name); - if (hPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "math function \"", name, "\" not known in this interpreter", - (char *) NULL); + /* + * Get the command that implements the math function. + */ + + TclNewLiteralStringObj(cmdNameObj, "tcl::mathfunc::"); + Tcl_AppendToObj(cmdNameObj, name, -1); + Tcl_IncrRefCount(cmdNameObj); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdNameObj); + Tcl_DecrRefCount(cmdNameObj); + + /* + * Report unknown functions. + */ + + if (cmdPtr == NULL) { + Tcl_Obj *message; + + TclNewLiteralStringObj(message, "unknown math function \""); + Tcl_AppendToObj(message, name, -1); + Tcl_AppendToObj(message, "\"", 1); + Tcl_SetObjResult(interp, message); + *numArgsPtr = -1; + *argTypesPtr = NULL; + *procPtr = NULL; + *clientDataPtr = NULL; return TCL_ERROR; } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - *numArgsPtr = numArgs = mathFuncPtr->numArgs; - if (numArgs == 0) { - /* Avoid doing zero-sized allocs... */ - numArgs = 1; - } - *argTypesPtr = argTypes = - (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); - for (i = 0; i < mathFuncPtr->numArgs; i++) { - argTypes[i] = mathFuncPtr->argTypes[i]; - } + /* + * Retrieve function info for user defined functions; return dummy + * information for builtins. + */ + + if (cmdPtr->objProc == &OldMathFuncProc) { + OldMathFuncData *dataPtr = cmdPtr->clientData; - if (mathFuncPtr->builtinFuncIndex == -1) { - *procPtr = (Tcl_MathProc *) NULL; + *procPtr = dataPtr->proc; + *numArgsPtr = dataPtr->numArgs; + *argTypesPtr = dataPtr->argTypes; + *clientDataPtr = dataPtr->clientData; } else { - *procPtr = mathFuncPtr->proc; - *clientDataPtr = mathFuncPtr->clientData; + *procPtr = NULL; + *numArgsPtr = -1; + *argTypesPtr = NULL; + *procPtr = NULL; + *clientDataPtr = NULL; } - return TCL_OK; } @@ -2975,9 +3380,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. @@ -2986,28 +3391,33 @@ Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, */ Tcl_Obj * -Tcl_ListMathFuncs(interp, pattern) - Tcl_Interp *interp; - CONST char *pattern; +Tcl_ListMathFuncs( + Tcl_Interp *interp, + const char *pattern) { - Interp *iPtr = (Interp *) interp; - Tcl_Obj *resultList = Tcl_NewObj(); - register Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - CONST char *name; - - for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr); - if ((pattern == NULL || Tcl_StringMatch(name, pattern)) && - /* I don't expect this to fail, but... */ - Tcl_ListObjAppendElement(interp, resultList, - Tcl_NewStringObj(name,-1)) != TCL_OK) { - Tcl_DecrRefCount(resultList); - return NULL; - } + Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1); + Tcl_Obj *result; + Tcl_InterpState state; + + if (pattern) { + Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); + Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj); + + Tcl_AppendObjToObj(script, arg); + Tcl_DecrRefCount(arg); /* Should tear down patternObj too */ } - return resultList; + + state = Tcl_SaveInterpState(interp, TCL_OK); + Tcl_IncrRefCount(script); + if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { + result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } else { + result = Tcl_NewObj(); + } + Tcl_DecrRefCount(script); + Tcl_RestoreInterpState(interp, state); + + return result; } /* @@ -3015,13 +3425,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. @@ -3029,15 +3438,18 @@ Tcl_ListMathFuncs(interp, pattern) *---------------------------------------------------------------------- */ -int -TclInterpReady(interp) - Tcl_Interp *interp; +int +TclInterpReady( + Tcl_Interp *interp) { +#if !defined(TCL_NO_STACK_CHECK) + int localInt; /* used for checking the stack */ +#endif 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); @@ -3045,46 +3457,53 @@ TclInterpReady(interp) /* * If the interpreter has been deleted, return an error. */ - + if (iPtr->flags & DELETED) { Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "attempt to call eval in deleted interpreter", -1); - Tcl_SetErrorCode(interp, "CORE", "IDELETE", - "attempt to call eval in deleted interpreter", - (char *) NULL); + Tcl_AppendResult(interp, + "attempt to call eval in deleted interpreter", NULL); + Tcl_SetErrorCode(interp, "TCL", "IDELETE", + "attempt to call eval in deleted interpreter", NULL); return TCL_ERROR; } /* - * 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) - || (TclpCheckStackSpace() == 0)) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many nested evaluations (infinite loop?)", -1); - return TCL_ERROR; + if (((iPtr->numLevels) <= iPtr->maxNestingDepth) + && CheckCStack(iPtr, &localInt)) { + return TCL_OK; } - return TCL_OK; + if (!CheckCStack(iPtr, &localInt)) { + Tcl_AppendResult(interp, + "out of stack space (infinite loop?)", NULL); + } else { + Tcl_AppendResult(interp, + "too many nested evaluations (infinite loop?)", NULL); + } + return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * TclEvalObjvInternal -- + * TclEvalObjvInternal + * + * This function 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. + * TclEvalObjvInternal is the backend for Tcl_EvalObjv, the bytecode + * engine also calls it directly. * * 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 function does NOT add any information to the + * errorInfo variable. * * Side effects: * Depends on the command. @@ -3093,39 +3512,39 @@ 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. */ - int objc; /* Number of words in command. */ - Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are +TclEvalObjvInternal( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * 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. */ - int length; /* Number of bytes in command; if -1, all + const char *command, /* Points to the beginning of the string + * representation of the command; this is used + * for traces. NULL if the string + * representation of the command is unknown is + * to be generated from (objc,objv), -1 if it + * is to be generated from bytecode + * source. This is only needed the traces. */ + 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. */ - { Command *cmdPtr; 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 = NULL; + CallFrame *varFramePtr = iPtr->varFramePtr; int code = TCL_OK; int traceCode = TCL_OK; - int checkTraces = 1; + int checkTraces = 1, traced; Namespace *savedNsPtr = NULL; + Namespace *lookupNsPtr = iPtr->lookupNsPtr; + Tcl_Obj *commandPtr = NULL; if (TclInterpReady(interp) == TCL_ERROR) { return TCL_ERROR; @@ -3135,93 +3554,107 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) return TCL_OK; } + /* + * If any execution traces rename or delete the current command, we may + * need (at most) two passes here. + */ + + reparseBecauseOfTraces: /* - * If any execution traces rename or delete the current command, - * we may need (at most) two passes here. + * Configure evaluation context to match the requested flags. */ - savedVarFramePtr = iPtr->varFramePtr; - while (1) { - - /* Configure evaluation context to match the requested flags */ - if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = NULL; - } else if ((flags & TCL_EVAL_INVOKE) && iPtr->varFramePtr) { - savedNsPtr = iPtr->varFramePtr->nsPtr; - iPtr->varFramePtr->nsPtr = iPtr->globalNsPtr; - } - - /* - * 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. - */ - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if (cmdPtr == NULL) { - newObjv = (Tcl_Obj **) ckalloc((unsigned) - ((objc + 1) * sizeof (Tcl_Obj *))); - for (i = objc-1; i >= 0; i--) { - newObjv[i+1] = objv[i]; - } - newObjv[0] = Tcl_NewStringObj("::unknown", -1); - Tcl_IncrRefCount(newObjv[0]); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); - if (cmdPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", Tcl_GetString(objv[0]), "\"", - (char *) NULL); - code = TCL_ERROR; + if (flags) { + if (flags & TCL_EVAL_INVOKE) { + savedNsPtr = varFramePtr->nsPtr; + if (lookupNsPtr) { + varFramePtr->nsPtr = lookupNsPtr; + iPtr->lookupNsPtr = NULL; } else { - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objc+1, newObjv, - command, length, 0); - iPtr->numLevels--; + varFramePtr->nsPtr = iPtr->globalNsPtr; } - Tcl_DecrRefCount(newObjv[0]); - ckfree((char *) newObjv); - if (savedNsPtr) { - iPtr->varFramePtr->nsPtr = savedNsPtr; + } else if ((flags & TCL_EVAL_GLOBAL) + && (varFramePtr != iPtr->rootFramePtr) && !savedVarFramePtr) { + varFramePtr = iPtr->rootFramePtr; + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = varFramePtr; + } + } + + /* + * Find the function to execute this command. If there isn't one, then see + * if there is an unknown command handler registered for this namespace. + * If so, create a new word array with the handler as the first words and + * the original command words as arguments. Then call ourselves + * recursively to execute it. + */ + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + if (!cmdPtr) { + goto notFound; + } + + if (savedNsPtr) { + varFramePtr->nsPtr = savedNsPtr; + } else if (iPtr->ensembleRewrite.sourceObjs) { + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ + + iPtr->ensembleRewrite.sourceObjs = NULL; + } + + /* + * Call trace functions if needed. + */ + + traced = (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)); + if (traced && checkTraces) { + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + + /* + * Insure that we have a correct nul-terminated command string for the + * trace code. + */ + + commandPtr = GetCommandSource(iPtr, command, length, objc, objv); + command = TclGetStringFromObj(commandPtr, &length); + + /* + * Execute any command or execution traces. Note that we bump up the + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. + */ + + cmdPtr->refCount++; + if (iPtr->tracePtr && (traceCode == TCL_OK)) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + TclCleanupCommandMacro(cmdPtr); + + /* + * If the traces modified/deleted the command or any existing traces, + * they will update the command's epoch. When that happens, set + * checkTraces is set to 0 to prevent the re-calling of traces (and + * any possible infinite loop) and we go back to re-find the command + * implementation. + */ + + if (cmdEpoch != newEpoch) { + checkTraces = 0; + if (commandPtr) { + Tcl_DecrRefCount(commandPtr); } - goto done; - } - if (savedNsPtr) { - iPtr->varFramePtr->nsPtr = savedNsPtr; + goto reparseBecauseOfTraces; } - - /* - * Call trace procedures if needed. - */ - if ((checkTraces) && (command != NULL)) { - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - - 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 (iPtr->tracePtr != NULL && traceCode == TCL_OK) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) - && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - TclCleanupCommand(cmdPtr); - if (cmdEpoch != newEpoch) { - /* The command has been modified in some way */ - checkTraces = 0; - continue; - } - } - break; } #ifdef USE_DTRACE @@ -3235,14 +3668,24 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } + if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { + Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); + char *a[4]; int i[2]; + + TclDTraceInfo(info, a, i); + TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); + TclDecrRefCount(info); + } #endif /* USE_DTRACE */ /* * Finally, invoke the command's Tcl_ObjCmdProc. */ + cmdPtr->refCount++; iPtr->cmdCount++; - if ( code == TCL_OK && traceCode == TCL_OK) { + if (code == TCL_OK && traceCode == TCL_OK + && !TclLimitExceeded(iPtr->limit)) { if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, (Tcl_Obj **)(objv + 1)); @@ -3252,48 +3695,58 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code); } } - if (Tcl_AsyncReady()) { + + if (TclAsyncReady(iPtr)) { code = Tcl_AsyncInvoke(interp, code); } + if (code == TCL_OK && TclLimitReady(iPtr->limit)) { + code = Tcl_LimitCheck(interp); + } /* * Call 'leave' command traces */ - if (!(cmdPtr->flags & CMD_IS_DELETED)) { - int saveErrFlags = iPtr->flags - & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET); - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces (interp, command, length, - cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); - } - if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); - } - if (traceCode == TCL_OK) { - iPtr->flags |= saveErrFlags; + + if (traced) { + if (!(cmdPtr->flags & CMD_IS_DELETED)) { + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + } + + /* + * 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) { + code = traceCode; + } + if (commandPtr) { + Tcl_DecrRefCount(commandPtr); } } - 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. + * Decrement the reference count of cmdPtr and deallocate it if it has + * dropped to zero. */ - if (traceCode != TCL_OK) { - code = traceCode; - } - + TclCleanupCommandMacro(cmdPtr); + /* - * 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 function 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); } @@ -3303,532 +3756,213 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) Tcl_Obj *r; r = Tcl_GetObjResult(interp); - TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r), r); + TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r),r); } #endif /* USE_DTRACE */ - done: - iPtr->varFramePtr = savedVarFramePtr; + done: + if (savedVarFramePtr) { + iPtr->varFramePtr = savedVarFramePtr; + } return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalObjv -- - * - * 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. - * - * Side effects: - * Depends on the command. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_EvalObjv(interp, objc, objv, flags) - Tcl_Interp *interp; /* Interpreter in which to evaluate the - * 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. */ -{ - Interp *iPtr = (Interp *)interp; - Trace *tracePtr; - Tcl_DString cmdBuf; - char *cmdString = ""; /* A command string is only necessary for - * command traces or error logs; it will be - * generated to replace this default value if - * necessary. */ - int cmdLen = 0; /* a non-zero value indicates that a command - * string was generated. */ - int code = TCL_OK; - int i; - int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - 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 - * command string. - */ - - Tcl_DStringInit(&cmdBuf); - for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); + notFound: + { + Namespace *currNsPtr = NULL; /* Used to check for and invoke any + * registered unknown command handler + * for the current namespace (TIP + * 181). */ + int newObjc, handlerObjc; + Tcl_Obj **handlerObjv; + + currNsPtr = varFramePtr->nsPtr; + if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) { + currNsPtr = iPtr->globalNsPtr; + if (currNsPtr == NULL) { + Tcl_Panic("TclEvalObjvInternal: NULL global namespace pointer"); } - cmdString = Tcl_DStringValue(&cmdBuf); - cmdLen = Tcl_DStringLength(&cmdBuf); - break; } - } - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags); - iPtr->numLevels--; + /* + * Check to see if the resolution namespace has lost its unknown + * handler. If so, reset it to "::unknown". + */ - /* - * If we are again at the top level, process any unusual - * return code returned by the evaluated code. - */ - - if (iPtr->numLevels == 0) { - if (code == TCL_RETURN) { - code = TclUpdateReturnInfo(iPtr); + if (currNsPtr->unknownHandlerPtr == NULL) { + TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); + Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); } - if ((code != TCL_OK) && (code != TCL_ERROR) - && !allowExceptions) { - ProcessUnexpectedResult(interp, code); - code = TCL_ERROR; + + /* + * Get the list of words for the unknown handler and allocate enough + * space to hold both the handler prefix and all words of the command + * invokation itself. + */ + + Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, + &handlerObjc, &handlerObjv); + newObjc = objc + handlerObjc; + newObjv = (Tcl_Obj **) TclStackAlloc(interp, + (int) sizeof(Tcl_Obj *) * newObjc); + + /* + * Copy command prefix from unknown handler and add on the real + * command's full argument list. Note that we only use memcpy() once + * because we have to increment the reference count of all the handler + * arguments anyway. + */ + + for (i = 0; i < handlerObjc; ++i) { + newObjv[i] = handlerObjv[i]; + Tcl_IncrRefCount(newObjv[i]); } - } - - if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { + memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); - /* - * If there was an error, a command string will be needed for the - * error log: generate it now if it was not done previously. + /* + * Look up and invoke the handler (by recursive call to this + * function). If there is no handler at all, instead of doing the + * recursive call we just generate a generic error message; it would + * be an infinite-recursion nightmare otherwise. */ - if (cmdLen == 0) { - Tcl_DStringInit(&cmdBuf); - for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); - } - cmdString = Tcl_DStringValue(&cmdBuf); - cmdLen = Tcl_DStringLength(&cmdBuf); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); + if (cmdPtr == NULL) { + Tcl_AppendResult(interp, "invalid command name \"", + TclGetString(objv[0]), "\"", NULL); + code = TCL_ERROR; + } else { + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, newObjc, newObjv, command, + length, 0); + iPtr->numLevels--; } - Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); - } - if (cmdLen != 0) { - Tcl_DStringFree(&cmdBuf); + /* + * Release any resources we locked and allocated during the handler + * call. + */ + + for (i = 0; i < handlerObjc; ++i) { + Tcl_DecrRefCount(newObjv[i]); + } + TclStackFree(interp, newObjv); + if (savedNsPtr) { + varFramePtr->nsPtr = savedNsPtr; + } + goto done; } - return code; } /* *---------------------------------------------------------------------- * - * Tcl_LogCommandInfo -- + * Tcl_EvalObjv -- * - * This procedure is invoked after an error occurs in an interpreter. - * It adds information to the "errorInfo" variable to describe the - * command that was being executed when the error occurred. + * This function evaluates a Tcl command that has already been parsed + * into words, with one Tcl_Obj holding each word. * * Results: - * None. + * 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: - * Information about the command is added to errorInfo and the - * line number stored internally in the interpreter is set. If this - * is the first call to this procedure or Tcl_AddObjErrorInfo since - * an error occurred, then old information in errorInfo is - * deleted. + * Depends on the command. * *---------------------------------------------------------------------- */ -void -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). */ +int +Tcl_EvalObjv( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * 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. */ { - char buffer[200]; - register CONST char *p; - char *ellipsis = ""; Interp *iPtr = (Interp *) interp; + int code = TCL_OK; + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objc, objv, NULL, 0, flags); + iPtr->numLevels--; + + if (code == TCL_OK) { + return code; + } else { - if (iPtr->flags & ERR_ALREADY_LOGGED) { /* - * Someone else has already logged error information for this - * command; we shouldn't add anything more. + * If we are again at the top level, process any unusual return code + * returned by the evaluated code. */ - return; - } + if (iPtr->numLevels == 0) { + if (code == TCL_RETURN) { + code = TclUpdateReturnInfo(iPtr); + } + if ((code != TCL_ERROR) && !allowExceptions) { + ProcessUnexpectedResult(interp, code); + code = TCL_ERROR; + } + } - /* - * Compute the line number where the error occurred. - */ + if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { + /* + * If there was an error, a command string will be needed for the + * error log: generate it now. Do not worry too much about doing + * it expensively. + */ - iPtr->errorLine = 1; - for (p = script; p != command; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } + Tcl_Obj *listPtr; + char *cmdString; + int cmdLen; - /* - * Create an error message to add to errorInfo, including up to a - * maximum number of characters of the command. - */ + listPtr = Tcl_NewListObj(objc, objv); + cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); + Tcl_DecrRefCount(listPtr); + } - if (length < 0) { - length = strlen(command); - } - if (length > 150) { - length = 150; - ellipsis = "..."; - } - while ( (command[length] & 0xC0) == 0x80 ) { - /* - * Back up truncation point so that we don't truncate in the - * middle of a multi-byte character (in UTF-8) - */ - length--; - ellipsis = "..."; - } - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - sprintf(buffer, "\n while executing\n\"%.*s%s\"", - length, command, ellipsis); - } else { - sprintf(buffer, "\n invoked from within\n\"%.*s%s\"", - length, command, ellipsis); + return code; } - Tcl_AddObjErrorInfo(interp, buffer, -1); - iPtr->flags &= ~ERR_ALREADY_LOGGED; } /* *---------------------------------------------------------------------- * - * Tcl_EvalTokensStandard, EvalTokensStandard -- + * 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 function + * 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. * - * TIP #280 : Keep public API, internally extended API. *---------------------------------------------------------------------- */ 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. */ - int count; /* Number of tokens to consider at tokenPtr. +Tcl_EvalTokensStandard( + 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. */ { -#ifdef TCL_TIP280 - return EvalTokensStandard (interp, tokenPtr, count, 1, NULL, NULL); -} - -static int -EvalTokensStandard(interp, tokenPtr, count, line, clNextOuter, outerScript) - 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. */ - int line; /* The line the script starts on. */ - int* clNextOuter; /* Information about an outer context for */ - CONST char* outerScript; /* continuation line data. This is set by - * EvalEx() to properly handle [...]-nested - * commands. The 'outerScript' refers to the - * most-outer script containing the embedded - * command, which is refered to by 'script'. The - * 'clNextOuter' refers to the current entry in - * the table of continuation lines in this - * "master script", and the character offsets are - * relative to the 'outerScript' as well. - * - * If outerScript == script, then this call is for - * words in the outer-most script/command. See - * Tcl_EvalEx() and TclEvalObjEx() for the places - * generating arguments for which this is true. - */ -{ -#endif - Tcl_Obj *resultPtr, *indexPtr, *valuePtr; - char buffer[TCL_UTF_MAX]; -#ifdef TCL_MEM_DEBUG -# define MAX_VAR_CHARS 5 -#else -# define MAX_VAR_CHARS 30 -#endif - char nameBuffer[MAX_VAR_CHARS+1]; - char *varName, *index; - CONST char *p = NULL; /* Initialized to avoid compiler warning. */ - int length, code; -#ifdef TCL_TIP280 -#define NUM_STATIC_POS 20 - int isLiteral, maxNumCL, numCL, i, adjust; - int* clPosition = NULL; - Interp* iPtr = (Interp*) interp; - int inFile = iPtr->evalFlags & TCL_EVAL_FILE; -#endif - - /* - * The only tricky thing about this procedure is that it attempts to - * avoid object creation and string copying whenever possible. For - * example, if the value is just a nested command, then use the - * command's result object directly. - */ - - code = TCL_OK; - resultPtr = NULL; - Tcl_ResetResult(interp); -#ifdef TCL_TIP280 - /* - * For the handling of continuation lines in literals we first check if - * this is actually a literal. For if not we can forego the additional - * processing. Otherwise we pre-allocate a small table to store the - * locations of all continuation lines we find in this literal, if - * any. The table is extended if needed. - */ - - numCL = 0; - maxNumCL = 0; - isLiteral = 1; - for (i=0 ; i < count; i++) { - if ((tokenPtr[i].type != TCL_TOKEN_TEXT) && - (tokenPtr[i].type != TCL_TOKEN_BS)) { - isLiteral = 0; - break; - } - } - - if (isLiteral) { - maxNumCL = NUM_STATIC_POS; - clPosition = (int*) ckalloc (maxNumCL*sizeof(int)); - } - adjust = 0; -#endif - for ( ; count > 0; count--, tokenPtr++) { - valuePtr = NULL; - - /* - * The switch statement below computes the next value to be - * concat to the result, as either a range of text or an - * object. - */ - - switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - p = tokenPtr->start; - length = tokenPtr->size; - break; - - case TCL_TOKEN_BS: - length = TclParseBackslash(tokenPtr->start, tokenPtr->size, - (int *) NULL, buffer); - p = buffer; -#ifdef TCL_TIP280 - /* - * If the backslash sequence we found is in a literal, and - * represented a continuation line, we compute and store its - * location (as char offset to the beginning of the _result_ - * script). We may have to extend the table of locations. - * - * Note that the continuation line information is relevant - * even if the word we are processing is not a literal, as it - * can affect nested commands. See the branch for - * TCL_TOKEN_COMMAND below, where the adjustment we are - * tracking here is taken into account. The good thing is that - * we do not need a table of everything, just the number of - * lines we have to add as correction. - */ - - if ((length == 1) && (buffer[0] == ' ') && - (tokenPtr->start[1] == '\n')) { - if (isLiteral) { - int clPos; - if (resultPtr == 0) { - clPos = 0; - } else { - Tcl_GetStringFromObj(resultPtr, &clPos); - } - - if (numCL >= maxNumCL) { - maxNumCL *= 2; - clPosition = (int*) ckrealloc ((char*)clPosition, - maxNumCL*sizeof(int)); - } - clPosition[numCL] = clPos; - numCL ++; - } - adjust ++; - } -#endif - break; - - case TCL_TOKEN_COMMAND: { - Interp *iPtr = (Interp *) interp; - iPtr->numLevels++; - code = TclInterpReady(interp); - if (code == TCL_OK) { -#ifndef TCL_TIP280 - code = Tcl_EvalEx(interp, - tokenPtr->start+1, tokenPtr->size-2, 0); -#else - /* TIP #280: Transfer line information to nested command */ - TclAdvanceContinuations (&line, &clNextOuter, - tokenPtr->start - outerScript); - code = EvalEx(interp, - tokenPtr->start+1, tokenPtr->size-2, 0, - line + adjust, clNextOuter, outerScript); - - /* - * Restore flag reset by the nested eval for future - * bracketed commands and their CmdFrame setup - */ - if (inFile) { - iPtr->evalFlags |= TCL_EVAL_FILE; - } -#endif - } - iPtr->numLevels--; - if (code != TCL_OK) { - goto done; - } - valuePtr = Tcl_GetObjResult(interp); - break; - } - - case TCL_TOKEN_VARIABLE: - if (tokenPtr->numComponents == 1) { - indexPtr = NULL; - index = NULL; - } else { -#ifndef TCL_TIP280 - code = Tcl_EvalTokensStandard(interp, tokenPtr+2, - tokenPtr->numComponents - 1); -#else - /* TIP #280: Transfer line information to nested command */ - code = EvalTokensStandard(interp, tokenPtr+2, - tokenPtr->numComponents - 1, line, NULL, NULL); -#endif - if (code != TCL_OK) { - goto done; - } - indexPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(indexPtr); - index = Tcl_GetString(indexPtr); - } - - /* - * We have to make a copy of the variable name in order - * to have a null-terminated string. We can't make a - * temporary modification to the script to null-terminate - * the name, because a trace callback might potentially - * reuse the script and be affected by the null character. - */ - - if (tokenPtr[1].size <= MAX_VAR_CHARS) { - varName = nameBuffer; - } else { - varName = ckalloc((unsigned) (tokenPtr[1].size + 1)); - } - strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size); - varName[tokenPtr[1].size] = 0; - valuePtr = Tcl_GetVar2Ex(interp, varName, index, - TCL_LEAVE_ERR_MSG); - if (varName != nameBuffer) { - ckfree(varName); - } - if (indexPtr != NULL) { - Tcl_DecrRefCount(indexPtr); - } - if (valuePtr == NULL) { - code = TCL_ERROR; - goto done; - } - count -= tokenPtr->numComponents; - tokenPtr += tokenPtr->numComponents; - break; - - default: - panic("unexpected token type in Tcl_EvalTokensStandard"); - } - - /* - * If valuePtr isn't NULL, the next piece of text comes from that - * object; otherwise, take length bytes starting at p. - */ - - if (resultPtr == NULL) { - if (valuePtr != NULL) { - resultPtr = valuePtr; - } else { - resultPtr = Tcl_NewStringObj(p, length); - } - Tcl_IncrRefCount(resultPtr); - } else { - if (Tcl_IsShared(resultPtr)) { - Tcl_DecrRefCount(resultPtr); - resultPtr = Tcl_DuplicateObj(resultPtr); - Tcl_IncrRefCount(resultPtr); - } - if (valuePtr != NULL) { - p = Tcl_GetStringFromObj(valuePtr, &length); - } - Tcl_AppendToObj(resultPtr, p, length); - } - } - if (resultPtr != NULL) { - Tcl_SetObjResult(interp, resultPtr); -#ifdef TCL_TIP280 - /* - * If the code found continuation lines (which implies that this word - * is a literal), then we store the accumulated table of locations in - * the thread-global data structure for the bytecode compiler to find - * later, assuming that the literal is a script which will be - * compiled. - */ - - if (numCL) { - TclContinuationsEnter(resultPtr, numCL, clPosition); - } - - /* - * Release the temp table we used to collect the locations of - * continuation lines, if any. - */ - - if (maxNumCL) { - ckfree ((char*) clPosition); - } -#endif - } else { - code = TCL_ERROR; - } - - done: - if (resultPtr != NULL) { - Tcl_DecrRefCount(resultPtr); - } - return code; + return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, + NULL, NULL); } /* @@ -3836,67 +3970,62 @@ EvalTokensStandard(interp, tokenPtr, count, line, clNextOuter, outerScript) * * 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 function + * 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. */ - int count; /* Number of tokens to consider at tokenPtr. +Tcl_EvalTokens( + 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. */ { - int code; Tcl_Obj *resPtr; - - code = Tcl_EvalTokensStandard(interp, tokenPtr, count); - if (code == TCL_OK) { - resPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resPtr); - Tcl_ResetResult(interp); - return resPtr; - } else { + + if (Tcl_EvalTokensStandard(interp, tokenPtr, count) != TCL_OK) { return NULL; } + resPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resPtr); + Tcl_ResetResult(interp); + return resPtr; } - /* *---------------------------------------------------------------------- * - * Tcl_EvalEx, EvalEx -- + * Tcl_EvalEx, TclEvalEx -- * - * 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 function 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. @@ -3906,38 +4035,35 @@ 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. */ - CONST char *script; /* First character of script to evaluate. */ - int numBytes; /* Number of bytes in script. If < 0, the +Tcl_EvalEx( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * 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 * 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. */ { -#ifdef TCL_TIP280 - return EvalEx (interp, script, numBytes, flags, 1, NULL, script); + return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script); } -static int -EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript) - Tcl_Interp *interp; /* Interpreter in which to evaluate the - * 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 +TclEvalEx( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * 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 * 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 line; /* The line the script starts on. */ - int* clNextOuter; /* Information about an outer context for */ - CONST char* outerScript; /* continuation line data. This is set only in - * EvalTokensStandard(), to properly handle + * first NUL character. */ + int flags, /* Collection of OR-ed bits that control the + * evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently supported. */ + int line, /* The line the script starts on. */ + int* clNextOuter, /* Information about an outer context for */ + CONST char* outerScript) /* continuation line data. This is set only in + * TclSubstTokens(), to properly handle * [...]-nested commands. The 'outerScript' * refers to the most-outer script containing the * embedded command, which is refered to by @@ -3953,31 +4079,32 @@ EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript) * generating arguments for which this is true. */ { -#endif Interp *iPtr = (Interp *) interp; - CONST char *p, *next; - Tcl_Parse parse; -#define NUM_STATIC_OBJS 20 - Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; + const char *p, *next; + const unsigned int minObjs = 20; + Tcl_Obj **objv, **objvSpace; + int *expand, *lines, *lineSpace; Tcl_Token *tokenPtr; - int code = TCL_OK; - int i, commandLength, bytesLeft, nested; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ + int commandLength, bytesLeft, expandRequested, code = TCL_OK; + 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. - */ - - int gotParse = 0, objectsUsed = 0; - -#ifdef TCL_TIP280 - /* TIP #280 Structures for tracking of command locations. */ - CmdFrame eeFrame; - + int gotParse = 0; + unsigned int i, objectsUsed = 0; + /* These variables keep track of how much + * state has been allocated while evaluating + * the script, so that it can be freed + * properly if an error occurs. */ + Tcl_Parse *parsePtr = (Tcl_Parse *) + TclStackAlloc(interp, sizeof(Tcl_Parse)); + CmdFrame *eeFramePtr = (CmdFrame *) + TclStackAlloc(interp, sizeof(CmdFrame)); + Tcl_Obj **stackObjArray = (Tcl_Obj **) + TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *)); + int *expandStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int)); + int *linesStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int)); + /* TIP #280 Structures for tracking of command + * locations. */ /* * Pointer for the tracking of invisible continuation lines. Initialized * only if the caller gave us a table of locations to track, via @@ -3995,7 +4122,6 @@ EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript) clNext = &iPtr->scriptCLLocPtr->loc[0]; } } -#endif if (numBytes < 0) { numBytes = strlen(script); @@ -4004,112 +4130,102 @@ EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript) savedVarFramePtr = iPtr->varFramePtr; if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = NULL; + iPtr->varFramePtr = iPtr->rootFramePtr; } /* - * 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 = staticObjArray; + objv = objvSpace = stackObjArray; + lines = lineSpace = linesStack; + expand = expandStack; p = script; bytesLeft = numBytes; - if (iPtr->evalFlags & TCL_BRACKET_TERM) { - nested = 1; - } else { - nested = 0; - } -#ifdef TCL_TIP280 - /* TIP #280 Initialize tracking. Do not push on the frame stack yet. */ /* - * We may cont. counting based on a specific context (CTX), or open a new - * context, either for a sourced script, or 'eval'. For sourced files we - * always have a path object, even if nothing was specified in the interp - * itself. That makes code using it simpler as NULL checks can be left - * out. Sourced file without path in the 'scriptFile' is possible during - * Tcl initialization. + * TIP #280 Initialize tracking. Do not push on the frame stack yet. + * + * We may continue counting based on a specific context (CTX), or open a + * new context, either for a sourced script, or 'eval'. For sourced files + * we always have a path object, even if nothing was specified in the + * interp itself. That makes code using it simpler as NULL checks can be + * left out. Sourced file without path in the 'scriptFile' is possible + * during Tcl initialization. */ if (iPtr->evalFlags & TCL_EVAL_CTX) { - /* Path information comes out of the context. */ + /* + * Path information comes out of the context. + */ - eeFrame.type = TCL_LOCATION_SOURCE; - eeFrame.data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; - Tcl_IncrRefCount (eeFrame.data.eval.path); + eeFramePtr->type = TCL_LOCATION_SOURCE; + eeFramePtr->data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; + Tcl_IncrRefCount(eeFramePtr->data.eval.path); } else if (iPtr->evalFlags & TCL_EVAL_FILE) { - /* Set up for a sourced file */ + /* + * Set up for a sourced file. + */ - eeFrame.type = TCL_LOCATION_SOURCE; + eeFramePtr->type = TCL_LOCATION_SOURCE; if (iPtr->scriptFile) { - /* Normalization here, to have the correct pwd. Should have + /* + * Normalization here, to have the correct pwd. Should have * negligible impact on performance, as the norm should have been * done already by the 'source' invoking us, and it caches the - * result + * result. */ - Tcl_Obj* norm = Tcl_FSGetNormalizedPath (interp, iPtr->scriptFile); - if (!norm) { - /* Error message in the interp result */ - return TCL_ERROR; + Tcl_Obj *norm = Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile); + + if (norm == NULL) { + /* + * Error message in the interp result. + */ + code = TCL_ERROR; + goto error; } - eeFrame.data.eval.path = norm; + eeFramePtr->data.eval.path = norm; } else { - eeFrame.data.eval.path = Tcl_NewStringObj ("",-1); + TclNewLiteralStringObj(eeFramePtr->data.eval.path, ""); } - Tcl_IncrRefCount (eeFrame.data.eval.path); + Tcl_IncrRefCount(eeFramePtr->data.eval.path); } else { - /* Set up for plain eval */ + /* + * Set up for plain eval. + */ - eeFrame.type = TCL_LOCATION_EVAL; - eeFrame.data.eval.path = NULL; + eeFramePtr->type = TCL_LOCATION_EVAL; + eeFramePtr->data.eval.path = NULL; } - eeFrame.level = (iPtr->cmdFramePtr == NULL - ? 1 - : iPtr->cmdFramePtr->level + 1); - eeFrame.framePtr = iPtr->framePtr; - eeFrame.nextPtr = iPtr->cmdFramePtr; - eeFrame.nline = 0; - eeFrame.line = NULL; -#endif + eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; + eeFramePtr->framePtr = iPtr->framePtr; + eeFramePtr->nextPtr = iPtr->cmdFramePtr; + eeFramePtr->nline = 0; + eeFramePtr->line = NULL; iPtr->evalFlags = 0; do { - if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) - != TCL_OK) { + if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { code = TCL_ERROR; goto error; } - gotParse = 1; - - if (nested && parse.term == (script + numBytes)) { - /* - * A nested script can only terminate in ']'. If - * the parsing got terminated at the end of the script, - * there was no closing ']'. Report the syntax error. - */ - code = TCL_ERROR; - goto error; - } - -#ifdef TCL_TIP280 /* * TIP #280 Track lines. The parser may have skipped text till it - * found the command we are now at. We have count the lines in this + * found the command we are now at. We have to count the lines in this * block, and do not forget invisible continuation lines. */ - TclAdvanceLines (&line, p, parse.commandStart); + TclAdvanceLines(&line, p, parsePtr->commandStart); TclAdvanceContinuations (&line, &clNext, - parse.commandStart - outerScript); -#endif + parsePtr->commandStart - outerScript); - if (parse.numWords > 0) { -#ifdef TCL_TIP280 + gotParse = 1; + if (parsePtr->numWords > 0) { /* * TIP #280. Track lines within the words of the current * command. We use a separate pointer into the table of @@ -4117,77 +4233,138 @@ EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript) * per-command parsing. */ - int wordLine = line; - CONST char* wordStart = parse.commandStart; + int wordLine = line; + const char *wordStart = parsePtr->commandStart; int* wordCLNext = clNext; -#endif /* * Generate an array of objects for the words of the command. */ - - if (parse.numWords <= NUM_STATIC_OBJS) { - objv = staticObjArray; - } else { - objv = (Tcl_Obj **) ckalloc((unsigned) - (parse.numWords * sizeof (Tcl_Obj *))); - } -#ifdef TCL_TIP280 - eeFrame.nline = parse.numWords; - eeFrame.line = (int*) ckalloc((unsigned) - (parse.numWords * sizeof (int))); -#endif + unsigned int objectsNeeded = 0; + unsigned int numWords = parsePtr->numWords; - for (objectsUsed = 0, tokenPtr = parse.tokenPtr; - objectsUsed < parse.numWords; - objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { -#ifndef TCL_TIP280 - code = Tcl_EvalTokensStandard(interp, tokenPtr+1, - tokenPtr->numComponents); -#else - /* - * TIP #280. Track lines to current word. Save the - * information on a per-word basis, signaling dynamic words as - * needed. Make the information available to the recursively - * called evaluator as well, including the type of context - * (source vs. eval). + if (numWords > minObjs) { + expand = (int *) ckalloc(numWords * sizeof(int)); + objvSpace = (Tcl_Obj **) + ckalloc(numWords * sizeof(Tcl_Obj *)); + lineSpace = (int *) ckalloc(numWords * sizeof(int)); + } + expandRequested = 0; + objv = objvSpace; + lines = lineSpace; + + for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr; + objectsUsed < numWords; + objectsUsed++, tokenPtr += tokenPtr->numComponents+1) { + /* + * TIP #280. Track lines to current word. Save the information + * on a per-word basis, signaling dynamic words as needed. + * Make the information available to the recursively called + * evaluator as well, including the type of context (source + * vs. eval). */ - TclAdvanceLines (&wordLine, wordStart, tokenPtr->start); + TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); TclAdvanceContinuations (&wordLine, &wordCLNext, tokenPtr->start - outerScript); wordStart = tokenPtr->start; - eeFrame.line [objectsUsed] = (TclWordKnownAtCompileTime (tokenPtr) - ? wordLine - : -1); + lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) + ? wordLine : -1; - if (eeFrame.type == TCL_LOCATION_SOURCE) { + if (eeFramePtr->type == TCL_LOCATION_SOURCE) { iPtr->evalFlags |= TCL_EVAL_FILE; } - code = EvalTokensStandard(interp, tokenPtr+1, - tokenPtr->numComponents, wordLine, - wordCLNext, outerScript); + code = TclSubstTokens(interp, tokenPtr+1, + tokenPtr->numComponents, NULL, wordLine, + wordCLNext, outerScript); iPtr->evalFlags = 0; -#endif - if (code == TCL_OK) { - objv[objectsUsed] = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(objv[objectsUsed]); -#ifdef TCL_TIP280 - if (wordCLNext) { - TclContinuationsEnterDerived (objv[objectsUsed], - wordStart - outerScript, wordCLNext); + if (code != TCL_OK) { + goto error; + } + objv[objectsUsed] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(objv[objectsUsed]); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + int numElements; + + code = TclListObjLength(interp, objv[objectsUsed], + &numElements); + if (code == TCL_ERROR) { + /* + * Attempt to expand a non-list. + */ + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (expanding word %d)", objectsUsed)); + Tcl_DecrRefCount(objv[objectsUsed]); + goto error; } -#endif + expandRequested = 1; + expand[objectsUsed] = 1; + + objectsNeeded += (numElements ? numElements : 1); } else { - goto error; + expand[objectsUsed] = 0; + objectsNeeded++; + } + + if (wordCLNext) { + TclContinuationsEnterDerived (objv[objectsUsed], + wordStart - outerScript, wordCLNext); + } + } /* for loop */ + if (expandRequested) { + /* + * Some word expansion was requested. Check for objv resize. + */ + + Tcl_Obj **copy = objvSpace; + int *lcopy = lineSpace; + int wordIdx = numWords; + int objIdx = objectsNeeded - 1; + + if ((numWords > minObjs) || (objectsNeeded > minObjs)) { + objv = objvSpace = (Tcl_Obj **) + ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); + lines = lineSpace = (int *) + ckalloc(objectsNeeded * sizeof(int)); + } + + objectsUsed = 0; + while (wordIdx--) { + if (expand[wordIdx]) { + int numElements; + Tcl_Obj **elements, *temp = copy[wordIdx]; + + Tcl_ListObjGetElements(NULL, temp, &numElements, + &elements); + objectsUsed += numElements; + while (numElements--) { + lines[objIdx] = -1; + objv[objIdx--] = elements[numElements]; + Tcl_IncrRefCount(elements[numElements]); + } + Tcl_DecrRefCount(temp); + } else { + lines[objIdx] = lcopy[wordIdx]; + objv[objIdx--] = copy[wordIdx]; + objectsUsed++; + } + } + objv += objIdx+1; + + if (copy != stackObjArray) { + ckfree((char *) copy); + } + if (lcopy != linesStack) { + ckfree((char *) lcopy); } } - + /* * Execute the command and free the objects for its words. * @@ -4198,29 +4375,28 @@ EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript) * have been executed. */ -#ifdef TCL_TIP280 - eeFrame.cmd.str.cmd = parse.commandStart; - eeFrame.cmd.str.len = parse.commandSize; + eeFramePtr->cmd.str.cmd = parsePtr->commandStart; + eeFramePtr->cmd.str.len = parsePtr->commandSize; - if (parse.term == parse.commandStart + parse.commandSize - 1) { - eeFrame.cmd.str.len --; + if (parsePtr->term == + parsePtr->commandStart + parsePtr->commandSize - 1) { + eeFramePtr->cmd.str.len--; } - TclArgumentEnter (interp, objv, objectsUsed, &eeFrame); - iPtr->cmdFramePtr = &eeFrame; -#endif - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objectsUsed, objv, - parse.commandStart, parse.commandSize, 0); + eeFramePtr->nline = objectsUsed; + eeFramePtr->line = lines; + + TclArgumentEnter (interp, objv, objectsUsed, eeFramePtr); + iPtr->cmdFramePtr = eeFramePtr; + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objectsUsed, objv, + parsePtr->commandStart, parsePtr->commandSize, 0); iPtr->numLevels--; -#ifdef TCL_TIP280 iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; TclArgumentRelease (interp, objv, objectsUsed); - ckfree ((char*) eeFrame.line); - eeFrame.line = NULL; - eeFrame.nline = 0; -#endif + eeFramePtr->line = NULL; + eeFramePtr->nline = 0; if (code != TCL_OK) { goto error; @@ -4229,9 +4405,21 @@ EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript) Tcl_DecrRefCount(objv[i]); } objectsUsed = 0; - if (objv != staticObjArray) { - ckfree((char *) objv); - objv = staticObjArray; + if (objvSpace != stackObjArray) { + ckfree((char *) objvSpace); + objvSpace = stackObjArray; + ckfree((char *) lineSpace); + lineSpace = linesStack; + } + + /* + * Free expand separately since objvSpace could have been + * reallocated above. + */ + + if (expand != expandStack) { + ckfree((char *) expand); + expand = expandStack; } } @@ -4242,214 +4430,91 @@ EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript) * executed command. */ - next = parse.commandStart + parse.commandSize; + next = parsePtr->commandStart + parsePtr->commandSize; bytesLeft -= next - p; p = next; -#ifdef TCL_TIP280 - TclAdvanceLines (&line, parse.commandStart, p); -#endif - Tcl_FreeParse(&parse); + TclAdvanceLines(&line, parsePtr->commandStart, p); + Tcl_FreeParse(parsePtr); gotParse = 0; - if (nested && (*parse.term == ']')) { - /* - * We get here in the special case where the TCL_BRACKET_TERM - * flag was set in the interpreter and the latest parsed command - * was terminated by the matching close-bracket we seek. - * Return immediately. - */ - - iPtr->termOffset = (p - 1) - script; - iPtr->varFramePtr = savedVarFramePtr; -#ifndef TCL_TIP280 - return TCL_OK; -#else - code = TCL_OK; - goto cleanup_return; -#endif - } } while (bytesLeft > 0); - - if (nested) { - /* - * This nested script did not terminate in ']', it is an error. - */ - - code = TCL_ERROR; - goto error; - } - - iPtr->termOffset = p - script; iPtr->varFramePtr = savedVarFramePtr; -#ifndef TCL_TIP280 - return TCL_OK; -#else code = TCL_OK; goto cleanup_return; -#endif - error: + error: /* - * Generate various pieces of error information, such as the line - * number where the error occurred and information to add to the - * errorInfo variable. Then free resources that had been allocated - * to the command. + * 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) { + if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { ProcessUnexpectedResult(interp, code); code = TCL_ERROR; } } - if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - commandLength = parse.commandSize; - if (parse.term == parse.commandStart + commandLength - 1) { + if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + commandLength = parsePtr->commandSize; + if (parsePtr->term == parsePtr->commandStart + commandLength - 1) { /* * The terminator character (such as ; or ]) of the command where * the error occurred is the last character in the parsed command. * Reduce the length by one so that the error message doesn't * include the terminator character. */ - + commandLength -= 1; } - Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + commandLength); } - + iPtr->flags &= ~ERR_ALREADY_LOGGED; + + /* + * Then free resources that had been allocated to the command. + */ + for (i = 0; i < objectsUsed; i++) { Tcl_DecrRefCount(objv[i]); } if (gotParse) { - Tcl_FreeParse(&parse); + Tcl_FreeParse(parsePtr); } - if (objv != staticObjArray) { - ckfree((char *) objv); + if (objvSpace != stackObjArray) { + ckfree((char *) objvSpace); + ckfree((char *) lineSpace); } - iPtr->varFramePtr = savedVarFramePtr; - - /* - * All that's left to do before returning is to set iPtr->termOffset - * to point past the end of the script we just evaluated. - */ - - next = parse.commandStart + parse.commandSize; - bytesLeft -= next - p; - p = next; - - if (!nested) { - iPtr->termOffset = p - script; -#ifndef TCL_TIP280 - return code; -#else - goto cleanup_return; -#endif + if (expand != expandStack) { + ckfree((char *) expand); } + iPtr->varFramePtr = savedVarFramePtr; + cleanup_return: /* - * When we are nested (the TCL_BRACKET_TERM flag was set in the - * interpreter), we must find the matching close-bracket to - * end the script we are evaluating. - * - * When our return code is TCL_CONTINUE or TCL_RETURN, we want - * to correctly set iPtr->termOffset to point to that matching - * close-bracket so our caller can move to the part of the - * string beyond the script we were asked to evaluate. - * So we try to parse past the rest of the commands. + * TIP #280. Release the local CmdFrame, and its contents. */ - next = NULL; - while (bytesLeft && (*parse.term != ']')) { - if (TCL_OK != Tcl_ParseCommand(NULL, p, bytesLeft, 1, &parse)) { - /* - * Syntax error. Set the termOffset to the beginning of - * the last command parsed. - */ - - if (next == NULL) { - iPtr->termOffset = (parse.commandStart - 1) - script; - } else { - iPtr->termOffset = (next - 1) - script; - } -#ifndef TCL_TIP280 - return code; -#else - goto cleanup_return; -#endif - } - next = parse.commandStart + parse.commandSize; - bytesLeft -= next - p; - p = next; - next = parse.commandStart; - Tcl_FreeParse(&parse); - } - - if (bytesLeft) { - /* - * parse.term points to the close-bracket. - */ - - iPtr->termOffset = parse.term - script; - } else if (parse.term == script + numBytes) { - /* - * There was no close-bracket. Syntax error. - */ - - iPtr->termOffset = parse.term - script; - Tcl_SetObjResult(interp, - Tcl_NewStringObj("missing close-bracket", -1)); -#ifndef TCL_TIP280 - return TCL_ERROR; -#else - code = TCL_ERROR; - goto cleanup_return; -#endif - } else if (*parse.term != ']') { - /* - * There was no close-bracket. Syntax error. - */ - - iPtr->termOffset = (parse.term + 1) - script; - Tcl_SetObjResult(interp, - Tcl_NewStringObj("missing close-bracket", -1)); -#ifndef TCL_TIP280 - return TCL_ERROR; -#else - code = TCL_ERROR; - goto cleanup_return; -#endif - } else { - /* - * parse.term points to the close-bracket. - */ - iPtr->termOffset = parse.term - script; + if (eeFramePtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(eeFramePtr->data.eval.path); } + TclStackFree(interp, linesStack); + TclStackFree(interp, expandStack); + TclStackFree(interp, stackObjArray); + TclStackFree(interp, eeFramePtr); + TclStackFree(interp, parsePtr); -#ifdef TCL_TIP280 - cleanup_return: - /* TIP #280. Release the local CmdFrame, and its contents. */ - - if (eeFrame.line != NULL) { - ckfree ((char*) eeFrame.line); - } - if (eeFrame.type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount (eeFrame.data.eval.path); - } -#endif return code; } -#ifdef TCL_TIP280 /* *---------------------------------------------------------------------- * * TclAdvanceLines -- * - * This procedure is a helper which counts the number of lines - * in a block of text and advances an external counter. + * This function is a helper which counts the number of lines in a block + * of text and advances an external counter. * * Results: * None. @@ -4462,15 +4527,16 @@ EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript) */ void -TclAdvanceLines (line,start,end) - int* line; - CONST char* start; - CONST char* end; +TclAdvanceLines( + int *line, + const char *start, + const char *end) { - CONST char* p; + register const char *p; + for (p = start; p < end; p++) { - if (*p == '\n') { - (*line) ++; + if (*p == '\n') { + (*line)++; } } } @@ -4504,11 +4570,11 @@ TclAdvanceContinuations (line,clNextPtrPtr,loc) /* * Track the invisible continuation lines embedded in a script, if * any. Here they are just spaces (already). They were removed by - * EvalTokensStandard() via TclParseBackslash(). + * TclSubstTokens() via TclParseBackslash(). * - * *clNextPtrPtr <=> We have continuation lines to track. - * **clNextPtrPtr >= 0 <=> We are not beyond the last possible location. - * loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line. + * *clNextPtrPtr <=> We have continuation lines to track. + * **clNextPtrPtr >= 0 <=> We are not beyond the last possible location. + * loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line. */ while (*clNextPtrPtr && (**clNextPtrPtr >= 0) && (loc >= **clNextPtrPtr)) { @@ -4647,7 +4713,7 @@ TclArgumentRelease(interp,objv,objc) * * This procedure is a helper for the TIP #280 uplevel extension. * It enters location references for the literal arguments of commands - * in bytecode about to be executed. Only the first entry has the actual + * in bytecode about to be invoked. Only the first entry has the actual * data, further entries simply count the usage up. * * Results: @@ -4661,7 +4727,7 @@ TclArgumentRelease(interp,objv,objc) */ void -TclArgumentBCEnter(interp, objv, objc, codePtr, cfPtr, pc) +TclArgumentBCEnter(interp,objv,objc,codePtr,cfPtr,pc) Tcl_Interp* interp; Tcl_Obj* objv[]; int objc; @@ -4674,12 +4740,12 @@ TclArgumentBCEnter(interp, objv, objc, codePtr, cfPtr, pc) if (hePtr) { ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); - hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc); + hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); if (hePtr) { - int word; - int cmd = (int) Tcl_GetHashValue(hePtr); + int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); ECL* ePtr = &eclPtr->loc[cmd]; + int word; /* * A few truths ... @@ -4691,6 +4757,10 @@ TclArgumentBCEnter(interp, objv, objc, codePtr, cfPtr, pc) * have to save them at compile time. */ + if (ePtr->nline != objc) { + Tcl_Panic ("TIP 280 data structure inconsistency"); + } + for (word = 1; word < objc; word++) { if (ePtr->line[word] >= 0) { int isnew; @@ -4747,7 +4817,7 @@ TclArgumentBCEnter(interp, objv, objc, codePtr, cfPtr, pc) */ void -TclArgumentBCRelease(interp, objv, objc, codePtr, pc) +TclArgumentBCRelease(interp,objv,objc,codePtr,pc) Tcl_Interp* interp; Tcl_Obj* objv[]; int objc; @@ -4759,10 +4829,10 @@ TclArgumentBCRelease(interp, objv, objc, codePtr, pc) if (hePtr) { ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); - hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc); + hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); if (hePtr) { - int cmd = (int) Tcl_GetHashValue(hePtr); + int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); ECL* ePtr = &eclPtr->loc[cmd]; int word; @@ -4776,7 +4846,7 @@ TclArgumentBCRelease(interp, objv, objc, codePtr, pc) (char *) objv[word]); if (hPtr) { CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); - + if (cfwPtr->prevPtr) { Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); } else { @@ -4821,16 +4891,16 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) CmdFrame* framePtr; /* - * An object which either has no string rep guaranteed to have been - * generated dynamically: bail out, this cannot have a usable absolute - * location. _Do not touch_ the information the set up by the caller. It - * knows better than us. + * An object which either has no string rep or else is a canonical list is + * guaranteed to have been generated dynamically: bail out, this cannot + * have a usable absolute location. _Do not touch_ the information the set + * up by the caller. It knows better than us. */ - if (!obj->bytes) { + if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { return; } - + /* * First look for location information recorded in the argument * stack. That is nearest. @@ -4850,36 +4920,34 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) */ hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj); + if (hPtr) { CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); framePtr = cfwPtr->framePtr; - framePtr->data.tebc.pc = (char*) ((ByteCode*) - framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc; + framePtr->data.tebc.pc = (char *) (((ByteCode*) + framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc); *cfPtrPtr = cfwPtr->framePtr; *wordPtr = cfwPtr->word; return; } } -#endif /* *---------------------------------------------------------------------- * * 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 function 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 function 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. @@ -4888,21 +4956,20 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) */ int -Tcl_Eval(interp, string) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by previous call to Tcl_CreateInterp). */ - CONST char *string; /* Pointer to TCL command to execute. */ +Tcl_Eval( + 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, string, -1, 0); + 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). */ - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); + (void) Tcl_GetStringResult(interp); return code; } @@ -4923,18 +4990,20 @@ Tcl_Eval(interp, string) *---------------------------------------------------------------------- */ +#undef Tcl_EvalObj int -Tcl_EvalObj(interp, objPtr) - Tcl_Interp * interp; - Tcl_Obj * objPtr; +Tcl_EvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) { return Tcl_EvalObjEx(interp, objPtr, 0); } +#undef Tcl_GlobalEvalObj int -Tcl_GlobalEvalObj(interp, objPtr) - Tcl_Interp * interp; - Tcl_Obj * objPtr; +Tcl_GlobalEvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) { return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); } @@ -4945,322 +5014,272 @@ Tcl_GlobalEvalObj(interp, objPtr) * Tcl_EvalObjEx, TclEvalObjEx -- * * 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. - * - * Just as in Tcl_Eval, interp->termOffset is set to the offset of the - * last character executed in the objPtr's string. + * 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. * * TIP #280 : Keep public API, internally extended API. *---------------------------------------------------------------------- */ 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_EvalObjEx( + 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. */ { -#ifdef TCL_TIP280 - return TclEvalObjEx (interp, objPtr, flags, NULL, 0); + return TclEvalObjEx(interp, objPtr, flags, NULL, 0); } int -TclEvalObjEx(interp, objPtr, flags, invoker, word) - 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. */ - CONST CmdFrame* invoker; /* Frame of the command doing the eval */ - int word; /* Index of the word which is in objPtr */ +TclEvalObjEx( + 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. */ + const CmdFrame *invoker, /* Frame of the command doing the eval. */ + int word) /* Index of the word which is in objPtr. */ { -#endif 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. */ - int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case + * TCL_EVAL_GLOBAL was set. */ Tcl_IncrRefCount(objPtr); - if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) { + /* 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 also preserves any associations between list elements and location + * information for such elements. + * + * 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 (TclListObjIsCanonical(objPtr)) { + /* + * TIP #280 Structures for tracking lines. As we know that this is + * dynamic execution we ignore the invoker, even if known. + */ + + int nelements; + Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr); + CmdFrame *eoFramePtr = (CmdFrame *) + TclStackAlloc(interp, sizeof(CmdFrame)); + + eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 + : iPtr->cmdFramePtr->level + 1); + eoFramePtr->framePtr = iPtr->framePtr; + eoFramePtr->nextPtr = iPtr->cmdFramePtr; + + eoFramePtr->nline = 0; + eoFramePtr->line = NULL; + + eoFramePtr->cmd.listPtr = objPtr; + Tcl_IncrRefCount(eoFramePtr->cmd.listPtr); + eoFramePtr->data.eval.path = NULL; + + /* + * TIP #280 We do _not_ compute all the line numbers for the words + * in the command. For the eval of a pure list the most sensible + * choice is to put all words on line 1. Given that we neither + * need memory for them nor compute anything. 'line' is left + * NULL. The two places using this information (TclInfoFrame, and + * TclInitCompileEnv), are special-cased to use the proper line + * number directly instead of accessing the 'line' array. + */ + + Tcl_ListObjGetElements(NULL, copyPtr, &nelements, &elements); + + iPtr->cmdFramePtr = eoFramePtr; + result = Tcl_EvalObjv(interp, nelements, elements, flags); + + Tcl_DecrRefCount(copyPtr); + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + Tcl_DecrRefCount(eoFramePtr->cmd.listPtr); + TclStackFree(interp, eoFramePtr); + } else 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). + */ + + /* + * TIP #280. Propagate context as much as we can. Especially if the + * script to evaluate is a single literal it makes sense to look if + * our context is one with absolute line numbers we can then track + * into the literal itself too. + * + * See also tclCompile.c, TclInitCompileEnv, for the equivalent code + * in the bytecode compiler. + */ + + /* + * Now we check if we have data about invisible continuation lines for + * the script, and make it available to the direct script parser and + * evaluator we are about to call, if so. * - * 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. + * It may be possible that the script Tcl_Obj* can be free'd while the + * evaluator is using it, leading to the release of the associated + * ContLineLoc structure as well. To ensure that the latter doesn't + * happen we set a lock on it. We release this lock later in this + * function, after the evaluator is done. The relevant "lineCLPtr" + * hashtable is managed in the file "tclObj.c". * - * USE_EVAL_DIRECT is a special flag used for testing purpose only - * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt) + * Another important action is to save (and later restore) the + * continuation line information of the caller, in case we are + * executing nested commands in the eval/direct path. */ - if (!(iPtr->flags & USE_EVAL_DIRECT) && - (objPtr->typePtr == &tclListType) && /* is a list... */ - (objPtr->bytes == NULL) /* ...without a string rep */) { - register List *listRepPtr = - (List *) objPtr->internalRep.twoPtrValue.ptr1; - int i, objc = listRepPtr->elemCount; - -#define TEOE_PREALLOC 10 - Tcl_Obj *staticObjv[TEOE_PREALLOC], **objv = staticObjv; - -#ifdef TCL_TIP280 - /* TIP #280 Structures for tracking lines. - * As we know that this is dynamic execution we ignore the - * invoker, even if known. - */ - CmdFrame eoFrame; - - eoFrame.type = TCL_LOCATION_EVAL_LIST; - eoFrame.level = (iPtr->cmdFramePtr == NULL ? - 1 : - iPtr->cmdFramePtr->level + 1); - eoFrame.framePtr = iPtr->framePtr; - eoFrame.nextPtr = iPtr->cmdFramePtr; - eoFrame.nline = 0; - eoFrame.line = NULL; - - /* NOTE: Getting the string rep of the list to eval to fill the - * command information required by 'info frame' implies that - * further calls for the same list would not be optimized, as it - * would not be 'pure' anymore. It would also be a waste of time - * as most of the time this information is not needed at all. What - * we do instead is to keep the list obj itself around and have - * 'info frame' sort it out. - */ - eoFrame.cmd.listPtr = objPtr; - Tcl_IncrRefCount (eoFrame.cmd.listPtr); - eoFrame.data.eval.path = NULL; -#endif - if (objc > TEOE_PREALLOC) { - objv = (Tcl_Obj **) ckalloc(objc*sizeof(Tcl_Obj *)); - } -#undef TEOE_PREALLOC - /* - * Copy the list elements here, to avoid a segfault if - * objPtr loses its List internal rep [Bug 1119369]. - * - * TIP #280 We do _not_ compute all the line numbers for the words - * in the command. For the eval of a pure list the most sensible - * choice is to put all words on line 1. Given that we neither - * need memory for them nor compute anything. 'line' is left - * NULL. The two places using this information (TclInfoFrame, and - * TclInitCompileEnv), are special-cased to use the proper line - * number directly instead of accessing the 'line' array. - */ + ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr; + ContLineLoc* clLocPtr = TclContinuationsGet (objPtr); - for (i=0; i < objc; i++) { - objv[i] = listRepPtr->elements[i]; - Tcl_IncrRefCount(objv[i]); - } + if (clLocPtr) { + iPtr->scriptCLLocPtr = clLocPtr; + Tcl_Preserve (iPtr->scriptCLLocPtr); + } else { + iPtr->scriptCLLocPtr = NULL; + } -#ifdef TCL_TIP280 - iPtr->cmdFramePtr = &eoFrame; -#endif - result = Tcl_EvalObjv(interp, objc, objv, flags); -#ifdef TCL_TIP280 - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; - Tcl_DecrRefCount (eoFrame.cmd.listPtr); -#endif + if (invoker == NULL) { + /* + * No context, force opening of our own. + */ - for (i=0; i < objc; i++) { - TclDecrRefCount(objv[i]); - } - if (objv != staticObjv) { - ckfree((char *) objv); - } -#ifdef TCL_TIP280 - ckfree ((char*) eoFrame.line); - eoFrame.line = NULL; - eoFrame.nline = 0; -#endif - } else { -#ifndef TCL_TIP280 script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); -#else + } else { /* - * TIP #280. Propagate context as much as we can. Especially if - * the script to evaluate is a single literal it makes sense to - * look if our context is one with absolute line numbers we can - * then track into the literal itself too. + * We have an invoker, describing the command asking for the + * evaluation of a subordinate script. This script may originate + * in a literal word, or from a variable, etc. Using the line + * array we now check if we have good line information for the + * relevant word. The type of context is relevant as well. In a + * non-'source' context we don't have to try tracking lines. * - * See also tclCompile.c, TclInitCompileEnv, for the equivalent - * code in the bytecode compiler. + * First see if the word exists and is a literal. If not we go + * through the easy dynamic branch. No need to perform more + * complex invokations. */ - /* - * Now we check if we have data about invisible continuation lines - * for the script, and make it available to the direct script - * parser and evaluator we are about to call, if so. - * - * It may be possible that the script Tcl_Obj* can be free'd while - * the evaluator is using it, leading to the release of the - * associated ContLineLoc structure as well. To ensure that the - * latter doesn't happen we set a lock on it. We release this lock - * later in this function, after the evaluator is done. The - * relevant "lineCLPtr" hashtable is managed in the file - * "tclObj.c". - * - * Another important action is to save (and later restore) the - * continuation line information of the caller, in case we are - * executing nested commands in the eval/direct path. - */ + int pc = 0; + CmdFrame *ctxPtr = (CmdFrame *) + TclStackAlloc(interp, sizeof(CmdFrame)); - ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr; - ContLineLoc* clLocPtr = TclContinuationsGet (objPtr); + *ctxPtr = *invoker; + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctxPtr->data.eval.path is not used. + * ctxPtr->data.tebc.codePtr is used instead. + */ - if (clLocPtr) { - iPtr->scriptCLLocPtr = clLocPtr; - Tcl_Preserve (iPtr->scriptCLLocPtr); - } else { - iPtr->scriptCLLocPtr = NULL; + TclGetSrcInfoForPc(ctxPtr); + pc = 1; } - if (invoker == NULL) { - /* No context, force opening of our own */ - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } else { - /* We have an invoker, describing the command asking for the - * evaluation of a subordinate script. This script may - * originate in a literal word, or from a variable, etc. Using - * the line array we now check if we have good line - * information for the relevant word. The type of context is - * relevant as well. In a non-'source' context we don't have - * to try tracking lines. - * - * First see if the word exists and is a literal. If not we go - * through the easy dynamic branch. No need to perform more - * complex invokations. - */ + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - CmdFrame ctx = *invoker; - int pc = 0; + if ((ctxPtr->nline <= word) || + (ctxPtr->line[word] < 0) || + (ctxPtr->type != TCL_LOCATION_SOURCE)) { + /* + * Dynamic script, or dynamic context, force our own + * context. + */ - if (invoker->type == TCL_LOCATION_BC) { - /* Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr is used instead. - */ - TclGetSrcInfoForPc (&ctx); - pc = 1; - } + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + } else { + /* + * Absolute context to reuse. + */ - if ((ctx.nline <= word) || - (ctx.line[word] < 0) || - (ctx.type != TCL_LOCATION_SOURCE)) { - /* Dynamic script, or dynamic context, force our own - * context */ + iPtr->invokeCmdFramePtr = ctxPtr; + iPtr->evalFlags |= TCL_EVAL_CTX; - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } else { - /* Absolute context available to reuse. */ + result = TclEvalEx(interp, script, numSrcBytes, flags, + ctxPtr->line[word], NULL, script); + } - iPtr->invokeCmdFramePtr = &ctx; - iPtr->evalFlags |= TCL_EVAL_CTX; + if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { + /* + * Death of SrcInfo reference. + */ - result = EvalEx(interp, script, numSrcBytes, flags, - ctx.line [word], NULL, script); - } - if (pc && (ctx.type == TCL_LOCATION_SOURCE)) { - /* Death of SrcInfo reference. */ - Tcl_DecrRefCount(ctx.data.eval.path); - } + Tcl_DecrRefCount(ctxPtr->data.eval.path); } + TclStackFree(interp, ctxPtr); + } - /* - * Now release the lock on the continuation line information, if - * any, and restore the caller's settings. - */ + /* + * Now release the lock on the continuation line information, if + * any, and restore the caller's settings. + */ - if (iPtr->scriptCLLocPtr) { - Tcl_Release (iPtr->scriptCLLocPtr); - } - iPtr->scriptCLLocPtr = saveCLLocPtr; -#endif + if (iPtr->scriptCLLocPtr) { + Tcl_Release (iPtr->scriptCLLocPtr); } + iPtr->scriptCLLocPtr = saveCLLocPtr; } else { /* * Let the compiler/engine subsystem do the evaluation. * - * TIP #280 The invoker provides us with the context for the - * script. We transfer this to the byte code compiler. + * TIP #280 The invoker provides us with the context for the script. + * We transfer this to the byte code compiler. */ + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); savedVarFramePtr = iPtr->varFramePtr; if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = NULL; + iPtr->varFramePtr = iPtr->rootFramePtr; } -#ifndef TCL_TIP280 - result = TclCompEvalObj(interp, objPtr); -#else result = TclCompEvalObj(interp, objPtr, invoker, word); -#endif /* - * 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) - && !allowExceptions) { + if ((result != TCL_OK) && (result != TCL_ERROR) + && !allowExceptions) { ProcessUnexpectedResult(interp, result); result = TCL_ERROR; - - /* - * If an error was created here, record information about - * what was being executed when the error occurred. Remove - * the extra \n added by tclMain.c in the command sent to - * Tcl_LogCommandInfo [Bug 833150]. - */ - - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - Tcl_LogCommandInfo(interp, script, script, --numSrcBytes); - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } } iPtr->evalFlags = 0; - iPtr->varFramePtr = savedVarFramePtr; + iPtr->varFramePtr = savedVarFramePtr; } TclDecrRefCount(objPtr); @@ -5272,39 +5291,37 @@ TclEvalObjEx(interp, objPtr, flags, invoker, word) * * 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. + * Function 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. * *---------------------------------------------------------------------- */ static void -ProcessUnexpectedResult(interp, returnCode) - Tcl_Interp *interp; /* The interpreter in which the unexpected +ProcessUnexpectedResult( + Tcl_Interp *interp, /* The interpreter in which the unexpected * result code was returned. */ - int returnCode; /* The unexpected result code. */ + int returnCode) /* The unexpected result code. */ { Tcl_ResetResult(interp); if (returnCode == TCL_BREAK) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"break\" outside of a loop", -1); + Tcl_AppendResult(interp, + "invoked \"break\" outside of a loop", NULL); } else if (returnCode == TCL_CONTINUE) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"continue\" outside of a loop", -1); + Tcl_AppendResult(interp, + "invoked \"continue\" outside of a loop", NULL); } else { - char buf[30 + TCL_INTEGER_SPACE]; - - sprintf(buf, "command returned bad code: %d", returnCode); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "command returned bad code: %d", returnCode)); } } @@ -5313,15 +5330,15 @@ ProcessUnexpectedResult(interp, returnCode) * * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- * - * Procedures to evaluate an expression and return its value in a + * Functions to evaluate an expression and return its value in a * particular form. * * 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. + * Each of the functions 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. * * Side effects: * None. @@ -5330,197 +5347,92 @@ ProcessUnexpectedResult(interp, returnCode) */ int -Tcl_ExprLong(interp, string, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the +Tcl_ExprLong( + Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - CONST char *string; /* Expression to evaluate. */ - long *ptr; /* Where to store result. */ + const char *exprstring, /* Expression to evaluate. */ + long *ptr) /* Where to store result. */ { register Tcl_Obj *exprPtr; - Tcl_Obj *resultPtr; - int length = strlen(string); int result = TCL_OK; - - if (length > 0) { - exprPtr = Tcl_NewStringObj(string, length); - Tcl_IncrRefCount(exprPtr); - result = Tcl_ExprObj(interp, exprPtr, &resultPtr); - if (result == TCL_OK) { - /* - * Store an integer based on the expression result. - */ - - if (resultPtr->typePtr == &tclIntType) { - *ptr = resultPtr->internalRep.longValue; - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = (long) resultPtr->internalRep.doubleValue; - } else if (resultPtr->typePtr == &tclWideIntType) { -#ifndef TCL_WIDE_INT_IS_LONG - /* - * 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); - } else { - Tcl_SetResult(interp, - "integer value too large to represent as non-long integer", - TCL_STATIC); - result = TCL_ERROR; - } -#else - *ptr = resultPtr->internalRep.longValue; -#endif - } else { - Tcl_SetResult(interp, - "expression didn't have numeric value", TCL_STATIC); - result = TCL_ERROR; - } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ - } else { - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); - } - Tcl_DecrRefCount(exprPtr); /* discard the expression object */ - } else { + if (*exprstring == '\0') { /* - * An empty string. Just set the result integer to 0. + * Legacy compatibility - return 0 for the zero-length string. */ - + *ptr = 0; + } else { + exprPtr = Tcl_NewStringObj(exprstring, -1); + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprLongObj(interp, exprPtr, ptr); + Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } } return result; } int -Tcl_ExprDouble(interp, string, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the +Tcl_ExprDouble( + Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - CONST char *string; /* Expression to evaluate. */ - double *ptr; /* Where to store result. */ + const char *exprstring, /* Expression to evaluate. */ + double *ptr) /* Where to store result. */ { register Tcl_Obj *exprPtr; - Tcl_Obj *resultPtr; - int length = strlen(string); int result = TCL_OK; - if (length > 0) { - exprPtr = Tcl_NewStringObj(string, length); - Tcl_IncrRefCount(exprPtr); - result = Tcl_ExprObj(interp, exprPtr, &resultPtr); - if (result == TCL_OK) { - /* - * Store a double based on the expression result. - */ - - if (resultPtr->typePtr == &tclIntType) { - *ptr = (double) resultPtr->internalRep.longValue; - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = resultPtr->internalRep.doubleValue; - } else if (resultPtr->typePtr == &tclWideIntType) { -#ifndef TCL_WIDE_INT_IS_LONG - /* - * 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); - } else { - Tcl_SetResult(interp, - "integer value too large to represent as non-long integer", - TCL_STATIC); - result = TCL_ERROR; - } -#else - *ptr = (double) resultPtr->internalRep.longValue; -#endif - } else { - Tcl_SetResult(interp, - "expression didn't have numeric value", TCL_STATIC); - result = TCL_ERROR; - } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ - } else { - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); - } - Tcl_DecrRefCount(exprPtr); /* discard the expression object */ - } else { + if (*exprstring == '\0') { /* - * An empty string. Just set the result double to 0.0. + * Legacy compatibility - return 0 for the zero-length string. */ - + *ptr = 0.0; + } else { + exprPtr = Tcl_NewStringObj(exprstring, -1); + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); + Tcl_DecrRefCount(exprPtr); + /* Discard the expression object. */ + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } } return result; } int -Tcl_ExprBoolean(interp, string, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - CONST char *string; /* Expression to evaluate. */ - int *ptr; /* Where to store 0/1 result. */ +Tcl_ExprBoolean( + Tcl_Interp *interp, /* Context in which to evaluate the + * expression. */ + const char *exprstring, /* Expression to evaluate. */ + int *ptr) /* Where to store 0/1 result. */ { - register Tcl_Obj *exprPtr; - Tcl_Obj *resultPtr; - int length = strlen(string); - int result = TCL_OK; + if (*exprstring == '\0') { + /* + * An empty string. Just set the result boolean to 0 (false). + */ - if (length > 0) { - exprPtr = Tcl_NewStringObj(string, length); - Tcl_IncrRefCount(exprPtr); - result = Tcl_ExprObj(interp, exprPtr, &resultPtr); - if (result == TCL_OK) { - /* - * Store a boolean based on the expression result. - */ + *ptr = 0; + return TCL_OK; + } else { + int result; + Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); - if (resultPtr->typePtr == &tclIntType) { - *ptr = (resultPtr->internalRep.longValue != 0); - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = (resultPtr->internalRep.doubleValue != 0.0); - } else if (resultPtr->typePtr == &tclWideIntType) { -#ifndef TCL_WIDE_INT_IS_LONG - *ptr = (resultPtr->internalRep.wideValue != 0); -#else - *ptr = (resultPtr->internalRep.longValue != 0); -#endif - } else { - result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); - } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ - } + 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. */ - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); + (void) Tcl_GetStringResult(interp); } - Tcl_DecrRefCount(exprPtr); /* discard the expression object */ - } else { - /* - * An empty string. Just set the result boolean to 0 (false). - */ - - *ptr = 0; + return result; } - return result; } /* @@ -5528,16 +5440,15 @@ Tcl_ExprBoolean(interp, string, ptr) * * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- * - * Procedures to evaluate an expression in an object and return its - * value in a particular form. + * Functions 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 functions 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. @@ -5546,230 +5457,117 @@ Tcl_ExprBoolean(interp, string, 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_ExprLongObj( + 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; + int result, type; + double d; + ClientData internalPtr; result = Tcl_ExprObj(interp, objPtr, &resultPtr); - if (result == TCL_OK) { - if (resultPtr->typePtr == &tclIntType) { - *ptr = resultPtr->internalRep.longValue; - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = (long) resultPtr->internalRep.doubleValue; - } else { - result = Tcl_GetLongFromObj(interp, resultPtr, ptr); - if (result != TCL_OK) { - return result; - } + if (result != TCL_OK) { + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type) != TCL_OK){ + return TCL_ERROR; + } + + switch (type) { + case TCL_NUMBER_DOUBLE: { + mp_int big; + + d = *((const double *) internalPtr); + Tcl_DecrRefCount(resultPtr); + if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { + return TCL_ERROR; } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ + resultPtr = Tcl_NewBignumObj(&big); + /* FALLTHROUGH */ } + case TCL_NUMBER_LONG: + case TCL_NUMBER_WIDE: + case TCL_NUMBER_BIG: + result = TclGetLongFromObj(interp, resultPtr, ptr); + break; + + case TCL_NUMBER_NAN: + Tcl_GetDoubleFromObj(interp, resultPtr, &d); + result = TCL_ERROR; + } + + Tcl_DecrRefCount(resultPtr);/* Discard the result object. */ return result; } 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_ExprDoubleObj( + 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; + int result, type; + ClientData internalPtr; result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result != TCL_OK) { + return TCL_ERROR; + } + + result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type); if (result == TCL_OK) { - if (resultPtr->typePtr == &tclIntType) { - *ptr = (double) resultPtr->internalRep.longValue; - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = resultPtr->internalRep.doubleValue; - } else { + switch (type) { + case TCL_NUMBER_NAN: +#ifndef ACCEPT_NAN + result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); + break; +#endif + case TCL_NUMBER_DOUBLE: + *ptr = *((const double *) internalPtr); + result = TCL_OK; + break; + default: result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); - if (result != TCL_OK) { - return result; - } } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ } + Tcl_DecrRefCount(resultPtr);/* Discard the result object. */ return result; } 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_ExprBooleanObj( + 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; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result == TCL_OK) { - if (resultPtr->typePtr == &tclIntType) { - *ptr = (resultPtr->internalRep.longValue != 0); - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = (resultPtr->internalRep.doubleValue != 0.0); - } else { - result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); - } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclInvoke -- - * - * Invokes a Tcl command, given an argv/argc, from either the - * exposed or the hidden sets of commands in the given interpreter. - * NOTE: The command is invoked in the current stack frame of - * the interpreter, thus it can modify local variables. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Whatever the command does. - * - *---------------------------------------------------------------------- - */ - -int -TclInvoke(interp, argc, argv, flags) - Tcl_Interp *interp; /* Where to invoke the command. */ - int argc; /* Count of args. */ - register CONST char **argv; /* The arg strings; argv[0] is the name of - * the command to invoke. */ - int flags; /* Combination of flags controlling the - * call: TCL_INVOKE_HIDDEN and - * TCL_INVOKE_NO_UNKNOWN. */ -{ - register Tcl_Obj *objPtr; - register int i; - int length, result; - - /* - * This procedure generates an objv array for object arguments that hold - * the argv strings. It starts out with stack-allocated space but uses - * dynamically-allocated storage if needed. - */ - -#define NUM_ARGS 20 - Tcl_Obj *(objStorage[NUM_ARGS]); - register Tcl_Obj **objv = objStorage; - - /* - * 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 + 1) > NUM_ARGS) { - objv = (Tcl_Obj **) - ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); - } - - for (i = 0; i < argc; i++) { - length = strlen(argv[i]); - objv[i] = Tcl_NewStringObj(argv[i], length); - Tcl_IncrRefCount(objv[i]); - } - objv[argc] = 0; - - /* - * Use TclObjInterpProc to actually invoke the command. - */ - - result = TclObjInvoke(interp, argc, objv, flags); - - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); - - /* - * Decrement the ref counts on the objv elements since we are done - * with them. - */ - - for (i = 0; i < argc; i++) { - objPtr = objv[i]; - Tcl_DecrRefCount(objPtr); - } - - /* - * Free the objv array if malloc'ed storage was used. - */ - - if (objv != objStorage) { - ckfree((char *) objv); + result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); + Tcl_DecrRefCount(resultPtr); + /* Discard the result object. */ } return result; -#undef NUM_ARGS -} - -/* - *---------------------------------------------------------------------- - * - * TclGlobalInvoke -- - * - * Invokes a Tcl command, given an argv/argc, from either the - * exposed or hidden sets of commands in the given interpreter. - * NOTE: The command is invoked in the global stack frame of - * the interpreter, thus it cannot see any current state on - * the stack for that interpreter. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Whatever the command does. - * - *---------------------------------------------------------------------- - */ - -int -TclGlobalInvoke(interp, argc, argv, flags) - Tcl_Interp *interp; /* Where to invoke the command. */ - int argc; /* Count of args. */ - register CONST char **argv; /* The arg strings; argv[0] is the name of - * the command to invoke. */ - int flags; /* Combination of flags controlling the - * call: TCL_INVOKE_HIDDEN and - * TCL_INVOKE_NO_UNKNOWN. */ -{ - register Interp *iPtr = (Interp *) interp; - int result; - CallFrame *savedVarFramePtr; - - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = NULL; - result = TclInvoke(interp, argc, argv, flags); - iPtr->varFramePtr = savedVarFramePtr; - return result; } /* *---------------------------------------------------------------------- * - * TclObjInvokeGlobal -- + * 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, thus it cannot see any current state on the + * interpreter or namespace, thus it cannot see any current state on the * stack of that interpreter. * * Results: @@ -5782,25 +5580,33 @@ TclGlobalInvoke(interp, argc, argv, flags) */ int -TclObjInvokeGlobal(interp, objc, objv, flags) - Tcl_Interp *interp; /* Interpreter in which command is to be +TclObjInvokeNamespace( + Tcl_Interp *interp, /* Interpreter in which command is to be * invoked. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the + 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. */ + 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. */ { - register Interp *iPtr = (Interp *) interp; int result; - CallFrame *savedVarFramePtr; + Tcl_CallFrame *framePtr; + + /* + * Make the specified namespace the current namespace and invoke the + * command. + */ + + result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0); + if (result != TCL_OK) { + return TCL_ERROR; + } - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = NULL; result = TclObjInvoke(interp, objc, objv, flags); - iPtr->varFramePtr = savedVarFramePtr; + + TclPopStackFrame(interp); return result; } @@ -5809,8 +5615,8 @@ TclObjInvokeGlobal(interp, objc, objv, 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. @@ -5822,165 +5628,77 @@ TclObjInvokeGlobal(interp, objc, objv, flags) */ int -TclObjInvoke(interp, objc, objv, flags) - Tcl_Interp *interp; /* Interpreter in which command is to be +TclObjInvoke( + Tcl_Interp *interp, /* Interpreter in which command is to be * invoked. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the + 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. */ char *cmdName; /* Name of the command from objv[0]. */ - register Tcl_HashEntry *hPtr; - Tcl_Command cmd; + Tcl_HashEntry *hPtr = NULL; Command *cmdPtr; - int localObjc; /* Used to invoke "unknown" if the */ - Tcl_Obj **localObjv = NULL; /* command is not found. */ - register int i; int result; - if (interp == (Tcl_Interp *) NULL) { - return TCL_ERROR; + if (interp == NULL) { + return TCL_ERROR; + } + + if ((objc < 1) || (objv == NULL)) { + Tcl_AppendResult(interp, "illegal argument vector", NULL); + return TCL_ERROR; } - if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "illegal argument vector", -1); - return TCL_ERROR; + if ((flags & TCL_INVOKE_HIDDEN) == 0) { + Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } - cmdName = Tcl_GetString(objv[0]); - if (flags & TCL_INVOKE_HIDDEN) { - /* - * We never invoke "unknown" for hidden commands. - */ - - hPtr = NULL; - hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr; - if (hTblPtr != NULL) { - hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); - } - if (hPtr == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid hidden command name \"", cmdName, "\"", - (char *) NULL); - return TCL_ERROR; - } - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - } else { - cmdPtr = NULL; - cmd = Tcl_FindCommand(interp, cmdName, - (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); - if (cmd != (Tcl_Command) NULL) { - cmdPtr = (Command *) cmd; - } - if (cmdPtr == NULL) { - if (!(flags & TCL_INVOKE_NO_UNKNOWN)) { - cmd = Tcl_FindCommand(interp, "unknown", - (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); - if (cmd != (Tcl_Command) NULL) { - cmdPtr = (Command *) cmd; - } - if (cmdPtr != NULL) { - localObjc = (objc + 1); - localObjv = (Tcl_Obj **) - ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc)); - localObjv[0] = Tcl_NewStringObj("unknown", -1); - Tcl_IncrRefCount(localObjv[0]); - for (i = 0; i < objc; i++) { - localObjv[i+1] = objv[i]; - } - objc = localObjc; - objv = localObjv; - } - } - - /* - * Check again if we found the command. If not, "unknown" is - * not present and we cannot help, or the caller said not to - * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN). - */ - - if (cmdPtr == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", cmdName, "\"", - (char *) NULL); - return TCL_ERROR; - } - } - } - - /* - * Invoke the command procedure. First reset the interpreter's string - * and object results to their default empty values since they could - * have gotten changed by earlier invocations. + if (TclInterpReady(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + cmdName = TclGetString(objv[0]); + hTblPtr = iPtr->hiddenCmdTablePtr; + if (hTblPtr != NULL) { + hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); + } + if (hPtr == NULL) { + Tcl_AppendResult(interp, "invalid hidden command name \"", + cmdName, "\"", NULL); + return TCL_ERROR; + } + cmdPtr = Tcl_GetHashValue(hPtr); + + /* + * Invoke the command function. */ - Tcl_ResetResult(interp); iPtr->cmdCount++; - result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + 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) && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { - Tcl_Obj *msg; - - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - msg = Tcl_NewStringObj("\n while invoking\n\"", -1); - } else { - msg = Tcl_NewStringObj("\n invoked from within\n\"", -1); - } - Tcl_IncrRefCount(msg); - for (i = 0; i < objc; i++) { - CONST char *bytes; - int length; - - Tcl_AppendObjToObj(msg, objv[i]); - bytes = Tcl_GetStringFromObj(msg, &length); - if (length > 100) { - /* - * Back up truncation point so that we don't truncate - * in the middle of a multi-byte character. - */ - length = 100; - while ( (bytes[length] & 0xC0) == 0x80 ) { - length--; - } - Tcl_SetObjLength(msg, length); - Tcl_AppendToObj(msg, "...", -1); - break; - } - if (i != (objc - 1)) { - Tcl_AppendToObj(msg, " ", -1); - } - } - - Tcl_AppendToObj(msg, "\"", -1); - Tcl_AddObjErrorInfo(interp, Tcl_GetString(msg), -1); - Tcl_DecrRefCount(msg); + 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); + Tcl_DecrRefCount(command); iPtr->flags &= ~ERR_ALREADY_LOGGED; } - - /* - * Free any locally allocated storage used to call "unknown". - */ - - if (localObjv != (Tcl_Obj **) NULL) { - Tcl_DecrRefCount(localObjv[0]); - ckfree((char *) localObjv); - } return result; } @@ -5994,413 +5712,81 @@ 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. * *--------------------------------------------------------------------------- */ int -Tcl_ExprString(interp, string) - Tcl_Interp *interp; /* Context in which to evaluate the +Tcl_ExprString( + Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - CONST char *string; /* Expression to evaluate. */ + const char *expr) /* Expression to evaluate. */ { - register Tcl_Obj *exprPtr; - Tcl_Obj *resultPtr; - int length = strlen(string); - char buf[TCL_DOUBLE_SPACE]; - int result = TCL_OK; - - if (length > 0) { - TclNewObj(exprPtr); - TclInitStringRep(exprPtr, string, length); - Tcl_IncrRefCount(exprPtr); + int code = TCL_OK; - result = Tcl_ExprObj(interp, exprPtr, &resultPtr); - if (result == TCL_OK) { - /* - * Set the interpreter's string result from the result object. - */ - - if (resultPtr->typePtr == &tclIntType) { - sprintf(buf, "%ld", resultPtr->internalRep.longValue); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else if (resultPtr->typePtr == &tclDoubleType) { - Tcl_PrintDouble((Tcl_Interp *) NULL, - resultPtr->internalRep.doubleValue, buf); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else { - /* - * Set interpreter's string result from the result object. - */ - - Tcl_SetResult(interp, TclGetString(resultPtr), - TCL_VOLATILE); - } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ - } else { - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); - } - Tcl_DecrRefCount(exprPtr); /* discard the expression object */ - } else { + if (expr[0] == '\0') { /* * An empty string. Just set the interpreter's result to 0. */ - - Tcl_SetResult(interp, "0", TCL_VOLATILE); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateObjTrace -- - * - * Arrange for a procedure to be called to trace command execution. - * - * Results: - * The return value is a token for the trace, which may be passed - * to Tcl_DeleteTrace to eliminate the trace. - * - * Side effects: - * From now on, proc will be called just before a command procedure - * is called to execute a Tcl command. Calls to proc will have the - * following form: - * - * void proc( ClientData clientData, - * Tcl_Interp* interp, - * int level, - * CONST char* command, - * Tcl_Command commandInfo, - * int objc, - * Tcl_Obj *CONST objv[] ); - * - * The 'clientData' and 'interp' arguments to 'proc' will be the - * same as the arguments to Tcl_CreateObjTrace. The 'level' - * argument gives the nesting depth of command interpretation within - * the interpreter. The 'command' argument is the ASCII text of - * the command being evaluated -- before any substitutions are - * performed. The 'commandInfo' argument gives a handle to the - * command procedure that will be evaluated. The 'objc' and 'objv' - * parameters give the parameter vector that will be passed to the - * command procedure. proc does not return a value. - * - * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo - * to change the command procedure or client data for the command - * being evaluated, and these changes will take effect with the - * current evaluation. - * - * The 'level' argument specifies the maximum nesting level of calls - * to be traced. If the execution depth of the interpreter exceeds - * 'level', the trace callback is not executed. - * - * The 'flags' argument is either zero or the value, - * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION - * flag is not present, the bytecode compiler will not generate inline - * code for Tcl's built-in commands. This behavior will have a significant - * impact on performance, but will ensure that all command evaluations are - * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the - * bytecode compiler will have its normal behavior of compiling in-line - * code for some of Tcl's built-in commands. In this case, the tracing - * will be imprecise -- in-line code will not be traced -- but run-time - * performance will be improved. The latter behavior is desired for - * many applications such as profiling of run time. - * - * When the trace is deleted, the 'delProc' procedure will be invoked, - * passing it the original client data. - * - *---------------------------------------------------------------------- - */ -Tcl_Trace -Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc ) - Tcl_Interp* interp; /* Tcl interpreter */ - int level; /* Maximum nesting level */ - int flags; /* Flags, see above */ - Tcl_CmdObjTraceProc* proc; /* Trace callback */ - ClientData clientData; /* Client data for the callback */ - Tcl_CmdObjTraceDeleteProc* delProc; - /* Procedure to call when trace is deleted */ -{ - register Trace *tracePtr; - register Interp *iPtr = (Interp *) interp; - - /* Test if this trace allows inline compilation of commands */ - - if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) { - if (iPtr->tracesForbiddingInline == 0) { - - /* - * When the first trace forbidding inline compilation is - * created, invalidate existing compiled code for this - * interpreter and arrange (by setting the - * DONT_COMPILE_CMDS_INLINE flag) that when compiling new - * code, no commands will be compiled inline (i.e., into - * an inline sequence of instructions). We do this because - * commands that were compiled inline will never result in - * a command trace being called. - */ - - iPtr->compileEpoch++; - iPtr->flags |= DONT_COMPILE_CMDS_INLINE; + 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); + if (code == TCL_OK) { + Tcl_SetObjResult(interp, resultPtr); + Tcl_DecrRefCount(resultPtr); } - iPtr->tracesForbiddingInline++; - } - - tracePtr = (Trace *) ckalloc(sizeof(Trace)); - tracePtr->level = level; - tracePtr->proc = proc; - tracePtr->clientData = clientData; - tracePtr->delProc = delProc; - tracePtr->nextPtr = iPtr->tracePtr; - tracePtr->flags = flags; - iPtr->tracePtr = tracePtr; - - return (Tcl_Trace) tracePtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateTrace -- - * - * Arrange for a procedure to be called to trace command execution. - * - * Results: - * The return value is a token for the trace, which may be passed - * to Tcl_DeleteTrace to eliminate the trace. - * - * Side effects: - * From now on, proc will be called just before a command procedure - * is called to execute a Tcl command. Calls to proc will have the - * following form: - * - * void - * proc(clientData, interp, level, command, cmdProc, cmdClientData, - * argc, argv) - * ClientData clientData; - * Tcl_Interp *interp; - * int level; - * char *command; - * int (*cmdProc)(); - * ClientData cmdClientData; - * int argc; - * char **argv; - * { - * } - * - * The clientData and interp arguments to proc will be the same - * as the corresponding arguments to this procedure. Level gives - * the nesting level of command interpretation for this interpreter - * (0 corresponds to top level). Command gives the ASCII text of - * the raw command, cmdProc and cmdClientData give the procedure that - * will be called to process the command and the ClientData value it - * will receive, and argc and argv give the arguments to the - * command, after any argument parsing and substitution. Proc - * does not return a value. - * - *---------------------------------------------------------------------- - */ -Tcl_Trace -Tcl_CreateTrace(interp, level, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which to create trace. */ - int level; /* Only call proc for commands at nesting - * level<=argument level (1=>top level). */ - Tcl_CmdTraceProc *proc; /* Procedure to call before executing each - * command. */ - ClientData clientData; /* Arbitrary value word to pass to proc. */ -{ - StringTraceData* data; - data = (StringTraceData*) ckalloc( sizeof( *data )); - data->clientData = clientData; - data->proc = proc; - return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc, - (ClientData) data, StringTraceDeleteProc ); -} - -/* - *---------------------------------------------------------------------- - * - * StringTraceProc -- - * - * Invoke a string-based trace procedure from an object-based - * callback. - * - * Results: - * None. - * - * Side effects: - * Whatever the string-based trace procedure does. - * - *---------------------------------------------------------------------- - */ - -static int -StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv ) - ClientData clientData; - Tcl_Interp* interp; - int level; - CONST char* command; - Tcl_Command commandInfo; - int objc; - Tcl_Obj *CONST *objv; -{ - StringTraceData* data = (StringTraceData*) clientData; - Command* cmdPtr = (Command*) commandInfo; - - CONST char** argv; /* Args to pass to string trace proc */ - - int i; + /* + * Force the string rep of the interp result. + */ - /* - * This is a bit messy because we have to emulate the old trace - * interface, which uses strings for everything. - */ - - argv = (CONST char **) ckalloc((unsigned) ( (objc + 1) - * sizeof(CONST char *) )); - for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); + (void) Tcl_GetStringResult(interp); } - argv[objc] = 0; - - /* - * Invoke the command procedure. Note that we cast away const-ness - * on two parameters for compatibility with legacy code; the code - * MUST NOT modify either command or argv. - */ - - ( data->proc )( data->clientData, interp, level, - (char*) command, cmdPtr->proc, cmdPtr->clientData, - objc, argv ); - ckfree( (char*) argv ); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * StringTraceDeleteProc -- - * - * Clean up memory when a string-based trace is deleted. - * - * Results: - * None. - * - * Side effects: - * Allocated memory is returned to the system. - * - *---------------------------------------------------------------------- - */ - -static void -StringTraceDeleteProc( clientData ) - ClientData clientData; -{ - ckfree( (char*) clientData ); + return code; } /* *---------------------------------------------------------------------- * - * Tcl_DeleteTrace -- + * Tcl_AppendObjToErrorInfo -- * - * Remove a trace. + * Add a Tcl_Obj value to the errorInfo field that describes the current + * error. * * Results: * None. * * Side effects: - * From now on there will be no more calls to the procedure given - * in trace. + * 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. * *---------------------------------------------------------------------- */ void -Tcl_DeleteTrace(interp, trace) - Tcl_Interp *interp; /* Interpreter that contains trace. */ - Tcl_Trace trace; /* Token for trace (returned previously by - * Tcl_CreateTrace). */ +Tcl_AppendObjToErrorInfo( + Tcl_Interp *interp, /* Interpreter to which error information + * pertains. */ + Tcl_Obj *objPtr) /* Message to record. */ { - Interp *iPtr = (Interp *) interp; - Trace *prevPtr, *tracePtr = (Trace *) trace; - register Trace **tracePtr2 = &(iPtr->tracePtr); - ActiveInterpTrace *activePtr; - - /* - * Locate the trace entry in the interpreter's trace list, - * and remove it from the list. - */ - - prevPtr = NULL; - while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { - prevPtr = *tracePtr2; - tracePtr2 = &((*tracePtr2)->nextPtr); - } - if (*tracePtr2 == NULL) { - return; - } - (*tracePtr2) = (*tracePtr2)->nextPtr; + int length; + const char *message = TclGetStringFromObj(objPtr, &length); - /* - * The code below makes it possible to delete traces while traces - * are active: it makes sure that the deleted trace won't be - * processed by TclCheckInterpTraces. - */ - - for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { - if (activePtr->nextTracePtr == tracePtr) { - if (activePtr->reverseScan) { - activePtr->nextTracePtr = prevPtr; - } else { - activePtr->nextTracePtr = tracePtr->nextPtr; - } - } - } - - /* - * If the trace forbids bytecode compilation, change the interpreter's - * state. If bytecode compilation is now permitted, flag the fact and - * advance the compilation epoch so that procs will be recompiled to - * take advantage of it. - */ - - if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) { - iPtr->tracesForbiddingInline--; - if (iPtr->tracesForbiddingInline == 0) { - iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; - iPtr->compileEpoch++; - } - } - - /* - * Execute any delete callback. - */ - - if (tracePtr->delProc != NULL) { - (tracePtr->delProc)(tracePtr->clientData); - } - - /* Delete the trace object */ - - Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC); + Tcl_IncrRefCount(objPtr); + Tcl_AddObjErrorInfo(interp, message, length); + Tcl_DecrRefCount(objPtr); } /* @@ -6408,27 +5794,25 @@ Tcl_DeleteTrace(interp, trace) * * Tcl_AddErrorInfo -- * - * Add information to the "errorInfo" variable 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 added to the "errorInfo" variable. - * If Tcl_Eval has been called since the current value of errorInfo - * was set, errorInfo is cleared before adding the new message. - * 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. * *---------------------------------------------------------------------- */ void -Tcl_AddErrorInfo(interp, message) - Tcl_Interp *interp; /* Interpreter to which error information +Tcl_AddErrorInfo( + Tcl_Interp *interp, /* Interpreter to which error information * pertains. */ - CONST char *message; /* Message to record. */ + const char *message) /* Message to record. */ { Tcl_AddObjErrorInfo(interp, message, -1); } @@ -6438,67 +5822,56 @@ Tcl_AddErrorInfo(interp, message) * * Tcl_AddObjErrorInfo -- * - * Add information to the "errorInfo" variable 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 added to the "errorInfo" variable. - * If "length" is negative, use bytes up to the first NULL byte. - * If Tcl_EvalObj has been called since the current value of errorInfo - * was set, errorInfo is cleared before adding the new message. - * 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. * *---------------------------------------------------------------------- */ void -Tcl_AddObjErrorInfo(interp, message, length) - Tcl_Interp *interp; /* Interpreter to which error information +Tcl_AddObjErrorInfo( + Tcl_Interp *interp, /* Interpreter to which error information * pertains. */ - CONST char *message; /* Points to the first byte of an array of + 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; - Tcl_Obj *objPtr; - + /* - * 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->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ - iPtr->flags |= ERR_IN_PROGRESS; + iPtr->flags |= ERR_LEGACY_COPY; + if (iPtr->errorInfo == NULL) { + 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. + */ - if (iPtr->result[0] == 0) { - Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, - iPtr->objResultPtr, TCL_GLOBAL_ONLY); - } else { /* use the string result */ - objPtr = Tcl_NewStringObj(interp->result, -1); - Tcl_IncrRefCount(objPtr); - Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, - objPtr, TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(objPtr); + iPtr->errorInfo = Tcl_NewStringObj(interp->result, -1); + } else { + iPtr->errorInfo = iPtr->objResultPtr; } - - /* - * If the errorCode variable wasn't set by the code that generated - * the error, set it to "NONE". - */ - - if (!(iPtr->flags & ERROR_CODE_SET)) { - objPtr = Tcl_NewStringObj("NONE", -1); - Tcl_IncrRefCount(objPtr); - Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL, - objPtr, TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(objPtr); + Tcl_IncrRefCount(iPtr->errorInfo); + if (!iPtr->errorCode) { + Tcl_SetErrorCode(interp, "NONE", NULL); } } @@ -6507,11 +5880,12 @@ Tcl_AddObjErrorInfo(interp, message, length) */ if (length != 0) { - objPtr = Tcl_NewStringObj(message, length); - Tcl_IncrRefCount(objPtr); - Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, - objPtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); - Tcl_DecrRefCount(objPtr); /* free msg object appended above */ + if (Tcl_IsShared(iPtr->errorInfo)) { + Tcl_DecrRefCount(iPtr->errorInfo); + iPtr->errorInfo = Tcl_DuplicateObj(iPtr->errorInfo); + Tcl_IncrRefCount(iPtr->errorInfo); + } + Tcl_AppendToObj(iPtr->errorInfo, message, length); } } @@ -6520,12 +5894,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. @@ -6534,19 +5908,18 @@ Tcl_AddObjErrorInfo(interp, message, length) */ int -Tcl_VarEvalVA (interp, argList) - Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ - va_list argList; /* Variable argument list. */ +Tcl_VarEvalVA( + Tcl_Interp *interp, /* Interpreter in which to evaluate command. */ + va_list argList) /* Variable argument list. */ { Tcl_DString buf; char *string; 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); @@ -6568,27 +5941,28 @@ 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. * *---------------------------------------------------------------------- */ - /* VARARGS2 */ /* ARGSUSED */ + /* ARGSUSED */ int -Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) +Tcl_VarEval( + Tcl_Interp *interp, + ...) { - Tcl_Interp *interp; va_list argList; int result; - interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + va_start(argList, interp); result = Tcl_VarEvalVA(interp, argList); va_end(argList); @@ -6596,36 +5970,35 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) } /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * Tcl_GlobalEval -- * * 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 functions active), + * just as if an "uplevel #0" command were being executed. * - --------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ int -Tcl_GlobalEval(interp, command) - Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ - CONST char *command; /* Command to evaluate. */ +Tcl_GlobalEval( + Tcl_Interp *interp, /* Interpreter in which to evaluate command. */ + const char *command) /* Command to evaluate. */ { register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr; savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = NULL; + iPtr->varFramePtr = iPtr->rootFramePtr; result = Tcl_Eval(interp, command); iPtr->varFramePtr = savedVarFramePtr; return result; @@ -6636,8 +6009,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. @@ -6649,10 +6022,10 @@ 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_SetRecursionLimit( + Tcl_Interp *interp, /* Interpreter whose nesting limit is to be + * set. */ + int depth) /* New value for maximimum depth. */ { Interp *iPtr = (Interp *) interp; int old; @@ -6669,39 +6042,36 @@ 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. * *---------------------------------------------------------------------- */ void -Tcl_AllowExceptions(interp) - Tcl_Interp *interp; /* Interpreter in which to set flag. */ +Tcl_AllowExceptions( + Tcl_Interp *interp) /* Interpreter in which to set flag. */ { Interp *iPtr = (Interp *) interp; iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; } - /* *---------------------------------------------------------------------- * - * Tcl_GetVersion + * 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. @@ -6713,24 +6083,898 @@ Tcl_AllowExceptions(interp) */ void -Tcl_GetVersion(majorV, minorV, patchLevelV, type) - int *majorV; - int *minorV; - int *patchLevelV; - int *type; +Tcl_GetVersion( + int *majorV, + int *minorV, + int *patchLevelV, + int *type) { if (majorV != NULL) { - *majorV = TCL_MAJOR_VERSION; + *majorV = TCL_MAJOR_VERSION; } if (minorV != NULL) { - *minorV = TCL_MINOR_VERSION; + *minorV = TCL_MINOR_VERSION; } if (patchLevelV != NULL) { - *patchLevelV = TCL_RELEASE_SERIAL; + *patchLevelV = TCL_RELEASE_SERIAL; } if (type != NULL) { - *type = TCL_RELEASE_LEVEL; + *type = TCL_RELEASE_LEVEL; + } +} + +/* + *---------------------------------------------------------------------- + * + * Math Functions -- + * + * This page contains the functions that implement all of the built-in + * math functions for expressions. + * + * Results: + * Each function 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. + * + *---------------------------------------------------------------------- + */ + +static int +ExprCeilFunc( + ClientData clientData, /* Ignored */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter list. */ +{ + int code; + double d; + mp_int big; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big))); + mp_clear(&big); + } else { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d))); + } + return TCL_OK; +} + +static int +ExprFloorFunc( + ClientData clientData, /* Ignored */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter list. */ +{ + int code; + double d; + mp_int big; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big))); + mp_clear(&big); + } else { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d))); + } + return TCL_OK; +} + +static int +ExprIsqrtFunc( + ClientData clientData, /* Ignored */ + Tcl_Interp *interp, /* The interpreter in which to execute. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter list. */ +{ + ClientData ptr; + int type; + double d; + Tcl_WideInt w; + mp_int big; + int exact = 0; /* Flag == 1 if the argument can be + * represented in a double as an exact + * integer. */ + + /* + * Check syntax. + */ + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + /* + * Make sure that the arg is a number. + */ + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + + switch (type) { + case TCL_NUMBER_NAN: + Tcl_GetDoubleFromObj(interp, objv[1], &d); + return TCL_ERROR; + case TCL_NUMBER_DOUBLE: + d = *((const double *) ptr); + if (d < 0) { + goto negarg; + } +#ifdef IEEE_FLOATING_POINT + if (d <= MAX_EXACT) { + exact = 1; + } +#endif + if (!exact) { + if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { + return TCL_ERROR; + } + } + break; + case TCL_NUMBER_BIG: + if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { + return TCL_ERROR; + } + if (SIGN(&big) == MP_NEG) { + mp_clear(&big); + goto negarg; + } + break; + default: + if (Tcl_GetWideIntFromObj(interp, objv[1], &w) != TCL_OK) { + return TCL_ERROR; + } + if (w < 0) { + goto negarg; + } + d = (double) w; +#ifdef IEEE_FLOATING_POINT + if (d < MAX_EXACT) { + exact = 1; + } +#endif + if (!exact) { + Tcl_GetBignumFromObj(interp, objv[1], &big); + } + break; + } + + if (exact) { + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d))); + } else { + mp_int root; + + mp_init(&root); + mp_sqrt(&big, &root); + mp_clear(&big); + Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root)); + } + + return TCL_OK; + + negarg: + Tcl_SetObjResult(interp, + Tcl_NewStringObj("square root of negative argument", -1)); + return TCL_ERROR; +} + +static int +ExprSqrtFunc( + ClientData clientData, /* Ignored */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter list. */ +{ + int code; + double d; + mp_int big; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + if ((d >= 0.0) && TclIsInfinite(d) + && (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) { + mp_int root; + + mp_init(&root); + mp_sqrt(&big, &root); + mp_clear(&big); + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root))); + mp_clear(&root); + } else { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d))); + } + return TCL_OK; +} + +static int +ExprUnaryFunc( + ClientData clientData, /* Contains the address of a function that + * takes one double argument and returns a + * double result. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + int code; + double d; + double (*func)(double) = (double (*)(double)) clientData; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + d = objv[1]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + errno = 0; + return CheckDoubleResult(interp, (*func)(d)); +} + +static int +CheckDoubleResult( + Tcl_Interp *interp, + double dResult) +{ +#ifndef ACCEPT_NAN + if (TclIsNaN(dResult)) { + TclExprFloatError(interp, dResult); + return TCL_ERROR; + } +#endif + if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) { + /* + * When ERANGE signals under/overflow, just accept 0.0 or +/-Inf + */ + } else if (errno != 0) { + /* + * Report other errno values as errors. + */ + + TclExprFloatError(interp, dResult); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); + return TCL_OK; +} + +static int +ExprBinaryFunc( + ClientData clientData, /* Contains the address of a function that + * 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. */ + Tcl_Obj *const *objv) /* Parameter vector. */ +{ + int code; + double d1, d2; + double (*func)(double, double) = (double (*)(double, double)) clientData; + + if (objc != 3) { + MathFuncWrongNumArgs(interp, 3, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + d1 = objv[1]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) { + d2 = objv[2]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + errno = 0; + return CheckDoubleResult(interp, (*func)(d1, d2)); +} + +static int +ExprAbsFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Parameter vector. */ +{ + ClientData ptr; + int type; + mp_int big; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + + if (type == TCL_NUMBER_LONG) { + long l = *((const long *) ptr); + + if (l > (long)0) { + goto unChanged; + } else if (l == (long)0) { + const char *string = objv[1]->bytes; + if (string) { + while (*string != '0') { + if (*string == '-') { + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); + return TCL_OK; + } + string++; + } + } + goto unChanged; + } else if (l == LONG_MIN) { + TclBNInitBignumFromLong(&big, l); + goto tooLarge; + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); + return TCL_OK; + } + + if (type == TCL_NUMBER_DOUBLE) { + double d = *((const double *) ptr); + static const double poszero = 0.0; + + /* We need to distinguish here between positive 0.0 and + * negative -0.0, see Bug ID #2954959. + */ + if (d == -0.0) { + if (!memcmp(&d, &poszero, sizeof(double))) { + goto unChanged; + } + } else { + if (d > -0.0) { + goto unChanged; + } + } + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); + return TCL_OK; + } + +#ifndef NO_WIDE_TYPE + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt w = *((const Tcl_WideInt *) ptr); + + if (w >= (Tcl_WideInt)0) { + goto unChanged; + } + if (w == LLONG_MIN) { + TclBNInitBignumFromWideInt(&big, w); + goto tooLarge; + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); + return TCL_OK; + } +#endif + + if (type == TCL_NUMBER_BIG) { + /* TODO: const correctness ? */ + if (mp_cmp_d((mp_int *) ptr, 0) == MP_LT) { + Tcl_GetBignumFromObj(NULL, objv[1], &big); + tooLarge: + mp_neg(&big, &big); + Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); + } else { + unChanged: + Tcl_SetObjResult(interp, objv[1]); + } + return TCL_OK; + } + + if (type == TCL_NUMBER_NAN) { +#ifdef ACCEPT_NAN + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; +#else + double d; + Tcl_GetDoubleFromObj(interp, objv[1], &d); + return TCL_ERROR; +#endif + } + return TCL_OK; +} + +static int +ExprBoolFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + int value; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[1], &value) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +static int +ExprDoubleFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + double dResult; + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { +#ifdef ACCEPT_NAN + if (objv[1]->typePtr == &tclDoubleType) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +#endif + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); + return TCL_OK; +} + +static int +ExprEntierFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + double d; + int type; + ClientData ptr; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + + if (type == TCL_NUMBER_DOUBLE) { + d = *((const double *) ptr); + if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) { + mp_int big; + + if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { + /* Infinity */ + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); + return TCL_OK; + } else { + long result = (long) d; + + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + return TCL_OK; + } + } + + if (type != TCL_NUMBER_NAN) { + /* + * All integers are already of integer type. + */ + + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + + /* + * Get the error message for NaN. + */ + + Tcl_GetDoubleFromObj(interp, objv[1], &d); + return TCL_ERROR; +} + +static int +ExprIntFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + long iResult; + Tcl_Obj *objPtr; + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { + return TCL_ERROR; } + objPtr = Tcl_GetObjResult(interp); + if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) { + /* + * Truncate the bignum; keep only bits in long range. + */ + + mp_int big; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetLongFromObj(NULL, objPtr, &iResult); + Tcl_DecrRefCount(objPtr); + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); + return TCL_OK; +} + +static int +ExprWideFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + Tcl_WideInt wResult; + Tcl_Obj *objPtr; + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { + return TCL_ERROR; + } + objPtr = Tcl_GetObjResult(interp); + if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { + /* + * Truncate the bignum; keep only bits in wide int range. + */ + + mp_int big; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + Tcl_GetWideIntFromObj(NULL, objPtr, &wResult); + Tcl_DecrRefCount(objPtr); + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); + return TCL_OK; +} + +static int +ExprRandFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + Interp *iPtr = (Interp *) interp; + double dResult; + long tmp; /* Algorithm assumes at least 32 bits. Only + * long guarantees that. See below. */ + Tcl_Obj *oResult; + + if (objc != 1) { + MathFuncWrongNumArgs(interp, 1, objc, objv); + return TCL_ERROR; + } + + 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) + */ + + iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); + + /* + * Make sure 1 <= randSeed <= (2^31) - 2. See below. + */ + + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed ^= 123459876; + } + } + + /* + * 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. + * + * In order to avoid potential problems with integer overflow, the + * 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. + * + * For more details on how this algorithm works, refer to the following + * papers: + * + * 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. + */ + +#define RAND_IA 16807 +#define RAND_IM 2147483647 +#define RAND_IQ 127773 +#define RAND_IR 2836 +#define RAND_MASK 123459876 + + tmp = iPtr->randSeed/RAND_IQ; + iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; + if (iPtr->randSeed < 0) { + iPtr->randSeed += RAND_IM; + } + + /* + * Since the recurrence keeps seed values in the range [1, RAND_IM - 1], + * dividing by RAND_IM yields a double in the range (0, 1). + */ + + dResult = iPtr->randSeed * (1.0/RAND_IM); + + /* + * Push a Tcl object with the result. + */ + + TclNewDoubleObj(oResult, dResult); + Tcl_SetObjResult(interp, oResult); + return TCL_OK; +} + +static int +ExprRoundFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Parameter vector. */ +{ + double d; + ClientData ptr; + int type; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + + if (type == TCL_NUMBER_DOUBLE) { + double fractPart, intPart; + long max = LONG_MAX, min = LONG_MIN; + + fractPart = modf(*((const double *) ptr), &intPart); + if (fractPart <= -0.5) { + min++; + } else if (fractPart >= 0.5) { + max--; + } + if ((intPart >= (double)max) || (intPart <= (double)min)) { + mp_int big; + + if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) { + /* Infinity */ + return TCL_ERROR; + } + if (fractPart <= -0.5) { + mp_sub_d(&big, 1, &big); + } else if (fractPart >= 0.5) { + mp_add_d(&big, 1, &big); + } + Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); + return TCL_OK; + } else { + long result = (long)intPart; + + if (fractPart <= -0.5) { + result--; + } else if (fractPart >= 0.5) { + result++; + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + return TCL_OK; + } + } + + if (type != TCL_NUMBER_NAN) { + /* + * All integers are already rounded + */ + + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + + /* + * Get the error message for NaN. + */ + + Tcl_GetDoubleFromObj(interp, objv[1], &d); + return TCL_ERROR; +} + +static int +ExprSrandFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Parameter vector. */ +{ + Interp *iPtr = (Interp *) interp; + long i = 0; /* Initialized to avoid compiler warning. */ + + /* + * Convert argument and use it to reset the seed. + */ + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) { + Tcl_Obj *objPtr; + mp_int big; + + if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { + /* TODO: more ::errorInfo here? or in caller? */ + return TCL_ERROR; + } + + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetLongFromObj(NULL, objPtr, &i); + Tcl_DecrRefCount(objPtr); + } + + /* + * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in + * ExprRandFunc() for more details. + */ + + iPtr->flags |= RAND_SEED_INITIALIZED; + iPtr->randSeed = i; + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed ^= 123459876; + } + + /* + * 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); +} + +/* + *---------------------------------------------------------------------- + * + * MathFuncWrongNumArgs -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static void +MathFuncWrongNumArgs( + Tcl_Interp *interp, /* Tcl interpreter */ + int expected, /* Formal parameter count. */ + int found, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + const char *name = Tcl_GetString(objv[0]); + const char *tail = name + strlen(name); + + while (tail > name+1) { + --tail; + if (*tail == ':' && tail[-1] == ':') { + name = tail+1; + break; + } + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "too %s arguments for math function \"%s\"", + (found < expected ? "few" : "many"), name)); } #ifdef USE_DTRACE @@ -6755,7 +6999,7 @@ DTraceObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { if (TCL_DTRACE_TCL_PROBE_ENABLED()) { char *a[10]; @@ -6769,6 +7013,60 @@ DTraceObjCmd( } return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TclDTraceInfo -- + * + * Extract information from a TIP280 dict for use by DTrace probes. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclDTraceInfo( + Tcl_Obj *info, + char **args, + int *argsi) +{ + static Tcl_Obj *keys[7] = { NULL }; + Tcl_Obj **k = keys, *val; + int i; + + if (!*k) { + TclNewLiteralStringObj(keys[0], "cmd"); + TclNewLiteralStringObj(keys[1], "type"); + TclNewLiteralStringObj(keys[2], "proc"); + TclNewLiteralStringObj(keys[3], "file"); + TclNewLiteralStringObj(keys[4], "lambda"); + TclNewLiteralStringObj(keys[5], "line"); + TclNewLiteralStringObj(keys[6], "level"); + } + for (i = 0; i < 4; i++) { + Tcl_DictObjGet(NULL, info, *k++, &val); + args[i] = val ? TclGetString(val) : NULL; + } + if (!args[2]) { + Tcl_DictObjGet(NULL, info, *k, &val); + args[2] = val ? TclGetString(val) : NULL; + } + k++; + for (i = 0; i < 2; i++) { + Tcl_DictObjGet(NULL, info, *k++, &val); + if (val) { + TclGetIntFromObj(NULL, val, &(argsi[i])); + } else { + argsi[i] = 0; + } + } +} TCL_DTRACE_DEBUG_LOG() |