diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 6869 |
1 files changed, 1755 insertions, 5114 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 02607a4..44cf543 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5,102 +5,22 @@ * including interpreter creation and deletion, command creation and * deletion, and command/script execution. * - * Copyright © 1987-1994 The Regents of the University of California. - * Copyright © 1994-1997 Sun Microsystems, Inc. - * Copyright © 1998-1999 Scriptics Corporation. - * Copyright © 2001, 2002 Kevin B. Kenny. All rights reserved. - * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> - * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. - * Copyright © 2008 Miguel Sofer <msofer@users.sourceforge.net> + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. + * 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. */ #include "tclInt.h" -#include "tclOOInt.h" #include "tclCompile.h" -#include "tclTomMath.h" -#include <math.h> -#include <assert.h> - -/* - * TCL_FPCLASSIFY_MODE: - * 0 - fpclassify - * 1 - _fpclass - * 2 - simulate - * 3 - __builtin_fpclassify - */ - -#ifndef TCL_FPCLASSIFY_MODE -#if defined(__MINGW32__) && defined(_X86_) /* mingw 32-bit */ -/* - * MINGW x86 (tested up to gcc 8.1) seems to have a bug in fpclassify, - * [fpclassify 1e-314], x86 => normal, x64 => subnormal, so switch to using a - * version using a compiler built-in. - */ -#define TCL_FPCLASSIFY_MODE 1 -#elif defined(fpclassify) /* fpclassify */ -/* - * This is the C99 standard. - */ #include <float.h> -#define TCL_FPCLASSIFY_MODE 0 -#elif defined(_FPCLASS_NN) /* _fpclass */ -/* - * This case handles newer MSVC on Windows, which doesn't have the standard - * operation but does have something that can tell us the same thing. - */ -#define TCL_FPCLASSIFY_MODE 1 -#else /* !fpclassify && !_fpclass (older MSVC), simulate */ -/* - * Older MSVC on Windows. So broken that we just have to do it our way. This - * assumes that we're on x86 (or at least a system with classic little-endian - * double layout and a 32-bit 'int' type). - */ -#define TCL_FPCLASSIFY_MODE 2 -#endif /* !fpclassify */ -/* actually there is no fallback to builtin fpclassify */ -#endif /* !TCL_FPCLASSIFY_MODE */ - - -/* - * Bug 7371b6270b: to check C call stack depth, prefer an approach which is - * compatible with AddressSanitizer (ASan) use-after-return detection. - */ - -#if defined(_MSC_VER) && defined(HAVE_INTRIN_H) -#include <intrin.h> /* for _AddressOfReturnAddress() */ -#endif - -/* - * As suggested by - * https://clang.llvm.org/docs/LanguageExtensions.html#has-builtin - */ -#ifndef __has_builtin -#define __has_builtin(x) 0 /* for non-clang compilers */ -#endif - -void * -TclGetCStackPtr(void) -{ -#if defined( __GNUC__ ) || __has_builtin(__builtin_frame_address) - return __builtin_frame_address(0); -#elif defined(_MSC_VER) && defined(HAVE_INTRIN_H) - return _AddressOfReturnAddress(); -#else - ptrdiff_t unused = 0; - /* - * LLVM recommends using volatile: - * https://github.com/llvm/llvm-project/blob/llvmorg-10.0.0-rc1/clang/lib/Basic/Stack.cpp#L31 - */ - ptrdiff_t *volatile stackLevel = &unused; - return (void *)stackLevel; -#endif -} - -#define INTERP_STACK_INITIAL_SIZE 2000 -#define CORO_STACK_INITIAL_SIZE 200 +#include <limits.h> +#include <math.h> +#include "tommath.h" /* * Determine whether we're using IEEE floating point @@ -121,159 +41,63 @@ typedef struct OldMathFuncData { Tcl_MathProc *proc; /* Handler function */ int numArgs; /* Number of args expected */ Tcl_ValueType *argTypes; /* Types of the args */ - void *clientData; /* Client data for the handler function */ + ClientData clientData; /* Client data for the handler function */ } OldMathFuncData; /* - * This is the script cancellation struct and hash table. The hash table is - * used to keep track of the information necessary to process script - * cancellation requests, including the original interp, asynchronous handler - * tokens (created by Tcl_AsyncCreate), and the clientData and flags arguments - * passed to Tcl_CancelEval on a per-interp basis. The cancelLock mutex is - * used for protecting calls to Tcl_CancelEval as well as protecting access to - * the hash table below. - */ - -typedef struct { - Tcl_Interp *interp; /* Interp this struct belongs to. */ - Tcl_AsyncHandler async; /* Async handler token for script - * cancellation. */ - char *result; /* The script cancellation result or NULL for - * a default result. */ - Tcl_Size length; /* Length of the above error message. */ - void *clientData; /* Not used. */ - int flags; /* Additional flags */ -} CancelInfo; -static Tcl_HashTable cancelTable; -static int cancelTableInitialized = 0; /* 0 means not yet initialized. */ -TCL_DECLARE_MUTEX(cancelLock); - -/* - * Table used to map command implementation functions to a human-readable type - * name, for [info type]. The keys in the table are function addresses, and - * the values in the table are static char* containing strings in Tcl's - * internal encoding (almost UTF-8). - */ - -static Tcl_HashTable commandTypeTable; -static int commandTypeInit = 0; -TCL_DECLARE_MUTEX(commandTypeLock); - -/* - * Declarations for managing contexts for non-recursive coroutines. Contexts - * are used to save the evaluation state between NR calls to each coro. - */ - -#define SAVE_CONTEXT(context) \ - (context).framePtr = iPtr->framePtr; \ - (context).varFramePtr = iPtr->varFramePtr; \ - (context).cmdFramePtr = iPtr->cmdFramePtr; \ - (context).lineLABCPtr = iPtr->lineLABCPtr - -#define RESTORE_CONTEXT(context) \ - iPtr->framePtr = (context).framePtr; \ - iPtr->varFramePtr = (context).varFramePtr; \ - iPtr->cmdFramePtr = (context).cmdFramePtr; \ - iPtr->lineLABCPtr = (context).lineLABCPtr - -/* * Static functions in this file: */ -static Tcl_ObjCmdProc BadEnsembleSubcommand; -static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, - const char *oldName, const char *newName, - int flags); -static int CancelEvalProc(void *clientData, - Tcl_Interp *interp, int code); -static int CheckDoubleResult(Tcl_Interp *interp, double dResult); -static void DeleteCoroutine(void *clientData); -static Tcl_FreeProc DeleteInterpProc; -static void DeleteOpCmdClientData(void *clientData); +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 Tcl_ObjCmdProc DTraceObjCmd; -static Tcl_NRPostProc DTraceCmdReturn; -#else -# define DTraceCmdReturn NULL -#endif /* USE_DTRACE */ -static Tcl_ObjCmdProc ExprAbsFunc; -static Tcl_ObjCmdProc ExprBinaryFunc; -static Tcl_ObjCmdProc ExprBoolFunc; -static Tcl_ObjCmdProc ExprCeilFunc; -static Tcl_ObjCmdProc ExprDoubleFunc; -static Tcl_ObjCmdProc ExprFloorFunc; -static Tcl_ObjCmdProc ExprIntFunc; -static Tcl_ObjCmdProc ExprIsqrtFunc; -static Tcl_ObjCmdProc ExprIsFiniteFunc; -static Tcl_ObjCmdProc ExprIsInfinityFunc; -static Tcl_ObjCmdProc ExprIsNaNFunc; -static Tcl_ObjCmdProc ExprIsNormalFunc; -static Tcl_ObjCmdProc ExprIsSubnormalFunc; -static Tcl_ObjCmdProc ExprIsUnorderedFunc; -static Tcl_ObjCmdProc ExprMaxFunc; -static Tcl_ObjCmdProc ExprMinFunc; -static Tcl_ObjCmdProc ExprRandFunc; -static Tcl_ObjCmdProc ExprRoundFunc; -static Tcl_ObjCmdProc ExprSqrtFunc; -static Tcl_ObjCmdProc ExprSrandFunc; -static Tcl_ObjCmdProc ExprUnaryFunc; -static Tcl_ObjCmdProc ExprWideFunc; -static Tcl_ObjCmdProc FloatClassifyObjCmd; -static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, - int actual, Tcl_Obj *const *objv); -static Tcl_NRPostProc NRCoroutineCallerCallback; -static Tcl_NRPostProc NRCoroutineExitCallback; -static Tcl_NRPostProc NRCommand; - -#if !defined(TCL_NO_DEPRECATED) -static Tcl_ObjCmdProc OldMathFuncProc; -static void OldMathFuncDeleteProc(void *clientData); -#endif /* !defined(TCL_NO_DEPRECATED) */ -static void ProcessUnexpectedResult(Tcl_Interp *interp, - int returnCode); -static int RewindCoroutine(CoroutineData *corPtr, int result); -static void TEOV_SwitchVarFrame(Tcl_Interp *interp); -static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, - Tcl_Size objc, Tcl_Obj *const objv[], int flags); -static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, - Tcl_Obj *namePtr, Namespace *lookupNsPtr); -static int TEOV_NotFound(Tcl_Interp *interp, Tcl_Size objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); -static int TEOV_RunEnterTraces(Tcl_Interp *interp, - Command **cmdPtrPtr, Tcl_Obj *commandPtr, Tcl_Size objc, - Tcl_Obj *const objv[]); -static Tcl_NRPostProc RewindCoroutineCallback; -static Tcl_NRPostProc TEOEx_ByteCodeCallback; -static Tcl_NRPostProc TEOEx_ListCallback; -static Tcl_NRPostProc TEOV_Error; -static Tcl_NRPostProc TEOV_Exception; -static Tcl_NRPostProc TEOV_NotFoundCallback; -static Tcl_NRPostProc TEOV_RestoreVarFrame; -static Tcl_NRPostProc TEOV_RunLeaveTraces; -static Tcl_NRPostProc EvalObjvCore; -static Tcl_NRPostProc Dispatch; - -static Tcl_ObjCmdProc NRInjectObjCmd; -static Tcl_NRPostProc NRPostInvoke; -static Tcl_ObjCmdProc CoroTypeObjCmd; -static Tcl_ObjCmdProc TclNRCoroInjectObjCmd; -static Tcl_ObjCmdProc TclNRCoroProbeObjCmd; -static Tcl_NRPostProc InjectHandler; -static Tcl_NRPostProc InjectHandlerPostCall; - -MODULE_SCOPE const TclStubs tclStubs; - -/* - * Magical counts for the number of arguments accepted by a coroutine command - * after particular kinds of [yield]. - */ +static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +#endif -#define CORO_ACTIVATE_YIELD NULL -#define CORO_ACTIVATE_YIELDM INT2PTR(1) +extern TclStubs tclStubs; -#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) -#define COROUTINE_ARGUMENTS_ARBITRARY (-2) - /* * The following structure define the commands in the Tcl core. */ @@ -282,35 +106,11 @@ 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. */ - Tcl_ObjCmdProc *nreProc; /* NR-based function for command */ - int flags; /* Various flag bits, as defined below. */ + int isSafe; /* If non-zero, command will be present in + * safe interpreter. Otherwise it will be + * hidden. */ } CmdInfo; -#define CMD_IS_SAFE 1 /* Whether this command is part of the set of - * commands present by default in a safe - * interpreter. */ -/* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle - * expansion for itself rather than needing the generic layer to take care of - * it for it. Defined in tclInt.h. */ - -/* - * The following struct states that the command it talks about (a subcommand - * of one of Tcl's built-in ensembles) is unsafe and must be hidden when an - * interpreter is made safe. (TclHideUnsafeCommands accesses an array of these - * structs.) Alas, we can't sensibly just store the information directly in - * the commands. - */ - -typedef struct { - const char *ensembleNsName; /* The ensemble's name within ::tcl. NULL for - * the end of the list of commands to hide. */ - const char *commandName; /* The name of the command within the - * ensemble. If this is NULL, we want to also - * make the overall command be hidden, an ugly - * hack because it is expected by security - * policies in the wild. */ -} UnsafeEnsembleInfo; - /* * The built-in commands, and the functions that implement them: */ @@ -320,166 +120,93 @@ static const CmdInfo builtInCmds[] = { * Commands in the generic core. */ - {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, - {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, - {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"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, TclNRCatchObjCmd, CMD_IS_SAFE}, - {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, - {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, - {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, - {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, - {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, - {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, - {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE}, - {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, CMD_IS_SAFE}, - {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE}, - {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE}, - {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE}, - {"fpclassify", FloatClassifyObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE}, - {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, - {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, - {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, - {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, - {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, - {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, - {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, - {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, - {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, - {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, - {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, - {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, - {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, - {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, - {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, - {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, CMD_IS_SAFE}, - {"scan", Tcl_ScanObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, CMD_IS_SAFE}, - {"split", Tcl_SplitObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, CMD_IS_SAFE}, - {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, CMD_IS_SAFE}, - {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, CMD_IS_SAFE}, - {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, CMD_IS_SAFE}, - {"trace", Tcl_TraceObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, CMD_IS_SAFE}, - {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, CMD_IS_SAFE}, - {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, CMD_IS_SAFE}, - {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, CMD_IS_SAFE}, - {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, - {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, - {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, - {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE}, + {"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, NULL, CMD_IS_SAFE}, - {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, - {"close", Tcl_CloseObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"eof", Tcl_EofObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"exec", Tcl_ExecObjCmd, NULL, NULL, 0}, - {"exit", Tcl_ExitObjCmd, NULL, NULL, 0}, - {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, - {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"flush", Tcl_FlushObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"gets", Tcl_GetsObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"glob", Tcl_GlobObjCmd, NULL, NULL, 0}, - {"load", Tcl_LoadObjCmd, NULL, NULL, 0}, - {"open", Tcl_OpenObjCmd, NULL, NULL, 0}, - {"pid", Tcl_PidObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"puts", Tcl_PutsObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"pwd", Tcl_PwdObjCmd, NULL, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"seek", Tcl_SeekObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"socket", Tcl_SocketObjCmd, NULL, NULL, 0}, - {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, - {"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, - {"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE}, - {NULL, NULL, NULL, NULL, 0} -}; - -/* - * Information about which pieces of ensembles to hide when making an - * interpreter safe: - */ - -static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = { - /* [encoding] has two unsafe commands. Assumed by older security policies - * to be overall unsafe; it isn't but... */ - {"encoding", NULL}, - {"encoding", "dirs"}, - {"encoding", "system"}, - /* [file] has MANY unsafe commands! Assumed by older security policies to - * be overall unsafe; it isn't but... */ - {"file", NULL}, - {"file", "atime"}, - {"file", "attributes"}, - {"file", "copy"}, - {"file", "delete"}, - {"file", "dirname"}, - {"file", "executable"}, - {"file", "exists"}, - {"file", "extension"}, - {"file", "isdirectory"}, - {"file", "isfile"}, - {"file", "link"}, - {"file", "lstat"}, - {"file", "mtime"}, - {"file", "mkdir"}, - {"file", "nativename"}, - {"file", "normalize"}, - {"file", "owned"}, - {"file", "readable"}, - {"file", "readlink"}, - {"file", "rename"}, - {"file", "rootname"}, - {"file", "size"}, - {"file", "stat"}, - {"file", "tail"}, - {"file", "tempdir"}, - {"file", "tempfile"}, - {"file", "type"}, - {"file", "volumes"}, - {"file", "writable"}, - /* [info] has two unsafe commands */ - {"info", "cmdtype"}, - {"info", "nameofexecutable"}, - /* [tcl::process] has ONLY unsafe commands! */ - {"process", "list"}, - {"process", "status"}, - {"process", "purge"}, - {"process", "autopurge"}, - /* [zipfs] has MANY unsafe commands! */ - {"zipfs", "lmkimg"}, - {"zipfs", "lmkzip"}, - {"zipfs", "mkimg"}, - {"zipfs", "mkkey"}, - {"zipfs", "mkzip"}, - {"zipfs", "mount"}, - {"zipfs", "mount_data"}, - {"zipfs", "unmount"}, - {NULL, NULL} + {"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} }; /* @@ -488,48 +215,40 @@ static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = { typedef struct { const char *name; /* Name of the function. The full name is - * "::tcl::mathfunc::<name>". */ + * "::tcl::mathfunc::<name>". */ Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */ - double (*fn)(double x); /* Real function pointer */ + ClientData clientData; /* Client data for the function */ } BuiltinFuncDef; static const BuiltinFuncDef BuiltinFuncTable[] = { - { "abs", ExprAbsFunc, NULL }, - { "acos", ExprUnaryFunc, acos }, - { "asin", ExprUnaryFunc, asin }, - { "atan", ExprUnaryFunc, atan }, - { "atan2", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) atan2}, + { "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, cos }, - { "cosh", ExprUnaryFunc, cosh }, + { "ceil", ExprCeilFunc, NULL }, + { "cos", ExprUnaryFunc, (ClientData) cos }, + { "cosh", ExprUnaryFunc, (ClientData) cosh }, { "double", ExprDoubleFunc, NULL }, - { "entier", ExprIntFunc, NULL }, - { "exp", ExprUnaryFunc, exp }, - { "floor", ExprFloorFunc, NULL }, - { "fmod", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) fmod}, - { "hypot", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) hypot}, + { "entier", ExprEntierFunc, NULL }, + { "exp", ExprUnaryFunc, (ClientData) exp }, + { "floor", ExprFloorFunc, NULL }, + { "fmod", ExprBinaryFunc, (ClientData) fmod }, + { "hypot", ExprBinaryFunc, (ClientData) hypot }, { "int", ExprIntFunc, NULL }, - { "isfinite", ExprIsFiniteFunc, NULL }, - { "isinf", ExprIsInfinityFunc, NULL }, - { "isnan", ExprIsNaNFunc, NULL }, - { "isnormal", ExprIsNormalFunc, NULL }, { "isqrt", ExprIsqrtFunc, NULL }, - { "issubnormal", ExprIsSubnormalFunc, NULL, }, - { "isunordered", ExprIsUnorderedFunc, NULL, }, - { "log", ExprUnaryFunc, log }, - { "log10", ExprUnaryFunc, log10 }, - { "max", ExprMaxFunc, NULL }, - { "min", ExprMinFunc, NULL }, - { "pow", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) pow}, + { "log", ExprUnaryFunc, (ClientData) log }, + { "log10", ExprUnaryFunc, (ClientData) log10 }, + { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, - { "sin", ExprUnaryFunc, sin }, - { "sinh", ExprUnaryFunc, sinh }, - { "sqrt", ExprSqrtFunc, NULL }, + { "sin", ExprUnaryFunc, (ClientData) sin }, + { "sinh", ExprUnaryFunc, (ClientData) sinh }, + { "sqrt", ExprSqrtFunc, NULL }, { "srand", ExprSrandFunc, NULL }, - { "tan", ExprUnaryFunc, tan }, - { "tanh", ExprUnaryFunc, tanh }, - { "wide", ExprWideFunc, NULL }, + { "tan", ExprUnaryFunc, (ClientData) tan }, + { "tanh", ExprUnaryFunc, (ClientData) tanh }, + { "wide", ExprWideFunc, NULL }, { NULL, NULL, NULL } }; @@ -595,155 +314,52 @@ static const OpCmdInfo mathOpCmds[] = { /* unused */ {0}, NULL}, { "eq", TclSortingOpCmd, TclCompileStreqOpCmd, /* unused */ {0}, NULL}, - { "lt", TclSortingOpCmd, TclCompileStrLtOpCmd, - /* unused */ {0}, NULL}, - { "le", TclSortingOpCmd, TclCompileStrLeOpCmd, - /* unused */ {0}, NULL}, - { "gt", TclSortingOpCmd, TclCompileStrGtOpCmd, - /* unused */ {0}, NULL}, - { "ge", TclSortingOpCmd, TclCompileStrGeOpCmd, - /* unused */ {0}, NULL}, { NULL, NULL, NULL, {0}, NULL} }; - + /* - *---------------------------------------------------------------------- - * - * TclFinalizeEvaluation -- - * - * Finalizes the script cancellation hash table. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- + * 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. */ -void -TclFinalizeEvaluation(void) -{ - Tcl_MutexLock(&cancelLock); - if (cancelTableInitialized == 1) { - Tcl_DeleteHashTable(&cancelTable); - cancelTableInitialized = 0; - } - Tcl_MutexUnlock(&cancelLock); - - Tcl_MutexLock(&commandTypeLock); - if (commandTypeInit) { - Tcl_DeleteHashTable(&commandTypeTable); - commandTypeInit = 0; - } - Tcl_MutexUnlock(&commandTypeLock); -} - +#if defined(TCL_NO_STACK_CHECK) /* - *---------------------------------------------------------------------- - * - * buildInfoObjCmd -- - * - * Implements tcl::build-info command. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- + * Stack check disabled: make them noops. */ -static int -buildInfoObjCmd( - void *clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?option?"); - return TCL_ERROR; - } - if (objc == 2) { - Tcl_Size len; - const char *arg = TclGetStringFromObj(objv[1], &len); - if (len == 7 && !strcmp(arg, "version")) { - char buf[80]; - const char *p = strchr((char *)clientData, '.'); - if (p) { - const char *q = strchr(p+1, '.'); - const char *r = strchr(p+1, '+'); - p = (q < r) ? q : r; - } - if (p) { - memcpy(buf, (char *)clientData, p - (char *)clientData); - buf[p - (char *)clientData] = '\0'; - Tcl_AppendResult(interp, buf, (void *)NULL); - } - return TCL_OK; - } else if (len == 10 && !strcmp(arg, "patchlevel")) { - char buf[80]; - const char *p = strchr((char *)clientData, '+'); - if (p) { - memcpy(buf, (char *)clientData, p - (char *)clientData); - buf[p - (char *)clientData] = '\0'; - Tcl_AppendResult(interp, buf, (void *)NULL); - } - return TCL_OK; - } else if (len == 6 && !strcmp(arg, "commit")) { - const char *q, *p = strchr((char *)clientData, '+'); - if (p) { - if ((q = strchr(p, '.'))) { - char buf[80]; - memcpy(buf, p+1, q - p - 1); - buf[q - p - 1] = '\0'; - Tcl_AppendResult(interp, buf, (void *)NULL); - } else { - Tcl_AppendResult(interp, p+1, (void *)NULL); - } - } - return TCL_OK; - } else if (len == 8 && !strcmp(arg, "compiler")) { - const char *p = strchr((char *)clientData, '.'); - while (p) { - if (!strncmp(p+1, "clang-", 6) || !strncmp(p+1, "gcc-", 4) - || !strncmp(p+1, "icc-", 4) || !strncmp(p+1, "msvc-", 5)) { - const char *q = strchr(p+1, '.'); - if (q) { - char buf[16]; - memcpy(buf, p+1, q - p - 1); - buf[q - p - 1] = '\0'; - Tcl_AppendResult(interp, buf, (void *)NULL); - } else { - Tcl_AppendResult(interp, p+1, (void *)NULL); - } - return TCL_OK; - } - p = strchr(p+1, '.'); - } - Tcl_AppendResult(interp, "0", (void *)NULL); - return TCL_OK; - } - const char *p = strchr((char *)clientData, '.'); - while (p) { - if (!strncmp(p+1, arg, len) && ((p[len+1] == '.') || (p[len+1] == '\0'))) { - Tcl_AppendResult(interp, "1", (void *)NULL); - return TCL_OK; - } - p = strchr(p+1, '.'); - } - Tcl_AppendResult(interp, "0", (void *)NULL); - return TCL_OK; - } - Tcl_AppendResult(interp, (char *)clientData, (void *)NULL); - return TCL_OK; -} +# 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 */ + +/* *---------------------------------------------------------------------- * * Tcl_CreateInterp -- @@ -770,10 +386,7 @@ Tcl_CreateInterp(void) const BuiltinFuncDef *builtinFuncPtr; const OpCmdInfo *opcmdInfoPtr; const CmdInfo *cmdInfoPtr; - Tcl_Namespace *nsPtr; - Tcl_HashEntry *hPtr; - int isNew; - CancelInfo *cancelInfo; + Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr; union { char c[sizeof(short)]; short s; @@ -783,7 +396,9 @@ Tcl_CreateInterp(void) #endif /* TCL_COMPILE_STATS */ char mathFuncName[32]; CallFrame *framePtr; - const char *version = Tcl_InitSubsystems(); + int result; + + TclInitSubsystems(); /* * Panic if someone updated the CallFrame structure without also updating @@ -791,88 +406,56 @@ Tcl_CreateInterp(void) */ if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) { + /*NOTREACHED*/ Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } -#if defined(_WIN32) && !defined(_WIN64) && !defined(_USE_64BIT_TIME_T) - /* If Tcl is compiled on Win32 using -D_USE_64BIT_TIME_T - * the result is a binary incompatible with the 'standard' build of - * Tcl: All extensions using Tcl_StatBuf need to be recompiled in - * the same way. Therefore, this is not officially supported. - * In stead, it is recommended to use Win64 or Tcl 9.0 (not released yet) - */ - if ((offsetof(Tcl_StatBuf,st_atime) != 32) - || (offsetof(Tcl_StatBuf,st_ctime) != 40)) { +#if defined(_WIN32) && !defined(_WIN64) + if (sizeof(time_t) != 4) { + /*NOTREACHED*/ + Tcl_Panic("<time.h> is not compatible with MSVC"); + } + if ((TclOffset(Tcl_StatBuf,st_atime) != 32) + || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) { + /*NOTREACHED*/ Tcl_Panic("<sys/stat.h> is not compatible with MSVC"); } #endif - if (cancelTableInitialized == 0) { - Tcl_MutexLock(&cancelLock); - if (cancelTableInitialized == 0) { - Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS); - cancelTableInitialized = 1; - } - - Tcl_MutexUnlock(&cancelLock); - } - -#undef TclObjInterpProc - if (commandTypeInit == 0) { - TclRegisterCommandTypeName(TclObjInterpProc, "proc"); - TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble"); - TclRegisterCommandTypeName(TclAliasObjCmd, "alias"); - TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias"); - TclRegisterCommandTypeName(TclChildObjCmd, "interp"); - TclRegisterCommandTypeName(TclInvokeImportedCmd, "import"); - TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object"); - TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject"); - TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass"); - TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine"); - } - /* * 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. */ - iPtr = (Interp *)ckalloc(sizeof(Interp)); + iPtr = (Interp *) ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; -#ifdef TCL_NO_DEPRECATED - iPtr->result = &tclEmptyString; -#else iPtr->result = iPtr->resultSpace; -#endif iPtr->freeProc = NULL; iPtr->errorLine = 0; - iPtr->stubTable = &tclStubs; - TclNewObj(iPtr->objResultPtr); + iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); iPtr->globalNsPtr = NULL; iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; - TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable)); - iPtr->extra.optimizer = TclOptimizeBytecode; - iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; /* Initialise as soon as :: is available */ iPtr->varFramePtr = NULL; /* Initialise as soon as :: is available */ /* - * TIP #280 - Initialize the arrays used to extend the ByteCode and Proc - * structures. + * 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->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); @@ -885,17 +468,6 @@ Tcl_CreateInterp(void) iPtr->errorInfo = NULL; TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo"); Tcl_IncrRefCount(iPtr->eiVar); - iPtr->errorStack = Tcl_NewListObj(0, NULL); - Tcl_IncrRefCount(iPtr->errorStack); - iPtr->resetErrorStack = 1; - TclNewLiteralStringObj(iPtr->upLiteral,"UP"); - Tcl_IncrRefCount(iPtr->upLiteral); - TclNewLiteralStringObj(iPtr->callLiteral,"CALL"); - Tcl_IncrRefCount(iPtr->callLiteral); - TclNewLiteralStringObj(iPtr->innerLiteral,"INNER"); - Tcl_IncrRefCount(iPtr->innerLiteral); - iPtr->innerContext = Tcl_NewListObj(0, NULL); - Tcl_IncrRefCount(iPtr->innerContext); iPtr->errorCode = NULL; TclNewLiteralStringObj(iPtr->ecVar, "::errorCode"); Tcl_IncrRefCount(iPtr->ecVar); @@ -905,30 +477,23 @@ Tcl_CreateInterp(void) iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; -#ifndef TCL_NO_DEPRECATED iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; -#endif Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; -#ifdef _WIN32 -# define getenv(x) _wgetenv(L##x) /* On Windows, use _wgetenv below */ -#endif - /* TIP #268 */ -#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE) if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { iPtr->packagePrefer = PKG_PREFER_STABLE; - } else -#endif + } else { iPtr->packagePrefer = PKG_PREFER_LATEST; + } iPtr->cmdCount = 0; - TclInitLiteralTable(&iPtr->literalTable); - iPtr->compileEpoch = 1; + TclInitLiteralTable(&(iPtr->literalTable)); + iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; iPtr->evalFlags = 0; @@ -940,12 +505,10 @@ Tcl_CreateInterp(void) iPtr->activeInterpTracePtr = NULL; iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ - TclNewObj(iPtr->emptyObjPtr); + iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); -#ifndef TCL_NO_DEPRECATED iPtr->resultSpace[0] = 0; -#endif iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ @@ -979,9 +542,12 @@ Tcl_CreateInterp(void) */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtr = (CallFrame *)ckalloc(sizeof(CallFrame)); - (void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + 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; @@ -995,7 +561,7 @@ Tcl_CreateInterp(void) * variable). */ - iPtr->execEnvPtr = TclCreateExecEnv(interp, INTERP_STACK_INITIAL_SIZE); + iPtr->execEnvPtr = TclCreateExecEnv(interp); /* * TIP #219, Tcl Channel Reflection API support. @@ -1004,44 +570,25 @@ Tcl_CreateInterp(void) iPtr->chanMsg = NULL; /* - * TIP #285, Script cancellation support. - */ - - TclNewObj(iPtr->asyncCancelMsg); - - cancelInfo = (CancelInfo *)ckalloc(sizeof(CancelInfo)); - cancelInfo->interp = interp; - - iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo); - cancelInfo->async = iPtr->asyncCancel; - cancelInfo->result = NULL; - cancelInfo->length = 0; - - Tcl_MutexLock(&cancelLock); - hPtr = Tcl_CreateHashEntry(&cancelTable, iPtr, &isNew); - Tcl_SetHashValue(hPtr, cancelInfo); - Tcl_MutexUnlock(&cancelLock); - - /* * Initialize the compilation and execution statistics kept for this * interpreter. */ #ifdef TCL_COMPILE_STATS - statsPtr = &iPtr->stats; + statsPtr = &(iPtr->stats); statsPtr->numExecutions = 0; statsPtr->numCompilations = 0; statsPtr->numByteCodesFreed = 0; - 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; - memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); - memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount)); - memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount)); + (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; @@ -1052,14 +599,22 @@ Tcl_CreateInterp(void) statsPtr->numLiteralsCreated = 0; statsPtr->totalLitStringBytes = 0.0; statsPtr->currentLitStringBytes = 0.0; - memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); + (void) memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); #endif /* TCL_COMPILE_STATS */ /* + * Initialise the stub table pointer. + */ + + iPtr->stubTable = &tclStubs; + + /* * Initialize the ensemble error message rewriting support. */ - TclResetRewriteEnsemble(interp, 1); + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; /* * TIP#143: Initialise the resource limit support. @@ -1068,36 +623,48 @@ Tcl_CreateInterp(void) TclInitLimitSupport(interp); /* - * Initialise the thread-specific data ekeko. Note that the thread's alloc - * cache was already initialised by the call to alloc the interp struct. + * Initialise the thread-specific data ekeko. */ -#if TCL_THREADS && defined(USE_THREAD_ALLOC) - iPtr->allocCache = (AllocCache *)TclpGetAllocCache(); +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + iPtr->allocCache = TclpGetAllocCache(); #else iPtr->allocCache = NULL; #endif iPtr->pendingObjDataPtr = NULL; iPtr->asyncReadyPtr = TclGetAsyncReadyPtr(); - iPtr->deferredCallbacks = NULL; /* - * Create the core commands. Do it here, rather than calling Tcl_CreateObjCommand, - * because it's faster (there's no need to check for a preexisting command - * by the same name). Set the Tcl_CmdProc to TclInvokeObjectCommand. + * Insure that the stack checking mechanism for this interp is + * initialized. */ - for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + 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 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->objProc == NULL) - && (cmdInfoPtr->compileProc == NULL) - && (cmdInfoPtr->nreProc == 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, &isNew); if (isNew) { - cmdPtr = (Command *)ckalloc(sizeof(Command)); + cmdPtr = (Command *) ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; cmdPtr->refCount = 1; @@ -1110,34 +677,22 @@ Tcl_CreateInterp(void) cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; cmdPtr->flags = 0; - if (cmdInfoPtr->flags & CMD_COMPILES_EXPANDED) { - cmdPtr->flags |= CMD_COMPILES_EXPANDED; - } cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = cmdInfoPtr->nreProc; Tcl_SetHashValue(hPtr, cmdPtr); } } /* - * Create the "array", "binary", "chan", "clock", "dict", "encoding", - * "file", "info", "namespace" and "string" ensembles. Note that all these - * commands (and their subcommands that are not present in the global - * namespace) are wholly safe *except* for "clock", "encoding" and "file". + * 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. */ - TclInitArrayCmd(interp); - TclInitBinaryCmd(interp); TclInitChanCmd(interp); TclInitDictCmd(interp); - TclInitEncodingCmd(interp); - TclInitFileCmd(interp); TclInitInfoCmd(interp); - TclInitNamespaceCmd(interp); TclInitStringCmd(interp); - TclInitPrefixCmd(interp); - TclInitProcessCmd(interp); /* * Register "clock" subcommands. These *do* go through @@ -1160,34 +715,11 @@ Tcl_CreateInterp(void) TclDefaultBgErrorHandlerObjCmd, NULL, NULL); /* - * Create unsupported commands for debugging bytecode and objects. + * Create an unsupported command for debugging bytecode. */ Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", - Tcl_DisassembleObjCmd, INT2PTR(0), NULL); - Tcl_CreateObjCommand(interp, "::tcl::unsupported::getbytecode", - Tcl_DisassembleObjCmd, INT2PTR(1), NULL); - Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", - Tcl_RepresentationCmd, NULL, NULL); - - /* Adding the bytecode assembler command */ - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, - "::tcl::unsupported::assemble", Tcl_AssembleObjCmd, - TclNRAssembleObjCmd, NULL, NULL); - cmdPtr->compileProc = &TclCompileAssembleCmd; - - /* Coroutine monkeybusiness */ - Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, - NRInjectObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype", - CoroTypeObjCmd, NULL, NULL); - - /* Export unsupported commands */ - nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0); - if (nsPtr) { - Tcl_Export(interp, nsPtr, "*", 1); - } - + Tcl_DisassembleObjCmd, NULL, NULL); #ifdef USE_DTRACE /* @@ -1201,33 +733,34 @@ Tcl_CreateInterp(void) * Register the builtin math functions. */ - nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL); - if (nsPtr == 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::") */ - memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN); for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL; builtinFuncPtr++) { strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name); Tcl_CreateObjCommand(interp, mathFuncName, - builtinFuncPtr->objCmdProc, (void *)builtinFuncPtr->fn, NULL); - Tcl_Export(interp, nsPtr, builtinFuncPtr->name, 0); + builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL); + Tcl_Export(interp, mathfuncNSPtr, builtinFuncPtr->name, 0); } /* * Register the mathematical "operator" commands. [TIP #174] */ - nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL); - if (nsPtr == NULL) { + 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"); } - Tcl_Export(interp, nsPtr, "*", 1); -#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ - memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN); + (void) Tcl_Export(interp, mathopNSPtr, "*", 1); + strcpy(mathFuncName, "::tcl::mathop::"); for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){ - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)ckalloc(sizeof(TclOpCmdClientData)); + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *) + ckalloc(sizeof(TclOpCmdClientData)); occdPtr->op = opcmdInfoPtr->name; occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs; @@ -1273,26 +806,24 @@ Tcl_CreateInterp(void) TCL_GLOBAL_ONLY); Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize", - Tcl_NewWideIntObj(sizeof(long)), TCL_GLOBAL_ONLY); + Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY); /* TIP #291 */ Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize", - Tcl_NewWideIntObj(sizeof(void *)), TCL_GLOBAL_ONLY); + Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY); /* * Set up other variables such as tcl_version and tcl_library */ - Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); - Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY); -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 + 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", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, NULL); -#endif /* !TCL_NO_DEPRECATED */ TclpSetVariables(interp); -#if TCL_THREADS && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#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 @@ -1306,112 +837,29 @@ Tcl_CreateInterp(void) /* * Register Tcl's version number. * TIP #268: Full patchlevel instead of just major.minor - * TIP #599: Extended build information "+<UUID>.<tag1>.<tag2>...." */ Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); - Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs); - Tcl_CreateObjCommand(interp, "::tcl::build-info", - buildInfoObjCmd, (void *)version, NULL); - - if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetStringResult(interp)); - } - - if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetStringResult(interp)); - } - /* - * Only build in zlib support if we've successfully detected a library to - * compile and link against. - */ +#ifdef Tcl_InitStubs +#undef Tcl_InitStubs +#endif + Tcl_InitStubs(interp, TCL_VERSION, 1); -#ifdef HAVE_ZLIB - if (TclZlibInit(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetStringResult(interp)); - } - if (TclZipfs_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetStringResult(interp)); + if (TclTommath_Init(interp) != TCL_OK) { + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } -#endif - TOP_CB(iPtr) = NULL; return interp; } static void DeleteOpCmdClientData( - void *clientData) -{ - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; - - ckfree(occdPtr); -} - -/* - * --------------------------------------------------------------------- - * - * TclRegisterCommandTypeName, TclGetCommandTypeName -- - * - * Command type registration and lookup mechanism. Everything is keyed by - * the Tcl_ObjCmdProc for the command, and that is used as the *key* into - * the hash table that maps to constant strings that are names. (It is - * recommended that those names be ASCII.) - * - * --------------------------------------------------------------------- - */ - -void -TclRegisterCommandTypeName( - Tcl_ObjCmdProc *implementationProc, - const char *nameStr) -{ - Tcl_HashEntry *hPtr; - - Tcl_MutexLock(&commandTypeLock); - if (commandTypeInit == 0) { - Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS); - commandTypeInit = 1; - } - if (nameStr != NULL) { - int isNew; - - hPtr = Tcl_CreateHashEntry(&commandTypeTable, - implementationProc, &isNew); - Tcl_SetHashValue(hPtr, (void *) nameStr); - } else { - hPtr = Tcl_FindHashEntry(&commandTypeTable, - implementationProc); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); - } - } - Tcl_MutexUnlock(&commandTypeLock); -} - -const char * -TclGetCommandTypeName( - Tcl_Command command) + ClientData clientData) { - Command *cmdPtr = (Command *) command; - Tcl_ObjCmdProc *procPtr = cmdPtr->objProc; - const char *name = "native"; - - if (procPtr == NULL) { - procPtr = cmdPtr->nreProc; - } - Tcl_MutexLock(&commandTypeLock); - if (commandTypeInit) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr); - - if (hPtr && Tcl_GetHashValue(hPtr)) { - name = (const char *) Tcl_GetHashValue(hPtr); - } - } - Tcl_MutexUnlock(&commandTypeLock); + TclOpCmdClientData *occdPtr = clientData; - return name; + ckfree((char *) occdPtr); } /* @@ -1434,94 +882,20 @@ int TclHideUnsafeCommands( Tcl_Interp *interp) /* Hide commands in this interpreter. */ { - const CmdInfo *cmdInfoPtr; - const UnsafeEnsembleInfo *unsafePtr; + register const CmdInfo *cmdInfoPtr; if (interp == NULL) { return TCL_ERROR; } for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { - if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) { + if (!cmdInfoPtr->isSafe) { Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } - - for (unsafePtr = unsafeEnsembleCommands; - unsafePtr->ensembleNsName; unsafePtr++) { - if (unsafePtr->commandName) { - /* - * Hide an ensemble subcommand. - */ - - Tcl_Obj *cmdName = Tcl_ObjPrintf("::tcl::%s::%s", - unsafePtr->ensembleNsName, unsafePtr->commandName); - Tcl_Obj *hideName = Tcl_ObjPrintf("tcl:%s:%s", - unsafePtr->ensembleNsName, unsafePtr->commandName); - - if (TclRenameCommand(interp, TclGetString(cmdName), - "___tmp") != TCL_OK - || Tcl_HideCommand(interp, "___tmp", - TclGetString(hideName)) != TCL_OK) { - Tcl_Panic("problem making '%s %s' safe: %s", - unsafePtr->ensembleNsName, unsafePtr->commandName, - Tcl_GetStringResult(interp)); - } - Tcl_CreateObjCommand(interp, TclGetString(cmdName), - BadEnsembleSubcommand, (void *)unsafePtr, NULL); - TclDecrRefCount(cmdName); - TclDecrRefCount(hideName); - } else { - /* - * Hide an ensemble main command (for compatibility). - */ - - if (Tcl_HideCommand(interp, unsafePtr->ensembleNsName, - unsafePtr->ensembleNsName) != TCL_OK) { - Tcl_Panic("problem making '%s' safe: %s", - unsafePtr->ensembleNsName, - Tcl_GetStringResult(interp)); - } - } - } - return TCL_OK; } /* - *---------------------------------------------------------------------- - * - * BadEnsembleSubcommand -- - * - * Command used to act as a backstop implementation when subcommands of - * ensembles are unsafe (the real implementations of the subcommands are - * hidden). The clientData is description of what was hidden. - * - * Results: - * A standard Tcl result (always a TCL_ERROR). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -BadEnsembleSubcommand( - void *clientData, - Tcl_Interp *interp, - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *) /* objv */) -{ - const UnsafeEnsembleInfo *infoPtr = (const UnsafeEnsembleInfo *)clientData; - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "not allowed to invoke subcommand %s of %s", - infoPtr->commandName, infoPtr->ensembleNsName)); - Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", (void *)NULL); - return TCL_ERROR; -} - -/* *-------------------------------------------------------------- * * Tcl_CallWhenDeleted -- @@ -1547,22 +921,22 @@ Tcl_CallWhenDeleted( Tcl_Interp *interp, /* Interpreter to watch. */ Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about * to be deleted. */ - void *clientData) /* One-word value to pass to proc. */ + ClientData clientData) /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; static Tcl_ThreadDataKey assocDataCounterKey; int *assocDataCounterPtr = - (int *)Tcl_GetThreadData(&assocDataCounterKey, sizeof(int)); + Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; - AssocData *dPtr = (AssocData *)ckalloc(sizeof(AssocData)); + AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; - snprintf(buffer, sizeof(buffer), "Assoc Data Key #%d", *assocDataCounterPtr); + sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr); (*assocDataCounterPtr)++; if (iPtr->assocData == NULL) { - iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew); @@ -1595,7 +969,7 @@ Tcl_DontCallWhenDeleted( Tcl_Interp *interp, /* Interpreter to watch. */ Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about * to be deleted. */ - void *clientData) /* One-word value to pass to proc. */ + ClientData clientData) /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTablePtr; @@ -1609,9 +983,9 @@ Tcl_DontCallWhenDeleted( } for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - dPtr = (AssocData *)Tcl_GetHashValue(hPtr); + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { - ckfree(dPtr); + ckfree((char *) dPtr); Tcl_DeleteHashEntry(hPtr); return; } @@ -1643,7 +1017,7 @@ Tcl_SetAssocData( const char *name, /* Name for association. */ Tcl_InterpDeleteProc *proc, /* Proc to call when interpreter is about to * be deleted. */ - void *clientData) /* One-word value to pass to proc. */ + ClientData clientData) /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; @@ -1651,14 +1025,14 @@ Tcl_SetAssocData( int isNew; if (iPtr->assocData == NULL) { - iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew); if (isNew == 0) { - dPtr = (AssocData *)Tcl_GetHashValue(hPtr); + dPtr = Tcl_GetHashValue(hPtr); } else { - dPtr = (AssocData *)ckalloc(sizeof(AssocData)); + dPtr = (AssocData *) ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; @@ -1699,12 +1073,12 @@ Tcl_DeleteAssocData( if (hPtr == NULL) { return; } - dPtr = (AssocData *)Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); + dPtr = Tcl_GetHashValue(hPtr); if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - ckfree(dPtr); + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); } /* @@ -1725,7 +1099,7 @@ Tcl_DeleteAssocData( *---------------------------------------------------------------------- */ -void * +ClientData Tcl_GetAssocData( Tcl_Interp *interp, /* Interpreter associated with. */ const char *name, /* Name of association. */ @@ -1744,7 +1118,7 @@ Tcl_GetAssocData( if (hPtr == NULL) { return NULL; } - dPtr = (AssocData *)Tcl_GetHashValue(hPtr); + dPtr = Tcl_GetHashValue(hPtr); if (procPtr != NULL) { *procPtr = dPtr->proc; } @@ -1825,7 +1199,7 @@ Tcl_DeleteInterp( * Ensure that the interpreter is eventually deleted. */ - Tcl_EventuallyFree(interp, DeleteInterpProc); + Tcl_EventuallyFree(interp, (Tcl_FreeProc *) DeleteInterpProc); } /* @@ -1851,22 +1225,19 @@ Tcl_DeleteInterp( static void DeleteInterpProc( - char *blockPtr) /* Interpreter to delete. */ + Tcl_Interp *interp) /* Interpreter to delete. */ { - Tcl_Interp *interp = (Tcl_Interp *) blockPtr; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *hTablePtr; ResolverScheme *resPtr, *nextResPtr; - Tcl_Size i; /* - * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup, - * unless we are exiting. + * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. */ - if ((iPtr->numLevels > 0) && !TclInExit()) { + if (iPtr->numLevels > 0) { Tcl_Panic("DeleteInterpProc called with active evals"); } @@ -1889,37 +1260,6 @@ DeleteInterpProc( } /* - * TIP #285, Script cancellation support. Delete this interp from the - * global hash table of CancelInfo structs. - */ - - Tcl_MutexLock(&cancelLock); - hPtr = Tcl_FindHashEntry(&cancelTable, iPtr); - if (hPtr != NULL) { - CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr); - - if (cancelInfo != NULL) { - if (cancelInfo->result != NULL) { - ckfree(cancelInfo->result); - } - ckfree(cancelInfo); - } - - Tcl_DeleteHashEntry(hPtr); - } - - if (iPtr->asyncCancel != NULL) { - Tcl_AsyncDelete(iPtr->asyncCancel); - iPtr->asyncCancel = NULL; - } - - if (iPtr->asyncCancelMsg != NULL) { - Tcl_DecrRefCount(iPtr->asyncCancelMsg); - iPtr->asyncCancelMsg = NULL; - } - Tcl_MutexUnlock(&cancelLock); - - /* * Shut down all limit handler callback scripts that call back into this * interpreter. Then eliminate all limit handlers for this interpreter. */ @@ -1948,40 +1288,41 @@ DeleteInterpProc( /* * 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 + * Tcl_DeleteCommandFromToken() will remove the entry from the * hiddenCmdTablePtr. */ hPtr = Tcl_FirstHashEntry(hTablePtr, &search); for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_DeleteCommandFromToken(interp, (Tcl_Command)Tcl_GetHashValue(hPtr)); + Tcl_DeleteCommandFromToken(interp, + (Tcl_Command) Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); - ckfree(hTablePtr); + ckfree((char *) hTablePtr); } + /* + * Invoke deletion callbacks; note that a callback can create new + * callbacks, so we iterate. + */ - if (iPtr->assocData != NULL) { + while (iPtr->assocData != NULL) { AssocData *dPtr; hTablePtr = iPtr->assocData; - /* - * Invoke deletion callbacks; note that a callback can create new - * callbacks, so we iterate. - */ + iPtr->assocData = NULL; for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); hPtr != NULL; hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { - dPtr = (AssocData *)Tcl_GetHashValue(hPtr); + dPtr = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - Tcl_DeleteHashEntry(hPtr); - ckfree(dPtr); + ckfree((char *) dPtr); } Tcl_DeleteHashTable(hTablePtr); - ckfree(hTablePtr); - iPtr->assocData = NULL; + ckfree((char *) hTablePtr); } /* @@ -1989,11 +1330,11 @@ DeleteInterpProc( * namespace. The order is important [Bug 1658572]. */ - if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) { + if (iPtr->framePtr != iPtr->rootFramePtr) { Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); } Tcl_PopCallFrame(interp); - ckfree(iPtr->rootFramePtr); + ckfree((char *) iPtr->rootFramePtr); iPtr->rootFramePtr = NULL; Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); @@ -2002,10 +1343,8 @@ DeleteInterpProc( * could have transferred ownership of the result string to Tcl. */ -#ifndef TCL_NO_DEPRECATED Tcl_FreeResult(interp); - iPtr->result = NULL; -#endif + interp->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); @@ -2018,21 +1357,13 @@ DeleteInterpProc( Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } - Tcl_DecrRefCount(iPtr->errorStack); - iPtr->errorStack = NULL; - Tcl_DecrRefCount(iPtr->upLiteral); - Tcl_DecrRefCount(iPtr->callLiteral); - Tcl_DecrRefCount(iPtr->innerLiteral); - Tcl_DecrRefCount(iPtr->innerContext); if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } -#ifndef TCL_NO_DEPRECATED if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); iPtr->appendResult = NULL; } -#endif TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); @@ -2051,7 +1382,7 @@ DeleteInterpProc( while (resPtr) { nextResPtr = resPtr->nextPtr; ckfree(resPtr->name); - ckfree(resPtr); + ckfree((char *) resPtr); resPtr = nextResPtr; } @@ -2060,101 +1391,104 @@ DeleteInterpProc( * interpreter. */ - TclDeleteLiteralTable(interp, &iPtr->literalTable); + TclDeleteLiteralTable(interp, &(iPtr->literalTable)); /* * TIP #280 - Release the arrays for ByteCode/Proc extension, and * contents. */ - for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - CmdFrame *cfPtr = (CmdFrame *)Tcl_GetHashValue(hPtr); - Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr); + { + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + int i; - procPtr->iPtr = NULL; - if (cfPtr) { - if (cfPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(cfPtr->data.eval.path); + for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch); + 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(cfPtr->line); - ckfree(cfPtr); + Tcl_DeleteHashEntry(hPtr); } - Tcl_DeleteHashEntry(hPtr); - } - Tcl_DeleteHashTable(iPtr->linePBodyPtr); - ckfree(iPtr->linePBodyPtr); - iPtr->linePBodyPtr = NULL; + 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, &search); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - ExtCmdLoc *eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hPtr); + for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + ExtCmdLoc *eclPtr = (ExtCmdLoc *) Tcl_GetHashValue(hPtr); - if (eclPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(eclPtr->path); - } - for (i=0; i<eclPtr->nuloc; i++) { - ckfree(eclPtr->loc[i].line); - } + if (eclPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(eclPtr->path); + } + for (i=0; i< eclPtr->nuloc; i++) { + ckfree((char *) eclPtr->loc[i].line); + } - if (eclPtr->loc != NULL) { - ckfree(eclPtr->loc); - } + if (eclPtr->loc != NULL) { + ckfree((char *) eclPtr->loc); + } - ckfree(eclPtr); - Tcl_DeleteHashEntry(hPtr); - } - Tcl_DeleteHashTable(iPtr->lineBCPtr); - ckfree(iPtr->lineBCPtr); - iPtr->lineBCPtr = NULL; + Tcl_DeleteHashTable (&eclPtr->litInfo); - /* - * Location stack for uplevel/eval/... scripts which were passed through - * proc arguments. Actually we track all arguments as we do not and cannot - * know which arguments will be used as scripts and which will not. - */ + ckfree((char *) eclPtr); + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(iPtr->lineBCPtr); + ckfree((char *) iPtr->lineBCPtr); + iPtr->lineBCPtr = NULL; - if (iPtr->lineLAPtr->numEntries && !TclInExit()) { /* - * When the interp goes away we have nothing on the stack, so there - * are no arguments, so this table has to be empty. + * Location stack for uplevel/eval/... scripts which were passed + * through proc arguments. Actually we track all arguments as we + * don't, cannot know which arguments will be used as scripts and + * which won't. */ - Tcl_Panic("Argument location tracking table not empty"); - } + if (iPtr->lineLAPtr->numEntries) { + /* + * When the interp goes away we have nothing on the stack, so + * there are no arguments, so this table has to be empty. + */ - Tcl_DeleteHashTable(iPtr->lineLAPtr); - ckfree(iPtr->lineLAPtr); - iPtr->lineLAPtr = NULL; + Tcl_Panic ("Argument location tracking table not empty"); + } - if (iPtr->lineLABCPtr->numEntries && !TclInExit()) { - /* - * When the interp goes away we have nothing on the stack, so there - * are no arguments, so this table has to be empty. - */ + Tcl_DeleteHashTable (iPtr->lineLAPtr); + ckfree((char*) iPtr->lineLAPtr); + iPtr->lineLAPtr = NULL; - Tcl_Panic("Argument location tracking table not empty"); - } + if (iPtr->lineLABCPtr->numEntries) { + /* + * When the interp goes away we have nothing on the stack, so + * there are no arguments, so this table has to be empty. + */ - Tcl_DeleteHashTable(iPtr->lineLABCPtr); - ckfree(iPtr->lineLABCPtr); - iPtr->lineLABCPtr = NULL; + Tcl_Panic ("Argument location tracking table not empty"); + } - /* - * Squelch the tables of traces on variables and searches over arrays in - * the in the interpreter. - */ + Tcl_DeleteHashTable (iPtr->lineLABCPtr); + ckfree((char*) iPtr->lineLABCPtr); + iPtr->lineLABCPtr = NULL; + } Tcl_DeleteHashTable(&iPtr->varTraces); Tcl_DeleteHashTable(&iPtr->varSearches); - ckfree(iPtr); + ckfree((char *) iPtr); } /* @@ -2220,10 +1554,9 @@ Tcl_HideCommand( */ if (strstr(hiddenCmdToken, "::") != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_AppendResult(interp, "cannot use namespace qualifiers in hidden command" - " token (rename)", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", (void *)NULL); + " token (rename)", NULL); return TCL_ERROR; } @@ -2245,10 +1578,8 @@ Tcl_HideCommand( */ if (cmdPtr->nsPtr != iPtr->globalNsPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only hide global namespace commands (use rename then hide)", - TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", (void *)NULL); + Tcl_AppendResult(interp, "can only hide global namespace commands" + " (use rename then hide)", NULL); return TCL_ERROR; } @@ -2258,7 +1589,8 @@ Tcl_HideCommand( hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr == NULL) { - hiddenCmdTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + hiddenCmdTablePtr = (Tcl_HashTable *) + ckalloc((unsigned) sizeof(Tcl_HashTable)); Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } @@ -2271,23 +1603,21 @@ Tcl_HideCommand( hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew); if (!isNew) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "hidden command named \"%s\" already exists", - hiddenCmdToken)); - Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", (void *)NULL); + Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken, + "\" already exists", NULL); return TCL_ERROR; } /* - * NB: This code is currently 'like' a rename to a special separate name + * 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. */ /* * Remove the hash entry for the command from the interpreter command - * table. This is like deleting the command, so bump its command epoch - * to invalidate any cached references that point to the command. + * table. This is like deleting the command, so bump its command epoch; + * this invalidates any cached references that point to the command. */ if (cmdPtr->hPtr != NULL) { @@ -2375,10 +1705,8 @@ Tcl_ExposeCommand( */ if (strstr(cmdName, "::") != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot expose to a namespace (use expose to toplevel, then rename)", - TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", (void *)NULL); + Tcl_AppendResult(interp, "cannot expose to a namespace " + "(use expose to toplevel, then rename)", NULL); return TCL_ERROR; } @@ -2392,29 +1720,27 @@ Tcl_ExposeCommand( hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); } if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown hidden command \"%s\"", hiddenCmdToken)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", - hiddenCmdToken, (void *)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 + * 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 theoretically impossible, we might rather Tcl_Panic + * This case is theoritically impossible, we might rather Tcl_Panic() * than 'nicely' erroring out ? */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "trying to expose a non-global command namespace command", - TCL_INDEX_NONE)); + Tcl_AppendResult(interp, + "trying to expose a non global command name space command", + NULL); return TCL_ERROR; } @@ -2431,24 +1757,12 @@ Tcl_ExposeCommand( hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); if (!isNew) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "exposed command \"%s\" already exists", cmdName)); - Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", (void *)NULL); + Tcl_AppendResult(interp, "exposed command \"", cmdName, + "\" already exists", NULL); return TCL_ERROR; } /* - * Command resolvers (per-interp, per-namespace) might have resolved to a - * command for the given namespace scope with this command not being - * registered with the namespace's command table. During BC compilation, - * the so-resolved command turns into a CmdName literal. Without - * invalidating a possible CmdName literal here explicitly, such literals - * keep being reused while pointing to overhauled commands. - */ - - TclInvalidateCmdLiteral(interp, cmdName, nsPtr); - - /* * 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. @@ -2514,7 +1828,7 @@ Tcl_ExposeCommand( * 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 eventually calls proc. When the command + * (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. * @@ -2530,18 +1844,18 @@ Tcl_CreateCommand( * specified namespace; otherwise it is put in * the global namespace. */ Tcl_CmdProc *proc, /* Function to associate with cmdName. */ - void *clientData, /* Arbitrary value passed to string proc. */ + 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; - Command *cmdPtr; + Namespace *nsPtr, *dummy1, *dummy2; + Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; const char *tail; - int isNew = 0, deleted = 0; + int isNew; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { @@ -2554,54 +1868,32 @@ Tcl_CreateCommand( } /* - * If the command name we seek to create already exists, we need to - * delete that first. That can be tricky in the presence of traces. - * Loop until we no longer find an existing command in the way, or - * until we've deleted one command and that didn't finish the job. + * 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. */ - while (1) { - /* - * 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) { - Namespace *dummy1, *dummy2; - - 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, &isNew); - - if (isNew || deleted) { - /* - * isNew - No conflict with existing command. - * deleted - We've already deleted a conflicting command - */ - break; + if (strstr(cmdName, "::") != 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, &isNew); + if (!isNew) { /* - * An existing command conflicts. Try to delete it... - */ - - cmdPtr = (Command *)Tcl_GetHashValue(hPtr); - - /* - * 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 = Tcl_GetHashValue(hPtr); cmdPtr->refCount++; if (cmdPtr->importRefPtr) { cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; @@ -2614,32 +1906,18 @@ Tcl_CreateCommand( cmdPtr->importRefPtr = NULL; } TclCleanupCommandMacro(cmdPtr); - deleted = 1; - } - - 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). - */ - - ckfree(Tcl_GetHashValue(hPtr)); - } - if (!deleted) { - /* - * Command resolvers (per-interp, per-namespace) might have resolved - * to a command for the given namespace scope with this command not - * being registered with the namespace's command table. During BC - * compilation, the so-resolved command turns into a CmdName literal. - * Without invalidating a possible CmdName literal here explicitly, - * such literals keep being reused while pointing to overhauled - * commands. - */ - - TclInvalidateCmdLiteral(interp, tail, nsPtr); + 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). + */ + 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 @@ -2649,7 +1927,7 @@ Tcl_CreateCommand( TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = (Command *)ckalloc(sizeof(Command)); + cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -2665,7 +1943,6 @@ Tcl_CreateCommand( cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = NULL; /* * Plug in any existing import references found above. Be sure to update @@ -2675,8 +1952,8 @@ Tcl_CreateCommand( if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { - Command *refCmdPtr = oldRefPtr->importedCmdPtr; - dataPtr = (ImportedCmdData *)refCmdPtr->objClientData; + refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } @@ -2728,36 +2005,39 @@ Tcl_CreateObjCommand( * the global namespace. */ Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ - void *clientData, /* Arbitrary value to pass to object - * function. */ - Tcl_CmdDeleteProc *deleteProc + 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; - Namespace *nsPtr; + ImportRef *oldRefPtr = NULL; + Namespace *nsPtr, *dummy1, *dummy2; + Command *cmdPtr, *refCmdPtr; + Tcl_HashEntry *hPtr; 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. */ + 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. + * namespace qualifiers, we put it in the specified namespace; otherwise, + * we always put it in the global namespace. */ if (strstr(cmdName, "::") != NULL) { - Namespace *dummy1, *dummy2; - TclGetNamespaceForQualName(interp, cmdName, NULL, - TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } @@ -2766,61 +2046,19 @@ Tcl_CreateObjCommand( tail = cmdName; } - return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, - proc, clientData, deleteProc); -} - -Tcl_Command -TclCreateObjCommandInNs( - Tcl_Interp *interp, - const char *cmdName, /* Name of command, without any namespace - * components. */ - Tcl_Namespace *namesp, /* The namespace to create the command in */ - Tcl_ObjCmdProc *proc, /* Object-based function to associate with - * name. */ - void *clientData, /* Arbitrary value to pass to object - * function. */ - Tcl_CmdDeleteProc *deleteProc) - /* If not NULL, gives a function to call when - * this command is deleted. */ -{ - int deleted = 0, isNew = 0; - Command *cmdPtr; - ImportRef *oldRefPtr = NULL; - ImportedCmdData *dataPtr; - Tcl_HashEntry *hPtr; - Namespace *nsPtr = (Namespace *) namesp; - - /* - * If the command name we seek to create already exists, we need to delete - * that first. That can be tricky in the presence of traces. Loop until we - * no longer find an existing command in the way, or until we've deleted - * one command and that didn't finish the job. - */ - - while (1) { - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); - - if (isNew || deleted) { - /* - * isNew - No conflict with existing command. - * deleted - We've already deleted a conflicting command - */ - break; - } - - /* - * An existing command conflicts. Try to delete it... - */ + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + TclInvalidateNsPath(nsPtr); + if (!isNew) { + cmdPtr = Tcl_GetHashValue(hPtr); - cmdPtr = (Command *)Tcl_GetHashValue(hPtr); + /* Command already exists. */ /* - * [***] This is wrong. See Tcl Bug a16752c252. - * However, this buggy behavior is kept under particular circumstances - * to accommodate deployed binaries of the "tclcompiler" program - * <http://sourceforge.net/projects/tclpro/> that crash if the bug is - * fixed. + * [***] This is wrong. See Tcl Bug a16752c252. + * However, this buggy behavior is kept under particular + * circumstances to accommodate deployed binaries of the + * "tclcompiler" program. http://sourceforge.net/projects/tclpro/ + * that crash if the bug is fixed. */ if (cmdPtr->objProc == TclInvokeStringCommand @@ -2844,47 +2082,25 @@ TclCreateObjCommandInNs( cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; } - /* - * Make sure namespace doesn't get deallocated. - */ - - cmdPtr->nsPtr->refCount++; - Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); - nsPtr = (Namespace *) TclEnsureNamespace(interp, - (Tcl_Namespace *) cmdPtr->nsPtr); - TclNsDecrRefCount(cmdPtr->nsPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; } TclCleanupCommandMacro(cmdPtr); - deleted = 1; - } - 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). - */ - - ckfree(Tcl_GetHashValue(hPtr)); - } - if (!deleted) { - /* - * Command resolvers (per-interp, per-namespace) might have resolved - * to a command for the given namespace scope with this command not - * being registered with the namespace's command table. During BC - * compilation, the so-resolved command turns into a CmdName literal. - * Without invalidating a possible CmdName literal here explicitly, - * such literals keep being reused while pointing to overhauled - * commands. - */ - - TclInvalidateCmdLiteral(interp, cmdName, nsPtr); + 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). + */ + 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 @@ -2892,9 +2108,8 @@ TclCreateObjCommandInNs( */ TclInvalidateNsCmdLookup(nsPtr); - TclInvalidateNsPath(nsPtr); } - cmdPtr = (Command *)ckalloc(sizeof(Command)); + cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -2910,7 +2125,6 @@ TclCreateObjCommandInNs( cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = NULL; /* * Plug in any existing import references found above. Be sure to update @@ -2920,11 +2134,8 @@ TclCreateObjCommandInNs( if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { - Command *refCmdPtr = oldRefPtr->importedCmdPtr; - - dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; - cmdPtr->refCount++; - TclCleanupCommandMacro(dataPtr->realCmdPtr); + refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } @@ -2964,18 +2175,18 @@ TclCreateObjCommandInNs( int TclInvokeStringCommand( - void *clientData, /* Points to command's Command structure. */ + ClientData clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + register int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Command *cmdPtr = (Command *)clientData; + Command *cmdPtr = clientData; int i, result; const char **argv = (const char **) - TclStackAlloc(interp, (objc + 1) * sizeof(char *)); + TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); - for (i = 0; i < objc; i++) { - argv[i] = TclGetString(objv[i]); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; @@ -2983,7 +2194,7 @@ TclInvokeStringCommand( * Invoke the command's string-based Tcl_CmdProc. */ - result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv); + result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); TclStackFree(interp, (void *) argv); return result; @@ -3001,7 +2212,7 @@ TclInvokeStringCommand( * in the Command structure. * * Results: - * A standard Tcl result value. + * A standard Tcl string result value. * * Side effects: * Besides those side effects of the called Tcl_ObjCmdProc, @@ -3012,18 +2223,18 @@ TclInvokeStringCommand( int TclInvokeObjectCommand( - void *clientData, /* Points to command's Command structure. */ + ClientData clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ + register const char **argv) /* Argument strings. */ { - Command *cmdPtr = ( Command *) clientData; + Command *cmdPtr = (Command *) clientData; Tcl_Obj *objPtr; int i, length, result; Tcl_Obj **objv = (Tcl_Obj **) - TclStackAlloc(interp, (argc * sizeof(Tcl_Obj *))); + TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *))); - for (i = 0; i < argc; i++) { + for (i = 0; i < argc; i++) { length = strlen(argv[i]); TclNewStringObj(objPtr, argv[i], length); Tcl_IncrRefCount(objPtr); @@ -3034,12 +2245,7 @@ TclInvokeObjectCommand( * Invoke the command's object-based Tcl_ObjCmdProc. */ - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, argc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, argc, objv); - } + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); /* * Move the interpreter's object result to the string result, then reset @@ -3053,7 +2259,7 @@ TclInvokeObjectCommand( * free the objv array if malloc'ed storage was used. */ - for (i = 0; i < argc; i++) { + for (i = 0; i < argc; i++) { objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } @@ -3109,13 +2315,15 @@ TclRenameCommand( cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't %s \"%s\": command doesn't exist", + Tcl_AppendResult(interp, "can't ", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", - oldName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, (void *)NULL); + " \"", oldName, "\": command doesn't exist", NULL); return TCL_ERROR; } + cmdNsPtr = cmdPtr->nsPtr; + oldFullName = Tcl_NewObj(); + Tcl_IncrRefCount(oldFullName); + Tcl_GetCommandFullName(interp, cmd, oldFullName); /* * If the new command name is NULL or empty, delete the command. Do this @@ -3124,42 +2332,35 @@ TclRenameCommand( if ((newName == NULL) || (*newName == '\0')) { Tcl_DeleteCommandFromToken(interp, cmd); - return TCL_OK; + result = TCL_OK; + goto done; } - cmdNsPtr = cmdPtr->nsPtr; - TclNewObj(oldFullName); - Tcl_IncrRefCount(oldFullName); - Tcl_GetCommandFullName(interp, cmd, oldFullName); - /* * 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_CreateObjCommand would. + * create the containing namespaces just like Tcl_CreateCommand would. */ TclGetNamespaceForQualName(interp, newName, NULL, TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); if ((newNsPtr == NULL) || (newTail == NULL)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't rename to \"%s\": bad command name", newName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (void *)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_SetObjResult(interp, Tcl_ObjPrintf( - "can't rename to \"%s\": command already exists", newName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME", - "TARGET_EXISTS", (void *)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). + * Tcl_HideCommand() code too (until the common parts are extracted out). * - dl */ @@ -3200,17 +2401,6 @@ TclRenameCommand( TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* - * Command resolvers (per-interp, per-namespace) might have resolved to a - * command for the given namespace scope with this command not being - * registered with the namespace's command table. During BC compilation, - * the so-resolved command turns into a CmdName literal. Without - * invalidating a possible CmdName literal here explicitly, such literals - * keep being reused while pointing to overhauled commands. - */ - - TclInvalidateCmdLiteral(interp, newTail, 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 @@ -3223,13 +2413,13 @@ TclRenameCommand( */ Tcl_DStringInit(&newFullName); - Tcl_DStringAppend(&newFullName, newNsPtr->fullName, TCL_INDEX_NONE); + Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1); if (newNsPtr != iPtr->globalNsPtr) { - TclDStringAppendLiteral(&newFullName, "::"); + Tcl_DStringAppend(&newFullName, "::", 2); } - Tcl_DStringAppend(&newFullName, newTail, TCL_INDEX_NONE); + Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; - CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName), + CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); Tcl_DStringFree(&newFullName); @@ -3329,7 +2519,7 @@ Tcl_SetCommandInfoFromToken( { Command *cmdPtr; /* Internal representation of the command */ - if (cmd == NULL) { + if (cmd == (Tcl_Command) NULL) { return 0; } @@ -3343,12 +2533,8 @@ Tcl_SetCommandInfoFromToken( if (infoPtr->objProc == NULL) { cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = cmdPtr; - cmdPtr->nreProc = NULL; } else { - if (infoPtr->objProc != cmdPtr->objProc) { - cmdPtr->nreProc = NULL; - cmdPtr->objProc = infoPtr->objProc; - } + cmdPtr->objProc = infoPtr->objProc; cmdPtr->objClientData = infoPtr->objClientData; } cmdPtr->deleteProc = infoPtr->deleteProc; @@ -3413,7 +2599,7 @@ Tcl_GetCommandInfoFromToken( { Command *cmdPtr; /* Internal representation of the command */ - if (cmd == NULL) { + if (cmd == (Tcl_Command) NULL) { return 0; } @@ -3432,6 +2618,7 @@ Tcl_GetCommandInfoFromToken( infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; + return 1; } @@ -3440,7 +2627,7 @@ Tcl_GetCommandInfoFromToken( * * Tcl_GetCommandName -- * - * Given a token returned by Tcl_CreateObjCommand, this function returns the + * Given a token returned by Tcl_CreateCommand, this function returns the * current name of the command (which may have changed due to renaming). * * Results: @@ -3454,9 +2641,9 @@ Tcl_GetCommandInfoFromToken( const char * Tcl_GetCommandName( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, /* Interpreter containing the command. */ Tcl_Command command) /* Token for command returned by a previous - * call to Tcl_CreateObjCommand. The command must + * call to Tcl_CreateCommand. The command must * not have been deleted. */ { Command *cmdPtr = (Command *) command; @@ -3471,7 +2658,7 @@ Tcl_GetCommandName( return ""; } - return (const char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); + return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); } /* @@ -3479,7 +2666,7 @@ Tcl_GetCommandName( * * Tcl_GetCommandFullName -- * - * Given a token returned by, e.g., Tcl_CreateObjCommand or Tcl_FindCommand, + * 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. @@ -3498,14 +2685,14 @@ void Tcl_GetCommandFullName( Tcl_Interp *interp, /* Interpreter containing the command. */ Tcl_Command command, /* Token for command returned by a previous - * call to Tcl_CreateObjCommand. The command must + * 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. */ { Interp *iPtr = (Interp *) interp; - Command *cmdPtr = (Command *) command; + register Command *cmdPtr = (Command *) command; char *name; /* @@ -3513,16 +2700,16 @@ Tcl_GetCommandFullName( * separator, and the command name. */ - if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) { + if (cmdPtr != NULL) { if (cmdPtr->nsPtr != NULL) { - Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, TCL_INDEX_NONE); + Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); if (cmdPtr->nsPtr != iPtr->globalNsPtr) { Tcl_AppendToObj(objPtr, "::", 2); } } if (cmdPtr->hPtr != NULL) { - name = (char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); - Tcl_AppendToObj(objPtr, name, TCL_INDEX_NONE); + name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); + Tcl_AppendToObj(objPtr, name, -1); } } } @@ -3557,7 +2744,7 @@ Tcl_DeleteCommand( */ cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); - if (cmd == NULL) { + if (cmd == (Tcl_Command) NULL) { return -1; } return Tcl_DeleteCommandFromToken(interp, cmd); @@ -3595,6 +2782,13 @@ Tcl_DeleteCommandFromToken( Tcl_Command importCmd; /* + * 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 @@ -3603,7 +2797,7 @@ Tcl_DeleteCommandFromToken( * and skip nested deletes. */ - if (cmdPtr->flags & CMD_DYING) { + 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 @@ -3616,37 +2810,26 @@ Tcl_DeleteCommandFromToken( Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; } - - /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. - */ - - cmdPtr->cmdEpoch++; - 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 themselves. This flag + * 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_DYING; + cmdPtr->flags |= CMD_IS_DELETED; /* - * Call each functions and then delete the trace. + * Call trace functions for the command being deleted. Then delete its + * traces. */ - cmdPtr->nsPtr->refCount++; - if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; - /* CallCommandTraces() does not cmdPtr, that's - * done just before Tcl_DeleteCommandFromToken() returns */ CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); /* @@ -3656,9 +2839,8 @@ Tcl_DeleteCommandFromToken( tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; - - if (tracePtr->refCount-- <= 1) { - ckfree(tracePtr); + if ((--tracePtr->refCount) <= 0) { + ckfree((char *) tracePtr); } tracePtr = nextPtr; } @@ -3666,13 +2848,12 @@ Tcl_DeleteCommandFromToken( } /* - * The list of commands exported from the namespace might have changed. + * 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); - TclNsDecrRefCount(cmdPtr->nsPtr); /* * If the command being deleted has a compile function, increment the @@ -3687,36 +2868,39 @@ Tcl_DeleteCommandFromToken( iPtr->compileEpoch++; } - if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) { - /* - * Delete any imports of this routine before deleting this routine itself. - * See issue 688fcc7082fa. - */ - for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; - refPtr = nextRefPtr) { - nextRefPtr = refPtr->nextPtr; - importCmd = (Tcl_Command) refPtr->importedCmdPtr; - Tcl_DeleteCommandFromToken(interp, importCmd); - } - } - if (cmdPtr->deleteProc != NULL) { /* * Delete the command's client data. If this was an imported command * created when a command was imported into a namespace, this client * 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() + * 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); + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + + /* + * If this command was imported into other namespaces, then imported + * commands were created that refer back to this command. Delete these + * imported commands now. + */ + if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) { + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; + refPtr = nextRefPtr) { + nextRefPtr = refPtr->nextPtr; + importCmd = (Tcl_Command) refPtr->importedCmdPtr; + Tcl_DeleteCommandFromToken(interp, importCmd); + } } /* @@ -3729,20 +2913,14 @@ Tcl_DeleteCommandFromToken( if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; - - /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. - */ - - cmdPtr->cmdEpoch++; } /* - * A number of tests for particular kinds of commands are done by checking - * whether the objProc field holds a known value. Set the field to NULL so - * that such tests won't have false positives when applied to deleted - * commands. + * 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. */ cmdPtr->objProc = NULL; @@ -3752,32 +2930,14 @@ Tcl_DeleteCommandFromToken( * 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 - * TclNRExecuteByteCode looks up the command in the command hashtable). + * CmdName Command reference is found to be invalid and TclExecuteByteCode + * looks up the command in the command hashtable). */ - cmdPtr->flags |= CMD_DEAD; TclCleanupCommandMacro(cmdPtr); return 0; } -/* - *---------------------------------------------------------------------- - * - * CallCommandTraces -- - * - * Abstraction of the code to call traces on a command. - * - * Results: - * Currently always NULL. - * - * Side effects: - * Anything; this may recursively evaluate scripts and code exists to do - * just that. - * - *---------------------------------------------------------------------- - */ - static char * CallCommandTraces( Interp *iPtr, /* Interpreter containing command. */ @@ -3790,7 +2950,7 @@ CallCommandTraces( * trigger, either TCL_TRACE_DELETE or * TCL_TRACE_RENAME. */ { - CommandTrace *tracePtr; + register CommandTrace *tracePtr; ActiveCommandTrace active; char *result; Tcl_Obj *oldNamePtr = NULL; @@ -3801,7 +2961,7 @@ CallCommandTraces( * 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_DYING) and returns immediately when a + * (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 @@ -3816,6 +2976,7 @@ CallCommandTraces( } } cmdPtr->flags |= CMD_TRACE_ACTIVE; + cmdPtr->refCount++; result = NULL; active.nextPtr = iPtr->activeCmdTracePtr; @@ -3847,11 +3008,11 @@ CallCommandTraces( if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK); } - tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, - oldName, newName, flags); + (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, oldName, newName, flags); cmdPtr->flags &= ~tracePtr->flags; - if (tracePtr->refCount-- <= 1) { - ckfree(tracePtr); + if ((--tracePtr->refCount) <= 0) { + ckfree((char *) tracePtr); } } @@ -3873,86 +3034,39 @@ CallCommandTraces( */ cmdPtr->flags &= ~CMD_TRACE_ACTIVE; + cmdPtr->refCount--; iPtr->activeCmdTracePtr = active.nextPtr; Tcl_Release(iPtr); return result; } - + /* *---------------------------------------------------------------------- * - * CancelEvalProc -- - * - * Marks this interpreter as being canceled. This causes current - * executions to be unwound as the interpreter enters a state where it - * refuses to execute more commands or handle [catch] or [try], yet the - * interpreter is still able to execute further commands after the - * cancelation is cleared (unlike if it is deleted). + * GetCommandSource -- * - * Results: - * The value given for the code argument. - * - * Side effects: - * Transfers a message from the cancellation message to the interpreter. + * 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 int -CancelEvalProc( - void *clientData, /* Interp to cancel the script in progress. */ - TCL_UNUSED(Tcl_Interp *), - int code) /* Current return code from command. */ +static Tcl_Obj * +GetCommandSource( + Interp *iPtr, + const char *command, + int numChars, + int objc, + Tcl_Obj *const objv[]) { - CancelInfo *cancelInfo = (CancelInfo *)clientData; - Interp *iPtr; - - if (cancelInfo != NULL) { - Tcl_MutexLock(&cancelLock); - iPtr = (Interp *) cancelInfo->interp; - - if (iPtr != NULL) { - /* - * Setting the CANCELED flag will cause the script in progress to - * be canceled as soon as possible. The core honors this flag at - * all the necessary places to ensure script cancellation is - * responsive. Extensions can check for this flag by calling - * Tcl_Canceled and checking if TCL_ERROR is returned or they can - * choose to ignore the script cancellation flag and the - * associated functionality altogether. Currently, the only other - * flag we care about here is the TCL_CANCEL_UNWIND flag (from - * Tcl_CancelEval). We do not want to simply combine all the flags - * from original Tcl_CancelEval call with the interp flags here - * just in case the caller passed flags that might cause behaviour - * unrelated to script cancellation. - */ - - TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); - - /* - * Now, we must set the script cancellation flags on all the child - * interpreters belonging to this one. - */ - - TclSetChildCancelFlags((Tcl_Interp *) iPtr, - cancelInfo->flags | CANCELED, 0); - - /* - * Create the result object now so that Tcl_Canceled can avoid - * locking the cancelLock mutex. - */ - - if (cancelInfo->result != NULL) { - Tcl_SetStringObj(iPtr->asyncCancelMsg, cancelInfo->result, - cancelInfo->length); - } else { - Tcl_SetObjLength(iPtr->asyncCancelMsg, 0); - } - } - Tcl_MutexUnlock(&cancelLock); + if (!command) { + return Tcl_NewListObj(objc, objv); } - - return code; + if (command == (char *) -1) { + command = TclGetSrcInfoForCmd(iPtr, &numChars); + } + return Tcl_NewStringObj(command, numChars); } /* @@ -3978,11 +3092,12 @@ CancelEvalProc( void TclCleanupCommand( - Command *cmdPtr) /* Points to the Command structure to + register Command *cmdPtr) /* Points to the Command structure to * be freed. */ { - if (cmdPtr->refCount-- <= 1) { - ckfree(cmdPtr); + cmdPtr->refCount--; + if (cmdPtr->refCount <= 0) { + ckfree((char *) cmdPtr); } } @@ -4002,40 +3117,39 @@ TclCleanupCommand( * 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, - * redefining a non-builtin function will force existing code to be + * redefioning a non-builtin function will force existing code to be * invalidated if the number of arguments has changed. * *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) void Tcl_CreateMathFunc( Tcl_Interp *interp, /* Interpreter in which function is to be * available. */ const char *name, /* Name of function (e.g. "sin"). */ - int numArgs, /* Number of arguments required by + 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. */ - void *clientData) /* Additional value to pass to the + ClientData clientData) /* Additional value to pass to the * function. */ { Tcl_DString bigName; - OldMathFuncData *data = (OldMathFuncData *)ckalloc(sizeof(OldMathFuncData)); + OldMathFuncData *data = (OldMathFuncData *) + ckalloc(sizeof(OldMathFuncData)); data->proc = proc; data->numArgs = numArgs; - data->argTypes = (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); - if ((numArgs > 0) && (argTypes != NULL)) { - memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); - } + data->argTypes = (Tcl_ValueType *) + ckalloc(numArgs * sizeof(Tcl_ValueType)); + memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); data->clientData = clientData; Tcl_DStringInit(&bigName); - TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::"); + Tcl_DStringAppend(&bigName, "::tcl::mathfunc::", -1); Tcl_DStringAppend(&bigName, name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName), @@ -4061,14 +3175,14 @@ Tcl_CreateMathFunc( static int OldMathFuncProc( - void *clientData, /* Pointer to OldMathFuncData describing the + ClientData clientData, /* Ponter to OldMathFuncData describing the * function being called */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Actual parameter count */ Tcl_Obj *const *objv) /* Parameter vector */ { Tcl_Obj *valuePtr; - OldMathFuncData *dataPtr = (OldMathFuncData *)clientData; + OldMathFuncData *dataPtr = clientData; Tcl_Value funcResult, *args; int result; int j, k; @@ -4087,20 +3201,16 @@ OldMathFuncProc( * Convert arguments from Tcl_Obj's to Tcl_Value's. */ - args = (Tcl_Value *)ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); + args = (Tcl_Value *) ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); for (j = 1, k = 0; j < objc; ++j, ++k) { - /* TODO: Convert to Tcl_GetNumberFromObj? */ + + /* TODO: Convert to TclGetNumberFromObj() ? */ valuePtr = objv[j]; result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); #ifdef ACCEPT_NAN - if (result != TCL_OK) { - const Tcl_ObjInternalRep *irPtr - = TclFetchInternalRep(valuePtr, &tclDoubleType); - - if (irPtr) { - d = irPtr->doubleValue; - result = TCL_OK; - } + if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) { + d = valuePtr->internalRep.doubleValue; + result = TCL_OK; } #endif if (result != TCL_OK) { @@ -4109,10 +3219,9 @@ OldMathFuncProc( */ Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument to math function didn't have numeric value", - -1)); - TclCheckBadOctal(interp, TclGetString(valuePtr)); - ckfree(args); + "argument to math function didn't have numeric value",-1)); + TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); + ckfree((char *)args); return TCL_ERROR; } @@ -4126,12 +3235,12 @@ OldMathFuncProc( args[k].type = dataPtr->argTypes[k]; switch (args[k].type) { case TCL_EITHER: - if (Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue) + if (Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue)) == TCL_OK) { args[k].type = TCL_INT; break; } - if (TclGetWideIntFromObj(interp, valuePtr, &args[k].wideValue) + if (Tcl_GetWideIntFromObj(interp, valuePtr, &(args[k].wideValue)) == TCL_OK) { args[k].type = TCL_WIDE_INT; break; @@ -4143,21 +3252,21 @@ OldMathFuncProc( args[k].doubleValue = d; break; case TCL_INT: - if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { - ckfree(args); + 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_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(args); + if (ExprWideFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) { + ckfree((char *)args); return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); - TclGetWideIntFromObj(NULL, valuePtr, &args[k].wideValue); + Tcl_GetWideIntFromObj(NULL, valuePtr, &(args[k].wideValue)); Tcl_ResetResult(interp); break; } @@ -4168,8 +3277,8 @@ OldMathFuncProc( */ errno = 0; - result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult); - ckfree(args); + result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult); + ckfree((char *)args); if (result != TCL_OK) { return result; } @@ -4179,9 +3288,9 @@ OldMathFuncProc( */ if (funcResult.type == TCL_INT) { - TclNewIntObj(valuePtr, funcResult.intValue); + TclNewLongObj(valuePtr, funcResult.intValue); } else if (funcResult.type == TCL_WIDE_INT) { - TclNewIntObj(valuePtr, funcResult.wideValue); + valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); } else { return CheckDoubleResult(interp, funcResult.doubleValue); } @@ -4208,12 +3317,12 @@ OldMathFuncProc( static void OldMathFuncDeleteProc( - void *clientData) + ClientData clientData) { - OldMathFuncData *dataPtr = (OldMathFuncData *)clientData; + OldMathFuncData *dataPtr = clientData; - ckfree(dataPtr->argTypes); - ckfree(dataPtr); + ckfree((void *) dataPtr->argTypes); + ckfree((void *) dataPtr); } /* @@ -4247,7 +3356,7 @@ Tcl_GetMathFuncInfo( int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, - void **clientDataPtr) + ClientData *clientDataPtr) { Tcl_Obj *cmdNameObj; Command *cmdPtr; @@ -4267,9 +3376,12 @@ Tcl_GetMathFuncInfo( */ if (cmdPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown math function \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, (void *)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; @@ -4283,7 +3395,7 @@ Tcl_GetMathFuncInfo( */ if (cmdPtr->objProc == &OldMathFuncProc) { - OldMathFuncData *dataPtr = (OldMathFuncData *)cmdPtr->clientData; + OldMathFuncData *dataPtr = cmdPtr->clientData; *procPtr = dataPtr->proc; *numArgsPtr = dataPtr->numArgs; @@ -4340,14 +3452,13 @@ Tcl_ListMathFuncs( if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); } else { - TclNewObj(result); + result = Tcl_NewObj(); } Tcl_DecrRefCount(script); Tcl_RestoreInterpState(interp, state); return result; } -#endif /* !defined(TCL_NO_DEPRECATED) */ /* *---------------------------------------------------------------------- @@ -4371,11 +3482,14 @@ int TclInterpReady( Tcl_Interp *interp) { - Interp *iPtr = (Interp *) interp; +#if !defined(TCL_NO_STACK_CHECK) + int localInt; /* used for checking the stack */ +#endif + register Interp *iPtr = (Interp *) interp; /* - * Reset the interpreter's result 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); @@ -4385,23 +3499,11 @@ TclInterpReady( */ if (iPtr->flags & DELETED) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to call eval in deleted interpreter", TCL_INDEX_NONE)); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "attempt to call eval in deleted interpreter", NULL); Tcl_SetErrorCode(interp, "TCL", "IDELETE", - "attempt to call eval in deleted interpreter", (void *)NULL); - return TCL_ERROR; - } - - if (iPtr->execEnvPtr->rewind) { - return TCL_ERROR; - } - - /* - * Make sure the script being evaluated (if any) has not been canceled. - */ - - if (TclCanceled(iPtr) && - (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) { + "attempt to call eval in deleted interpreter", NULL); return TCL_ERROR; } @@ -4410,366 +3512,81 @@ TclInterpReady( * probably because of an infinite loop somewhere. */ - if ((iPtr->numLevels <= iPtr->maxNestingDepth)) { + if (((iPtr->numLevels) <= iPtr->maxNestingDepth) + && CheckCStack(iPtr, &localInt)) { return TCL_OK; } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "too many nested evaluations (infinite loop?)", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (void *)NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclResetCancellation -- - * - * Reset the script cancellation flags if the nesting level - * (iPtr->numLevels) for the interp is zero or argument force is - * non-zero. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * The script cancellation flags for the interp may be reset. - * - *---------------------------------------------------------------------- - */ - -int -TclResetCancellation( - Tcl_Interp *interp, - int force) -{ - Interp *iPtr = (Interp *) interp; - - if (iPtr == NULL) { - return TCL_ERROR; - } - - if (force || (iPtr->numLevels == 0)) { - TclUnsetCancelFlags(iPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Canceled -- - * - * Check if the script in progress has been canceled, i.e., - * Tcl_CancelEval was called for this interpreter or any of its parent - * interpreters. - * - * Results: - * The return value is TCL_OK if the script evaluation has not been - * canceled, TCL_ERROR otherwise. - * - * If "flags" contains TCL_LEAVE_ERR_MSG, an error message is returned in - * the interpreter's result object. Otherwise, the interpreter's result - * object is left unchanged. If "flags" contains TCL_CANCEL_UNWIND, - * TCL_ERROR will only be returned if the script evaluation is being - * completely unwound. - * - * Side effects: - * The CANCELED flag for the interp will be reset if it is set. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Canceled( - Tcl_Interp *interp, - int flags) -{ - Interp *iPtr = (Interp *) interp; - - /* - * Has the current script in progress for this interpreter been canceled - * or is the stack being unwound due to the previous script cancellation? - */ - - if (!TclCanceled(iPtr)) { - return TCL_OK; - } - - /* - * The CANCELED flag is a one-shot flag that is reset immediately upon - * being detected; however, if the TCL_CANCEL_UNWIND flag is set we will - * continue to report that the script in progress has been canceled - * thereby allowing the evaluation stack for the interp to be fully - * unwound. - */ - - iPtr->flags &= ~CANCELED; - - /* - * The CANCELED flag was detected and reset; however, if the caller - * specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR - * (indicating that the script in progress has been canceled) if the - * evaluation stack for the interp is being fully unwound. - */ - - if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) { - return TCL_OK; - } - - /* - * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the - * interp's result; otherwise, we leave it alone. - */ - - if (flags & TCL_LEAVE_ERR_MSG) { - const char *id, *message = NULL; - Tcl_Size length; - - /* - * Setup errorCode variables so that we can differentiate between - * being canceled and unwound. - */ - - if (iPtr->asyncCancelMsg != NULL) { - message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length); - } else { - length = 0; - } - - if (iPtr->flags & TCL_CANCEL_UNWIND) { - id = "IUNWIND"; - if (length == 0) { - message = "eval unwound"; - } - } else { - id = "ICANCEL"; - if (length == 0) { - message = "eval canceled"; - } - } - - Tcl_SetObjResult(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, (void *)NULL); - } - - /* - * Return TCL_ERROR to the caller (not necessarily just the Tcl core - * itself) that indicates further processing of the script or command in - * progress should halt gracefully and as soon as possible. - */ - - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CancelEval -- - * - * This function schedules the cancellation of the current script in the - * given interpreter. - * - * Results: - * The return value is a standard Tcl completion code such as TCL_OK or - * TCL_ERROR. Since the interp may belong to a different thread, no error - * message can be left in the interp's result. - * - * Side effects: - * The script in progress in the specified interpreter will be canceled - * with TCL_ERROR after asynchronous handlers are invoked at the next - * Tcl_Canceled check. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_CancelEval( - Tcl_Interp *interp, /* Interpreter in which to cancel the - * script. */ - Tcl_Obj *resultObjPtr, /* The script cancellation error message or - * NULL for a default error message. */ - void *clientData, /* Passed to CancelEvalProc. */ - int flags) /* Collection of OR-ed bits that control - * the cancellation of the script. Only - * TCL_CANCEL_UNWIND is currently - * supported. */ -{ - Tcl_HashEntry *hPtr; - CancelInfo *cancelInfo; - int code = TCL_ERROR; - const char *result; - - if (interp == NULL) { - return TCL_ERROR; - } - - Tcl_MutexLock(&cancelLock); - if (cancelTableInitialized != 1) { - /* - * No CancelInfo hash table (Tcl_CreateInterp has never been called?) - */ - - goto done; - } - hPtr = Tcl_FindHashEntry(&cancelTable, interp); - if (hPtr == NULL) { - /* - * No CancelInfo record for this interpreter. - */ - - goto done; - } - cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr); - - /* - * Populate information needed by the interpreter thread to fulfill the - * cancellation request. Currently, clientData is ignored. If the - * TCL_CANCEL_UNWIND flags bit is set, the script in progress is not - * allowed to catch the script cancellation because the evaluation stack - * for the interp is completely unwound. - */ - - if (resultObjPtr != NULL) { - result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length); - cancelInfo->result = (char *)ckrealloc(cancelInfo->result,cancelInfo->length); - memcpy(cancelInfo->result, result, cancelInfo->length); - TclDecrRefCount(resultObjPtr); /* Discard their result object. */ + if (!CheckCStack(iPtr, &localInt)) { + Tcl_AppendResult(interp, + "out of stack space (infinite loop?)", NULL); } else { - cancelInfo->result = NULL; - cancelInfo->length = 0; + Tcl_AppendResult(interp, + "too many nested evaluations (infinite loop?)", NULL); } - cancelInfo->clientData = clientData; - cancelInfo->flags = flags; - Tcl_AsyncMark(cancelInfo->async); - code = TCL_OK; - - done: - Tcl_MutexUnlock(&cancelLock); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InterpActive -- - * - * Returns non-zero if the specified interpreter is in use, i.e. if there - * is an evaluation currently active in the interpreter. - * - * Results: - * See above. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_InterpActive( - Tcl_Interp *interp) -{ - return ((Interp *) interp)->numLevels > 0; + return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * Tcl_EvalObjv -- + * TclEvalObjvInternal * * This function evaluates a Tcl command that has already been parsed - * into words, with one Tcl_Obj holding each word. + * 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. + * 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: - * Always pushes a callback. Other side effects depend on the command. + * Depends on the command. * *---------------------------------------------------------------------- */ int -Tcl_EvalObjv( +TclEvalObjvInternal( Tcl_Interp *interp, /* Interpreter in which to evaluate the * command. Also used for error reporting. */ - Tcl_Size objc, /* Number of words in command. */ + 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. 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 - * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and - * TCL_EVAL_NOERR are currently supported. */ -{ - int result; - NRE_callback *rootPtr = TOP_CB(interp); - - result = TclNREvalObjv(interp, objc, objv, flags, NULL); - return TclNRRunCallbacks(interp, result, rootPtr); -} - -int -TclNREvalObjv( - Tcl_Interp *interp, /* Interpreter in which to evaluate the - * command. Also used for error reporting. */ - Tcl_Size 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, TCL_EVAL_INVOKE and - * TCL_EVAL_NOERR are currently supported. */ - Command *cmdPtr) /* NULL if the Command is to be looked up - * here, otherwise the pointer to the - * requested Command struct to be invoked. */ -{ - Interp *iPtr = (Interp *) interp; - - /* - * data[1] stores a marker for use by tailcalls; it will be set to 1 by - * command redirectors (imports, alias, ensembles) so that tailcall skips - * this callback (that marks the end of the target command) and goes back - * to the end of the source command. - */ - - if (iPtr->deferredCallbacks) { - iPtr->deferredCallbacks = NULL; - } else { - TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - } - - iPtr->numLevels++; - TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), - INT2PTR(objc), objv); - return TCL_OK; -} - -static int -EvalObjvCore( - void *data[], - Tcl_Interp *interp, - TCL_UNUSED(int) /*result*/) + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are + * currently supported. */ { - Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0]; - int flags = PTR2INT(data[1]); - Tcl_Size objc = PTR2INT(data[2]); - Tcl_Obj **objv = (Tcl_Obj **)data[3]; + Command *cmdPtr; Interp *iPtr = (Interp *) interp; - Namespace *lookupNsPtr = NULL; - int enterTracesDone = 0; - - /* - * Push records for task to be done on return, in INVERSE order. First, if - * needed, the exception handlers (as they should happen last). - */ - - if (!(flags & TCL_EVAL_NOERR)) { - TEOV_PushExceptionHandlers(interp, objc, objv, flags); - } + Tcl_Obj **newObjv; + int i; + CallFrame *savedVarFramePtr = NULL; + CallFrame *varFramePtr = iPtr->varFramePtr; + int code = TCL_OK; + int traceCode = TCL_OK; + int checkTraces = 1, traced; + Namespace *savedNsPtr = NULL; + Namespace *lookupNsPtr = iPtr->lookupNsPtr; + Tcl_Obj *commandPtr = NULL; - if (TCL_OK != TclInterpReady(interp)) { + if (TclInterpReady(interp) == TCL_ERROR) { return TCL_ERROR; } @@ -4777,150 +3594,113 @@ EvalObjvCore( return TCL_OK; } - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; - } + /* + * If any execution traces rename or delete the current command, we may + * need (at most) two passes here. + */ + + reparseBecauseOfTraces: /* * Configure evaluation context to match the requested flags. */ - if (iPtr->lookupNsPtr) { + if (flags) { + if (flags & TCL_EVAL_INVOKE) { + savedNsPtr = varFramePtr->nsPtr; + if (lookupNsPtr) { + varFramePtr->nsPtr = lookupNsPtr; + iPtr->lookupNsPtr = NULL; + } else { + varFramePtr->nsPtr = iPtr->globalNsPtr; + } + } else if ((flags & TCL_EVAL_GLOBAL) + && (varFramePtr != iPtr->rootFramePtr) && !savedVarFramePtr) { + varFramePtr = iPtr->rootFramePtr; + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = varFramePtr; + } + } - /* - * Capture the namespace we should do command name resolution in, as - * instructed by our caller sneaking it in to us in a private interp - * field. Clear that field right away so we cannot possibly have its - * use leak where it should not. The sneaky message pass is done. - * - * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. - * TODO: Is that a bug? - */ + /* + * 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. + */ - lookupNsPtr = iPtr->lookupNsPtr; - iPtr->lookupNsPtr = NULL; - } else if (flags & TCL_EVAL_INVOKE) { - lookupNsPtr = iPtr->globalNsPtr; - } else { + 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 */ - TclResetRewriteEnsemble(interp, 1); - - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } + iPtr->ensembleRewrite.sourceObjs = NULL; } /* - * Lookup the Command to dispatch. + * Call trace functions if needed. */ - reresolve: - assert(cmdPtr == NULL); - if (preCmdPtr) { + traced = (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)); + if (traced && checkTraces) { + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + /* - * Caller gave it to us. - */ + * Insure that we have a correct nul-terminated command string for the + * trace code. + */ - if (!(preCmdPtr->flags & CMD_DEAD)) { - /* - * So long as it exists, use it. - */ + commandPtr = GetCommandSource(iPtr, command, length, objc, objv); + command = TclGetStringFromObj(commandPtr, &length); - cmdPtr = preCmdPtr; - } else if (flags & TCL_EVAL_NORESOLVE) { - /* - * When it's been deleted, and we're told not to attempt resolving - * it ourselves, all we can do is raise an error. - */ + /* + * 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. + */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to invoke a deleted command")); - Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", (void *)NULL); - return TCL_ERROR; + cmdPtr->refCount++; + if (iPtr->tracePtr && (traceCode == TCL_OK)) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); } - } - if (cmdPtr == NULL) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); } - } - - if (enterTracesDone || iPtr->tracePtr - || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - Tcl_Obj *commandPtr = TclGetSourceFromFrame( - flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv); - - Tcl_IncrRefCount(commandPtr); - if (!enterTracesDone) { - int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, - objc, objv); - - /* - * Send any exception from enter traces back as an exception - * raised by the traced command. - * TODO: Is this a bug? Letting an execution trace BREAK or - * CONTINUE or RETURN in the place of the traced command? Would - * either converting all exceptions to TCL_ERROR, or just - * swallowing them be better? (Swallowing them has the problem of - * permanently hiding program errors.) - */ - - if (code != TCL_OK) { - Tcl_DecrRefCount(commandPtr); - return code; - } + newEpoch = cmdPtr->cmdEpoch; + TclCleanupCommandMacro(cmdPtr); - /* - * If the enter traces made the resolved cmdPtr unusable, go back - * and resolve again, but next time don't run enter traces again. - */ + /* + * 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 (cmdPtr == NULL) { - enterTracesDone = 1; + if (traceCode == TCL_OK && cmdEpoch != newEpoch) { + checkTraces = 0; + if (commandPtr) { Tcl_DecrRefCount(commandPtr); - goto reresolve; + commandPtr = NULL; } + goto reparseBecauseOfTraces; } - - /* - * Schedule leave traces. Raise the refCount on the resolved cmdPtr, - * so that when it passes to the leave traces we know it's still - * valid. - */ - - cmdPtr->refCount++; - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); } - TclNRAddCallback(interp, Dispatch, - cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, - cmdPtr->objClientData, INT2PTR(objc), objv); - return TCL_OK; -} - -static int -Dispatch( - void *data[], - Tcl_Interp *interp, - TCL_UNUSED(int) /*result*/) -{ - Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0]; - void *clientData = data[1]; - int objc = PTR2INT(data[2]); - Tcl_Obj **objv = (Tcl_Obj **)data[3]; - Interp *iPtr = (Interp *) interp; - #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { - const char *a[10]; + char *a[10]; int i = 0; while (i < 10) { @@ -4931,315 +3711,172 @@ Dispatch( } if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); - const char *a[6]; Tcl_Size i[2]; + 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], a[4], a[5]); + TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); TclDecrRefCount(info); } - if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) - && objc) { - TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); - } - if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } #endif /* USE_DTRACE */ - iPtr->cmdCount++; - return objProc(clientData, interp, objc, objv); -} - -int -TclNRRunCallbacks( - Tcl_Interp *interp, - int result, - struct NRE_callback *rootPtr) - /* All callbacks down to rootPtr not inclusive - * are to be run. */ -{ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - Interp *iPtr = (Interp *) interp; -#endif /* !defined(TCL_NO_DEPRECATED) */ - - /* - * 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. - * - * This only needs to be done for the first item in the list: all other - * are for NR function calls, and those are Tcl_Obj based. - */ - -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - if (*(iPtr->result) != 0) { - (void) Tcl_GetObjResult(interp); - } -#endif /* !defined(TCL_NO_DEPRECATED) */ - /* - * This is the trampoline. + * Finally, invoke the command's Tcl_ObjCmdProc. */ - while (TOP_CB(interp) != rootPtr) { - NRE_callback *callbackPtr = TOP_CB(interp); - Tcl_NRPostProc *procPtr = callbackPtr->procPtr; - - TOP_CB(interp) = callbackPtr->nextPtr; - result = procPtr(callbackPtr->data, interp, result); - TCLNR_FREE(interp, callbackPtr); - } - return result; -} - -static int -NRCommand( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr; - - iPtr->numLevels--; - - /* - * If there is a tailcall, schedule it next - */ - - if (data[1] && (data[1] != INT2PTR(1))) { - listPtr = (Tcl_Obj *)data[1]; - data[1] = NULL; - - TclNRAddCallback(interp, TclNRTailcallEval, listPtr, NULL, NULL, NULL); + cmdPtr->refCount++; + iPtr->cmdCount++; + 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)); + } + code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + if (TCL_DTRACE_CMD_RETURN_ENABLED()) { + TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code); + } } - /* OPT ?? - * Do not interrupt a series of cleanups with async or limit checks: - * just check at the end? - */ - if (TclAsyncReady(iPtr)) { - result = Tcl_AsyncInvoke(interp, result); - } - if ((result == TCL_OK) && TclCanceled(iPtr)) { - result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG); + code = Tcl_AsyncInvoke(interp, code); } - if (result == TCL_OK && TclLimitReady(iPtr->limit)) { - result = Tcl_LimitCheck(interp); + if (code == TCL_OK && TclLimitReady(iPtr->limit)) { + code = Tcl_LimitCheck(interp); } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TEOV_Exception - - * TEOV_LookupCmdFromObj - - * TEOV_RunEnterTraces - - * TEOV_RunLeaveTraces - - * TEOV_NotFound - - * - * These are helper functions for Tcl_EvalObjv. - * - *---------------------------------------------------------------------- - */ - -static void -TEOV_PushExceptionHandlers( - Tcl_Interp *interp, - Tcl_Size objc, - Tcl_Obj *const objv[], - int flags) -{ - Interp *iPtr = (Interp *) interp; - /* - * If any error processing is necessary, push the appropriate records. - * Note that we have to push them in the inverse order: first the one that - * has to run last. + * Call 'leave' command traces */ - if (!(flags & TCL_EVAL_INVOKE)) { - /* - * Error messages - */ - - TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc), - objv, NULL, NULL); - } + 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 (iPtr->numLevels == 1) { /* - * No CONTINUE or BREAK at level 0, manage RETURN + * 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. */ - TclNRAddCallback(interp, TEOV_Exception, INT2PTR(iPtr->evalFlags), - NULL, NULL, NULL); + if (traceCode != TCL_OK) { + code = traceCode; + } + if (commandPtr) { + Tcl_DecrRefCount(commandPtr); + } } -} - -static void -TEOV_SwitchVarFrame( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; /* - * Change the varFrame to be the rootVarFrame, and push a record to - * restore things at the end. + * Decrement the reference count of cmdPtr and deallocate it if it has + * dropped to zero. */ - TclNRAddCallback(interp, TEOV_RestoreVarFrame, iPtr->varFramePtr, NULL, - NULL, NULL); - iPtr->varFramePtr = iPtr->rootFramePtr; -} - -static int -TEOV_RestoreVarFrame( - void *data[], - Tcl_Interp *interp, - int result) -{ - ((Interp *) interp)->varFramePtr = (CallFrame *)data[0]; - return result; -} - -static int -TEOV_Exception( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - int allowExceptions = (PTR2INT(data[0]) & TCL_ALLOW_EXCEPTIONS); - - if (result != TCL_OK) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } - if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { - ProcessUnexpectedResult(interp, result); - result = TCL_ERROR; - } - } + TclCleanupCommandMacro(cmdPtr); /* - * We are returning to level 0, so should process TclResetCancellation. As - * numLevels has not *yet* been decreased, do not call it: do the thing - * here directly. + * 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. */ - TclUnsetCancelFlags(iPtr); - return result; -} - -static int -TEOV_Error( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr; - const char *cmdString; - Tcl_Size cmdLen; - Tcl_Size objc = PTR2INT(data[0]); - Tcl_Obj **objv = (Tcl_Obj **)data[1]; + if (*(iPtr->result) != 0) { + (void) Tcl_GetObjResult(interp); + } - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - /* - * If there was an error, a command string will be needed for the - * error log: get it out of the itemPtr. The details depend on the - * type. - */ +#ifdef USE_DTRACE + if (TCL_DTRACE_CMD_RESULT_ENABLED()) { + Tcl_Obj *r; - listPtr = Tcl_NewListObj(objc, objv); - cmdString = TclGetStringFromObj(listPtr, &cmdLen); - Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); - Tcl_DecrRefCount(listPtr); + r = Tcl_GetObjResult(interp); + TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r),r); } - iPtr->flags &= ~ERR_ALREADY_LOGGED; - return result; -} +#endif /* USE_DTRACE */ -static int -TEOV_NotFound( - Tcl_Interp *interp, - Tcl_Size objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr) -{ - Command * cmdPtr; - Interp *iPtr = (Interp *) interp; - Tcl_Size i, newObjc, handlerObjc; - Tcl_Obj **newObjv, **handlerObjv; - CallFrame *varFramePtr = iPtr->varFramePtr; - Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered - * unknown command handler for the current - * namespace (TIP 181). */ - Namespace *savedNsPtr = NULL; + done: + if (savedVarFramePtr) { + iPtr->varFramePtr = savedVarFramePtr; + } + return code; - currNsPtr = varFramePtr->nsPtr; - if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) { - currNsPtr = iPtr->globalNsPtr; - if (currNsPtr == NULL) { - Tcl_Panic("TEOV_NotFound: NULL global namespace pointer"); + 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"); + } } - } - /* - * Check to see if the resolution namespace has lost its unknown handler. - * If so, reset it to "::unknown". - */ + /* + * Check to see if the resolution namespace has lost its unknown + * handler. If so, reset it to "::unknown". + */ - if (currNsPtr->unknownHandlerPtr == NULL) { - TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); - Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); - } + if (currNsPtr->unknownHandlerPtr == NULL) { + TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); + Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); + } - /* - * 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 invocation - * itself. - */ + /* + * 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. + */ - TclListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, - &handlerObjc, &handlerObjv); - newObjc = objc + handlerObjc; - newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc); + 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. - */ + /* + * 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]); - } - memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * objc); + for (i = 0; i < handlerObjc; ++i) { + newObjv[i] = handlerObjv[i]; + Tcl_IncrRefCount(newObjv[i]); + } + memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); - /* - * 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. - * - * In this case we worry a bit less about recursion for now, and call the - * "blocking" interface. - */ + /* + * 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. + */ - cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr); - if (cmdPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid command name \"%s\"", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(objv[0]), (void *)NULL); + 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--; + } /* * Release any resources we locked and allocated during the handler @@ -5250,165 +3887,89 @@ TEOV_NotFound( Tcl_DecrRefCount(newObjv[i]); } TclStackFree(interp, newObjv); - return TCL_ERROR; - } - - if (lookupNsPtr) { - savedNsPtr = varFramePtr->nsPtr; - varFramePtr->nsPtr = lookupNsPtr; - } - TclSkipTailcall(interp); - TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc), - newObjv, savedNsPtr, NULL); - return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL); -} - -static int -TEOV_NotFoundCallback( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Size objc = PTR2INT(data[0]); - Tcl_Obj **objv = (Tcl_Obj **)data[1]; - Namespace *savedNsPtr = (Namespace *)data[2]; - - Tcl_Size i; - - if (savedNsPtr) { - iPtr->varFramePtr->nsPtr = savedNsPtr; - } - - /* - * Release any resources we locked and allocated during the handler call. - */ - - for (i = 0; i < objc; ++i) { - Tcl_DecrRefCount(objv[i]); + if (savedNsPtr) { + varFramePtr->nsPtr = savedNsPtr; + } + goto done; } - TclStackFree(interp, objv); - - return result; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObjv -- + * + * This function 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. + * + *---------------------------------------------------------------------- + */ -static int -TEOV_RunEnterTraces( - Tcl_Interp *interp, - Command **cmdPtrPtr, - Tcl_Obj *commandPtr, - Tcl_Size objc, - Tcl_Obj *const objv[]) +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. */ { Interp *iPtr = (Interp *) interp; - Command *cmdPtr = *cmdPtrPtr; - Tcl_Size length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch; - int traceCode = TCL_OK; - const char *command = TclGetStringFromObj(commandPtr, &length); - - /* - * Call trace functions. - * 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. - */ + int code = TCL_OK; + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - cmdPtr->refCount++; - if (iPtr->tracePtr) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - TclCleanupCommandMacro(cmdPtr); + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objc, objv, NULL, 0, flags); + iPtr->numLevels--; - if (traceCode != TCL_OK) { - if (traceCode == TCL_ERROR) { - Tcl_Obj *info; + if (code == TCL_OK) { + return code; + } else { - TclNewLiteralStringObj(info, "\n (enter trace on \""); - Tcl_AppendLimitedToObj(info, command, length, 55, "..."); - Tcl_AppendToObj(info, "\")", 2); - Tcl_AppendObjToErrorInfo(interp, info); - iPtr->flags |= ERR_ALREADY_LOGGED; - } - return traceCode; - } - if (cmdEpoch != newEpoch) { - *cmdPtrPtr = NULL; - } - return TCL_OK; -} + /* + * If we are again at the top level, process any unusual return code + * returned by the evaluated code. + */ -static int -TEOV_RunLeaveTraces( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - int traceCode = TCL_OK; - Tcl_Size objc = PTR2INT(data[0]); - Tcl_Obj *commandPtr = (Tcl_Obj *)data[1]; - Command *cmdPtr = (Command *)data[2]; - Tcl_Obj **objv = (Tcl_Obj **)data[3]; - Tcl_Size length; - const char *command = TclGetStringFromObj(commandPtr, &length); - - if (!(cmdPtr->flags & CMD_DYING)) { - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); - } - if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); + if (iPtr->numLevels == 0) { + if (code == TCL_RETURN) { + code = TclUpdateReturnInfo(iPtr); + } + if ((code != TCL_ERROR) && !allowExceptions) { + ProcessUnexpectedResult(interp, code); + code = TCL_ERROR; + } } - } - /* - * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. - * Prevent that by resetting the cmdPtr field and dealing right here with - * cmdPtr->refCount. - */ - - TclCleanupCommandMacro(cmdPtr); + 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. + */ - if (traceCode != TCL_OK) { - if (traceCode == TCL_ERROR) { - Tcl_Obj *info; + Tcl_Obj *listPtr; + char *cmdString; + int cmdLen; - TclNewLiteralStringObj(info, "\n (leave trace on \""); - Tcl_AppendLimitedToObj(info, command, length, 55, "..."); - Tcl_AppendToObj(info, "\")", 2); - Tcl_AppendObjToErrorInfo(interp, info); - iPtr->flags |= ERR_ALREADY_LOGGED; + listPtr = Tcl_NewListObj(objc, objv); + cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); + Tcl_DecrRefCount(listPtr); } - result = traceCode; - } - Tcl_DecrRefCount(commandPtr); - return result; -} - -static inline Command * -TEOV_LookupCmdFromObj( - Tcl_Interp *interp, - Tcl_Obj *namePtr, - Namespace *lookupNsPtr) -{ - Interp *iPtr = (Interp *) interp; - Command *cmdPtr; - Namespace *savedNsPtr = iPtr->varFramePtr->nsPtr; - if (lookupNsPtr) { - iPtr->varFramePtr->nsPtr = lookupNsPtr; + return code; } - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); - iPtr->varFramePtr->nsPtr = savedNsPtr; - return cmdPtr; } /* @@ -5438,14 +3999,13 @@ Tcl_EvalTokensStandard( * errors. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * evaluate and concatenate. */ - Tcl_Size count) /* Number of tokens to consider at tokenPtr. + int count) /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, - NULL, NULL); + NULL, NULL); } -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -5480,7 +4040,7 @@ Tcl_EvalTokens( * errors. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * evaluate and concatenate. */ - Tcl_Size count) /* Number of tokens to consider at tokenPtr. + int count) /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { Tcl_Obj *resPtr; @@ -5493,7 +4053,6 @@ Tcl_EvalTokens( Tcl_ResetResult(interp); return resPtr; } -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -5521,14 +4080,14 @@ 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. */ - Tcl_Size numBytes, /* Number of bytes in script. If -1, the + int numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ int flags) /* Collection of OR-ed bits that control the * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ { - return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script); + return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script); } int @@ -5536,64 +4095,66 @@ 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. */ - Tcl_Size numBytes, /* Number of bytes in script. If -1, the + int numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first NUL character. */ int flags, /* Collection of OR-ed bits that control the * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ - Tcl_Size line, /* The line the script starts on. */ - Tcl_Size *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 referred to - * by 'script'. The 'clNextOuter' refers to - * the current entry in the table of - * continuation lines in this "main script", - * and the character offsets are relative to - * the 'outerScript' as well. - * - * If outerScript == script, then this call is - * for the outer-most script/command. See - * Tcl_EvalEx() and TclEvalObjEx() for places - * generating arguments for which this is - * true. */ + 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 + * '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 the outer-most script/command. See + * Tcl_EvalEx() and TclEvalObjEx() for places + * generating arguments for which this is true. + */ { Interp *iPtr = (Interp *) interp; const char *p, *next; - const int minObjs = 20; + const unsigned int minObjs = 20; Tcl_Obj **objv, **objvSpace; - int *expand; - Tcl_Size *lines, *lineSpace; + int *expand, *lines, *lineSpace; Tcl_Token *tokenPtr; - int expandRequested, code = TCL_OK; - Tcl_Size bytesLeft, commandLength; + 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); int gotParse = 0; - Tcl_Size i, objectsUsed = 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_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)); - Tcl_Size *linesStack = (Tcl_Size *)TclStackAlloc(interp, minObjs * sizeof(Tcl_Size)); + int *expandStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int)); + int *linesStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int)); /* TIP #280 Structures for tracking of command * locations. */ - Tcl_Size *clNext = NULL; /* Pointer for the tracking of invisible - * continuation lines. Initialized only if the - * caller gave us a table of locations to - * track, via scriptCLLocPtr. It always refers - * to the table entry holding the location of - * the next invisible continuation line to - * look for, while parsing the script. */ + /* + * Pointer for the tracking of invisible continuation lines. Initialized + * only if the caller gave us a table of locations to track, via + * scriptCLLocPtr. It always refers to the table entry holding the + * location of the next invisible continuation line to look for, while + * parsing the script. + */ + + int* clNext = NULL; if (iPtr->scriptCLLocPtr) { if (clNextOuter) { @@ -5627,22 +4188,23 @@ TclEvalEx( /* * TIP #280 Initialize tracking. Do not push on the frame stack yet. * - * We 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. + * 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. */ - eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; - eeFramePtr->framePtr = iPtr->framePtr; - eeFramePtr->nextPtr = iPtr->cmdFramePtr; - eeFramePtr->nline = 0; - eeFramePtr->line = NULL; - eeFramePtr->cmdObj = NULL; + if (iPtr->evalFlags & TCL_EVAL_CTX) { + /* + * Path information comes out of the context. + */ - iPtr->cmdFramePtr = eeFramePtr; - if (iPtr->evalFlags & TCL_EVAL_FILE) { + 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. */ @@ -5663,7 +4225,6 @@ TclEvalEx( /* * Error message in the interp result. */ - code = TCL_ERROR; goto error; } @@ -5681,13 +4242,17 @@ TclEvalEx( eeFramePtr->data.eval.path = NULL; } + 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, 0, parsePtr) != TCL_OK) { code = TCL_ERROR; - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - parsePtr->term + 1 - parsePtr->commandStart); - goto posterror; + goto error; } /* @@ -5697,8 +4262,8 @@ TclEvalEx( */ TclAdvanceLines(&line, p, parsePtr->commandStart); - TclAdvanceContinuations(&line, &clNext, - parsePtr->commandStart - outerScript); + TclAdvanceContinuations (&line, &clNext, + parsePtr->commandStart - outerScript); gotParse = 1; if (parsePtr->numWords > 0) { @@ -5709,26 +4274,27 @@ TclEvalEx( * per-command parsing. */ - Tcl_Size wordLine = line; + int wordLine = line; const char *wordStart = parsePtr->commandStart; - Tcl_Size *wordCLNext = clNext; - Tcl_Size objectsNeeded = 0; - Tcl_Size numWords = parsePtr->numWords; + int* wordCLNext = clNext; /* * Generate an array of objects for the words of the command. */ + unsigned int objectsNeeded = 0; + unsigned int numWords = parsePtr->numWords; + if (numWords > minObjs) { - expand = (int *)ckalloc(numWords * sizeof(int)); - objvSpace = (Tcl_Obj **)ckalloc(numWords * sizeof(Tcl_Obj *)); - lineSpace = (Tcl_Size *)ckalloc(numWords * sizeof(Tcl_Size)); + 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; - iPtr->cmdFramePtr = eeFramePtr->nextPtr; for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr; objectsUsed < numWords; objectsUsed++, tokenPtr += tokenPtr->numComponents+1) { @@ -5741,8 +4307,8 @@ TclEvalEx( */ TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); - TclAdvanceContinuations(&wordLine, &wordCLNext, - tokenPtr->start - outerScript); + TclAdvanceContinuations (&wordLine, &wordCLNext, + tokenPtr->start - outerScript); wordStart = tokenPtr->start; lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) @@ -5754,17 +4320,17 @@ TclEvalEx( code = TclSubstTokens(interp, tokenPtr+1, tokenPtr->numComponents, NULL, wordLine, - wordCLNext, outerScript); + wordCLNext, outerScript); iPtr->evalFlags = 0; if (code != TCL_OK) { - break; + goto error; } objv[objectsUsed] = Tcl_GetObjResult(interp); Tcl_IncrRefCount(objv[objectsUsed]); if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - Tcl_Size numElements; + int numElements; code = TclListObjLength(interp, objv[objectsUsed], &numElements); @@ -5774,9 +4340,9 @@ TclEvalEx( */ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (expanding word %" TCL_SIZE_MODIFIER "d)", objectsUsed)); + "\n (expanding word %d)", objectsUsed)); Tcl_DecrRefCount(objv[objectsUsed]); - break; + goto error; } expandRequested = 1; expand[objectsUsed] = 1; @@ -5788,37 +4354,34 @@ TclEvalEx( } if (wordCLNext) { - TclContinuationsEnterDerived(objv[objectsUsed], - wordStart - outerScript, wordCLNext); + TclContinuationsEnterDerived (objv[objectsUsed], + wordStart - outerScript, wordCLNext); } } /* for loop */ - iPtr->cmdFramePtr = eeFramePtr; - if (code != TCL_OK) { - goto error; - } if (expandRequested) { /* * Some word expansion was requested. Check for objv resize. */ Tcl_Obj **copy = objvSpace; - Tcl_Size *lcopy = lineSpace; - Tcl_Size wordIdx = numWords; - Tcl_Size objIdx = objectsNeeded - 1; - - if ((numWords > minObjs) || (objectsNeeded > minObjs)) { - objv = objvSpace = - (Tcl_Obj **)ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = (Tcl_Size *)ckalloc(objectsNeeded * sizeof(Tcl_Size)); + 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]) { - Tcl_Size numElements; + int numElements; Tcl_Obj **elements, *temp = copy[wordIdx]; - TclListObjGetElements(NULL, temp, &numElements, + Tcl_ListObjGetElements(NULL, temp, &numElements, &elements); objectsUsed += numElements; while (numElements--) { @@ -5836,10 +4399,10 @@ TclEvalEx( objv += objIdx+1; if (copy != stackObjArray) { - ckfree(copy); + ckfree((char *) copy); } if (lcopy != linesStack) { - ckfree(lcopy); + ckfree((char *) lcopy); } } @@ -5853,28 +4416,28 @@ TclEvalEx( * have been executed. */ - eeFramePtr->cmd = parsePtr->commandStart; - eeFramePtr->len = parsePtr->commandSize; + eeFramePtr->cmd.str.cmd = parsePtr->commandStart; + eeFramePtr->cmd.str.len = parsePtr->commandSize; if (parsePtr->term == parsePtr->commandStart + parsePtr->commandSize - 1) { - eeFramePtr->len--; + eeFramePtr->cmd.str.len--; } eeFramePtr->nline = objectsUsed; eeFramePtr->line = lines; - TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); - code = Tcl_EvalObjv(interp, objectsUsed, objv, - TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME); - TclArgumentRelease(interp, objv, objectsUsed); + TclArgumentEnter (interp, objv, objectsUsed, eeFramePtr); + iPtr->cmdFramePtr = eeFramePtr; + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objectsUsed, objv, + parsePtr->commandStart, parsePtr->commandSize, 0); + iPtr->numLevels--; + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + TclArgumentRelease (interp, objv, objectsUsed); eeFramePtr->line = NULL; eeFramePtr->nline = 0; - if (eeFramePtr->cmdObj) { - Tcl_DecrRefCount(eeFramePtr->cmdObj); - eeFramePtr->cmdObj = NULL; - } if (code != TCL_OK) { goto error; @@ -5884,9 +4447,9 @@ TclEvalEx( } objectsUsed = 0; if (objvSpace != stackObjArray) { - ckfree(objvSpace); + ckfree((char *) objvSpace); objvSpace = stackObjArray; - ckfree(lineSpace); + ckfree((char *) lineSpace); lineSpace = linesStack; } @@ -5896,7 +4459,7 @@ TclEvalEx( */ if (expand != expandStack) { - ckfree(expand); + ckfree((char *) expand); expand = expandStack; } } @@ -5948,7 +4511,6 @@ TclEvalEx( Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, commandLength); } - posterror: iPtr->flags &= ~ERR_ALREADY_LOGGED; /* @@ -5962,11 +4524,11 @@ TclEvalEx( Tcl_FreeParse(parsePtr); } if (objvSpace != stackObjArray) { - ckfree(objvSpace); - ckfree(lineSpace); + ckfree((char *) objvSpace); + ckfree((char *) lineSpace); } if (expand != expandStack) { - ckfree(expand); + ckfree((char *) expand); } iPtr->varFramePtr = savedVarFramePtr; @@ -5975,7 +4537,6 @@ TclEvalEx( * TIP #280. Release the local CmdFrame, and its contents. */ - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; if (eeFramePtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eeFramePtr->data.eval.path); } @@ -6008,11 +4569,11 @@ TclEvalEx( void TclAdvanceLines( - Tcl_Size *line, + int *line, const char *start, const char *end) { - const char *p; + register const char *p; for (p = start; p < end; p++) { if (*p == '\n') { @@ -6042,31 +4603,29 @@ TclAdvanceLines( */ void -TclAdvanceContinuations( - Tcl_Size *line, - Tcl_Size **clNextPtrPtr, - int loc) +TclAdvanceContinuations (line,clNextPtrPtr,loc) + int* line; + int** clNextPtrPtr; + int loc; { /* - * Track the invisible continuation lines embedded in a script, if any. - * Here they are just spaces (already). They were removed by - * TclSubstTokens via TclParseBackslash. + * Track the invisible continuation lines embedded in a script, if + * any. Here they are just spaces (already). They were removed by + * 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. */ - while (*clNextPtrPtr && (**clNextPtrPtr >= 0) - && (loc >= **clNextPtrPtr)) { + while (*clNextPtrPtr && (**clNextPtrPtr >= 0) && (loc >= **clNextPtrPtr)) { /* * We just stepped over an invisible continuation line. Adjust the * line counter and step to the table entry holding the location of * the next continuation line to track. */ - - (*line)++; - (*clNextPtrPtr)++; + (*line) ++; + (*clNextPtrPtr) ++; } } @@ -6084,8 +4643,8 @@ TclAdvanceContinuations( * * TclArgumentEnter -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * enters location references for the arguments of a command to be + * This procedure is a helper for the TIP #280 uplevel extension. + * It enters location references for the arguments of a command to be * invoked. Only the first entry has the actual data, further entries * simply count the usage up. * @@ -6100,50 +4659,45 @@ TclAdvanceContinuations( */ void -TclArgumentEnter( - Tcl_Interp *interp, - Tcl_Obj **objv, - Tcl_Size objc, - CmdFrame *cfPtr) -{ - Interp *iPtr = (Interp *) interp; - int isNew; - Tcl_Size i; - Tcl_HashEntry *hPtr; - CFWord *cfwPtr; - - for (i = 1; i < objc; i++) { +TclArgumentEnter(interp,objv,objc,cfPtr) + Tcl_Interp* interp; + Tcl_Obj** objv; + int objc; + CmdFrame* cfPtr; +{ + Interp* iPtr = (Interp*) interp; + int new, i; + Tcl_HashEntry* hPtr; + CFWord* cfwPtr; + + for (i=1; i < objc; i++) { /* - * Ignore argument words without line information (= dynamic). If they - * are variables they may have location information associated with - * that, either through globally recorded 'set' invocations, or - * literals in bytecode. Either way there is no need to record + * Ignore argument words without line information (= dynamic). If + * they are variables they may have location information associated + * with that, either through globally recorded 'set' invokations, or + * literals in bytecode. Eitehr way there is no need to record * something here. */ - if (cfPtr->line[i] < 0) { - continue; - } - hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &isNew); - if (isNew) { - /* - * The word is not on the stack yet, remember the current location - * and initialize references. - */ - - cfwPtr = (CFWord *)ckalloc(sizeof(CFWord)); - cfwPtr->framePtr = cfPtr; - cfwPtr->word = i; - cfwPtr->refCount = 1; - Tcl_SetHashValue(hPtr, cfwPtr); + if (cfPtr->line [i] < 0) continue; + hPtr = Tcl_CreateHashEntry (iPtr->lineLAPtr, (char*) objv[i], &new); + if (new) { + /* + * The word is not on the stack yet, remember the current location + * and initialize references. + */ + cfwPtr = (CFWord*) ckalloc (sizeof (CFWord)); + cfwPtr->framePtr = cfPtr; + cfwPtr->word = i; + cfwPtr->refCount = 1; + Tcl_SetHashValue (hPtr, cfwPtr); } else { - /* - * The word is already on the stack, its current location is not - * relevant. Just remember the reference to prevent early removal. - */ - - cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr); - cfwPtr->refCount++; + /* + * The word is already on the stack, its current location is not + * relevant. Just remember the reference to prevent early removal. + */ + cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); + cfwPtr->refCount ++; } } } @@ -6153,10 +4707,10 @@ TclArgumentEnter( * * TclArgumentRelease -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * removes the location references for the arguments of a command just - * done. Usage is counted down, the data is removed only when no user is - * left over. + * This procedure is a helper for the TIP #280 uplevel extension. + * It removes the location references for the arguments of a command + * just done. Usage is counted down, the data is removed only when + * no user is left over. * * Results: * None. @@ -6169,30 +4723,27 @@ TclArgumentEnter( */ void -TclArgumentRelease( - Tcl_Interp *interp, - Tcl_Obj **objv, - Tcl_Size objc) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Size i; +TclArgumentRelease(interp,objv,objc) + Tcl_Interp* interp; + Tcl_Obj** objv; + int objc; +{ + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hPtr; + CFWord* cfwPtr; + int i; - for (i = 1; i < objc; i++) { - CFWord *cfwPtr; - Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(iPtr->lineLAPtr, objv[i]); + for (i=1; i < objc; i++) { + hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) objv[i]); - if (!hPtr) { - continue; - } - cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr); + if (!hPtr) { continue; } + cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); - if (cfwPtr->refCount-- > 1) { - continue; - } + cfwPtr->refCount --; + if (cfwPtr->refCount > 0) { continue; } - ckfree(cfwPtr); - Tcl_DeleteHashEntry(hPtr); + ckfree ((char*) cfwPtr); + Tcl_DeleteHashEntry (hPtr); } } @@ -6201,9 +4752,9 @@ TclArgumentRelease( * * TclArgumentBCEnter -- * - * 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 invoked. Only the first entry has the actual + * 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 invoked. Only the first entry has the actual * data, further entries simply count the usage up. * * Results: @@ -6217,94 +4768,73 @@ TclArgumentRelease( */ void -TclArgumentBCEnter( - Tcl_Interp *interp, - Tcl_Obj *objv[], - Tcl_Size objc, - void *codePtr, - CmdFrame *cfPtr, - Tcl_Size cmd, - Tcl_Size pc) -{ - ExtCmdLoc *eclPtr; - Tcl_Size word; - ECL *ePtr; - CFWordBC *lastPtr = NULL; - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); - - if (!hePtr) { - return; - } - eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr); - ePtr = &eclPtr->loc[cmd]; +TclArgumentBCEnter(interp,objv,objc,codePtr,cfPtr,pc) + Tcl_Interp* interp; + Tcl_Obj* objv[]; + int objc; + void* codePtr; + CmdFrame* cfPtr; + int pc; +{ + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); + + if (hePtr) { + ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); + hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); + + if (hePtr) { + int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); + ECL* ePtr = &eclPtr->loc[cmd]; + int word; - /* - * ePtr->nline is the number of words originally parsed. - * - * objc is the number of elements getting invoked. - * - * If they are not the same, we arrived here by compiling an - * ensemble dispatch. Ensemble subcommands that lead to script - * evaluation are not supposed to get compiled, because a command - * such as [info level] in the script can expose some of the dispatch - * shenanigans. This means that we don't have to tend to the - * housekeeping, and can escape now. - */ - - if (ePtr->nline != objc) { - return; - } - - /* - * Having disposed of the ensemble cases, we can state... - * A few truths ... - * (1) ePtr->nline == objc - * (2) (ePtr->line[word] < 0) => !literal, for all words - * (3) (word == 0) => !literal - * - * Item (2) is why we can use objv to get the literals, and do not - * have to save them at compile time. - */ - - for (word = 1; word < objc; word++) { - if (ePtr->line[word] >= 0) { - int isNew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, - objv[word], &isNew); - CFWordBC *cfwPtr = (CFWordBC *)ckalloc(sizeof(CFWordBC)); - - cfwPtr->framePtr = cfPtr; - cfwPtr->obj = objv[word]; - cfwPtr->pc = pc; - cfwPtr->word = word; - cfwPtr->nextPtr = lastPtr; - lastPtr = cfwPtr; + /* + * A few truths ... + * (1) ePtr->nline == objc + * (2) (ePtr->line[word] < 0) => !literal, for all words + * (3) (word == 0) => !literal + * + * Item (2) is why we can use objv to get the literals, and do not + * have to save them at compile time. + */ - if (isNew) { - /* - * The word is not on the stack yet, remember the current - * location and initialize references. - */ + if (ePtr->nline != objc) { + Tcl_Panic ("TIP 280 data structure inconsistency"); + } - cfwPtr->prevPtr = NULL; - } else { - /* - * The object is already on the stack, however it may have - * a different location now (literal sharing may map - * multiple location to a single Tcl_Obj*. Save the old - * information in the new structure. - */ + for (word = 1; word < objc; word++) { + if (ePtr->line[word] >= 0) { + int isnew; + Tcl_HashEntry* hPtr = + Tcl_CreateHashEntry (iPtr->lineLABCPtr, + (char*) objv[word], &isnew); + CFWordBC* cfwPtr = (CFWordBC*) ckalloc (sizeof (CFWordBC)); - cfwPtr->prevPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); - } + cfwPtr->framePtr = cfPtr; + cfwPtr->pc = pc; + cfwPtr->word = word; - Tcl_SetHashValue(hPtr, cfwPtr); - } - } /* for */ + if (isnew) { + /* + * The word is not on the stack yet, remember the + * current location and initialize references. + */ + cfwPtr->prevPtr = NULL; + } else { + /* + * The object is already on the stack, however it may + * have a different location now (literal sharing may + * map multiple location to a single Tcl_Obj*. Save + * the old information in the new structure. + */ + cfwPtr->prevPtr = (CFWordBC*) Tcl_GetHashValue(hPtr); + } - cfPtr->litarg = lastPtr; + Tcl_SetHashValue (hPtr, cfwPtr); + } + } /* for */ + } /* if */ + } /* if */ } /* @@ -6312,10 +4842,10 @@ TclArgumentBCEnter( * * TclArgumentBCRelease -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * removes the location references for the literal arguments of commands - * in bytecode just done. Usage is counted down, the data is removed only - * when no user is left over. + * This procedure is a helper for the TIP #280 uplevel extension. + * It removes the location references for the literal arguments of + * commands in bytecode just done. Usage is counted down, the data + * is removed only when no user is left over. * * Results: * None. @@ -6328,34 +4858,48 @@ TclArgumentBCEnter( */ void -TclArgumentBCRelease( - Tcl_Interp *interp, - CmdFrame *cfPtr) +TclArgumentBCRelease(interp,objv,objc,codePtr,pc) + Tcl_Interp* interp; + Tcl_Obj* objv[]; + int objc; + void* codePtr; + int pc; { - Interp *iPtr = (Interp *) interp; - CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg; + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); - while (cfwPtr) { - CFWordBC *nextPtr = cfwPtr->nextPtr; - Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(iPtr->lineLABCPtr, cfwPtr->obj); - CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); + if (hePtr) { + ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); + hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); - if (xPtr != cfwPtr) { - Tcl_Panic("TclArgumentBC Enter/Release Mismatch"); - } + if (hePtr) { + int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); + ECL* ePtr = &eclPtr->loc[cmd]; + int word; - if (cfwPtr->prevPtr) { - Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); - } else { - Tcl_DeleteHashEntry(hPtr); - } + /* + * Iterate in reverse order, to properly match our pop to the push + * in TclArgumentBCEnter(). + */ + for (word = objc-1; word >= 1; word--) { + if (ePtr->line[word] >= 0) { + Tcl_HashEntry* hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, + (char *) objv[word]); + if (hPtr) { + CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); + + if (cfwPtr->prevPtr) { + Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); + } else { + Tcl_DeleteHashEntry(hPtr); + } - ckfree(cfwPtr); - cfwPtr = nextPtr; + ckfree((char *) cfwPtr); + } + } + } + } } - - cfPtr->litarg = NULL; } /* @@ -6363,8 +4907,8 @@ TclArgumentBCRelease( * * TclArgumentGet -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * finds the location references for a Tcl_Obj, if any. + * This procedure is a helper for the TIP #280 uplevel extension. + * It find the location references for a Tcl_Obj, if any. * * Results: * None. @@ -6377,15 +4921,15 @@ TclArgumentBCRelease( */ void -TclArgumentGet( - Tcl_Interp *interp, - Tcl_Obj *obj, - CmdFrame **cfPtrPtr, - int *wordPtr) +TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) + Tcl_Interp* interp; + Tcl_Obj* obj; + CmdFrame** cfPtrPtr; + int* wordPtr; { - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - CmdFrame *framePtr; + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hPtr; + CmdFrame* framePtr; /* * An object which either has no string rep or else is a canonical list is @@ -6394,7 +4938,7 @@ TclArgumentGet( * up by the caller. It knows better than us. */ - if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) { + if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { return; } @@ -6403,11 +4947,10 @@ TclArgumentGet( * stack. That is nearest. */ - hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, obj); + hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) obj); if (hPtr) { - CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr); - - *wordPtr = cfwPtr->word; + CFWord* cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); + *wordPtr = cfwPtr->word; *cfPtrPtr = cfwPtr->framePtr; return; } @@ -6417,15 +4960,16 @@ TclArgumentGet( * that stack. */ - hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, obj); + hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj); + if (hPtr) { - CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); + CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); framePtr = cfwPtr->framePtr; - framePtr->data.tebc.pc = (char *) (((ByteCode *) + framePtr->data.tebc.pc = (char *) (((ByteCode*) framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc); *cfPtrPtr = cfwPtr->framePtr; - *wordPtr = cfwPtr->word; + *wordPtr = cfwPtr->word; return; } } @@ -6452,15 +4996,13 @@ TclArgumentGet( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_Eval int 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, script, TCL_INDEX_NONE, 0); + int code = Tcl_EvalEx(interp, script, -1, 0); /* * For backwards compatibility with old C code that predates the object @@ -6497,6 +5039,7 @@ Tcl_EvalObj( { return Tcl_EvalObjEx(interp, objPtr, 0); } + #undef Tcl_GlobalEvalObj int Tcl_GlobalEvalObj( @@ -6505,7 +5048,6 @@ Tcl_GlobalEvalObj( { return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); } -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -6516,11 +5058,6 @@ Tcl_GlobalEvalObj( * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is * specified. * - * If the flag TCL_EVAL_DIRECT is passed in, the value of invoker - * must be NULL. Support for non-NULL invokers in that mode has - * been removed since it was unused and untested. Failure to - * follow this limitation will lead to an assertion panic. - * * 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 @@ -6539,7 +5076,7 @@ int Tcl_EvalObjEx( Tcl_Interp *interp, /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ - Tcl_Obj *objPtr, /* Pointer to object containing commands to + 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 @@ -6552,26 +5089,7 @@ int TclEvalObjEx( Tcl_Interp *interp, /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ - 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. */ -{ - int result = TCL_OK; - NRE_callback *rootPtr = TOP_CB(interp); - - result = TclNREvalObjEx(interp, objPtr, flags, invoker, word); - return TclNRRunCallbacks(interp, result, rootPtr); -} - -int -TclNREvalObjEx( - Tcl_Interp *interp, /* Token for command interpreter (returned by - * a previous call to Tcl_CreateInterp). */ - Tcl_Obj *objPtr, /* Pointer to object containing commands to + 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 @@ -6579,128 +5097,88 @@ TclNREvalObjEx( const CmdFrame *invoker, /* Frame of the command doing the eval. */ int word) /* Index of the word which is in objPtr. */ { - Interp *iPtr = (Interp *) interp; + 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. */ - /* - * This function consists of three independent blocks for: direct - * evaluation of canonical lists, compilation and bytecode execution and - * finally direct evaluation. Precisely one of these blocks will be run. + Tcl_IncrRefCount(objPtr); + + /* 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)) { - CmdFrame *eoFramePtr = NULL; - Tcl_Size objc; - Tcl_Obj *listPtr, **objv; - /* - * Canonical List Optimization: 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. + * TIP #280 Structures for tracking lines. As we know that this is + * dynamic execution we ignore the invoker, even if known. */ - /* - * Shimmer protection! Always pass an unshared obj. The caller could - * incr the refCount of objPtr AFTER calling us! To be completely safe - * we always make a copy. The callback takes care of the refCounts for - * both listPtr and objPtr. - * - * TODO: Create a test to demo this need, or eliminate it. - * FIXME OPT: preserve just the internal rep? - */ - - Tcl_IncrRefCount(objPtr); - listPtr = TclListObjCopy(interp, objPtr); - Tcl_IncrRefCount(listPtr); - - if (word != INT_MIN) { - /* - * TIP #280 Structures for tracking lines. As we know that this is - * dynamic execution we ignore the invoker, even if known. - * - * 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. - * - * Note that we use (word==INTMIN) to signal that no command frame - * should be pushed, as needed by alias and ensemble redirections. - */ - - eoFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); - eoFramePtr->nline = 0; - eoFramePtr->line = NULL; - - eoFramePtr->type = TCL_LOCATION_EVAL; - eoFramePtr->level = (iPtr->cmdFramePtr == NULL? - 1 : iPtr->cmdFramePtr->level + 1); - eoFramePtr->framePtr = iPtr->framePtr; - eoFramePtr->nextPtr = iPtr->cmdFramePtr; + int nelements; + Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr); + CmdFrame *eoFramePtr = (CmdFrame *) + TclStackAlloc(interp, sizeof(CmdFrame)); - eoFramePtr->cmdObj = objPtr; - eoFramePtr->cmd = NULL; - eoFramePtr->len = 0; - eoFramePtr->data.eval.path = NULL; + eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 + : iPtr->cmdFramePtr->level + 1); + eoFramePtr->framePtr = iPtr->framePtr; + eoFramePtr->nextPtr = iPtr->cmdFramePtr; - iPtr->cmdFramePtr = eoFramePtr; + eoFramePtr->nline = 0; + eoFramePtr->line = NULL; - flags |= TCL_EVAL_SOURCE_IN_FRAME; - } + eoFramePtr->cmd.listPtr = objPtr; + Tcl_IncrRefCount(eoFramePtr->cmd.listPtr); + eoFramePtr->data.eval.path = NULL; - TclMarkTailcall(interp); - TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, - objPtr, NULL); - - TclListObjGetElements(NULL, listPtr, &objc, &objv); - return TclNREvalObjv(interp, objc, objv, flags, NULL); - } - - if (!(flags & TCL_EVAL_DIRECT)) { /* - * 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 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. */ - int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - ByteCode *codePtr; - CallFrame *savedVarFramePtr = NULL; /* Saves old copy of - * iPtr->varFramePtr in case - * TCL_EVAL_GLOBAL was set. */ - - if (TclInterpReady(interp) != TCL_OK) { - return TCL_ERROR; - } - if (flags & TCL_EVAL_GLOBAL) { - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = iPtr->rootFramePtr; - } - Tcl_IncrRefCount(objPtr); - codePtr = TclCompileObj(interp, objPtr, invoker, word); + Tcl_ListObjGetElements(NULL, copyPtr, &nelements, &elements); - TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr, - objPtr, INT2PTR(allowExceptions), NULL); - return TclNRExecuteByteCode(interp, codePtr); - } + 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). + * We're not supposed to use the compiler or byte-code interpreter. + * Let Tcl_EvalEx evaluate the command directly (and probably more + * slowly). */ - const char *script; - Tcl_Size numSrcBytes; + /* + * 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 @@ -6711,7 +5189,7 @@ TclNREvalObjEx( * 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" + * 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 @@ -6719,92 +5197,133 @@ TclNREvalObjEx( * executing nested commands in the eval/direct path. */ - ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; + ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr; + ContLineLoc* clLocPtr = TclContinuationsGet (objPtr); - assert(invoker == NULL); + if (clLocPtr) { + iPtr->scriptCLLocPtr = clLocPtr; + Tcl_Preserve (iPtr->scriptCLLocPtr); + } else { + iPtr->scriptCLLocPtr = NULL; + } - iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); + if (invoker == NULL) { + /* + * No context, force opening of our own. + */ - Tcl_IncrRefCount(objPtr); + 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 = TclGetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + int pc = 0; + CmdFrame *ctxPtr = (CmdFrame *) + TclStackAlloc(interp, sizeof(CmdFrame)); - TclDecrRefCount(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. + */ - iPtr->scriptCLLocPtr = saveCLLocPtr; - return result; - } -} + TclGetSrcInfoForPc(ctxPtr); + pc = 1; + } -static int -TEOEx_ByteCodeCallback( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - CallFrame *savedVarFramePtr = (CallFrame *)data[0]; - Tcl_Obj *objPtr = (Tcl_Obj *)data[1]; - int allowExceptions = PTR2INT(data[2]); + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - if (iPtr->numLevels == 0) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } - if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { - const char *script; - Tcl_Size numSrcBytes; - - ProcessUnexpectedResult(interp, result); - result = TCL_ERROR; - script = TclGetStringFromObj(objPtr, &numSrcBytes); - Tcl_LogCommandInfo(interp, script, script, numSrcBytes); + if ((ctxPtr->nline <= word) || + (ctxPtr->line[word] < 0) || + (ctxPtr->type != TCL_LOCATION_SOURCE)) { + /* + * Dynamic script, or dynamic context, force our own + * context. + */ + + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + + } else { + /* + * Absolute context to reuse. + */ + + iPtr->invokeCmdFramePtr = ctxPtr; + iPtr->evalFlags |= TCL_EVAL_CTX; + + result = TclEvalEx(interp, script, numSrcBytes, flags, + ctxPtr->line[word], NULL, script); + } + + if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { + /* + * Death of SrcInfo reference. + */ + + Tcl_DecrRefCount(ctxPtr->data.eval.path); + } + TclStackFree(interp, ctxPtr); } /* - * We are returning to level 0, so should call TclResetCancellation. - * Let us just unset the flags inline. + * Now release the lock on the continuation line information, if + * any, and restore the caller's settings. */ - TclUnsetCancelFlags(iPtr); - } - iPtr->evalFlags = 0; - - /* - * Restore the callFrame if this was a TCL_EVAL_GLOBAL. - */ - - if (savedVarFramePtr) { - iPtr->varFramePtr = savedVarFramePtr; - } + 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. + */ + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - TclDecrRefCount(objPtr); - return result; -} + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = iPtr->rootFramePtr; + } -static int -TEOEx_ListCallback( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr = (Tcl_Obj *)data[0]; - CmdFrame *eoFramePtr = (CmdFrame *)data[1]; - Tcl_Obj *objPtr = (Tcl_Obj *)data[2]; + result = TclCompEvalObj(interp, objPtr, invoker, word); - /* - * Remove the cmdFrame - */ + /* + * If we are again at the top level, process any unusual return code + * returned by the evaluated code. + */ - if (eoFramePtr) { - iPtr->cmdFramePtr = eoFramePtr->nextPtr; - TclStackFree(interp, eoFramePtr); + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR) + && !allowExceptions) { + ProcessUnexpectedResult(interp, result); + result = TCL_ERROR; + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, numSrcBytes); + } + } + iPtr->evalFlags = 0; + iPtr->varFramePtr = savedVarFramePtr; } - TclDecrRefCount(objPtr); - TclDecrRefCount(listPtr); + TclDecrRefCount(objPtr); return result; } @@ -6834,21 +5353,17 @@ ProcessUnexpectedResult( * result code was returned. */ int returnCode) /* The unexpected result code. */ { - char buf[TCL_INTEGER_SPACE]; - Tcl_ResetResult(interp); if (returnCode == TCL_BREAK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invoked \"break\" outside of a loop", TCL_INDEX_NONE)); + Tcl_AppendResult(interp, + "invoked \"break\" outside of a loop", NULL); } else if (returnCode == TCL_CONTINUE) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invoked \"continue\" outside of a loop", TCL_INDEX_NONE)); + Tcl_AppendResult(interp, + "invoked \"continue\" outside of a loop", NULL); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "command returned bad code: %d", returnCode)); } - snprintf(buf, sizeof(buf), "%d", returnCode); - Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, (void *)NULL); } /* @@ -6879,7 +5394,7 @@ Tcl_ExprLong( const char *exprstring, /* Expression to evaluate. */ long *ptr) /* Where to store result. */ { - Tcl_Obj *exprPtr; + register Tcl_Obj *exprPtr; int result = TCL_OK; if (*exprstring == '\0') { /* @@ -6888,7 +5403,7 @@ Tcl_ExprLong( *ptr = 0; } else { - exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE); + exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); @@ -6906,7 +5421,7 @@ Tcl_ExprDouble( const char *exprstring, /* Expression to evaluate. */ double *ptr) /* Where to store result. */ { - Tcl_Obj *exprPtr; + register Tcl_Obj *exprPtr; int result = TCL_OK; if (*exprstring == '\0') { @@ -6916,7 +5431,7 @@ Tcl_ExprDouble( *ptr = 0.0; } else { - exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE); + exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); @@ -6944,7 +5459,7 @@ Tcl_ExprBoolean( return TCL_OK; } else { int result; - Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE); + Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); @@ -6986,20 +5501,20 @@ int Tcl_ExprLongObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Expression to evaluate. */ + register Tcl_Obj *objPtr, /* Expression to evaluate. */ long *ptr) /* Where to store long result. */ { Tcl_Obj *resultPtr; int result, type; double d; - void *internalPtr; + ClientData internalPtr; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) { + if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type) != TCL_OK){ return TCL_ERROR; } @@ -7013,9 +5528,10 @@ Tcl_ExprLongObj( return TCL_ERROR; } resultPtr = Tcl_NewBignumObj(&big); + /* FALLTHROUGH */ } - /* FALLTHRU */ - case TCL_NUMBER_INT: + case TCL_NUMBER_LONG: + case TCL_NUMBER_WIDE: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); break; @@ -7033,19 +5549,19 @@ int Tcl_ExprDoubleObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Expression to evaluate. */ + register Tcl_Obj *objPtr, /* Expression to evaluate. */ double *ptr) /* Where to store double result. */ { Tcl_Obj *resultPtr; int result, type; - void *internalPtr; + ClientData internalPtr; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result != TCL_OK) { return TCL_ERROR; } - result = Tcl_GetNumberFromObj(interp, resultPtr, &internalPtr, &type); + result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type); if (result == TCL_OK) { switch (type) { case TCL_NUMBER_NAN: @@ -7069,7 +5585,7 @@ int Tcl_ExprBooleanObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Expression to evaluate. */ + register Tcl_Obj *objPtr, /* Expression to evaluate. */ int *ptr) /* Where to store 0/1 result. */ { Tcl_Obj *resultPtr; @@ -7091,7 +5607,6 @@ Tcl_ExprBooleanObj( * * Object version: Invokes a Tcl command, given an objv/objc, from either * the exposed or hidden set of commands in the given interpreter. - * * NOTE: The command is invoked in the global stack frame of the * interpreter or namespace, thus it cannot see any current state on the * stack of that interpreter. @@ -7109,7 +5624,7 @@ int TclObjInvokeNamespace( Tcl_Interp *interp, /* Interpreter in which command is to be * invoked. */ - Tcl_Size objc, /* Count of arguments. */ + int objc, /* Count of arguments. */ Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the * name of the command to invoke. */ Tcl_Namespace *nsPtr, /* The namespace to use. */ @@ -7125,7 +5640,11 @@ TclObjInvokeNamespace( * command. */ - (void) TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0); + result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0); + if (result != TCL_OK) { + return TCL_ERROR; + } + result = TclObjInvoke(interp, objc, objv, flags); TclPopStackFrame(interp); @@ -7153,39 +5672,36 @@ int TclObjInvoke( Tcl_Interp *interp, /* Interpreter in which command is to be * invoked. */ - Tcl_Size objc, /* Count of arguments. */ + 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. */ { + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + char *cmdName; /* Name of the command from objv[0]. */ + Tcl_HashEntry *hPtr = NULL; + Command *cmdPtr; + int result; + if (interp == NULL) { return TCL_ERROR; } + if ((objc < 1) || (objv == NULL)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "illegal argument vector", TCL_INDEX_NONE)); + Tcl_AppendResult(interp, "illegal argument vector", NULL); return TCL_ERROR; } + if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } - return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); -} -int -TclNRInvoke( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ - const char *cmdName; /* Name of the command from objv[0]. */ - Tcl_HashEntry *hPtr = NULL; - Command *cmdPtr; + if (TclInterpReady(interp) == TCL_ERROR) { + return TCL_ERROR; + } cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -7193,39 +5709,37 @@ TclNRInvoke( hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); } if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid hidden command name \"%s\"", cmdName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName, - (void *)NULL); + Tcl_AppendResult(interp, "invalid hidden command name \"", + cmdName, "\"", NULL); return TCL_ERROR; } - cmdPtr = (Command *)Tcl_GetHashValue(hPtr); + cmdPtr = Tcl_GetHashValue(hPtr); /* - * Avoid the exception-handling brain damage when numLevels == 0 + * Invoke the command function. */ - iPtr->numLevels++; - Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); + iPtr->cmdCount++; + result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); /* - * Normal command resolution of objv[0] isn't going to find cmdPtr. - * That's the whole point of **hidden** commands. So tell the Eval core - * machinery not to even try (and risk finding something wrong). + * If an error occurred, record information about what was being executed + * when the error occurred. */ - return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); -} - -static int -NRPostInvoke( - TCL_UNUSED(void **), - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *)interp; + if ((result == TCL_ERROR) + && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) + && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { + int length; + Tcl_Obj *command = Tcl_NewListObj(objc, objv); + const char *cmdString; - iPtr->numLevels--; + Tcl_IncrRefCount(command); + cmdString = Tcl_GetStringFromObj(command, &length); + Tcl_LogCommandInfo(interp, cmdString, cmdString, length); + Tcl_DecrRefCount(command); + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } return result; } @@ -7262,9 +5776,9 @@ Tcl_ExprString( * An empty string. Just set the interpreter's result to 0. */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + Tcl_SetResult(interp, "0", TCL_VOLATILE); } else { - Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, TCL_INDEX_NONE); + Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); Tcl_IncrRefCount(exprObj); code = Tcl_ExprObj(interp, exprObj, &resultPtr); @@ -7273,13 +5787,13 @@ Tcl_ExprString( Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); } - } - /* - * Force the string rep of the interp result. - */ + /* + * Force the string rep of the interp result. + */ - (void) Tcl_GetStringResult(interp); + (void) Tcl_GetStringResult(interp); + } return code; } @@ -7302,14 +5816,13 @@ Tcl_ExprString( *---------------------------------------------------------------------- */ -#undef Tcl_AddObjErrorInfo void Tcl_AppendObjToErrorInfo( Tcl_Interp *interp, /* Interpreter to which error information * pertains. */ Tcl_Obj *objPtr) /* Message to record. */ { - Tcl_Size length; + int length; const char *message = TclGetStringFromObj(objPtr, &length); Tcl_IncrRefCount(objPtr); @@ -7336,8 +5849,6 @@ Tcl_AppendObjToErrorInfo( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_AddErrorInfo void Tcl_AddErrorInfo( Tcl_Interp *interp, /* Interpreter to which error information @@ -7346,7 +5857,6 @@ Tcl_AddErrorInfo( { Tcl_AddObjErrorInfo(interp, message, -1); } -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -7375,10 +5885,10 @@ Tcl_AddObjErrorInfo( * pertains. */ const char *message, /* Points to the first byte of an array of * bytes of the message. */ - Tcl_Size length) /* The number of bytes in the message. If < 0, + int length) /* The number of bytes in the message. If < 0, * then append all bytes up to a NULL byte. */ { - Interp *iPtr = (Interp *) interp; + register Interp *iPtr = (Interp *) interp; /* * If we are just starting to log an error, errorInfo is initialized from @@ -7387,8 +5897,7 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - if (*(iPtr->result) != 0) { + 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 @@ -7397,13 +5906,13 @@ Tcl_AddObjErrorInfo( * interp->result completely. */ - iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, TCL_INDEX_NONE); - } else -#endif /* !defined(TCL_NO_DEPRECATED) */ + iPtr->errorInfo = Tcl_NewStringObj(interp->result, -1); + } else { iPtr->errorInfo = iPtr->objResultPtr; + } Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { - Tcl_SetErrorCode(interp, "NONE", (void *)NULL); + Tcl_SetErrorCode(interp, "NONE", NULL); } } @@ -7422,7 +5931,7 @@ Tcl_AddObjErrorInfo( } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_VarEvalVA -- * @@ -7431,17 +5940,17 @@ Tcl_AddObjErrorInfo( * * Results: * A standard Tcl return result. An error message or other result may be - * left in the interp. + * left in the interp's result. * * Side effects: * Depends on what was done by the command. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int Tcl_VarEvalVA( - Tcl_Interp *interp, /* Interpreter in which to evaluate command */ + Tcl_Interp *interp, /* Interpreter in which to evaluate command. */ va_list argList) /* Variable argument list. */ { Tcl_DString buf; @@ -7460,10 +5969,10 @@ Tcl_VarEvalVA( if (string == NULL) { break; } - Tcl_DStringAppend(&buf, string, TCL_INDEX_NONE); + Tcl_DStringAppend(&buf, string, -1); } - result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), TCL_INDEX_NONE, 0); + result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); Tcl_DStringFree(&buf); return result; } @@ -7478,14 +5987,14 @@ Tcl_VarEvalVA( * * Results: * A standard Tcl return result. An error message or other result may be - * left in the interp. + * left in interp->result. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- */ - + /* ARGSUSED */ int Tcl_VarEval( Tcl_Interp *interp, @@ -7520,25 +6029,21 @@ Tcl_VarEval( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_GlobalEval int Tcl_GlobalEval( - Tcl_Interp *interp, /* Interpreter in which to evaluate - * command. */ + Tcl_Interp *interp, /* Interpreter in which to evaluate command. */ const char *command) /* Command to evaluate. */ { - Interp *iPtr = (Interp *) interp; + register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr; savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = iPtr->rootFramePtr; - result = Tcl_EvalEx(interp, command, TCL_INDEX_NONE, 0); + result = Tcl_Eval(interp, command); iPtr->varFramePtr = savedVarFramePtr; return result; } -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -7557,14 +6062,14 @@ Tcl_GlobalEval( *---------------------------------------------------------------------- */ -Tcl_Size +int Tcl_SetRecursionLimit( Tcl_Interp *interp, /* Interpreter whose nesting limit is to be * set. */ - Tcl_Size depth) /* New value for maximum depth. */ + int depth) /* New value for maximimum depth. */ { Interp *iPtr = (Interp *) interp; - Tcl_Size old; + int old; old = iPtr->maxNestingDepth; if (depth > 0) { @@ -7660,7 +6165,7 @@ Tcl_GetVersion( static int ExprCeilFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -7676,19 +6181,14 @@ ExprCeilFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); - - if (irPtr) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } + 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); @@ -7700,7 +6200,7 @@ ExprCeilFunc( static int ExprFloorFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -7716,19 +6216,14 @@ ExprFloorFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); - - if (irPtr) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } + 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); @@ -7740,18 +6235,19 @@ ExprFloorFunc( static int ExprIsqrtFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored */ Tcl_Interp *interp, /* The interpreter in which to execute. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter list. */ { - void *ptr; + 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. */ + int exact = 0; /* Flag == 1 if the argument can be + * represented in a double as an exact + * integer. */ /* * Check syntax. @@ -7766,7 +6262,7 @@ ExprIsqrtFunc( * Make sure that the arg is a number. */ - if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } @@ -7794,13 +6290,13 @@ ExprIsqrtFunc( if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { return TCL_ERROR; } - if (mp_isneg(&big)) { + if (SIGN(&big) == MP_NEG) { mp_clear(&big); goto negarg; } break; default: - if (TclGetWideIntFromObj(interp, objv[1], &w) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[1], &w) != TCL_OK) { return TCL_ERROR; } if (w < 0) { @@ -7822,31 +6318,24 @@ ExprIsqrtFunc( Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d))); } else { mp_int root; - mp_err err; - err = mp_init(&root); - if (err == MP_OKAY) { - err = mp_sqrt(&big, &root); - } + mp_init(&root); + mp_sqrt(&big, &root); mp_clear(&big); - if (err != MP_OKAY) { - return TCL_ERROR; - } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root)); } + return TCL_OK; negarg: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "square root of negative argument", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "domain error: argument not in valid range", (void *)NULL); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("square root of negative argument", -1)); return TCL_ERROR; } static int ExprSqrtFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -7862,32 +6351,21 @@ ExprSqrtFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); - - if (irPtr) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } + 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) && isinf(d) + if ((d >= 0.0) && TclIsInfinite(d) && (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) { mp_int root; - mp_err err; - err = mp_init(&root); - if (err == MP_OKAY) { - err = mp_sqrt(&big, &root); - } + mp_init(&root); + mp_sqrt(&big, &root); mp_clear(&big); - if (err != MP_OKAY) { - mp_clear(&root); - return TCL_ERROR; - } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root))); mp_clear(&root); } else { @@ -7898,7 +6376,7 @@ ExprSqrtFunc( static int ExprUnaryFunc( - void *clientData, /* Contains the address of a function that + 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 @@ -7916,21 +6394,17 @@ ExprUnaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); - - if (irPtr) { - d = irPtr->doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; - } + 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)); + return CheckDoubleResult(interp, (*func)(d)); } static int @@ -7939,12 +6413,12 @@ CheckDoubleResult( double dResult) { #ifndef ACCEPT_NAN - if (isnan(dResult)) { + if (TclIsNaN(dResult)) { TclExprFloatError(interp, dResult); return TCL_ERROR; } #endif - if ((errno == ERANGE) && ((dResult == 0.0) || isinf(dResult))) { + if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) { /* * When ERANGE signals under/overflow, just accept 0.0 or +/-Inf */ @@ -7962,7 +6436,7 @@ CheckDoubleResult( static int ExprBinaryFunc( - void *clientData, /* Contains the address of a function that + 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 @@ -7980,14 +6454,10 @@ ExprBinaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); - - if (irPtr) { - d1 = irPtr->doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; - } + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + d1 = objv[1]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; } #endif if (code != TCL_OK) { @@ -7995,32 +6465,28 @@ ExprBinaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); - - if (irPtr) { - d2 = irPtr->doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; - } + 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)); + return CheckDoubleResult(interp, (*func)(d1, d2)); } static int ExprAbsFunc( - TCL_UNUSED(void *), + 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. */ { - void *ptr; + ClientData ptr; int type; mp_int big; @@ -8029,45 +6495,32 @@ ExprAbsFunc( return TCL_ERROR; } - if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } - if (type == TCL_NUMBER_INT) { - Tcl_WideInt l = *((const Tcl_WideInt *) ptr); + if (type == TCL_NUMBER_LONG) { + long l = *((const long *) ptr); - if (l > 0) { + if (l > (long)0) { goto unChanged; - } else if (l == 0) { - if (TclHasStringRep(objv[1])) { - Tcl_Size numBytes; - const char *bytes = TclGetStringFromObj(objv[1], &numBytes); - - while (numBytes) { - if (*bytes == '-') { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + } 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; } - bytes++; numBytes--; + string++; } } goto unChanged; - } else if (l == WIDE_MIN) { - if (sizeof(Tcl_WideInt) > sizeof(int64_t)) { - Tcl_WideUInt ul = -(Tcl_WideUInt)WIDE_MIN; - if (mp_init(&big) != MP_OKAY || mp_unpack(&big, 1, 1, - sizeof(Tcl_WideInt), 0, 0, &ul) != MP_OKAY) { - return TCL_ERROR; - } - if (mp_neg(&big, &big) != MP_OKAY) { - return TCL_ERROR; - } - } else if (mp_init_i64(&big, l) != MP_OKAY) { - return TCL_ERROR; - } + } else if (l == LONG_MIN) { + TclBNInitBignumFromLong(&big, l); goto tooLarge; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); return TCL_OK; } @@ -8075,29 +6528,44 @@ ExprAbsFunc( double d = *((const double *) ptr); static const double poszero = 0.0; - /* - * We need to distinguish here between positive 0.0 and negative -0.0. - * [Bug 2954959] + /* 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))) { + if (!memcmp(&d, &poszero, sizeof(double))) { + goto unChanged; + } + } else { + if (d > -0.0) { 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) { - if (mp_isneg((const mp_int *) ptr)) { + /* TODO: const correctness ? */ + if (mp_cmp_d((mp_int *) ptr, 0) == MP_LT) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: - if (mp_neg(&big, &big) != MP_OKAY) { - return TCL_ERROR; - } + mp_neg(&big, &big); Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { unChanged: @@ -8112,7 +6580,6 @@ ExprAbsFunc( return TCL_OK; #else double d; - Tcl_GetDoubleFromObj(interp, objv[1], &d); return TCL_ERROR; #endif @@ -8122,7 +6589,7 @@ ExprAbsFunc( static int ExprBoolFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8143,21 +6610,20 @@ ExprBoolFunc( static int ExprDoubleFunc( - TCL_UNUSED(void *), + 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 (TclHasInternalRep(objv[1], &tclDoubleType)) { + if (objv[1]->typePtr == &tclDoubleType) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } @@ -8169,8 +6635,8 @@ ExprDoubleFunc( } static int -ExprIntFunc( - TCL_UNUSED(void *), +ExprEntierFunc( + ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8178,19 +6644,19 @@ ExprIntFunc( { double d; int type; - void *ptr; + ClientData ptr; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } - if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type == TCL_NUMBER_DOUBLE) { d = *((const double *) ptr); - if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) { + if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) { mp_int big; if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { @@ -8200,9 +6666,9 @@ ExprIntFunc( Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; } else { - Tcl_WideInt result = (Tcl_WideInt) d; + long result = (long) d; - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); return TCL_OK; } } @@ -8225,92 +6691,72 @@ ExprIntFunc( } static int -ExprWideFunc( - TCL_UNUSED(void *), +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. */ { - Tcl_WideInt wResult; - - if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) { + long iResult; + Tcl_Obj *objPtr; + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { return TCL_ERROR; } - TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); - return TCL_OK; -} + objPtr = Tcl_GetObjResult(interp); + if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) { + /* + * Truncate the bignum; keep only bits in long range. + */ -/* - * Common implmentation of max() and min(). - */ -static int -ExprMaxMinFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count. */ - Tcl_Obj *const *objv, /* Actual parameter vector. */ - int op) /* Comparison direction */ -{ - Tcl_Obj *res; - double d; - int type; - int i; - void *ptr; + mp_int big; - if (objc < 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; + 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); } - res = objv[1]; - for (i = 1; i < objc; i++) { - if (Tcl_GetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - /* - * Get the error message for NaN. - */ - - Tcl_GetDoubleFromObj(interp, objv[i], &d); - return TCL_ERROR; - } - if (TclCompareTwoNumbers(objv[i], res) == op) { - res = objv[i]; - } - } - - Tcl_SetObjResult(interp, res); + Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); return TCL_OK; } static int -ExprMaxFunc( - TCL_UNUSED(void *), +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. */ { - return ExprMaxMinFunc(NULL, interp, objc, objv, MP_GT); -} + 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. + */ -static int -ExprMinFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count. */ - Tcl_Obj *const *objv) /* Actual parameter vector. */ -{ - return ExprMaxMinFunc(NULL, interp, objc, objv, MP_LT); + 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( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8331,19 +6777,19 @@ ExprRandFunc( iPtr->flags |= RAND_SEED_INITIALIZED; /* - * To ensure different seeds in different threads (bug #416643), - * take into consideration the thread this interp is running in. + * Take into consideration the thread this interp is running in order + * to insure different seeds in different threads (bug #416643) */ - iPtr->randSeed = TclpGetClicks() + PTR2UINT(Tcl_GetCurrentThread())*4093U; + iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ - iPtr->randSeed &= 0x7FFFFFFFL; - if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFFL)) { - iPtr->randSeed ^= 123459876L; + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed ^= 123459876; } } @@ -8403,14 +6849,14 @@ ExprRandFunc( static int ExprRoundFunc( - TCL_UNUSED(void *), + 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; - void *ptr; + ClientData ptr; int type; if (objc != 2) { @@ -8418,13 +6864,13 @@ ExprRoundFunc( return TCL_ERROR; } - if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type == TCL_NUMBER_DOUBLE) { double fractPart, intPart; - Tcl_WideInt max = WIDE_MAX, min = WIDE_MIN; + long max = LONG_MAX, min = LONG_MIN; fractPart = modf(*((const double *) ptr), &intPart); if (fractPart <= -0.5) { @@ -8434,31 +6880,27 @@ ExprRoundFunc( } if ((intPart >= (double)max) || (intPart <= (double)min)) { mp_int big; - mp_err err = MP_OKAY; if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) { /* Infinity */ return TCL_ERROR; } if (fractPart <= -0.5) { - err = mp_sub_d(&big, 1, &big); + mp_sub_d(&big, 1, &big); } else if (fractPart >= 0.5) { - err = mp_add_d(&big, 1, &big); - } - if (err != MP_OKAY) { - return TCL_ERROR; + mp_add_d(&big, 1, &big); } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; } else { - Tcl_WideInt result = (Tcl_WideInt)intPart; + long result = (long)intPart; if (fractPart <= -0.5) { result--; } else if (fractPart >= 0.5) { result++; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); return TCL_OK; } } @@ -8482,14 +6924,14 @@ ExprRoundFunc( static int ExprSrandFunc( - TCL_UNUSED(void *), + 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; - Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */ + long i = 0; /* Initialized to avoid compiler warning. */ /* * Convert argument and use it to reset the seed. @@ -8500,18 +6942,31 @@ ExprSrandFunc( return TCL_ERROR; } - if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) { - 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. + * ExprRandFunc() for more details. */ iPtr->flags |= RAND_SEED_INITIALIZED; - iPtr->randSeed = (long) w & 0x7FFFFFFF; - if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) { + iPtr->randSeed = i; + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } @@ -8521,396 +6976,7 @@ ExprSrandFunc( * will always succeed. */ - return ExprRandFunc(NULL, interp, 1, objv); -} - -/* - *---------------------------------------------------------------------- - * - * Double Classification Functions -- - * - * This page contains the functions that implement all of the built-in - * math functions for classifying IEEE doubles. - * - * These have to be a little bit careful while Tcl_GetDoubleFromObj() - * rejects NaN values, which these functions *explicitly* accept. - * - * 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. - * - *---------------------------------------------------------------------- - * - * Older MSVC is supported by Tcl, but doesn't have fpclassify(). Of course. - * But it does sometimes have _fpclass() which does almost the same job; if - * even that is absent, we grobble around directly in the platform's binary - * representation of double. - * - * The ClassifyDouble() function makes all that conform to a common API - * (effectively the C99 standard API renamed), and just delegates to the - * standard macro on platforms that do it correctly. - */ - -static inline int -ClassifyDouble( - double d) -{ -#if TCL_FPCLASSIFY_MODE == 0 - return fpclassify(d); -#else /* TCL_FPCLASSIFY_MODE != 0 */ - /* - * If we don't have fpclassify(), we also don't have the values it returns. - * Hence we define those here. - */ -#ifndef FP_NAN -# define FP_NAN 1 /* Value is NaN */ -# define FP_INFINITE 2 /* Value is an infinity */ -# define FP_ZERO 3 /* Value is a zero */ -# define FP_NORMAL 4 /* Value is a normal float */ -# define FP_SUBNORMAL 5 /* Value has lost accuracy */ -#endif /* !FP_NAN */ - -#if TCL_FPCLASSIFY_MODE == 3 - return __builtin_fpclassify( - FP_NAN, FP_INFINITE, FP_NORMAL, FP_SUBNORMAL, FP_ZERO, d); -#elif TCL_FPCLASSIFY_MODE == 2 - /* - * We assume this hack is only needed on little-endian systems. - * Specifically, x86 running Windows. It's fairly easy to enable for - * others if they need it (because their libc/libm is broken) but we'll - * jump that hurdle when requred. We can solve the word ordering then. - */ - - union { - double d; /* Interpret as double */ - struct { - unsigned int low; /* Lower 32 bits */ - unsigned int high; /* Upper 32 bits */ - } w; /* Interpret as unsigned integer words */ - } doubleMeaning; /* So we can look at the representation of a - * double directly. Platform (i.e., processor) - * specific; this is for x86 (and most other - * little-endian processors, but those are - * untested). */ - unsigned int exponent, mantissaLow, mantissaHigh; - /* The pieces extracted from the double. */ - int zeroMantissa; /* Was the mantissa zero? That's special. */ - - /* - * Shifts and masks to use with the doubleMeaning variable above. - */ - -#define EXPONENT_MASK 0x7FF /* 11 bits (after shifting) */ -#define EXPONENT_SHIFT 20 /* Moves exponent to bottom of word */ -#define MANTISSA_MASK 0xFFFFF /* 20 bits (plus 32 from other word) */ - - /* - * Extract the exponent (11 bits) and mantissa (52 bits). Note that we - * totally ignore the sign bit. - */ - - doubleMeaning.d = d; - exponent = (doubleMeaning.w.high >> EXPONENT_SHIFT) & EXPONENT_MASK; - mantissaLow = doubleMeaning.w.low; - mantissaHigh = doubleMeaning.w.high & MANTISSA_MASK; - zeroMantissa = (mantissaHigh == 0 && mantissaLow == 0); - - /* - * Look for the special cases of exponent. - */ - - switch (exponent) { - case 0: - /* - * When the exponent is all zeros, it's a ZERO or a SUBNORMAL. - */ - - return zeroMantissa ? FP_ZERO : FP_SUBNORMAL; - case EXPONENT_MASK: - /* - * When the exponent is all ones, it's an INF or a NAN. - */ - - return zeroMantissa ? FP_INFINITE : FP_NAN; - default: - /* - * Everything else is a NORMAL double precision float. - */ - - return FP_NORMAL; - } -#elif TCL_FPCLASSIFY_MODE == 1 - switch (_fpclass(d)) { - case _FPCLASS_NZ: - case _FPCLASS_PZ: - return FP_ZERO; - case _FPCLASS_NN: - case _FPCLASS_PN: - return FP_NORMAL; - case _FPCLASS_ND: - case _FPCLASS_PD: - return FP_SUBNORMAL; - case _FPCLASS_NINF: - case _FPCLASS_PINF: - return FP_INFINITE; - default: - Tcl_Panic("result of _fpclass() outside documented range!"); - case _FPCLASS_QNAN: - case _FPCLASS_SNAN: - return FP_NAN; - } -#else /* TCL_FPCLASSIFY_MODE not in (0..3) */ -#error "unknown or unexpected TCL_FPCLASSIFY_MODE" -#endif /* TCL_FPCLASSIFY_MODE */ -#endif /* !fpclassify */ -} - -static int -ExprIsFiniteFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - void *ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - type = ClassifyDouble(d); - result = (type != FP_INFINITE && type != FP_NAN); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsInfinityFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - void *ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_INFINITE); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsNaNFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - void *ptr; - int type, result = 1; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_NAN); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsNormalFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - void *ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_NORMAL); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsSubnormalFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - void *ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_SUBNORMAL); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsUnorderedFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - void *ptr; - int type, result = 0; - - if (objc != 3) { - MathFuncWrongNumArgs(interp, 3, objc, objv); - return TCL_ERROR; - } - - if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - result = 1; - } else { - d = *((const double *) ptr); - result = (ClassifyDouble(d) == FP_NAN); - } - - if (Tcl_GetNumberFromObj(interp, objv[2], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - result |= 1; - } else { - d = *((const double *) ptr); - result |= (ClassifyDouble(d) == FP_NAN); - } - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -FloatClassifyObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - Tcl_Obj *objPtr; - void *ptr; - int type; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "floatValue"); - return TCL_ERROR; - } - - if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - goto gotNaN; - } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - switch (ClassifyDouble(d)) { - case FP_INFINITE: - TclNewLiteralStringObj(objPtr, "infinite"); - break; - case FP_NAN: - gotNaN: - TclNewLiteralStringObj(objPtr, "nan"); - break; - case FP_NORMAL: - TclNewLiteralStringObj(objPtr, "normal"); - break; - case FP_SUBNORMAL: - TclNewLiteralStringObj(objPtr, "subnormal"); - break; - case FP_ZERO: - TclNewLiteralStringObj(objPtr, "zero"); - break; - default: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unable to classify number: %f", d)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objPtr); - return TCL_OK; + return ExprRandFunc(clientData, interp, 1, objv); } /* @@ -8937,23 +7003,22 @@ MathFuncWrongNumArgs( int found, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { - const char *name = TclGetString(objv[0]); + const char *name = Tcl_GetString(objv[0]); const char *tail = name + strlen(name); while (tail > name+1) { - tail--; + --tail; if (*tail == ':' && tail[-1] == ':') { name = tail+1; break; } } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s arguments for math function \"%s\"", - (found < expected ? "not enough" : "too many"), name)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL); + "too %s arguments for math function \"%s\"", + (found < expected ? "few" : "many"), name)); } - #ifdef USE_DTRACE + /* *---------------------------------------------------------------------- * @@ -8972,8 +7037,8 @@ MathFuncWrongNumArgs( static int DTraceObjCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { @@ -9009,1473 +7074,49 @@ DTraceObjCmd( void TclDTraceInfo( Tcl_Obj *info, - const char **args, - Tcl_Size *argsi) + char **args, + int *argsi) { - static Tcl_Obj *keys[10] = { NULL }; + static Tcl_Obj *keys[7] = { NULL }; Tcl_Obj **k = keys, *val; - int i = 0; + int i; if (!*k) { -#define kini(s) TclNewLiteralStringObj(keys[i], s); i++ - kini("cmd"); kini("type"); kini("proc"); kini("file"); - kini("method"); kini("class"); kini("lambda"); kini("object"); - kini("line"); kini("level"); -#undef kini - } - for (i = 0; i < 6; i++) { + 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; } - - /* - * no "proc" -> use "lambda" - */ - if (!args[2]) { Tcl_DictObjGet(NULL, info, *k, &val); args[2] = val ? TclGetString(val) : NULL; } k++; - - /* - * no "class" -> use "object" - */ - - if (!args[5]) { - Tcl_DictObjGet(NULL, info, *k, &val); - args[5] = val ? TclGetString(val) : NULL; - } - k++; for (i = 0; i < 2; i++) { Tcl_DictObjGet(NULL, info, *k++, &val); if (val) { - TclGetIntFromObj(NULL, val, &argsi[i]); + TclGetIntFromObj(NULL, val, &(argsi[i])); } else { argsi[i] = 0; } } } - -/* - *---------------------------------------------------------------------- - * - * DTraceCmdReturn -- - * - * NR callback for DTrace command return probes. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -DTraceCmdReturn( - void *data[], - Tcl_Interp *interp, - int result) -{ - char *cmdName = TclGetString((Tcl_Obj *) data[0]); - - if (TCL_DTRACE_CMD_RETURN_ENABLED()) { - TCL_DTRACE_CMD_RETURN(cmdName, result); - } - if (TCL_DTRACE_CMD_RESULT_ENABLED()) { - Tcl_Obj *r = Tcl_GetObjResult(interp); - - TCL_DTRACE_CMD_RESULT(cmdName, result, TclGetString(r), r); - } - return result; -} TCL_DTRACE_DEBUG_LOG() #endif /* USE_DTRACE */ /* - *---------------------------------------------------------------------- - * - * Tcl_NRCallObjProc -- - * - * This function calls an objProc directly while managing things properly - * if it happens to be an NR objProc. It is meant to be used by extenders - * that provide an NR implementation of a command, as this function - * permits a trivial coding of the non-NR objProc. - * - * 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 objProc. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_NRCallObjProc( - Tcl_Interp *interp, - Tcl_ObjCmdProc *objProc, - void *clientData, - Tcl_Size objc, - Tcl_Obj *const objv[]) -{ - NRE_callback *rootPtr = TOP_CB(interp); - - TclNRAddCallback(interp, Dispatch, objProc, clientData, - INT2PTR(objc), objv); - return TclNRRunCallbacks(interp, TCL_OK, rootPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_NRCreateCommand -- - * - * Define a new NRE-enabled 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. - * - * 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. - * - * 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. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -Tcl_NRCreateCommand( - 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 function to associate with - * name, provides direct access for direct - * calls. */ - Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with - * name, provides NR implementation */ - void *clientData, /* Arbitrary value to pass to object - * function. */ - Tcl_CmdDeleteProc *deleteProc) - /* If not NULL, gives a function to call when - * this command is deleted. */ -{ - Command *cmdPtr = (Command *) - Tcl_CreateObjCommand(interp, cmdName, proc, clientData, - deleteProc); - - cmdPtr->nreProc = nreProc; - return (Tcl_Command) cmdPtr; -} - -Tcl_Command -TclNRCreateCommandInNs( - Tcl_Interp *interp, - const char *cmdName, - Tcl_Namespace *nsPtr, - Tcl_ObjCmdProc *proc, - Tcl_ObjCmdProc *nreProc, - void *clientData, - Tcl_CmdDeleteProc *deleteProc) -{ - Command *cmdPtr = (Command *) - TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData, - deleteProc); - - cmdPtr->nreProc = nreProc; - return (Tcl_Command) cmdPtr; -} - -/**************************************************************************** - * Stuff for the public api - ****************************************************************************/ - -int -Tcl_NREvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - int flags) -{ - return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN); -} - -int -Tcl_NREvalObjv( - Tcl_Interp *interp, /* Interpreter in which to evaluate the - * command. Also used for error reporting. */ - Tcl_Size 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, TCL_EVAL_INVOKE and - * TCL_EVAL_NOERR are currently supported. */ -{ - return TclNREvalObjv(interp, objc, objv, flags, NULL); -} - -int -Tcl_NRCmdSwap( - Tcl_Interp *interp, - Tcl_Command cmd, - Tcl_Size objc, - Tcl_Obj *const objv[], - int flags) -{ - return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, - (Command *) cmd); -} - -/***************************************************************************** - * Tailcall related code - ***************************************************************************** - * - * The steps of the tailcall dance are as follows: - * - * 1. when [tailcall] is invoked, it stores the corresponding callback in - * the current CallFrame and returns TCL_RETURN - * 2. when the CallFrame is popped, it calls TclSetTailcall to store the - * callback in the proper NRCommand callback - the spot where the command - * that pushed the CallFrame is completely cleaned up - * 3. when the NRCommand callback runs, it schedules the tailcall callback - * to run immediately after it returns - * - * One delicate point is to properly define the NRCommand where the tailcall - * will execute. There are functions whose purpose is to help define the - * precise spot: - * TclMarkTailcall: if the NEXT command to be pushed tailcalls, execution - * should continue right here - * TclSkipTailcall: if the NEXT command to be pushed tailcalls, execution - * should continue after the CURRENT command is fully returned ("skip - * the next command: we are redirecting to it, tailcalls should run - * after WE return") - * TclPushTailcallPoint: the search for a tailcalling spot cannot traverse - * this point. This is special for OO, as some of the oo constructs - * that behave like commands may not push an NRCommand callback. - */ - -void -TclMarkTailcall( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - - if (iPtr->deferredCallbacks == NULL) { - TclNRAddCallback(interp, NRCommand, NULL, NULL, - NULL, NULL); - iPtr->deferredCallbacks = TOP_CB(interp); - } -} - -void -TclSkipTailcall( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - - TclMarkTailcall(interp); - iPtr->deferredCallbacks->data[1] = INT2PTR(1); -} - -void -TclPushTailcallPoint( - Tcl_Interp *interp) -{ - TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - ((Interp *) interp)->numLevels++; -} - -/* - *---------------------------------------------------------------------- - * - * TclSetTailcall -- - * - * Splice a tailcall command in the proper spot of the NRE callback - * stack, so that it runs at the right time. - * - *---------------------------------------------------------------------- - */ - -void -TclSetTailcall( - Tcl_Interp *interp, - Tcl_Obj *listPtr) -{ - /* - * Find the splicing spot: right before the NRCommand of the thing - * being tailcalled. Note that we skip NRCommands marked by a 1 in data[1] - * (used by command redirectors). - */ - - NRE_callback *runPtr; - - for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { - if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { - break; - } - } - if (!runPtr) { - Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); - } - runPtr->data[1] = listPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclNRTailcallObjCmd -- - * - * Prepare the tailcall as a list and store it in the current - * varFrame. When the frame is later popped the tailcall will be spliced - * at the proper place. - * - * Results: - * The first NRCommand callback that is not marked to be skipped is - * updated so that its data[1] field contains the tailcall list. - * - *---------------------------------------------------------------------- - */ - -int -TclNRTailcallObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - - if (objc < 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?"); - return TCL_ERROR; - } - - if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "tailcall can only be called from a proc, lambda or method", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (void *)NULL); - return TCL_ERROR; - } - - /* - * Invocation without args just clears a scheduled tailcall; invocation - * with an argument replaces any previously scheduled tailcall. - */ - - if (iPtr->varFramePtr->tailcallPtr) { - Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); - iPtr->varFramePtr->tailcallPtr = NULL; - } - - /* - * Create the callback to actually evaluate the tailcalled - * command, then set it in the varFrame so that PopCallFrame can use it - * at the proper time. - */ - - if (objc > 1) { - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - - /* - * The tailcall data is in a Tcl list: the first element is the - * namespace, the rest the command to be tailcalled. - */ - - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE); - listPtr = Tcl_NewListObj(objc, objv); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - - iPtr->varFramePtr->tailcallPtr = listPtr; - } - return TCL_RETURN; -} - -/* - *---------------------------------------------------------------------- - * - * TclNRTailcallEval -- - * - * This NREcallback actually causes the tailcall to be evaluated. - * - *---------------------------------------------------------------------- - */ - -int -TclNRTailcallEval( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr; - Tcl_Namespace *nsPtr; - Tcl_Size objc; - Tcl_Obj **objv; - - TclListObjGetElements(interp, listPtr, &objc, &objv); - nsObjPtr = objv[0]; - - if (result == TCL_OK) { - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - } - - if (result != TCL_OK) { - /* - * Tailcall execution was preempted, eg by an intervening catch or by - * a now-gone namespace: cleanup and return. - */ - - Tcl_DecrRefCount(listPtr); - return result; - } - - /* - * Perform the tailcall - */ - - TclMarkTailcall(interp); - TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); - iPtr->lookupNsPtr = (Namespace *) nsPtr; - return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); -} - -int -TclNRReleaseValues( - void *data[], - TCL_UNUSED(Tcl_Interp *), - int result) -{ - int i = 0; - - while (i < 4) { - if (data[i]) { - Tcl_DecrRefCount((Tcl_Obj *) data[i]); - } else { - break; - } - i++; - } - return result; -} - -void -Tcl_NRAddCallback( - Tcl_Interp *interp, - Tcl_NRPostProc *postProcPtr, - void *data0, - void *data1, - void *data2, - void *data3) -{ - if (!(postProcPtr)) { - Tcl_Panic("Adding a callback without an objProc?!"); - } - TclNRAddCallback(interp, postProcPtr, data0, data1, data2, data3); -} - -/* - *---------------------------------------------------------------------- - * - * TclNRCoroutineObjCmd -- (and friends) - * - * This object-based function is invoked to process the "coroutine" Tcl - * command. It is heavily based on "apply". - * - * Results: - * A standard Tcl object result value. - * - * Side effects: - * A new procedure gets created. - * - * ** FIRST EXPERIMENTAL IMPLEMENTATION ** - * - * It is fairly amateurish and not up to our standards - mainly in terms of - * error messages and [info] interaction. Just to test the infrastructure in - * teov and tebc. - *---------------------------------------------------------------------- - */ - -#define iPtr ((Interp *) interp) - -int -TclNRYieldObjCmd( - void *clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?"); - return TCL_ERROR; - } - - if (!corPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yield can only be called in a coroutine", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (void *)NULL); - return TCL_ERROR; - } - - if (objc == 2) { - Tcl_SetObjResult(interp, objv[1]); - } - - NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); - TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - clientData, NULL, NULL); - return TCL_OK; -} - -int -TclNRYieldToObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp); - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); - return TCL_ERROR; - } - - if (!corPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto can only be called in a coroutine", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (void *)NULL); - return TCL_ERROR; - } - - if (((Namespace *) nsPtr)->flags & NS_DYING) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto called in deleted namespace", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", - (void *)NULL); - return TCL_ERROR; - } - - /* - * Add the tailcall in the caller env, then just yield. - * - * This is essentially code from TclNRTailcallObjCmd - */ - - listPtr = Tcl_NewListObj(objc, objv); - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - - /* - * Add the callback in the caller's env, then instruct TEBC to yield. - */ - - iPtr->execEnvPtr = corPtr->callerEEPtr; - /* Not calling Tcl_IncrRefCount(listPtr) here because listPtr is private */ - TclSetTailcall(interp, listPtr); - corPtr->yieldPtr = listPtr; - iPtr->execEnvPtr = corPtr->eePtr; - - return TclNRYieldObjCmd(CORO_ACTIVATE_YIELDM, interp, 1, objv); -} - -static int -RewindCoroutineCallback( - void *data[], - Tcl_Interp *interp, - TCL_UNUSED(int) /*result*/) -{ - return Tcl_RestoreInterpState(interp, (Tcl_InterpState)data[0]); -} - -static int -RewindCoroutine( - CoroutineData *corPtr, - int result) -{ - Tcl_Interp *interp = corPtr->eePtr->interp; - Tcl_InterpState state = Tcl_SaveInterpState(interp, result); - - NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); - NRE_ASSERT(corPtr->eePtr != NULL); - NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr); - - corPtr->eePtr->rewind = 1; - TclNRAddCallback(interp, RewindCoroutineCallback, state, - NULL, NULL, NULL); - return TclNRInterpCoroutine(corPtr, interp, 0, NULL); -} - -static void -DeleteCoroutine( - void *clientData) -{ - CoroutineData *corPtr = (CoroutineData *)clientData; - Tcl_Interp *interp = corPtr->eePtr->interp; - NRE_callback *rootPtr = TOP_CB(interp); - - if (COR_IS_SUSPENDED(corPtr)) { - TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr); - } -} - -static int -NRCoroutineCallerCallback( - void *data[], - Tcl_Interp *interp, - int result) -{ - CoroutineData *corPtr = (CoroutineData *)data[0]; - Command *cmdPtr = corPtr->cmdPtr; - - /* - * This is the last callback in the caller execEnv, right before switching - * to the coroutine's - */ - - NRE_ASSERT(iPtr->execEnvPtr == corPtr->callerEEPtr); - - if (!corPtr->eePtr) { - /* - * The execEnv was wound down but not deleted for our sake. We finish - * the job here. The caller context has already been restored. - */ - - NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr); - NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); - NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); - ckfree(corPtr); - return result; - } - - NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); - SAVE_CONTEXT(corPtr->running); - RESTORE_CONTEXT(corPtr->caller); - - if (cmdPtr->flags & CMD_DYING) { - /* - * The command was deleted while it was running: wind down the - * execEnv, this will do the complete cleanup. RewindCoroutine will - * restore both the caller's context and interp state. - */ - - return RewindCoroutine(corPtr, result); - } - - return result; -} - -static int -NRCoroutineExitCallback( - void *data[], - Tcl_Interp *interp, - int result) -{ - CoroutineData *corPtr = (CoroutineData *)data[0]; - Command *cmdPtr = corPtr->cmdPtr; - - /* - * This runs at the bottom of the Coroutine's execEnv: it will be executed - * when the coroutine returns or is wound down, but not when it yields. It - * deletes the coroutine and restores the caller's environment. - */ - - NRE_ASSERT(interp == corPtr->eePtr->interp); - NRE_ASSERT(TOP_CB(interp) == NULL); - NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); - NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); - NRE_ASSERT((corPtr->callerEEPtr->callbackPtr->procPtr == NRCoroutineCallerCallback)); - - cmdPtr->deleteProc = NULL; - Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); - TclCleanupCommandMacro(cmdPtr); - - corPtr->eePtr->corPtr = NULL; - TclDeleteExecEnv(corPtr->eePtr); - corPtr->eePtr = NULL; - - corPtr->stackLevel = NULL; - - /* - * #280. - * Drop the coroutine-owned copy of the lineLABCPtr hashtable for literal - * command arguments in bytecode. - */ - - Tcl_DeleteHashTable(corPtr->lineLABCPtr); - ckfree(corPtr->lineLABCPtr); - corPtr->lineLABCPtr = NULL; - - RESTORE_CONTEXT(corPtr->caller); - iPtr->execEnvPtr = corPtr->callerEEPtr; - iPtr->numLevels++; - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclNRCoroutineActivateCallback -- - * - * This is the workhorse for coroutines: it implements both yield and - * resume. - * - * It is important that both be implemented in the same callback: the - * detection of the impossibility to suspend due to a busy C-stack relies - * on the precise position of a local variable in the stack. We do not - * want the compiler to play tricks on us, either by moving things around - * or inlining. - * - *---------------------------------------------------------------------- - */ - -int -TclNRCoroutineActivateCallback( - void *data[], - Tcl_Interp *interp, - TCL_UNUSED(int) /*result*/) -{ - CoroutineData *corPtr = (CoroutineData *)data[0]; - void *stackLevel = TclGetCStackPtr(); - - if (!corPtr->stackLevel) { - /* - * -- Coroutine is suspended -- - * Push the callback to restore the caller's context on yield or - * return. - */ - - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, - NULL, NULL, NULL); - - /* - * Record the stackLevel at which the resume is happening, then swap - * the interp's environment to make it suitable to run this coroutine. - */ - - corPtr->stackLevel = stackLevel; - Tcl_Size numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = iPtr->numLevels; - - SAVE_CONTEXT(corPtr->caller); - corPtr->callerEEPtr = iPtr->execEnvPtr; - RESTORE_CONTEXT(corPtr->running); - iPtr->execEnvPtr = corPtr->eePtr; - iPtr->numLevels += numLevels; - } else { - /* - * Coroutine is active: yield - */ - - if (corPtr->stackLevel != stackLevel) { - NRE_callback *runPtr; - - iPtr->execEnvPtr = corPtr->callerEEPtr; - if (corPtr->yieldPtr) { - for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { - if (runPtr->data[1] == corPtr->yieldPtr) { - Tcl_DecrRefCount((Tcl_Obj *)runPtr->data[1]); - runPtr->data[1] = NULL; - corPtr->yieldPtr = NULL; - break; - } - } - } - iPtr->execEnvPtr = corPtr->eePtr; - - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot yield: C stack busy", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", - (void *)NULL); - return TCL_ERROR; - } - - void *type = data[1]; - if (type == CORO_ACTIVATE_YIELD) { - corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; - } else if (type == CORO_ACTIVATE_YIELDM) { - corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; - } else { - Tcl_Panic("Yield received an option which is not implemented"); - } - - corPtr->yieldPtr = NULL; - corPtr->stackLevel = NULL; - - Tcl_Size numLevels = iPtr->numLevels; - iPtr->numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; - - iPtr->execEnvPtr = corPtr->callerEEPtr; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclNREvalList -- - * - * Callback to invoke command as list, used in order to delayed - * processing of canonical list command in sane environment. - * - *---------------------------------------------------------------------- - */ - -static int -TclNREvalList( - void *data[], - Tcl_Interp *interp, - TCL_UNUSED(int) /*result*/) -{ - Tcl_Size objc; - Tcl_Obj **objv; - Tcl_Obj *listPtr = (Tcl_Obj *)data[0]; - - Tcl_IncrRefCount(listPtr); - - TclMarkTailcall(interp); - TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); - TclListObjGetElements(NULL, listPtr, &objc, &objv); - return TclNREvalObjv(interp, objc, objv, 0, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * CoroTypeObjCmd -- - * - * Implementation of [::tcl::unsupported::corotype] command. - * - *---------------------------------------------------------------------- - */ - -static int -CoroTypeObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Command *cmdPtr; - CoroutineData *corPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "coroName"); - return TCL_ERROR; - } - - /* - * Look up the coroutine. - */ - - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); - if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only get coroutine type of a coroutine", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objv[1]), (void *)NULL); - return TCL_ERROR; - } - - /* - * An active coroutine is "active". Can't tell what it might do in the - * future. - */ - - corPtr = (CoroutineData *)cmdPtr->objClientData; - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("active", TCL_INDEX_NONE)); - return TCL_OK; - } - - /* - * Inactive coroutines are classified by the (effective) command used to - * suspend them, which matters when you're injecting a probe. - */ - - switch (corPtr->nargs) { - case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: - Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", TCL_INDEX_NONE)); - return TCL_OK; - case COROUTINE_ARGUMENTS_ARBITRARY: - Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", TCL_INDEX_NONE)); - return TCL_OK; - default: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unknown coroutine type", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", (void *)NULL); - return TCL_ERROR; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd -- - * - * Implementation of [coroinject] and [coroprobe] commands. - * - *---------------------------------------------------------------------- - */ - -static inline CoroutineData * -GetCoroutineFromObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - const char *errMsg) -{ - /* - * How to get a coroutine from its handle. - */ - - Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); - - if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objPtr), (void *)NULL); - return NULL; - } - return (CoroutineData *)cmdPtr->objClientData; -} - -static int -TclNRCoroInjectObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr; - - /* - * Usage more or less like tailcall: - * coroinject coroName cmd ?arg1 arg2 ...? - */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); - return TCL_ERROR; - } - - corPtr = GetCoroutineFromObj(interp, objv[1], - "can only inject a command into a coroutine"); - if (!corPtr) { - return TCL_ERROR; - } - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a suspended coroutine", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL); - return TCL_ERROR; - } - - /* - * Add the callback to the coro's execEnv, so that it is the first thing - * to happen when the coro is resumed. - */ - - ExecEnv *savedEEPtr = iPtr->execEnvPtr; - iPtr->execEnvPtr = corPtr->eePtr; - TclNRAddCallback(interp, InjectHandler, corPtr, - Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL); - iPtr->execEnvPtr = savedEEPtr; - - return TCL_OK; -} - -static int -TclNRCoroProbeObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr; - - /* - * Usage more or less like tailcall: - * coroprobe coroName cmd ?arg1 arg2 ...? - */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); - return TCL_ERROR; - } - - corPtr = GetCoroutineFromObj(interp, objv[1], - "can only inject a probe command into a coroutine"); - if (!corPtr) { - return TCL_ERROR; - } - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a probe command into a suspended coroutine", - TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL); - return TCL_ERROR; - } - - /* - * Add the callback to the coro's execEnv, so that it is the first thing - * to happen when the coro is resumed. - */ - - ExecEnv *savedEEPtr = iPtr->execEnvPtr; - iPtr->execEnvPtr = corPtr->eePtr; - TclNRAddCallback(interp, InjectHandler, corPtr, - Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr); - iPtr->execEnvPtr = savedEEPtr; - - /* - * Now we immediately transfer control to the coroutine to run our probe. - * TRICKY STUFF copied from the [yield] implementation. - * - * Push the callback to restore the caller's context on yield back. - */ - - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, - NULL, NULL, NULL); - - /* - * Record the stackLevel at which the resume is happening, then swap - * the interp's environment to make it suitable to run this coroutine. - */ - - corPtr->stackLevel = &corPtr; - Tcl_Size numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = iPtr->numLevels; - - /* - * Do the actual stack swap. - */ - - SAVE_CONTEXT(corPtr->caller); - corPtr->callerEEPtr = iPtr->execEnvPtr; - RESTORE_CONTEXT(corPtr->running); - iPtr->execEnvPtr = corPtr->eePtr; - iPtr->numLevels += numLevels; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InjectHandler, InjectHandlerPostProc -- - * - * Part of the implementation of [coroinject] and [coroprobe]. These are - * run inside the context of the coroutine being injected/probed into. - * - * InjectHandler runs a script (possibly adding arguments) in the context - * of the coroutine. The script is specified as a one-shot list (with - * reference count equal to 1) in data[1]. This function also arranges - * for InjectHandlerPostProc to be the part that runs after the script - * completes. - * - * InjectHandlerPostProc cleans up after InjectHandler (deleting the - * list) and, for the [coroprobe] command *only*, yields back to the - * caller context (i.e., where [coroprobe] was run). - *s - *---------------------------------------------------------------------- - */ - -static int -InjectHandler( - void *data[], - Tcl_Interp *interp, - TCL_UNUSED(int) /*result*/) -{ - CoroutineData *corPtr = (CoroutineData *)data[0]; - Tcl_Obj *listPtr = (Tcl_Obj *)data[1]; - Tcl_Size nargs = PTR2INT(data[2]); - void *isProbe = data[3]; - Tcl_Size objc; - Tcl_Obj **objv; - - if (!isProbe) { - /* - * If this is [coroinject], add the extra arguments now. - */ - - if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) { - Tcl_ListObjAppendElement(NULL, listPtr, - Tcl_NewStringObj("yield", TCL_INDEX_NONE)); - } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) { - Tcl_ListObjAppendElement(NULL, listPtr, - Tcl_NewStringObj("yieldto", TCL_INDEX_NONE)); - } else { - /* - * I don't think this is reachable... - */ - Tcl_Obj *nargsObj; - TclNewIndexObj(nargsObj, nargs); - Tcl_ListObjAppendElement(NULL, listPtr, nargsObj); - } - Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp)); - } - - /* - * Call the user's script; we're in the right place. - */ - - Tcl_IncrRefCount(listPtr); - TclMarkTailcall(interp); - TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr, - INT2PTR(nargs), isProbe); - TclListObjGetElements(NULL, listPtr, &objc, &objv); - return TclNREvalObjv(interp, objc, objv, 0, NULL); -} - -static int -InjectHandlerPostCall( - void *data[], - Tcl_Interp *interp, - int result) -{ - CoroutineData *corPtr = (CoroutineData *)data[0]; - Tcl_Obj *listPtr = (Tcl_Obj *)data[1]; - Tcl_Size nargs = PTR2INT(data[2]); - void *isProbe = data[3]; - - /* - * Delete the command words for what we just executed. - */ - - Tcl_DecrRefCount(listPtr); - - /* - * If we were doing a probe, splice ourselves back out of the stack - * cleanly here. General injection should instead just look after itself. - * - * Code from guts of [yield] implementation. - */ - - if (isProbe) { - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (injected coroutine probe command)"); - } - corPtr->nargs = nargs; - corPtr->stackLevel = NULL; - Tcl_Size numLevels = iPtr->numLevels; - iPtr->numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; - iPtr->execEnvPtr = corPtr->callerEEPtr; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * NRInjectObjCmd -- - * - * Implementation of [::tcl::unsupported::inject] command. - * - *---------------------------------------------------------------------- - */ - -static int -NRInjectObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr; - ExecEnv *savedEEPtr = iPtr->execEnvPtr; - - /* - * Usage more or less like tailcall: - * inject coroName cmd ?arg1 arg2 ...? - */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); - return TCL_ERROR; - } - - corPtr = GetCoroutineFromObj(interp, objv[1], - "can only inject a command into a coroutine"); - if (!corPtr) { - return TCL_ERROR; - } - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a suspended coroutine", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL); - return TCL_ERROR; - } - - /* - * Add the callback to the coro's execEnv, so that it is the first thing - * to happen when the coro is resumed. - */ - - iPtr->execEnvPtr = corPtr->eePtr; - TclNRAddCallback(interp, TclNREvalList, Tcl_NewListObj(objc-2, objv+2), - NULL, NULL, NULL); - iPtr->execEnvPtr = savedEEPtr; - - return TCL_OK; -} - -int -TclNRInterpCoroutine( - void *clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - CoroutineData *corPtr = (CoroutineData *)clientData; - - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "coroutine \"%s\" is already running", - TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", (void *)NULL); - return TCL_ERROR; - } - - /* - * Parse all the arguments to work out what to feed as the result of the - * [yield]. TRICKY POINT: objc==0 happens here! It occurs when a coroutine - * is deleted! - */ - - switch (corPtr->nargs) { - case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: - if (objc == 2) { - Tcl_SetObjResult(interp, objv[1]); - } else if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?arg?"); - return TCL_ERROR; - } - break; - default: - if (corPtr->nargs + 1 != objc) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("wrong coro nargs; how did we get here? " - "not implemented!", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL); - return TCL_ERROR; - } - /* fallthrough */ - case COROUTINE_ARGUMENTS_ARBITRARY: - if (objc > 1) { - Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, objv+1)); - } - break; - } - - TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - NULL, NULL, NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclNRCoroutineObjCmd -- - * - * Implementation of [coroutine] command; see documentation for - * description of what this does. - * - *---------------------------------------------------------------------- - */ - -int -TclNRCoroutineObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Command *cmdPtr; - CoroutineData *corPtr; - const char *procName, *simpleName; - Namespace *nsPtr, *altNsPtr, *cxtNsPtr, - *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); - Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?"); - return TCL_ERROR; - } - - procName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, procName, inNsPtr, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); - - if (nsPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\": unknown namespace", - procName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", (void *)NULL); - return TCL_ERROR; - } - if (simpleName == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\": bad procedure name", - procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, (void *)NULL); - return TCL_ERROR; - } - - /* - * We ARE creating the coroutine command: allocate the corresponding - * struct and create the corresponding command. - */ - - corPtr = (CoroutineData *)ckalloc(sizeof(CoroutineData)); - - cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, - (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, - corPtr, DeleteCoroutine); - - corPtr->cmdPtr = cmdPtr; - cmdPtr->refCount++; - - /* - * #280. - * Provide the new coroutine with its own copy of the lineLABCPtr - * hashtable for literal command arguments in bytecode. Note that that - * CFWordBC chains are not duplicated, only the entrypoints to them. This - * means that in the presence of coroutines each chain is potentially a - * tree. Like the chain -> tree conversion of the CmdFrame stack. - */ - - { - Tcl_HashSearch hSearch; - Tcl_HashEntry *hePtr; - - corPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); - - for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch); - hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) { - int isNew; - Tcl_HashEntry *newPtr = - Tcl_CreateHashEntry(corPtr->lineLABCPtr, - Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr), - &isNew); - - Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr)); - } - } - - /* - * Create the base context. - */ - - corPtr->running.framePtr = iPtr->rootFramePtr; - corPtr->running.varFramePtr = iPtr->rootFramePtr; - corPtr->running.cmdFramePtr = NULL; - corPtr->running.lineLABCPtr = corPtr->lineLABCPtr; - corPtr->stackLevel = NULL; - corPtr->auxNumLevels = 0; - corPtr->yieldPtr = NULL; - - /* - * Create the coro's execEnv, switch to it to push the exit and coro - * command callbacks, then switch back. - */ - - corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE); - corPtr->callerEEPtr = iPtr->execEnvPtr; - corPtr->eePtr->corPtr = corPtr; - - SAVE_CONTEXT(corPtr->caller); - corPtr->callerEEPtr = iPtr->execEnvPtr; - RESTORE_CONTEXT(corPtr->running); - iPtr->execEnvPtr = corPtr->eePtr; - - TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, - NULL, NULL, NULL); - - /* - * Ensure that the command is looked up in the correct namespace. - */ - - iPtr->lookupNsPtr = lookupNsPtr; - Tcl_NREvalObj(interp, Tcl_NewListObj(objc - 2, objv + 2), 0); - iPtr->numLevels--; - - SAVE_CONTEXT(corPtr->running); - RESTORE_CONTEXT(corPtr->caller); - iPtr->execEnvPtr = corPtr->callerEEPtr; - - /* - * Now just resume the coroutine. - */ - - TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - NULL, NULL, NULL); - return TCL_OK; -} - -/* - * This is used in the [info] ensemble - */ - -int -TclInfoCoroutineCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; - } - - if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) { - Tcl_Obj *namePtr; - - TclNewObj(namePtr); - Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, namePtr); - Tcl_SetObjResult(interp, namePtr); - } - return TCL_OK; -} - -#undef iPtr - -/* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil * End: */ |