summaryrefslogtreecommitdiffstats
path: root/generic/tclBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r--generic/tclBasic.c7566
1 files changed, 3931 insertions, 3635 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 134deac..5779ca5 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;
}
@@ -4924,17 +4991,17 @@ Tcl_Eval(interp, string)
*/
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);
}
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 +5012,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 +5289,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 +5328,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 +5345,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 +5438,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 +5455,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 +5578,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 +5613,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 +5626,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 +5710,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 +5792,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 +5820,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 +5878,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 +5892,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 +5906,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 +5939,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 +5968,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 +6007,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 +6020,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 +6040,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 +6081,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 +6997,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 +7011,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()