7123 lines
198 KiB
C
7123 lines
198 KiB
C
/*
|
||
* tclBasic.c --
|
||
*
|
||
* Contains the basic facilities for TCL command interpretation,
|
||
* including interpreter creation and deletion, command creation and
|
||
* deletion, and command/script execution.
|
||
*
|
||
* Copyright (c) 1987-1994 The Regents of the University of California.
|
||
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
||
* Copyright (c) 1998-1999 by Scriptics Corporation.
|
||
* Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
|
||
* 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 "tclCompile.h"
|
||
#include <float.h>
|
||
#include <limits.h>
|
||
#include <math.h>
|
||
#include "tommath.h"
|
||
|
||
/*
|
||
* Determine whether we're using IEEE floating point
|
||
*/
|
||
|
||
#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024)
|
||
# define IEEE_FLOATING_POINT
|
||
/* Largest odd integer that can be represented exactly in a double */
|
||
# define MAX_EXACT 9007199254740991.0
|
||
#endif
|
||
|
||
/*
|
||
* The following structure defines the client data for a math function
|
||
* registered with Tcl_CreateMathFunc
|
||
*/
|
||
|
||
typedef struct OldMathFuncData {
|
||
Tcl_MathProc *proc; /* Handler function */
|
||
int numArgs; /* Number of args expected */
|
||
Tcl_ValueType *argTypes; /* Types of the args */
|
||
ClientData clientData; /* Client data for the handler function */
|
||
} OldMathFuncData;
|
||
|
||
/*
|
||
* Static functions in this file:
|
||
*/
|
||
|
||
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
|
||
const char *oldName, const char *newName, int flags);
|
||
static int CheckDoubleResult(Tcl_Interp *interp, double dResult);
|
||
static void DeleteInterpProc(Tcl_Interp *interp);
|
||
static void DeleteOpCmdClientData(ClientData clientData);
|
||
static Tcl_Obj *GetCommandSource(Interp *iPtr, const char *command,
|
||
int numChars, int objc, Tcl_Obj *const objv[]);
|
||
static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode);
|
||
static int OldMathFuncProc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static void OldMathFuncDeleteProc(ClientData clientData);
|
||
static int ExprAbsFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprBinaryFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprBoolFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprCeilFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprDoubleFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprEntierFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprFloorFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprIntFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprIsqrtFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprRandFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprRoundFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprSqrtFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprSrandFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprUnaryFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static int ExprWideFunc(ClientData clientData, Tcl_Interp *interp,
|
||
int argc, Tcl_Obj *const *objv);
|
||
static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
|
||
int actual, Tcl_Obj *const *objv);
|
||
#ifdef USE_DTRACE
|
||
static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc,
|
||
Tcl_Obj *const objv[]);
|
||
#endif
|
||
|
||
extern TclStubs tclStubs;
|
||
|
||
/*
|
||
* The following structure define the commands in the Tcl core.
|
||
*/
|
||
|
||
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. */
|
||
int isSafe; /* If non-zero, command will be present in
|
||
* safe interpreter. Otherwise it will be
|
||
* hidden. */
|
||
} CmdInfo;
|
||
|
||
/*
|
||
* The built-in commands, and the functions that implement them:
|
||
*/
|
||
|
||
static const CmdInfo builtInCmds[] = {
|
||
/*
|
||
* Commands in the generic core.
|
||
*/
|
||
|
||
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1},
|
||
{"apply", Tcl_ApplyObjCmd, NULL, 1},
|
||
{"array", Tcl_ArrayObjCmd, NULL, 1},
|
||
{"binary", Tcl_BinaryObjCmd, NULL, 1},
|
||
{"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1},
|
||
#ifndef EXCLUDE_OBSOLETE_COMMANDS
|
||
{"case", Tcl_CaseObjCmd, NULL, 1},
|
||
#endif
|
||
{"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, 1},
|
||
{"concat", Tcl_ConcatObjCmd, NULL, 1},
|
||
{"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, 1},
|
||
{"error", Tcl_ErrorObjCmd, NULL, 1},
|
||
{"eval", Tcl_EvalObjCmd, NULL, 1},
|
||
{"expr", Tcl_ExprObjCmd, TclCompileExprCmd, 1},
|
||
{"for", Tcl_ForObjCmd, TclCompileForCmd, 1},
|
||
{"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, 1},
|
||
{"format", Tcl_FormatObjCmd, NULL, 1},
|
||
{"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, 1},
|
||
{"if", Tcl_IfObjCmd, TclCompileIfCmd, 1},
|
||
{"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, 1},
|
||
{"join", Tcl_JoinObjCmd, NULL, 1},
|
||
{"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, 1},
|
||
{"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, 1},
|
||
{"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, 1},
|
||
{"linsert", Tcl_LinsertObjCmd, NULL, 1},
|
||
{"list", Tcl_ListObjCmd, TclCompileListCmd, 1},
|
||
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, 1},
|
||
{"lrange", Tcl_LrangeObjCmd, NULL, 1},
|
||
{"lrepeat", Tcl_LrepeatObjCmd, NULL, 1},
|
||
{"lreplace", Tcl_LreplaceObjCmd, NULL, 1},
|
||
{"lreverse", Tcl_LreverseObjCmd, NULL, 1},
|
||
{"lsearch", Tcl_LsearchObjCmd, NULL, 1},
|
||
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, 1},
|
||
{"lsort", Tcl_LsortObjCmd, NULL, 1},
|
||
{"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, 1},
|
||
{"package", Tcl_PackageObjCmd, NULL, 1},
|
||
{"proc", Tcl_ProcObjCmd, NULL, 1},
|
||
{"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, 1},
|
||
{"regsub", Tcl_RegsubObjCmd, NULL, 1},
|
||
{"rename", Tcl_RenameObjCmd, NULL, 1},
|
||
{"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, 1},
|
||
{"scan", Tcl_ScanObjCmd, NULL, 1},
|
||
{"set", Tcl_SetObjCmd, TclCompileSetCmd, 1},
|
||
{"split", Tcl_SplitObjCmd, NULL, 1},
|
||
{"subst", Tcl_SubstObjCmd, NULL, 1},
|
||
{"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, 1},
|
||
{"trace", Tcl_TraceObjCmd, NULL, 1},
|
||
{"unset", Tcl_UnsetObjCmd, NULL, 1},
|
||
{"uplevel", Tcl_UplevelObjCmd, NULL, 1},
|
||
{"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, 1},
|
||
{"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, 1},
|
||
{"while", Tcl_WhileObjCmd, TclCompileWhileCmd, 1},
|
||
|
||
/*
|
||
* Commands in the OS-interface. Note that many of these are unsafe.
|
||
*/
|
||
|
||
{"after", Tcl_AfterObjCmd, NULL, 1},
|
||
{"cd", Tcl_CdObjCmd, NULL, 0},
|
||
{"close", Tcl_CloseObjCmd, NULL, 1},
|
||
{"eof", Tcl_EofObjCmd, NULL, 1},
|
||
{"encoding", Tcl_EncodingObjCmd, NULL, 0},
|
||
{"exec", Tcl_ExecObjCmd, NULL, 0},
|
||
{"exit", Tcl_ExitObjCmd, NULL, 0},
|
||
{"fblocked", Tcl_FblockedObjCmd, NULL, 1},
|
||
{"fconfigure", Tcl_FconfigureObjCmd, NULL, 0},
|
||
{"fcopy", Tcl_FcopyObjCmd, NULL, 1},
|
||
{"file", Tcl_FileObjCmd, NULL, 0},
|
||
{"fileevent", Tcl_FileEventObjCmd, NULL, 1},
|
||
{"flush", Tcl_FlushObjCmd, NULL, 1},
|
||
{"gets", Tcl_GetsObjCmd, NULL, 1},
|
||
{"glob", Tcl_GlobObjCmd, NULL, 0},
|
||
{"load", Tcl_LoadObjCmd, NULL, 0},
|
||
{"open", Tcl_OpenObjCmd, NULL, 0},
|
||
{"pid", Tcl_PidObjCmd, NULL, 1},
|
||
{"puts", Tcl_PutsObjCmd, NULL, 1},
|
||
{"pwd", Tcl_PwdObjCmd, NULL, 0},
|
||
{"read", Tcl_ReadObjCmd, NULL, 1},
|
||
{"seek", Tcl_SeekObjCmd, NULL, 1},
|
||
{"socket", Tcl_SocketObjCmd, NULL, 0},
|
||
{"source", Tcl_SourceObjCmd, NULL, 0},
|
||
{"tell", Tcl_TellObjCmd, NULL, 1},
|
||
{"time", Tcl_TimeObjCmd, NULL, 1},
|
||
{"unload", Tcl_UnloadObjCmd, NULL, 0},
|
||
{"update", Tcl_UpdateObjCmd, NULL, 1},
|
||
{"vwait", Tcl_VwaitObjCmd, NULL, 1},
|
||
{NULL, NULL, NULL, 0}
|
||
};
|
||
|
||
/*
|
||
* Math functions. All are safe.
|
||
*/
|
||
|
||
typedef struct {
|
||
const char *name; /* Name of the function. The full name is
|
||
* "::tcl::mathfunc::<name>". */
|
||
Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */
|
||
ClientData clientData; /* Client data for the function */
|
||
} BuiltinFuncDef;
|
||
static const BuiltinFuncDef BuiltinFuncTable[] = {
|
||
{ "abs", ExprAbsFunc, NULL },
|
||
{ "acos", ExprUnaryFunc, (ClientData) acos },
|
||
{ "asin", ExprUnaryFunc, (ClientData) asin },
|
||
{ "atan", ExprUnaryFunc, (ClientData) atan },
|
||
{ "atan2", ExprBinaryFunc, (ClientData) atan2 },
|
||
{ "bool", ExprBoolFunc, NULL },
|
||
{ "ceil", ExprCeilFunc, NULL },
|
||
{ "cos", ExprUnaryFunc, (ClientData) cos },
|
||
{ "cosh", ExprUnaryFunc, (ClientData) cosh },
|
||
{ "double", ExprDoubleFunc, NULL },
|
||
{ "entier", ExprEntierFunc, NULL },
|
||
{ "exp", ExprUnaryFunc, (ClientData) exp },
|
||
{ "floor", ExprFloorFunc, NULL },
|
||
{ "fmod", ExprBinaryFunc, (ClientData) fmod },
|
||
{ "hypot", ExprBinaryFunc, (ClientData) hypot },
|
||
{ "int", ExprIntFunc, NULL },
|
||
{ "isqrt", ExprIsqrtFunc, NULL },
|
||
{ "log", ExprUnaryFunc, (ClientData) log },
|
||
{ "log10", ExprUnaryFunc, (ClientData) log10 },
|
||
{ "pow", ExprBinaryFunc, (ClientData) pow },
|
||
{ "rand", ExprRandFunc, NULL },
|
||
{ "round", ExprRoundFunc, NULL },
|
||
{ "sin", ExprUnaryFunc, (ClientData) sin },
|
||
{ "sinh", ExprUnaryFunc, (ClientData) sinh },
|
||
{ "sqrt", ExprSqrtFunc, NULL },
|
||
{ "srand", ExprSrandFunc, NULL },
|
||
{ "tan", ExprUnaryFunc, (ClientData) tan },
|
||
{ "tanh", ExprUnaryFunc, (ClientData) tanh },
|
||
{ "wide", ExprWideFunc, NULL },
|
||
{ NULL, NULL, NULL }
|
||
};
|
||
|
||
/*
|
||
* TIP#174's math operators. All are safe.
|
||
*/
|
||
|
||
typedef struct {
|
||
const char *name; /* Name of object-based command. */
|
||
Tcl_ObjCmdProc *objProc; /* Object-based function for command. */
|
||
CompileProc *compileProc; /* Function called to compile command. */
|
||
union {
|
||
int numArgs;
|
||
int identity;
|
||
} i;
|
||
const char *expected; /* For error message, what argument(s)
|
||
* were expected. */
|
||
} OpCmdInfo;
|
||
static const OpCmdInfo mathOpCmds[] = {
|
||
{ "~", TclSingleOpCmd, TclCompileInvertOpCmd,
|
||
/* numArgs */ {1}, "integer"},
|
||
{ "!", TclSingleOpCmd, TclCompileNotOpCmd,
|
||
/* numArgs */ {1}, "boolean"},
|
||
{ "+", TclVariadicOpCmd, TclCompileAddOpCmd,
|
||
/* identity */ {0}, NULL},
|
||
{ "*", TclVariadicOpCmd, TclCompileMulOpCmd,
|
||
/* identity */ {1}, NULL},
|
||
{ "&", TclVariadicOpCmd, TclCompileAndOpCmd,
|
||
/* identity */ {-1}, NULL},
|
||
{ "|", TclVariadicOpCmd, TclCompileOrOpCmd,
|
||
/* identity */ {0}, NULL},
|
||
{ "^", TclVariadicOpCmd, TclCompileXorOpCmd,
|
||
/* identity */ {0}, NULL},
|
||
{ "**", TclVariadicOpCmd, TclCompilePowOpCmd,
|
||
/* identity */ {1}, NULL},
|
||
{ "<<", TclSingleOpCmd, TclCompileLshiftOpCmd,
|
||
/* numArgs */ {2}, "integer shift"},
|
||
{ ">>", TclSingleOpCmd, TclCompileRshiftOpCmd,
|
||
/* numArgs */ {2}, "integer shift"},
|
||
{ "%", TclSingleOpCmd, TclCompileModOpCmd,
|
||
/* numArgs */ {2}, "integer integer"},
|
||
{ "!=", TclSingleOpCmd, TclCompileNeqOpCmd,
|
||
/* numArgs */ {2}, "value value"},
|
||
{ "ne", TclSingleOpCmd, TclCompileStrneqOpCmd,
|
||
/* numArgs */ {2}, "value value"},
|
||
{ "in", TclSingleOpCmd, TclCompileInOpCmd,
|
||
/* numArgs */ {2}, "value list"},
|
||
{ "ni", TclSingleOpCmd, TclCompileNiOpCmd,
|
||
/* numArgs */ {2}, "value list"},
|
||
{ "-", TclNoIdentOpCmd, TclCompileMinusOpCmd,
|
||
/* unused */ {0}, "value ?value ...?"},
|
||
{ "/", TclNoIdentOpCmd, TclCompileDivOpCmd,
|
||
/* unused */ {0}, "value ?value ...?"},
|
||
{ "<", TclSortingOpCmd, TclCompileLessOpCmd,
|
||
/* unused */ {0}, NULL},
|
||
{ "<=", TclSortingOpCmd, TclCompileLeqOpCmd,
|
||
/* unused */ {0}, NULL},
|
||
{ ">", TclSortingOpCmd, TclCompileGreaterOpCmd,
|
||
/* unused */ {0}, NULL},
|
||
{ ">=", TclSortingOpCmd, TclCompileGeqOpCmd,
|
||
/* unused */ {0}, NULL},
|
||
{ "==", TclSortingOpCmd, TclCompileEqOpCmd,
|
||
/* unused */ {0}, NULL},
|
||
{ "eq", TclSortingOpCmd, TclCompileStreqOpCmd,
|
||
/* unused */ {0}, NULL},
|
||
{ NULL, NULL, NULL,
|
||
{0}, NULL}
|
||
};
|
||
|
||
/*
|
||
* Macros for stack checks. The goal of these macros is to allow the size of
|
||
* the stack to be checked (so preventing overflow) in a *cheap* way. Note
|
||
* that the check needs to be (amortized) cheap since it is on the critical
|
||
* path for recursion.
|
||
*/
|
||
|
||
#if defined(TCL_NO_STACK_CHECK)
|
||
/*
|
||
* Stack check disabled: make them noops.
|
||
*/
|
||
|
||
# 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 --
|
||
*
|
||
* Create a new TCL command interpreter.
|
||
*
|
||
* Results:
|
||
* The return value is a token for the interpreter, which may be used in
|
||
* calls to functions like Tcl_CreateCmd, Tcl_Eval, or Tcl_DeleteInterp.
|
||
*
|
||
* Side effects:
|
||
* The command interpreter is initialized with the built-in commands and
|
||
* with the variables documented in tclvars(n).
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
Tcl_Interp *
|
||
Tcl_CreateInterp(void)
|
||
{
|
||
Interp *iPtr;
|
||
Tcl_Interp *interp;
|
||
Command *cmdPtr;
|
||
const BuiltinFuncDef *builtinFuncPtr;
|
||
const OpCmdInfo *opcmdInfoPtr;
|
||
const CmdInfo *cmdInfoPtr;
|
||
Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr;
|
||
union {
|
||
char c[sizeof(short)];
|
||
short s;
|
||
} order;
|
||
#ifdef TCL_COMPILE_STATS
|
||
ByteCodeStats *statsPtr;
|
||
#endif /* TCL_COMPILE_STATS */
|
||
char mathFuncName[32];
|
||
CallFrame *framePtr;
|
||
int result;
|
||
|
||
TclInitSubsystems();
|
||
|
||
/*
|
||
* Panic if someone updated the CallFrame structure without also updating
|
||
* the Tcl_CallFrame structure (or vice versa).
|
||
*/
|
||
|
||
if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) {
|
||
/*NOTREACHED*/
|
||
Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
|
||
}
|
||
|
||
#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
|
||
|
||
/*
|
||
* 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));
|
||
interp = (Tcl_Interp *) iPtr;
|
||
|
||
iPtr->result = iPtr->resultSpace;
|
||
iPtr->freeProc = NULL;
|
||
iPtr->errorLine = 0;
|
||
iPtr->objResultPtr = Tcl_NewObj();
|
||
Tcl_IncrRefCount(iPtr->objResultPtr);
|
||
iPtr->handle = TclHandleCreate(iPtr);
|
||
iPtr->globalNsPtr = NULL;
|
||
iPtr->hiddenCmdTablePtr = NULL;
|
||
iPtr->interpInfo = NULL;
|
||
|
||
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.
|
||
*/
|
||
|
||
iPtr->cmdFramePtr = NULL;
|
||
iPtr->linePBodyPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
|
||
iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
|
||
iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
|
||
iPtr->lineLABCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
|
||
Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
|
||
Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
|
||
Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
|
||
Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
|
||
iPtr->scriptCLLocPtr = NULL;
|
||
|
||
iPtr->activeVarTracePtr = NULL;
|
||
|
||
iPtr->returnOpts = NULL;
|
||
iPtr->errorInfo = NULL;
|
||
TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo");
|
||
Tcl_IncrRefCount(iPtr->eiVar);
|
||
iPtr->errorCode = NULL;
|
||
TclNewLiteralStringObj(iPtr->ecVar, "::errorCode");
|
||
Tcl_IncrRefCount(iPtr->ecVar);
|
||
iPtr->returnLevel = 1;
|
||
iPtr->returnCode = TCL_OK;
|
||
|
||
iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */
|
||
iPtr->lookupNsPtr = NULL;
|
||
|
||
iPtr->appendResult = NULL;
|
||
iPtr->appendAvl = 0;
|
||
iPtr->appendUsed = 0;
|
||
|
||
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
|
||
iPtr->packageUnknown = NULL;
|
||
|
||
/* TIP #268 */
|
||
if (getenv("TCL_PKG_PREFER_LATEST") == NULL) {
|
||
iPtr->packagePrefer = PKG_PREFER_STABLE;
|
||
} else {
|
||
iPtr->packagePrefer = PKG_PREFER_LATEST;
|
||
}
|
||
|
||
iPtr->cmdCount = 0;
|
||
TclInitLiteralTable(&(iPtr->literalTable));
|
||
iPtr->compileEpoch = 0;
|
||
iPtr->compiledProcPtr = NULL;
|
||
iPtr->resolverPtr = NULL;
|
||
iPtr->evalFlags = 0;
|
||
iPtr->scriptFile = NULL;
|
||
iPtr->flags = 0;
|
||
iPtr->tracePtr = NULL;
|
||
iPtr->tracesForbiddingInline = 0;
|
||
iPtr->activeCmdTracePtr = NULL;
|
||
iPtr->activeInterpTracePtr = NULL;
|
||
iPtr->assocData = NULL;
|
||
iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */
|
||
iPtr->emptyObjPtr = Tcl_NewObj();
|
||
/* Another empty object. */
|
||
Tcl_IncrRefCount(iPtr->emptyObjPtr);
|
||
iPtr->resultSpace[0] = 0;
|
||
iPtr->threadId = Tcl_GetCurrentThread();
|
||
|
||
/* TIP #378 */
|
||
#ifdef TCL_INTERP_DEBUG_FRAME
|
||
iPtr->flags |= INTERP_DEBUG_FRAME;
|
||
#else
|
||
if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) {
|
||
iPtr->flags |= INTERP_DEBUG_FRAME;
|
||
}
|
||
#endif
|
||
|
||
/*
|
||
* Initialise the tables for variable traces and searches *before*
|
||
* creating the global ns - so that the trace on errorInfo can be
|
||
* recorded.
|
||
*/
|
||
|
||
Tcl_InitHashTable(&iPtr->varTraces, TCL_ONE_WORD_KEYS);
|
||
Tcl_InitHashTable(&iPtr->varSearches, TCL_ONE_WORD_KEYS);
|
||
|
||
iPtr->globalNsPtr = NULL; /* Force creation of global ns below. */
|
||
iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
|
||
NULL, NULL);
|
||
if (iPtr->globalNsPtr == NULL) {
|
||
Tcl_Panic("Tcl_CreateInterp: can't create global namespace");
|
||
}
|
||
|
||
/*
|
||
* Initialise the rootCallframe. It cannot be allocated on the stack, as
|
||
* it has to be in place before TclCreateExecEnv tries to use a variable.
|
||
*/
|
||
|
||
/* This is needed to satisfy GCC 3.3's strict aliasing rules */
|
||
framePtr = (CallFrame *) ckalloc(sizeof(CallFrame));
|
||
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
|
||
(Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0);
|
||
if (result != TCL_OK) {
|
||
Tcl_Panic("Tcl_CreateInterp: failed to push the root stack frame");
|
||
}
|
||
framePtr->objc = 0;
|
||
|
||
iPtr->framePtr = framePtr;
|
||
iPtr->varFramePtr = framePtr;
|
||
iPtr->rootFramePtr = framePtr;
|
||
|
||
/*
|
||
* Initialize support for code compilation and execution. We call
|
||
* TclCreateExecEnv after initializing namespaces since it tries to
|
||
* reference a Tcl variable (it links to the Tcl "tcl_traceExec"
|
||
* variable).
|
||
*/
|
||
|
||
iPtr->execEnvPtr = TclCreateExecEnv(interp);
|
||
|
||
/*
|
||
* TIP #219, Tcl Channel Reflection API support.
|
||
*/
|
||
|
||
iPtr->chanMsg = NULL;
|
||
|
||
/*
|
||
* Initialize the compilation and execution statistics kept for this
|
||
* interpreter.
|
||
*/
|
||
|
||
#ifdef TCL_COMPILE_STATS
|
||
statsPtr = &(iPtr->stats);
|
||
statsPtr->numExecutions = 0;
|
||
statsPtr->numCompilations = 0;
|
||
statsPtr->numByteCodesFreed = 0;
|
||
(void) memset(statsPtr->instructionCount, 0,
|
||
sizeof(statsPtr->instructionCount));
|
||
|
||
statsPtr->totalSrcBytes = 0.0;
|
||
statsPtr->totalByteCodeBytes = 0.0;
|
||
statsPtr->currentSrcBytes = 0.0;
|
||
statsPtr->currentByteCodeBytes = 0.0;
|
||
(void) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
|
||
(void) memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount));
|
||
(void) memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount));
|
||
|
||
statsPtr->currentInstBytes = 0.0;
|
||
statsPtr->currentLitBytes = 0.0;
|
||
statsPtr->currentExceptBytes = 0.0;
|
||
statsPtr->currentAuxBytes = 0.0;
|
||
statsPtr->currentCmdMapBytes = 0.0;
|
||
|
||
statsPtr->numLiteralsCreated = 0;
|
||
statsPtr->totalLitStringBytes = 0.0;
|
||
statsPtr->currentLitStringBytes = 0.0;
|
||
(void) memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount));
|
||
#endif /* TCL_COMPILE_STATS */
|
||
|
||
/*
|
||
* Initialise the stub table pointer.
|
||
*/
|
||
|
||
iPtr->stubTable = &tclStubs;
|
||
|
||
/*
|
||
* Initialize the ensemble error message rewriting support.
|
||
*/
|
||
|
||
iPtr->ensembleRewrite.sourceObjs = NULL;
|
||
iPtr->ensembleRewrite.numRemovedObjs = 0;
|
||
iPtr->ensembleRewrite.numInsertedObjs = 0;
|
||
|
||
/*
|
||
* TIP#143: Initialise the resource limit support.
|
||
*/
|
||
|
||
TclInitLimitSupport(interp);
|
||
|
||
/*
|
||
* Initialise the thread-specific data ekeko.
|
||
*/
|
||
|
||
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
|
||
iPtr->allocCache = TclpGetAllocCache();
|
||
#else
|
||
iPtr->allocCache = NULL;
|
||
#endif
|
||
iPtr->pendingObjDataPtr = NULL;
|
||
iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
|
||
|
||
/*
|
||
* Insure that the stack checking mechanism for this interp is
|
||
* initialized.
|
||
*/
|
||
|
||
GetCStackParams(iPtr);
|
||
|
||
/*
|
||
* Create the core commands. Do it here, rather than calling
|
||
* Tcl_CreateCommand, because it's faster (there's no need to check for a
|
||
* pre-existing command by the same name). If a command has a Tcl_CmdProc
|
||
* but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
|
||
* TclInvokeStringCommand. This is an object-based wrapper 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)) {
|
||
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->hPtr = hPtr;
|
||
cmdPtr->nsPtr = iPtr->globalNsPtr;
|
||
cmdPtr->refCount = 1;
|
||
cmdPtr->cmdEpoch = 0;
|
||
cmdPtr->compileProc = cmdInfoPtr->compileProc;
|
||
cmdPtr->proc = TclInvokeObjectCommand;
|
||
cmdPtr->clientData = cmdPtr;
|
||
cmdPtr->objProc = cmdInfoPtr->objProc;
|
||
cmdPtr->objClientData = NULL;
|
||
cmdPtr->deleteProc = NULL;
|
||
cmdPtr->deleteData = NULL;
|
||
cmdPtr->flags = 0;
|
||
cmdPtr->importRefPtr = NULL;
|
||
cmdPtr->tracePtr = NULL;
|
||
Tcl_SetHashValue(hPtr, cmdPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Create the "chan", "dict", "info" and "string" ensembles. Note that all
|
||
* these commands (and their subcommands that are not present in the
|
||
* global namespace) are wholly safe.
|
||
*/
|
||
|
||
TclInitChanCmd(interp);
|
||
TclInitDictCmd(interp);
|
||
TclInitInfoCmd(interp);
|
||
TclInitStringCmd(interp);
|
||
|
||
/*
|
||
* Register "clock" subcommands. These *do* go through
|
||
* Tcl_CreateObjCommand, since they aren't in the global namespace and
|
||
* involve ensembles.
|
||
*/
|
||
|
||
TclClockInit(interp);
|
||
|
||
/*
|
||
* Register the built-in functions. This is empty now that they are
|
||
* implemented as commands in the ::tcl::mathfunc namespace.
|
||
*/
|
||
|
||
/*
|
||
* Register the default [interp bgerror] handler.
|
||
*/
|
||
|
||
Tcl_CreateObjCommand(interp, "::tcl::Bgerror",
|
||
TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
|
||
|
||
/*
|
||
* Create an unsupported command for debugging bytecode.
|
||
*/
|
||
|
||
Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
|
||
Tcl_DisassembleObjCmd, NULL, NULL);
|
||
|
||
#ifdef USE_DTRACE
|
||
/*
|
||
* Register the tcl::dtrace command.
|
||
*/
|
||
|
||
Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
|
||
#endif /* USE_DTRACE */
|
||
|
||
/*
|
||
* Register the builtin math functions.
|
||
*/
|
||
|
||
mathfuncNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL);
|
||
if (mathfuncNSPtr == NULL) {
|
||
Tcl_Panic("Can't create math function namespace");
|
||
}
|
||
strcpy(mathFuncName, "::tcl::mathfunc::");
|
||
#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
|
||
for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
|
||
builtinFuncPtr++) {
|
||
strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
|
||
Tcl_CreateObjCommand(interp, mathFuncName,
|
||
builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL);
|
||
Tcl_Export(interp, mathfuncNSPtr, builtinFuncPtr->name, 0);
|
||
}
|
||
|
||
/*
|
||
* Register the mathematical "operator" commands. [TIP #174]
|
||
*/
|
||
|
||
mathopNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL);
|
||
#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */
|
||
if (mathopNSPtr == NULL) {
|
||
Tcl_Panic("can't create math operator namespace");
|
||
}
|
||
(void) Tcl_Export(interp, mathopNSPtr, "*", 1);
|
||
strcpy(mathFuncName, "::tcl::mathop::");
|
||
for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){
|
||
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)
|
||
ckalloc(sizeof(TclOpCmdClientData));
|
||
|
||
occdPtr->op = opcmdInfoPtr->name;
|
||
occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs;
|
||
occdPtr->expected = opcmdInfoPtr->expected;
|
||
strcpy(mathFuncName + MATH_OP_PREFIX_LEN, opcmdInfoPtr->name);
|
||
cmdPtr = (Command *) Tcl_CreateObjCommand(interp, mathFuncName,
|
||
opcmdInfoPtr->objProc, occdPtr, DeleteOpCmdClientData);
|
||
if (cmdPtr == NULL) {
|
||
Tcl_Panic("failed to create math operator %s",
|
||
opcmdInfoPtr->name);
|
||
} else if (opcmdInfoPtr->compileProc != NULL) {
|
||
cmdPtr->compileProc = opcmdInfoPtr->compileProc;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Do Multiple/Safe Interps Tcl init stuff
|
||
*/
|
||
|
||
TclInterpInit(interp);
|
||
TclSetupEnv(interp);
|
||
|
||
/*
|
||
* TIP #59: Make embedded configuration information available.
|
||
*/
|
||
|
||
TclInitEmbeddedConfigurationInformation(interp);
|
||
|
||
/*
|
||
* TIP #440: Declare the name of the script engine to be "Tcl".
|
||
*/
|
||
|
||
Tcl_SetVar2(interp, "tcl_platform", "engine", "Tcl",
|
||
TCL_GLOBAL_ONLY);
|
||
|
||
/*
|
||
* Compute the byte order of this machine.
|
||
*/
|
||
|
||
order.s = 1;
|
||
Tcl_SetVar2(interp, "tcl_platform", "byteOrder",
|
||
((order.c[0] == 1) ? "littleEndian" : "bigEndian"),
|
||
TCL_GLOBAL_ONLY);
|
||
|
||
Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize",
|
||
Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY);
|
||
|
||
/* TIP #291 */
|
||
Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize",
|
||
Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY);
|
||
|
||
/*
|
||
* Set up other variables such as tcl_version and tcl_library
|
||
*/
|
||
|
||
Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
|
||
Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
|
||
Tcl_TraceVar2(interp, "tcl_precision", NULL,
|
||
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
|
||
TclPrecTraceProc, NULL);
|
||
TclpSetVariables(interp);
|
||
|
||
#ifdef TCL_THREADS
|
||
/*
|
||
* The existence of the "threaded" element of the tcl_platform array
|
||
* indicates that this particular Tcl shell has been compiled with threads
|
||
* turned on. Using "info exists tcl_platform(threaded)" a Tcl script can
|
||
* introspect on the interpreter level of thread safety.
|
||
*/
|
||
|
||
Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY);
|
||
#endif
|
||
|
||
/*
|
||
* Register Tcl's version number.
|
||
* TIP #268: Full patchlevel instead of just major.minor
|
||
*/
|
||
|
||
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
|
||
|
||
#ifdef Tcl_InitStubs
|
||
#undef Tcl_InitStubs
|
||
#endif
|
||
Tcl_InitStubs(interp, TCL_VERSION, 1);
|
||
|
||
if (TclTommath_Init(interp) != TCL_OK) {
|
||
Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
|
||
}
|
||
|
||
return interp;
|
||
}
|
||
|
||
static void
|
||
DeleteOpCmdClientData(
|
||
ClientData clientData)
|
||
{
|
||
TclOpCmdClientData *occdPtr = clientData;
|
||
|
||
ckfree((char *) occdPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclHideUnsafeCommands --
|
||
*
|
||
* Hides base commands that are not marked as safe from this interpreter.
|
||
*
|
||
* Results:
|
||
* TCL_OK if it succeeds, TCL_ERROR else.
|
||
*
|
||
* Side effects:
|
||
* Hides functionality in an interpreter.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclHideUnsafeCommands(
|
||
Tcl_Interp *interp) /* Hide commands in this interpreter. */
|
||
{
|
||
register const CmdInfo *cmdInfoPtr;
|
||
|
||
if (interp == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
|
||
if (!cmdInfoPtr->isSafe) {
|
||
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
|
||
}
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*--------------------------------------------------------------
|
||
*
|
||
* Tcl_CallWhenDeleted --
|
||
*
|
||
* Arrange for a function to be called before a given interpreter is
|
||
* deleted. The function is called as soon as Tcl_DeleteInterp is called;
|
||
* if Tcl_CallWhenDeleted is called on an interpreter that has already
|
||
* been deleted, the function will be called when the last Tcl_Release is
|
||
* done on the interpreter.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* When Tcl_DeleteInterp is invoked to delete interp, proc will be
|
||
* invoked. See the manual entry for details.
|
||
*
|
||
*--------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_CallWhenDeleted(
|
||
Tcl_Interp *interp, /* Interpreter to watch. */
|
||
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
|
||
* to be deleted. */
|
||
ClientData clientData) /* One-word value to pass to proc. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
static Tcl_ThreadDataKey assocDataCounterKey;
|
||
int *assocDataCounterPtr =
|
||
Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int));
|
||
int isNew;
|
||
char buffer[32 + TCL_INTEGER_SPACE];
|
||
AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
|
||
Tcl_HashEntry *hPtr;
|
||
|
||
sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
|
||
(*assocDataCounterPtr)++;
|
||
|
||
if (iPtr->assocData == NULL) {
|
||
iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
|
||
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
|
||
}
|
||
hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew);
|
||
dPtr->proc = proc;
|
||
dPtr->clientData = clientData;
|
||
Tcl_SetHashValue(hPtr, dPtr);
|
||
}
|
||
|
||
/*
|
||
*--------------------------------------------------------------
|
||
*
|
||
* Tcl_DontCallWhenDeleted --
|
||
*
|
||
* Cancel the arrangement for a function to be called when a given
|
||
* interpreter is deleted.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* If proc and clientData were previously registered as a callback via
|
||
* Tcl_CallWhenDeleted, they are unregistered. If they weren't previously
|
||
* registered then nothing happens.
|
||
*
|
||
*--------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_DontCallWhenDeleted(
|
||
Tcl_Interp *interp, /* Interpreter to watch. */
|
||
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
|
||
* to be deleted. */
|
||
ClientData clientData) /* One-word value to pass to proc. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
Tcl_HashTable *hTablePtr;
|
||
Tcl_HashSearch hSearch;
|
||
Tcl_HashEntry *hPtr;
|
||
AssocData *dPtr;
|
||
|
||
hTablePtr = iPtr->assocData;
|
||
if (hTablePtr == NULL) {
|
||
return;
|
||
}
|
||
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
|
||
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
||
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
||
if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
|
||
ckfree((char *) dPtr);
|
||
Tcl_DeleteHashEntry(hPtr);
|
||
return;
|
||
}
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_SetAssocData --
|
||
*
|
||
* Creates a named association between user-specified data, a delete
|
||
* function and this interpreter. If the association already exists the
|
||
* data is overwritten with the new data. The delete function will be
|
||
* invoked when the interpreter is deleted.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Sets the associated data, creates the association if needed.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_SetAssocData(
|
||
Tcl_Interp *interp, /* Interpreter to associate with. */
|
||
const char *name, /* Name for association. */
|
||
Tcl_InterpDeleteProc *proc, /* Proc to call when interpreter is about to
|
||
* be deleted. */
|
||
ClientData clientData) /* One-word value to pass to proc. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
AssocData *dPtr;
|
||
Tcl_HashEntry *hPtr;
|
||
int isNew;
|
||
|
||
if (iPtr->assocData == NULL) {
|
||
iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
|
||
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
|
||
}
|
||
hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew);
|
||
if (isNew == 0) {
|
||
dPtr = Tcl_GetHashValue(hPtr);
|
||
} else {
|
||
dPtr = (AssocData *) ckalloc(sizeof(AssocData));
|
||
}
|
||
dPtr->proc = proc;
|
||
dPtr->clientData = clientData;
|
||
|
||
Tcl_SetHashValue(hPtr, dPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_DeleteAssocData --
|
||
*
|
||
* Deletes a named association of user-specified data with the specified
|
||
* interpreter.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Deletes the association.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_DeleteAssocData(
|
||
Tcl_Interp *interp, /* Interpreter to associate with. */
|
||
const char *name) /* Name of association. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
AssocData *dPtr;
|
||
Tcl_HashEntry *hPtr;
|
||
|
||
if (iPtr->assocData == NULL) {
|
||
return;
|
||
}
|
||
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
|
||
if (hPtr == NULL) {
|
||
return;
|
||
}
|
||
dPtr = Tcl_GetHashValue(hPtr);
|
||
if (dPtr->proc != NULL) {
|
||
dPtr->proc(dPtr->clientData, interp);
|
||
}
|
||
ckfree((char *) dPtr);
|
||
Tcl_DeleteHashEntry(hPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GetAssocData --
|
||
*
|
||
* Returns the client data associated with this name in the specified
|
||
* interpreter.
|
||
*
|
||
* Results:
|
||
* The client data in the AssocData record denoted by the named
|
||
* association, or NULL.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
ClientData
|
||
Tcl_GetAssocData(
|
||
Tcl_Interp *interp, /* Interpreter associated with. */
|
||
const char *name, /* Name of association. */
|
||
Tcl_InterpDeleteProc **procPtr)
|
||
/* Pointer to place to store address of
|
||
* current deletion callback. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
AssocData *dPtr;
|
||
Tcl_HashEntry *hPtr;
|
||
|
||
if (iPtr->assocData == NULL) {
|
||
return NULL;
|
||
}
|
||
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
|
||
if (hPtr == NULL) {
|
||
return NULL;
|
||
}
|
||
dPtr = Tcl_GetHashValue(hPtr);
|
||
if (procPtr != NULL) {
|
||
*procPtr = dPtr->proc;
|
||
}
|
||
return dPtr->clientData;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_InterpDeleted --
|
||
*
|
||
* Returns nonzero if the interpreter has been deleted with a call to
|
||
* Tcl_DeleteInterp.
|
||
*
|
||
* Results:
|
||
* Nonzero if the interpreter is deleted, zero otherwise.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_InterpDeleted(
|
||
Tcl_Interp *interp)
|
||
{
|
||
return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_DeleteInterp --
|
||
*
|
||
* Ensures that the interpreter will be deleted eventually. If there are
|
||
* no Tcl_Preserve calls in effect for this interpreter, it is deleted
|
||
* immediately, otherwise the interpreter is deleted when the last
|
||
* Tcl_Preserve is matched by a call to Tcl_Release. In either case, the
|
||
* function runs the currently registered deletion callbacks.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* The interpreter is marked as deleted. The caller may still use it
|
||
* safely if there are calls to Tcl_Preserve in effect for the
|
||
* interpreter, but further calls to Tcl_Eval etc in this interpreter
|
||
* will fail.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_DeleteInterp(
|
||
Tcl_Interp *interp) /* Token for command interpreter (returned by
|
||
* a previous call to Tcl_CreateInterp). */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
|
||
/*
|
||
* If the interpreter has already been marked deleted, just punt.
|
||
*/
|
||
|
||
if (iPtr->flags & DELETED) {
|
||
return;
|
||
}
|
||
|
||
/*
|
||
* Mark the interpreter as deleted. No further evals will be allowed.
|
||
* Increase the compileEpoch as a signal to compiled bytecodes.
|
||
*/
|
||
|
||
iPtr->flags |= DELETED;
|
||
iPtr->compileEpoch++;
|
||
|
||
/*
|
||
* Ensure that the interpreter is eventually deleted.
|
||
*/
|
||
|
||
Tcl_EventuallyFree(interp, (Tcl_FreeProc *) DeleteInterpProc);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* DeleteInterpProc --
|
||
*
|
||
* Helper function to delete an interpreter. This function is called when
|
||
* the last call to Tcl_Preserve on this interpreter is matched by a call
|
||
* to Tcl_Release. The function cleans up all resources used in the
|
||
* interpreter and calls all currently registered interpreter deletion
|
||
* callbacks.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Whatever the interpreter deletion callbacks do. Frees resources used
|
||
* by the interpreter.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
DeleteInterpProc(
|
||
Tcl_Interp *interp) /* Interpreter to delete. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
Tcl_HashEntry *hPtr;
|
||
Tcl_HashSearch search;
|
||
Tcl_HashTable *hTablePtr;
|
||
ResolverScheme *resPtr, *nextResPtr;
|
||
|
||
/*
|
||
* Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
|
||
*/
|
||
|
||
if (iPtr->numLevels > 0) {
|
||
Tcl_Panic("DeleteInterpProc called with active evals");
|
||
}
|
||
|
||
/*
|
||
* The interpreter should already be marked deleted; otherwise how did we
|
||
* get here?
|
||
*/
|
||
|
||
if (!(iPtr->flags & DELETED)) {
|
||
Tcl_Panic("DeleteInterpProc called on interpreter not marked deleted");
|
||
}
|
||
|
||
/*
|
||
* TIP #219, Tcl Channel Reflection API. Discard a leftover state.
|
||
*/
|
||
|
||
if (iPtr->chanMsg != NULL) {
|
||
Tcl_DecrRefCount(iPtr->chanMsg);
|
||
iPtr->chanMsg = NULL;
|
||
}
|
||
|
||
/*
|
||
* Shut down all limit handler callback scripts that call back into this
|
||
* interpreter. Then eliminate all limit handlers for this interpreter.
|
||
*/
|
||
|
||
TclRemoveScriptLimitCallbacks(interp);
|
||
TclLimitRemoveAllHandlers(interp);
|
||
|
||
/*
|
||
* Dismantle the namespace here, before we clear the assocData. If any
|
||
* background errors occur here, they will be deleted below.
|
||
*
|
||
* Dismantle the namespace after freeing the iPtr->handle so that each
|
||
* bytecode releases its literals without caring to update the literal
|
||
* table, as it will be freed later in this function without further use.
|
||
*/
|
||
|
||
TclHandleFree(iPtr->handle);
|
||
TclTeardownNamespace(iPtr->globalNsPtr);
|
||
|
||
/*
|
||
* Delete all the hidden commands.
|
||
*/
|
||
|
||
hTablePtr = iPtr->hiddenCmdTablePtr;
|
||
if (hTablePtr != NULL) {
|
||
/*
|
||
* Non-pernicious deletion. The deletion callbacks will not be allowed
|
||
* to create any new hidden or non-hidden commands.
|
||
* 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_DeleteHashTable(hTablePtr);
|
||
ckfree((char *) hTablePtr);
|
||
}
|
||
|
||
/*
|
||
* Invoke deletion callbacks; note that a callback can create new
|
||
* callbacks, so we iterate.
|
||
*/
|
||
|
||
while (iPtr->assocData != NULL) {
|
||
AssocData *dPtr;
|
||
|
||
hTablePtr = iPtr->assocData;
|
||
iPtr->assocData = NULL;
|
||
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
|
||
hPtr != NULL;
|
||
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
|
||
dPtr = Tcl_GetHashValue(hPtr);
|
||
Tcl_DeleteHashEntry(hPtr);
|
||
if (dPtr->proc != NULL) {
|
||
dPtr->proc(dPtr->clientData, interp);
|
||
}
|
||
ckfree((char *) dPtr);
|
||
}
|
||
Tcl_DeleteHashTable(hTablePtr);
|
||
ckfree((char *) hTablePtr);
|
||
}
|
||
|
||
/*
|
||
* Pop the root frame pointer and finish deleting the global
|
||
* namespace. The order is important [Bug 1658572].
|
||
*/
|
||
|
||
if (iPtr->framePtr != iPtr->rootFramePtr) {
|
||
Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top");
|
||
}
|
||
Tcl_PopCallFrame(interp);
|
||
ckfree((char *) iPtr->rootFramePtr);
|
||
iPtr->rootFramePtr = NULL;
|
||
Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
|
||
|
||
/*
|
||
* Free up the result *after* deleting variables, since variable deletion
|
||
* could have transferred ownership of the result string to Tcl.
|
||
*/
|
||
|
||
Tcl_FreeResult(interp);
|
||
interp->result = NULL;
|
||
Tcl_DecrRefCount(iPtr->objResultPtr);
|
||
iPtr->objResultPtr = NULL;
|
||
Tcl_DecrRefCount(iPtr->ecVar);
|
||
if (iPtr->errorCode) {
|
||
Tcl_DecrRefCount(iPtr->errorCode);
|
||
iPtr->errorCode = NULL;
|
||
}
|
||
Tcl_DecrRefCount(iPtr->eiVar);
|
||
if (iPtr->errorInfo) {
|
||
Tcl_DecrRefCount(iPtr->errorInfo);
|
||
iPtr->errorInfo = NULL;
|
||
}
|
||
if (iPtr->returnOpts) {
|
||
Tcl_DecrRefCount(iPtr->returnOpts);
|
||
}
|
||
if (iPtr->appendResult != NULL) {
|
||
ckfree(iPtr->appendResult);
|
||
iPtr->appendResult = NULL;
|
||
}
|
||
TclFreePackageInfo(iPtr);
|
||
while (iPtr->tracePtr != NULL) {
|
||
Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr);
|
||
}
|
||
if (iPtr->execEnvPtr != NULL) {
|
||
TclDeleteExecEnv(iPtr->execEnvPtr);
|
||
}
|
||
if (iPtr->scriptFile) {
|
||
Tcl_DecrRefCount(iPtr->scriptFile);
|
||
iPtr->scriptFile = NULL;
|
||
}
|
||
Tcl_DecrRefCount(iPtr->emptyObjPtr);
|
||
iPtr->emptyObjPtr = NULL;
|
||
|
||
resPtr = iPtr->resolverPtr;
|
||
while (resPtr) {
|
||
nextResPtr = resPtr->nextPtr;
|
||
ckfree(resPtr->name);
|
||
ckfree((char *) resPtr);
|
||
resPtr = nextResPtr;
|
||
}
|
||
|
||
/*
|
||
* Free up literal objects created for scripts compiled by the
|
||
* interpreter.
|
||
*/
|
||
|
||
TclDeleteLiteralTable(interp, &(iPtr->literalTable));
|
||
|
||
/*
|
||
* TIP #280 - Release the arrays for ByteCode/Proc extension, and
|
||
* contents.
|
||
*/
|
||
|
||
{
|
||
Tcl_HashEntry *hPtr;
|
||
Tcl_HashSearch hSearch;
|
||
int i;
|
||
|
||
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);
|
||
}
|
||
Tcl_DeleteHashEntry(hPtr);
|
||
}
|
||
Tcl_DeleteHashTable(iPtr->linePBodyPtr);
|
||
ckfree((char *) iPtr->linePBodyPtr);
|
||
iPtr->linePBodyPtr = NULL;
|
||
|
||
/*
|
||
* See also tclCompile.c, TclCleanupByteCode
|
||
*/
|
||
|
||
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((char *) eclPtr->loc[i].line);
|
||
}
|
||
|
||
if (eclPtr->loc != NULL) {
|
||
ckfree((char *) eclPtr->loc);
|
||
}
|
||
|
||
Tcl_DeleteHashTable (&eclPtr->litInfo);
|
||
|
||
ckfree((char *) eclPtr);
|
||
Tcl_DeleteHashEntry(hPtr);
|
||
}
|
||
Tcl_DeleteHashTable(iPtr->lineBCPtr);
|
||
ckfree((char *) iPtr->lineBCPtr);
|
||
iPtr->lineBCPtr = NULL;
|
||
|
||
/*
|
||
* 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.
|
||
*/
|
||
|
||
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_Panic ("Argument location tracking table not empty");
|
||
}
|
||
|
||
Tcl_DeleteHashTable (iPtr->lineLAPtr);
|
||
ckfree((char*) iPtr->lineLAPtr);
|
||
iPtr->lineLAPtr = NULL;
|
||
|
||
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_Panic ("Argument location tracking table not empty");
|
||
}
|
||
|
||
Tcl_DeleteHashTable (iPtr->lineLABCPtr);
|
||
ckfree((char*) iPtr->lineLABCPtr);
|
||
iPtr->lineLABCPtr = NULL;
|
||
}
|
||
|
||
Tcl_DeleteHashTable(&iPtr->varTraces);
|
||
Tcl_DeleteHashTable(&iPtr->varSearches);
|
||
|
||
ckfree((char *) iPtr);
|
||
}
|
||
|
||
/*
|
||
*---------------------------------------------------------------------------
|
||
*
|
||
* Tcl_HideCommand --
|
||
*
|
||
* Makes a command hidden so that it cannot be invoked from within an
|
||
* interpreter, only from within an ancestor.
|
||
*
|
||
* Results:
|
||
* A standard Tcl result; also leaves a message in the interp's result if
|
||
* an error occurs.
|
||
*
|
||
* Side effects:
|
||
* Removes a command from the command table and create an entry into the
|
||
* hidden command table under the specified token name.
|
||
*
|
||
*---------------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_HideCommand(
|
||
Tcl_Interp *interp, /* Interpreter in which to hide command. */
|
||
const char *cmdName, /* Name of command to hide. */
|
||
const char *hiddenCmdToken) /* Token name of the to-be-hidden command. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
Tcl_Command cmd;
|
||
Command *cmdPtr;
|
||
Tcl_HashTable *hiddenCmdTablePtr;
|
||
Tcl_HashEntry *hPtr;
|
||
int isNew;
|
||
|
||
if (iPtr->flags & DELETED) {
|
||
/*
|
||
* The interpreter is being deleted. Do not create any new structures,
|
||
* because it is not safe to modify the interpreter.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Disallow hiding of commands that are currently in a namespace or
|
||
* renaming (as part of hiding) into a namespace (because the current
|
||
* implementation with a single global table and the needed uniqueness of
|
||
* names cause problems with namespaces).
|
||
*
|
||
* We don't need to check for "::" in cmdName because the real check is on
|
||
* the nsPtr below.
|
||
*
|
||
* hiddenCmdToken is just a string which is not interpreted in any way. It
|
||
* may contain :: but the string is not interpreted as a namespace
|
||
* qualifier command name. Thus, hiding foo::bar to foo::bar and then
|
||
* trying to expose or invoke ::foo::bar will NOT work; but if the
|
||
* application always uses the same strings it will get consistent
|
||
* behaviour.
|
||
*
|
||
* But as we currently limit ourselves to the global namespace only for
|
||
* the source, in order to avoid potential confusion, lets prevent "::" in
|
||
* the token too. - dl
|
||
*/
|
||
|
||
if (strstr(hiddenCmdToken, "::") != NULL) {
|
||
Tcl_AppendResult(interp,
|
||
"cannot use namespace qualifiers in hidden command"
|
||
" token (rename)", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Find the command to hide. An error is returned if cmdName can't be
|
||
* found. Look up the command only from the global namespace. Full path of
|
||
* the command must be given if using namespaces.
|
||
*/
|
||
|
||
cmd = Tcl_FindCommand(interp, cmdName, NULL,
|
||
/*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
|
||
if (cmd == (Tcl_Command) NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
cmdPtr = (Command *) cmd;
|
||
|
||
/*
|
||
* Check that the command is really in global namespace
|
||
*/
|
||
|
||
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
|
||
Tcl_AppendResult(interp, "can only hide global namespace commands"
|
||
" (use rename then hide)", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Initialize the hidden command table if necessary.
|
||
*/
|
||
|
||
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
|
||
if (hiddenCmdTablePtr == NULL) {
|
||
hiddenCmdTablePtr = (Tcl_HashTable *)
|
||
ckalloc((unsigned) sizeof(Tcl_HashTable));
|
||
Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
|
||
iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
|
||
}
|
||
|
||
/*
|
||
* It is an error to move an exposed command to a hidden command with
|
||
* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
|
||
* exists.
|
||
*/
|
||
|
||
hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew);
|
||
if (!isNew) {
|
||
Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken,
|
||
"\" already exists", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* NB: This code is currently 'like' a rename to a specialy set apart name
|
||
* table. Changes here and in TclRenameCommand must be kept in synch 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;
|
||
* this invalidates any cached references that point to the command.
|
||
*/
|
||
|
||
if (cmdPtr->hPtr != NULL) {
|
||
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
||
cmdPtr->hPtr = NULL;
|
||
cmdPtr->cmdEpoch++;
|
||
}
|
||
|
||
/*
|
||
* The list of command exported from the namespace might have changed.
|
||
* However, we do not need to recompute this just yet; next time we need
|
||
* the info will be soon enough.
|
||
*/
|
||
|
||
TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
|
||
|
||
/*
|
||
* Now link the hash table entry with the command structure. We ensured
|
||
* above that the nsPtr was right.
|
||
*/
|
||
|
||
cmdPtr->hPtr = hPtr;
|
||
Tcl_SetHashValue(hPtr, cmdPtr);
|
||
|
||
/*
|
||
* If the command being hidden has a compile function, increment the
|
||
* interpreter's compileEpoch to invalidate its compiled code. This makes
|
||
* sure that we don't later try to execute old code compiled with
|
||
* command-specific (i.e., inline) bytecodes for the now-hidden command.
|
||
* This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose
|
||
* compilation epoch doesn't match is recompiled.
|
||
*/
|
||
|
||
if (cmdPtr->compileProc != NULL) {
|
||
iPtr->compileEpoch++;
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_ExposeCommand --
|
||
*
|
||
* Makes a previously hidden command callable from inside the interpreter
|
||
* instead of only by its ancestors.
|
||
*
|
||
* Results:
|
||
* A standard Tcl result. If an error occurs, a message is left in the
|
||
* interp's result.
|
||
*
|
||
* Side effects:
|
||
* Moves commands from one hash table to another.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_ExposeCommand(
|
||
Tcl_Interp *interp, /* Interpreter in which to make command
|
||
* callable. */
|
||
const char *hiddenCmdToken, /* Name of hidden command. */
|
||
const char *cmdName) /* Name of to-be-exposed command. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
Command *cmdPtr;
|
||
Namespace *nsPtr;
|
||
Tcl_HashEntry *hPtr;
|
||
Tcl_HashTable *hiddenCmdTablePtr;
|
||
int isNew;
|
||
|
||
if (iPtr->flags & DELETED) {
|
||
/*
|
||
* The interpreter is being deleted. Do not create any new structures,
|
||
* because it is not safe to modify the interpreter.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Check that we have a regular name for the command (that the user is not
|
||
* trying to do an expose and a rename (to another namespace) at the same
|
||
* time).
|
||
*/
|
||
|
||
if (strstr(cmdName, "::") != NULL) {
|
||
Tcl_AppendResult(interp, "cannot expose to a namespace "
|
||
"(use expose to toplevel, then rename)", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Get the command from the hidden command table:
|
||
*/
|
||
|
||
hPtr = NULL;
|
||
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
|
||
if (hiddenCmdTablePtr != NULL) {
|
||
hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
|
||
}
|
||
if (hPtr == NULL) {
|
||
Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken,
|
||
"\"", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
cmdPtr = Tcl_GetHashValue(hPtr);
|
||
|
||
/*
|
||
* Check that we have a true global namespace command (enforced by
|
||
* Tcl_HideCommand() but let's double check. (If it was not, we would not
|
||
* really know how to handle it).
|
||
*/
|
||
|
||
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
|
||
/*
|
||
* This case is theoritically impossible, we might rather Tcl_Panic()
|
||
* than 'nicely' erroring out ?
|
||
*/
|
||
|
||
Tcl_AppendResult(interp,
|
||
"trying to expose a non global command name space command",
|
||
NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* This is the global table.
|
||
*/
|
||
|
||
nsPtr = cmdPtr->nsPtr;
|
||
|
||
/*
|
||
* It is an error to overwrite an existing exposed command as a result of
|
||
* exposing a previously hidden command.
|
||
*/
|
||
|
||
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
|
||
if (!isNew) {
|
||
Tcl_AppendResult(interp, "exposed command \"", cmdName,
|
||
"\" already exists", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* The list of command exported from the namespace might have changed.
|
||
* However, we do not need to recompute this just yet; next time we need
|
||
* the info will be soon enough.
|
||
*/
|
||
|
||
TclInvalidateNsCmdLookup(nsPtr);
|
||
|
||
/*
|
||
* Remove the hash entry for the command from the interpreter hidden
|
||
* command table.
|
||
*/
|
||
|
||
if (cmdPtr->hPtr != NULL) {
|
||
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
||
cmdPtr->hPtr = NULL;
|
||
}
|
||
|
||
/*
|
||
* Now link the hash table entry with the command structure. This is like
|
||
* creating a new command, so deal with any shadowing of commands in the
|
||
* global namespace.
|
||
*/
|
||
|
||
cmdPtr->hPtr = hPtr;
|
||
|
||
Tcl_SetHashValue(hPtr, cmdPtr);
|
||
|
||
/*
|
||
* Not needed as we are only in the global namespace (but would be needed
|
||
* again if we supported namespace command hiding)
|
||
*
|
||
* TclResetShadowedCmdRefs(interp, cmdPtr);
|
||
*/
|
||
|
||
/*
|
||
* If the command being exposed has a compile function, increment
|
||
* interpreter's compileEpoch to invalidate its compiled code. This makes
|
||
* sure that we don't later try to execute old code compiled assuming the
|
||
* command is hidden. This field is checked in Tcl_EvalObj and
|
||
* ObjInterpProc, and code whose compilation epoch doesn't match is
|
||
* recompiled.
|
||
*/
|
||
|
||
if (cmdPtr->compileProc != NULL) {
|
||
iPtr->compileEpoch++;
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_CreateCommand --
|
||
*
|
||
* Define a new command in a command table.
|
||
*
|
||
* Results:
|
||
* The return value is a token for the command, which can be used in
|
||
* future calls to Tcl_GetCommandName.
|
||
*
|
||
* Side effects:
|
||
* If a command named cmdName already exists for interp, it is deleted.
|
||
* In the future, when cmdName is seen as the name of a command by
|
||
* Tcl_Eval, proc will be called. To support the bytecode interpreter,
|
||
* the command is created with a wrapper Tcl_ObjCmdProc
|
||
* (TclInvokeStringCommand) that eventially calls proc. When the command
|
||
* is deleted from the table, deleteProc will be called. See the manual
|
||
* entry for details on the calling sequence.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
Tcl_Command
|
||
Tcl_CreateCommand(
|
||
Tcl_Interp *interp, /* Token for command interpreter returned by a
|
||
* previous call to Tcl_CreateInterp. */
|
||
const char *cmdName, /* Name of command. If it contains namespace
|
||
* qualifiers, the new command is put in the
|
||
* specified namespace; otherwise it is put in
|
||
* the global namespace. */
|
||
Tcl_CmdProc *proc, /* Function to associate with cmdName. */
|
||
ClientData clientData, /* Arbitrary value passed to string proc. */
|
||
Tcl_CmdDeleteProc *deleteProc)
|
||
/* If not NULL, gives a function to call when
|
||
* this command is deleted. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
ImportRef *oldRefPtr = NULL;
|
||
Namespace *nsPtr, *dummy1, *dummy2;
|
||
Command *cmdPtr, *refCmdPtr;
|
||
Tcl_HashEntry *hPtr;
|
||
const char *tail;
|
||
int 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.
|
||
*/
|
||
|
||
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) {
|
||
/*
|
||
* 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;
|
||
}
|
||
|
||
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
|
||
|
||
if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
|
||
oldRefPtr = cmdPtr->importRefPtr;
|
||
cmdPtr->importRefPtr = NULL;
|
||
}
|
||
TclCleanupCommandMacro(cmdPtr);
|
||
|
||
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
|
||
* need the info will be soon enough.
|
||
*/
|
||
|
||
TclInvalidateNsCmdLookup(nsPtr);
|
||
TclInvalidateNsPath(nsPtr);
|
||
}
|
||
cmdPtr = (Command *) ckalloc(sizeof(Command));
|
||
Tcl_SetHashValue(hPtr, cmdPtr);
|
||
cmdPtr->hPtr = hPtr;
|
||
cmdPtr->nsPtr = nsPtr;
|
||
cmdPtr->refCount = 1;
|
||
cmdPtr->cmdEpoch = 0;
|
||
cmdPtr->compileProc = NULL;
|
||
cmdPtr->objProc = TclInvokeStringCommand;
|
||
cmdPtr->objClientData = cmdPtr;
|
||
cmdPtr->proc = proc;
|
||
cmdPtr->clientData = clientData;
|
||
cmdPtr->deleteProc = deleteProc;
|
||
cmdPtr->deleteData = clientData;
|
||
cmdPtr->flags = 0;
|
||
cmdPtr->importRefPtr = NULL;
|
||
cmdPtr->tracePtr = NULL;
|
||
|
||
/*
|
||
* Plug in any existing import references found above. Be sure to update
|
||
* all of these references to point to the new command.
|
||
*/
|
||
|
||
if (oldRefPtr != NULL) {
|
||
cmdPtr->importRefPtr = oldRefPtr;
|
||
while (oldRefPtr != NULL) {
|
||
refCmdPtr = oldRefPtr->importedCmdPtr;
|
||
dataPtr = refCmdPtr->objClientData;
|
||
dataPtr->realCmdPtr = cmdPtr;
|
||
oldRefPtr = oldRefPtr->nextPtr;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* We just created a command, so in its namespace and all of its parent
|
||
* namespaces, it may shadow global commands with the same name. If any
|
||
* shadowed commands are found, invalidate all cached command references
|
||
* in the affected namespaces.
|
||
*/
|
||
|
||
TclResetShadowedCmdRefs(interp, cmdPtr);
|
||
return (Tcl_Command) cmdPtr;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_CreateObjCommand --
|
||
*
|
||
* Define a new object-based command in a command table.
|
||
*
|
||
* Results:
|
||
* The return value is a token for the command, which can be used in
|
||
* future calls to Tcl_GetCommandName.
|
||
*
|
||
* Side effects:
|
||
* If a command named "cmdName" already exists for interp, it is
|
||
* first deleted. Then the new command is created from the arguments.
|
||
* [***] (See below for exception).
|
||
*
|
||
* 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_CreateObjCommand(
|
||
Tcl_Interp *interp, /* Token for command interpreter (returned by
|
||
* previous call to Tcl_CreateInterp). */
|
||
const char *cmdName, /* Name of command. If it contains namespace
|
||
* qualifiers, the new command is put in the
|
||
* specified namespace; otherwise it is put in
|
||
* the global namespace. */
|
||
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
|
||
* name. */
|
||
ClientData clientData, /* Arbitrary value to pass to object
|
||
* function. */
|
||
Tcl_CmdDeleteProc *deleteProc)
|
||
/* If not NULL, gives a function to call when
|
||
* this command is deleted. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
ImportRef *oldRefPtr = NULL;
|
||
Namespace *nsPtr, *dummy1, *dummy2;
|
||
Command *cmdPtr, *refCmdPtr;
|
||
Tcl_HashEntry *hPtr;
|
||
const char *tail;
|
||
int 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.
|
||
*/
|
||
|
||
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);
|
||
TclInvalidateNsPath(nsPtr);
|
||
if (!isNew) {
|
||
cmdPtr = 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.
|
||
*/
|
||
|
||
if (cmdPtr->objProc == TclInvokeStringCommand
|
||
&& cmdPtr->clientData == clientData
|
||
&& cmdPtr->deleteData == clientData
|
||
&& cmdPtr->deleteProc == deleteProc) {
|
||
cmdPtr->objProc = proc;
|
||
cmdPtr->objClientData = clientData;
|
||
return (Tcl_Command) cmdPtr;
|
||
}
|
||
|
||
/*
|
||
* Otherwise, we delete the old command. Be careful to preserve any
|
||
* existing import links so we can restore them down below. That way,
|
||
* you can redefine a command and its import status will remain
|
||
* intact.
|
||
*/
|
||
|
||
cmdPtr->refCount++;
|
||
if (cmdPtr->importRefPtr) {
|
||
cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
|
||
}
|
||
|
||
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
|
||
|
||
if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
|
||
oldRefPtr = cmdPtr->importRefPtr;
|
||
cmdPtr->importRefPtr = NULL;
|
||
}
|
||
TclCleanupCommandMacro(cmdPtr);
|
||
|
||
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
|
||
* need the info will be soon enough.
|
||
*/
|
||
|
||
TclInvalidateNsCmdLookup(nsPtr);
|
||
}
|
||
cmdPtr = (Command *) ckalloc(sizeof(Command));
|
||
Tcl_SetHashValue(hPtr, cmdPtr);
|
||
cmdPtr->hPtr = hPtr;
|
||
cmdPtr->nsPtr = nsPtr;
|
||
cmdPtr->refCount = 1;
|
||
cmdPtr->cmdEpoch = 0;
|
||
cmdPtr->compileProc = NULL;
|
||
cmdPtr->objProc = proc;
|
||
cmdPtr->objClientData = clientData;
|
||
cmdPtr->proc = TclInvokeObjectCommand;
|
||
cmdPtr->clientData = cmdPtr;
|
||
cmdPtr->deleteProc = deleteProc;
|
||
cmdPtr->deleteData = clientData;
|
||
cmdPtr->flags = 0;
|
||
cmdPtr->importRefPtr = NULL;
|
||
cmdPtr->tracePtr = NULL;
|
||
|
||
/*
|
||
* Plug in any existing import references found above. Be sure to update
|
||
* all of these references to point to the new command.
|
||
*/
|
||
|
||
if (oldRefPtr != NULL) {
|
||
cmdPtr->importRefPtr = oldRefPtr;
|
||
while (oldRefPtr != NULL) {
|
||
refCmdPtr = oldRefPtr->importedCmdPtr;
|
||
dataPtr = refCmdPtr->objClientData;
|
||
dataPtr->realCmdPtr = cmdPtr;
|
||
oldRefPtr = oldRefPtr->nextPtr;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* We just created a command, so in its namespace and all of its parent
|
||
* namespaces, it may shadow global commands with the same name. If any
|
||
* shadowed commands are found, invalidate all cached command references
|
||
* in the affected namespaces.
|
||
*/
|
||
|
||
TclResetShadowedCmdRefs(interp, cmdPtr);
|
||
return (Tcl_Command) cmdPtr;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclInvokeStringCommand --
|
||
*
|
||
* "Wrapper" Tcl_ObjCmdProc used to call an existing string-based
|
||
* Tcl_CmdProc if no object-based function exists for a command. A
|
||
* pointer to this function is stored as the Tcl_ObjCmdProc in a Command
|
||
* structure. It simply turns around and calls the string Tcl_CmdProc in
|
||
* the Command structure.
|
||
*
|
||
* Results:
|
||
* A standard Tcl object result value.
|
||
*
|
||
* Side effects:
|
||
* Besides those side effects of the called Tcl_CmdProc,
|
||
* TclInvokeStringCommand allocates and frees storage.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclInvokeStringCommand(
|
||
ClientData clientData, /* Points to command's Command structure. */
|
||
Tcl_Interp *interp, /* Current interpreter. */
|
||
register int objc, /* Number of arguments. */
|
||
Tcl_Obj *const objv[]) /* Argument objects. */
|
||
{
|
||
Command *cmdPtr = clientData;
|
||
int i, result;
|
||
const char **argv = (const char **)
|
||
TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *));
|
||
|
||
for (i = 0; i < objc; i++) {
|
||
argv[i] = Tcl_GetString(objv[i]);
|
||
}
|
||
argv[objc] = 0;
|
||
|
||
/*
|
||
* Invoke the command's string-based Tcl_CmdProc.
|
||
*/
|
||
|
||
result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
|
||
|
||
TclStackFree(interp, (void *) argv);
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclInvokeObjectCommand --
|
||
*
|
||
* "Wrapper" Tcl_CmdProc used to call an existing object-based
|
||
* Tcl_ObjCmdProc if no string-based function exists for a command. A
|
||
* pointer to this function is stored as the Tcl_CmdProc in a Command
|
||
* structure. It simply turns around and calls the object Tcl_ObjCmdProc
|
||
* in the Command structure.
|
||
*
|
||
* Results:
|
||
* A standard Tcl string result value.
|
||
*
|
||
* Side effects:
|
||
* Besides those side effects of the called Tcl_ObjCmdProc,
|
||
* TclInvokeObjectCommand allocates and frees storage.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclInvokeObjectCommand(
|
||
ClientData clientData, /* Points to command's Command structure. */
|
||
Tcl_Interp *interp, /* Current interpreter. */
|
||
int argc, /* Number of arguments. */
|
||
register const char **argv) /* Argument strings. */
|
||
{
|
||
Command *cmdPtr = (Command *) clientData;
|
||
Tcl_Obj *objPtr;
|
||
int i, length, result;
|
||
Tcl_Obj **objv = (Tcl_Obj **)
|
||
TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *)));
|
||
|
||
for (i = 0; i < argc; i++) {
|
||
length = strlen(argv[i]);
|
||
TclNewStringObj(objPtr, argv[i], length);
|
||
Tcl_IncrRefCount(objPtr);
|
||
objv[i] = objPtr;
|
||
}
|
||
|
||
/*
|
||
* Invoke the command's object-based Tcl_ObjCmdProc.
|
||
*/
|
||
|
||
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
|
||
|
||
/*
|
||
* Move the interpreter's object result to the string result, then reset
|
||
* the object result.
|
||
*/
|
||
|
||
(void) Tcl_GetStringResult(interp);
|
||
|
||
/*
|
||
* Decrement the ref counts for the argument objects created above, then
|
||
* free the objv array if malloc'ed storage was used.
|
||
*/
|
||
|
||
for (i = 0; i < argc; i++) {
|
||
objPtr = objv[i];
|
||
Tcl_DecrRefCount(objPtr);
|
||
}
|
||
TclStackFree(interp, objv);
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclRenameCommand --
|
||
*
|
||
* Called to give an existing Tcl command a different name. Both the old
|
||
* command name and the new command name can have "::" namespace
|
||
* qualifiers. If the new command has a different namespace context, the
|
||
* command will be moved to that namespace and will execute in the
|
||
* context of that new namespace.
|
||
*
|
||
* If the new command name is NULL or the null string, the command is
|
||
* deleted.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
|
||
*
|
||
* Side effects:
|
||
* If anything goes wrong, an error message is returned in the
|
||
* interpreter's result object.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclRenameCommand(
|
||
Tcl_Interp *interp, /* Current interpreter. */
|
||
const char *oldName, /* Existing command name. */
|
||
const char *newName) /* New command name. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
const char *newTail;
|
||
Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
|
||
Tcl_Command cmd;
|
||
Command *cmdPtr;
|
||
Tcl_HashEntry *hPtr, *oldHPtr;
|
||
int isNew, result;
|
||
Tcl_Obj *oldFullName;
|
||
Tcl_DString newFullName;
|
||
|
||
/*
|
||
* Find the existing command. An error is returned if cmdName can't be
|
||
* found.
|
||
*/
|
||
|
||
cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0);
|
||
cmdPtr = (Command *) cmd;
|
||
if (cmdPtr == NULL) {
|
||
Tcl_AppendResult(interp, "can't ",
|
||
((newName == NULL)||(*newName == '\0'))? "delete":"rename",
|
||
" \"", oldName, "\": command doesn't exist", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
cmdNsPtr = cmdPtr->nsPtr;
|
||
oldFullName = Tcl_NewObj();
|
||
Tcl_IncrRefCount(oldFullName);
|
||
Tcl_GetCommandFullName(interp, cmd, oldFullName);
|
||
|
||
/*
|
||
* If the new command name is NULL or empty, delete the command. Do this
|
||
* with Tcl_DeleteCommandFromToken, since we already have the command.
|
||
*/
|
||
|
||
if ((newName == NULL) || (*newName == '\0')) {
|
||
Tcl_DeleteCommandFromToken(interp, cmd);
|
||
result = TCL_OK;
|
||
goto done;
|
||
}
|
||
|
||
/*
|
||
* Make sure that the destination command does not already exist. The
|
||
* rename operation is like creating a command, so we should automatically
|
||
* create the containing namespaces just like Tcl_CreateCommand would.
|
||
*/
|
||
|
||
TclGetNamespaceForQualName(interp, newName, NULL,
|
||
TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
|
||
|
||
if ((newNsPtr == NULL) || (newTail == 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_AppendResult(interp, "can't rename to \"", newName,
|
||
"\": command already exists", NULL);
|
||
result = TCL_ERROR;
|
||
goto done;
|
||
}
|
||
|
||
/*
|
||
* Warning: any changes done in the code here are likely to be needed in
|
||
* Tcl_HideCommand() code too (until the common parts are extracted out).
|
||
* - dl
|
||
*/
|
||
|
||
/*
|
||
* Put the command in the new namespace so we can check for an alias loop.
|
||
* Since we are adding a new command to a namespace, we must handle any
|
||
* shadowing of the global commands that this might create.
|
||
*/
|
||
|
||
oldHPtr = cmdPtr->hPtr;
|
||
hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &isNew);
|
||
Tcl_SetHashValue(hPtr, cmdPtr);
|
||
cmdPtr->hPtr = hPtr;
|
||
cmdPtr->nsPtr = newNsPtr;
|
||
TclResetShadowedCmdRefs(interp, cmdPtr);
|
||
|
||
/*
|
||
* Now check for an alias loop. If we detect one, put everything back the
|
||
* way it was and report the error.
|
||
*/
|
||
|
||
result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
|
||
if (result != TCL_OK) {
|
||
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
||
cmdPtr->hPtr = oldHPtr;
|
||
cmdPtr->nsPtr = cmdNsPtr;
|
||
goto done;
|
||
}
|
||
|
||
/*
|
||
* The list of command exported from the namespace might have changed.
|
||
* However, we do not need to recompute this just yet; next time we need
|
||
* the info will be soon enough. These might refer to the same variable,
|
||
* but that's no big deal.
|
||
*/
|
||
|
||
TclInvalidateNsCmdLookup(cmdNsPtr);
|
||
TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
|
||
|
||
/*
|
||
* Script for rename traces can delete the command "oldName". Therefore
|
||
* increment the reference count for cmdPtr so that it's Command structure
|
||
* is freed only towards the end of this function by calling
|
||
* TclCleanupCommand.
|
||
*
|
||
* The trace function needs to get a fully qualified name for old and new
|
||
* commands [Tcl bug #651271], or else there's no way for the trace
|
||
* function to get the namespace from which the old command is being
|
||
* renamed!
|
||
*/
|
||
|
||
Tcl_DStringInit(&newFullName);
|
||
Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1);
|
||
if (newNsPtr != iPtr->globalNsPtr) {
|
||
Tcl_DStringAppend(&newFullName, "::", 2);
|
||
}
|
||
Tcl_DStringAppend(&newFullName, newTail, -1);
|
||
cmdPtr->refCount++;
|
||
CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName),
|
||
Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
|
||
Tcl_DStringFree(&newFullName);
|
||
|
||
/*
|
||
* The new command name is okay, so remove the command from its current
|
||
* namespace. This is like deleting the command, so bump the cmdEpoch to
|
||
* invalidate any cached references to the command.
|
||
*/
|
||
|
||
Tcl_DeleteHashEntry(oldHPtr);
|
||
cmdPtr->cmdEpoch++;
|
||
|
||
/*
|
||
* If the command being renamed has a compile function, increment the
|
||
* interpreter's compileEpoch to invalidate its compiled code. This makes
|
||
* sure that we don't later try to execute old code compiled for the
|
||
* now-renamed command.
|
||
*/
|
||
|
||
if (cmdPtr->compileProc != NULL) {
|
||
iPtr->compileEpoch++;
|
||
}
|
||
|
||
/*
|
||
* Now free the Command structure, if the "oldName" command has been
|
||
* deleted by invocation of rename traces.
|
||
*/
|
||
|
||
TclCleanupCommandMacro(cmdPtr);
|
||
result = TCL_OK;
|
||
|
||
done:
|
||
TclDecrRefCount(oldFullName);
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_SetCommandInfo --
|
||
*
|
||
* Modifies various information about a Tcl command. Note that this
|
||
* function will not change a command's namespace; use TclRenameCommand
|
||
* to do that. Also, the isNativeObjectProc member of *infoPtr is
|
||
* ignored.
|
||
*
|
||
* Results:
|
||
* If cmdName exists in interp, then the information at *infoPtr is
|
||
* stored with the command in place of the current information and 1 is
|
||
* returned. If the command doesn't exist then 0 is returned.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_SetCommandInfo(
|
||
Tcl_Interp *interp, /* Interpreter in which to look for
|
||
* command. */
|
||
const char *cmdName, /* Name of desired command. */
|
||
const Tcl_CmdInfo *infoPtr) /* Where to find information to store in the
|
||
* command. */
|
||
{
|
||
Tcl_Command cmd;
|
||
|
||
cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0);
|
||
return Tcl_SetCommandInfoFromToken(cmd, infoPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_SetCommandInfoFromToken --
|
||
*
|
||
* Modifies various information about a Tcl command. Note that this
|
||
* function will not change a command's namespace; use TclRenameCommand
|
||
* to do that. Also, the isNativeObjectProc member of *infoPtr is
|
||
* ignored.
|
||
*
|
||
* Results:
|
||
* If cmdName exists in interp, then the information at *infoPtr is
|
||
* stored with the command in place of the current information and 1 is
|
||
* returned. If the command doesn't exist then 0 is returned.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_SetCommandInfoFromToken(
|
||
Tcl_Command cmd,
|
||
const Tcl_CmdInfo *infoPtr)
|
||
{
|
||
Command *cmdPtr; /* Internal representation of the command */
|
||
|
||
if (cmd == (Tcl_Command) NULL) {
|
||
return 0;
|
||
}
|
||
|
||
/*
|
||
* The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
|
||
*/
|
||
|
||
cmdPtr = (Command *) cmd;
|
||
cmdPtr->proc = infoPtr->proc;
|
||
cmdPtr->clientData = infoPtr->clientData;
|
||
if (infoPtr->objProc == NULL) {
|
||
cmdPtr->objProc = TclInvokeStringCommand;
|
||
cmdPtr->objClientData = cmdPtr;
|
||
} else {
|
||
cmdPtr->objProc = infoPtr->objProc;
|
||
cmdPtr->objClientData = infoPtr->objClientData;
|
||
}
|
||
cmdPtr->deleteProc = infoPtr->deleteProc;
|
||
cmdPtr->deleteData = infoPtr->deleteData;
|
||
return 1;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GetCommandInfo --
|
||
*
|
||
* Returns various information about a Tcl command.
|
||
*
|
||
* Results:
|
||
* If cmdName exists in interp, then *infoPtr is modified to hold
|
||
* information about cmdName and 1 is returned. If the command doesn't
|
||
* exist then 0 is returned and *infoPtr isn't modified.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_GetCommandInfo(
|
||
Tcl_Interp *interp, /* Interpreter in which to look for
|
||
* command. */
|
||
const char *cmdName, /* Name of desired command. */
|
||
Tcl_CmdInfo *infoPtr) /* Where to store information about
|
||
* command. */
|
||
{
|
||
Tcl_Command cmd;
|
||
|
||
cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0);
|
||
return Tcl_GetCommandInfoFromToken(cmd, infoPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GetCommandInfoFromToken --
|
||
*
|
||
* Returns various information about a Tcl command.
|
||
*
|
||
* Results:
|
||
* Copies information from the command identified by 'cmd' into a
|
||
* caller-supplied structure and returns 1. If the 'cmd' is NULL, leaves
|
||
* the structure untouched and returns 0.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_GetCommandInfoFromToken(
|
||
Tcl_Command cmd,
|
||
Tcl_CmdInfo *infoPtr)
|
||
{
|
||
Command *cmdPtr; /* Internal representation of the command */
|
||
|
||
if (cmd == (Tcl_Command) NULL) {
|
||
return 0;
|
||
}
|
||
|
||
/*
|
||
* Set isNativeObjectProc 1 if objProc was registered by a call to
|
||
* Tcl_CreateObjCommand. Otherwise set it to 0.
|
||
*/
|
||
|
||
cmdPtr = (Command *) cmd;
|
||
infoPtr->isNativeObjectProc =
|
||
(cmdPtr->objProc != TclInvokeStringCommand);
|
||
infoPtr->objProc = cmdPtr->objProc;
|
||
infoPtr->objClientData = cmdPtr->objClientData;
|
||
infoPtr->proc = cmdPtr->proc;
|
||
infoPtr->clientData = cmdPtr->clientData;
|
||
infoPtr->deleteProc = cmdPtr->deleteProc;
|
||
infoPtr->deleteData = cmdPtr->deleteData;
|
||
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
|
||
|
||
return 1;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GetCommandName --
|
||
*
|
||
* Given a token returned by Tcl_CreateCommand, this function returns the
|
||
* current name of the command (which may have changed due to renaming).
|
||
*
|
||
* Results:
|
||
* The return value is the name of the given command.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
const char *
|
||
Tcl_GetCommandName(
|
||
Tcl_Interp *interp, /* Interpreter containing the command. */
|
||
Tcl_Command command) /* Token for command returned by a previous
|
||
* call to Tcl_CreateCommand. The command must
|
||
* not have been deleted. */
|
||
{
|
||
Command *cmdPtr = (Command *) command;
|
||
|
||
if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
|
||
/*
|
||
* This should only happen if command was "created" after the
|
||
* interpreter began to be deleted, so there isn't really any command.
|
||
* Just return an empty string.
|
||
*/
|
||
|
||
return "";
|
||
}
|
||
|
||
return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GetCommandFullName --
|
||
*
|
||
* Given a token returned by, e.g., Tcl_CreateCommand or Tcl_FindCommand,
|
||
* this function appends to an object the command's full name, qualified
|
||
* by a sequence of parent namespace names. The command's fully-qualified
|
||
* name may have changed due to renaming.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* The command's fully-qualified name is appended to the string
|
||
* representation of objPtr.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_GetCommandFullName(
|
||
Tcl_Interp *interp, /* Interpreter containing the command. */
|
||
Tcl_Command command, /* Token for command returned by a previous
|
||
* call to Tcl_CreateCommand. The command must
|
||
* not have been deleted. */
|
||
Tcl_Obj *objPtr) /* Points to the object onto which the
|
||
* command's full name is appended. */
|
||
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
register Command *cmdPtr = (Command *) command;
|
||
char *name;
|
||
|
||
/*
|
||
* Add the full name of the containing namespace, followed by the "::"
|
||
* separator, and the command name.
|
||
*/
|
||
|
||
if (cmdPtr != NULL) {
|
||
if (cmdPtr->nsPtr != NULL) {
|
||
Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
|
||
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
|
||
Tcl_AppendToObj(objPtr, "::", 2);
|
||
}
|
||
}
|
||
if (cmdPtr->hPtr != NULL) {
|
||
name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
|
||
Tcl_AppendToObj(objPtr, name, -1);
|
||
}
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_DeleteCommand --
|
||
*
|
||
* Remove the given command from the given interpreter.
|
||
*
|
||
* Results:
|
||
* 0 is returned if the command was deleted successfully. -1 is returned
|
||
* if there didn't exist a command by that name.
|
||
*
|
||
* Side effects:
|
||
* cmdName will no longer be recognized as a valid command for interp.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_DeleteCommand(
|
||
Tcl_Interp *interp, /* Token for command interpreter (returned by
|
||
* a previous Tcl_CreateInterp call). */
|
||
const char *cmdName) /* Name of command to remove. */
|
||
{
|
||
Tcl_Command cmd;
|
||
|
||
/*
|
||
* Find the desired command and delete it.
|
||
*/
|
||
|
||
cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0);
|
||
if (cmd == (Tcl_Command) NULL) {
|
||
return -1;
|
||
}
|
||
return Tcl_DeleteCommandFromToken(interp, cmd);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_DeleteCommandFromToken --
|
||
*
|
||
* Removes the given command from the given interpreter. This function
|
||
* resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead of
|
||
* a command name for efficiency.
|
||
*
|
||
* Results:
|
||
* 0 is returned if the command was deleted successfully. -1 is returned
|
||
* if there didn't exist a command by that name.
|
||
*
|
||
* Side effects:
|
||
* The command specified by "cmd" will no longer be recognized as a valid
|
||
* command for "interp".
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_DeleteCommandFromToken(
|
||
Tcl_Interp *interp, /* Token for command interpreter returned by a
|
||
* previous call to Tcl_CreateInterp. */
|
||
Tcl_Command cmd) /* Token for command to delete. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
Command *cmdPtr = (Command *) cmd;
|
||
ImportRef *refPtr, *nextRefPtr;
|
||
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
|
||
* as OTcl). However, this means that the callback could try to delete or
|
||
* rename the command. The deleted flag allows us to detect these cases
|
||
* and skip nested deletes.
|
||
*/
|
||
|
||
if (cmdPtr->flags & CMD_IS_DELETED) {
|
||
/*
|
||
* Another deletion is already in progress. Remove the hash table
|
||
* entry now, but don't invoke a callback or free the command
|
||
* structure. Take care to only remove the hash entry if it has not
|
||
* already been removed; otherwise if we manage to hit this function
|
||
* three times, everything goes up in smoke. [Bug 1220058]
|
||
*/
|
||
|
||
if (cmdPtr->hPtr != NULL) {
|
||
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
||
cmdPtr->hPtr = NULL;
|
||
}
|
||
return 0;
|
||
}
|
||
|
||
/*
|
||
* We must delete this command, even though both traces and delete procs
|
||
* may try to avoid this (renaming the command etc). Also traces and
|
||
* delete procs may try to delete the command themsevles. This flag
|
||
* declares that a delete is in progress and that recursive deletes should
|
||
* be ignored.
|
||
*/
|
||
|
||
cmdPtr->flags |= CMD_IS_DELETED;
|
||
|
||
/*
|
||
* Call trace functions for the command being deleted. Then delete its
|
||
* traces.
|
||
*/
|
||
|
||
if (cmdPtr->tracePtr != NULL) {
|
||
CommandTrace *tracePtr;
|
||
CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
|
||
|
||
/*
|
||
* Now delete these traces.
|
||
*/
|
||
|
||
tracePtr = cmdPtr->tracePtr;
|
||
while (tracePtr != NULL) {
|
||
CommandTrace *nextPtr = tracePtr->nextPtr;
|
||
if ((--tracePtr->refCount) <= 0) {
|
||
ckfree((char *) tracePtr);
|
||
}
|
||
tracePtr = nextPtr;
|
||
}
|
||
cmdPtr->tracePtr = NULL;
|
||
}
|
||
|
||
/*
|
||
* The list of command exported from the namespace might have changed.
|
||
* However, we do not need to recompute this just yet; next time we need
|
||
* the info will be soon enough.
|
||
*/
|
||
|
||
TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
|
||
|
||
/*
|
||
* If the command being deleted has a compile function, increment the
|
||
* interpreter's compileEpoch to invalidate its compiled code. This makes
|
||
* sure that we don't later try to execute old code compiled with
|
||
* command-specific (i.e., inline) bytecodes for the now-deleted command.
|
||
* This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose
|
||
* compilation epoch doesn't match is recompiled.
|
||
*/
|
||
|
||
if (cmdPtr->compileProc != NULL) {
|
||
iPtr->compileEpoch++;
|
||
}
|
||
|
||
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()
|
||
* 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);
|
||
}
|
||
|
||
/*
|
||
* 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);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Don't use hPtr to delete the hash entry here, because it's possible
|
||
* that the deletion callback renamed the command. Instead, use
|
||
* cmdPtr->hptr, and make sure that no-one else has already deleted the
|
||
* hash entry.
|
||
*/
|
||
|
||
if (cmdPtr->hPtr != NULL) {
|
||
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
||
cmdPtr->hPtr = NULL;
|
||
}
|
||
|
||
/*
|
||
* Mark the Command structure as no longer valid. This allows
|
||
* TclExecuteByteCode to recognize when a Command has logically been
|
||
* deleted and a pointer to this Command structure cached in a CmdName
|
||
* object is invalid. TclExecuteByteCode will look up the command again in
|
||
* the interpreter's command hashtable.
|
||
*/
|
||
|
||
cmdPtr->objProc = NULL;
|
||
|
||
/*
|
||
* Now free the Command structure, unless there is another reference to it
|
||
* from a CmdName Tcl object in some ByteCode code sequence. In that case,
|
||
* delay the cleanup until all references are either discarded (when a
|
||
* ByteCode is freed) or replaced by a new reference (when a cached
|
||
* CmdName Command reference is found to be invalid and TclExecuteByteCode
|
||
* looks up the command in the command hashtable).
|
||
*/
|
||
|
||
TclCleanupCommandMacro(cmdPtr);
|
||
return 0;
|
||
}
|
||
|
||
static char *
|
||
CallCommandTraces(
|
||
Interp *iPtr, /* Interpreter containing command. */
|
||
Command *cmdPtr, /* Command whose traces are to be invoked. */
|
||
const char *oldName, /* Command's old name, or NULL if we must get
|
||
* the name from cmdPtr */
|
||
const char *newName, /* Command's new name, or NULL if the command
|
||
* is not being renamed */
|
||
int flags) /* Flags indicating the type of traces to
|
||
* trigger, either TCL_TRACE_DELETE or
|
||
* TCL_TRACE_RENAME. */
|
||
{
|
||
register CommandTrace *tracePtr;
|
||
ActiveCommandTrace active;
|
||
char *result;
|
||
Tcl_Obj *oldNamePtr = NULL;
|
||
Tcl_InterpState state = NULL;
|
||
|
||
if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
|
||
/*
|
||
* While a rename trace is active, we will not process any more rename
|
||
* traces; while a delete trace is active we will never reach here -
|
||
* because Tcl_DeleteCommandFromToken checks for the condition
|
||
* (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a
|
||
* command deletion is in progress. For all other traces, delete
|
||
* traces will not be invoked but a call to TraceCommandProc will
|
||
* ensure that tracePtr->clientData is freed whenever the command
|
||
* "oldName" is deleted.
|
||
*/
|
||
|
||
if (cmdPtr->flags & TCL_TRACE_RENAME) {
|
||
flags &= ~TCL_TRACE_RENAME;
|
||
}
|
||
if (flags == 0) {
|
||
return NULL;
|
||
}
|
||
}
|
||
cmdPtr->flags |= CMD_TRACE_ACTIVE;
|
||
cmdPtr->refCount++;
|
||
|
||
result = NULL;
|
||
active.nextPtr = iPtr->activeCmdTracePtr;
|
||
active.reverseScan = 0;
|
||
iPtr->activeCmdTracePtr = &active;
|
||
|
||
if (flags & TCL_TRACE_DELETE) {
|
||
flags |= TCL_TRACE_DESTROYED;
|
||
}
|
||
active.cmdPtr = cmdPtr;
|
||
|
||
Tcl_Preserve(iPtr);
|
||
|
||
for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
|
||
tracePtr = active.nextTracePtr) {
|
||
active.nextTracePtr = tracePtr->nextPtr;
|
||
if (!(tracePtr->flags & flags)) {
|
||
continue;
|
||
}
|
||
cmdPtr->flags |= tracePtr->flags;
|
||
if (oldName == NULL) {
|
||
TclNewObj(oldNamePtr);
|
||
Tcl_IncrRefCount(oldNamePtr);
|
||
Tcl_GetCommandFullName((Tcl_Interp *) iPtr,
|
||
(Tcl_Command) cmdPtr, oldNamePtr);
|
||
oldName = TclGetString(oldNamePtr);
|
||
}
|
||
tracePtr->refCount++;
|
||
if (state == NULL) {
|
||
state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK);
|
||
}
|
||
(*tracePtr->traceProc)(tracePtr->clientData,
|
||
(Tcl_Interp *) iPtr, oldName, newName, flags);
|
||
cmdPtr->flags &= ~tracePtr->flags;
|
||
if ((--tracePtr->refCount) <= 0) {
|
||
ckfree((char *) tracePtr);
|
||
}
|
||
}
|
||
|
||
if (state) {
|
||
Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
|
||
}
|
||
|
||
/*
|
||
* If a new object was created to hold the full oldName, free it now.
|
||
*/
|
||
|
||
if (oldNamePtr != NULL) {
|
||
TclDecrRefCount(oldNamePtr);
|
||
}
|
||
|
||
/*
|
||
* Restore the variable's flags, remove the record of our active traces,
|
||
* and then return.
|
||
*/
|
||
|
||
cmdPtr->flags &= ~CMD_TRACE_ACTIVE;
|
||
cmdPtr->refCount--;
|
||
iPtr->activeCmdTracePtr = active.nextPtr;
|
||
Tcl_Release(iPtr);
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* GetCommandSource --
|
||
*
|
||
* This function returns a Tcl_Obj with the full source string for the
|
||
* command. This insures that traces get a correct NUL-terminated command
|
||
* string.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static Tcl_Obj *
|
||
GetCommandSource(
|
||
Interp *iPtr,
|
||
const char *command,
|
||
int numChars,
|
||
int objc,
|
||
Tcl_Obj *const objv[])
|
||
{
|
||
if (!command) {
|
||
return Tcl_NewListObj(objc, objv);
|
||
}
|
||
if (command == (char *) -1) {
|
||
command = TclGetSrcInfoForCmd(iPtr, &numChars);
|
||
}
|
||
return Tcl_NewStringObj(command, numChars);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCleanupCommand --
|
||
*
|
||
* This function frees up a Command structure unless it is still
|
||
* referenced from an interpreter's command hashtable or from a CmdName
|
||
* Tcl object representing the name of a command in a ByteCode
|
||
* instruction sequence.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Memory gets freed unless a reference to the Command structure still
|
||
* exists. In that case the cleanup is delayed until the command is
|
||
* deleted or when the last ByteCode referring to it is freed.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
TclCleanupCommand(
|
||
register Command *cmdPtr) /* Points to the Command structure to
|
||
* be freed. */
|
||
{
|
||
cmdPtr->refCount--;
|
||
if (cmdPtr->refCount <= 0) {
|
||
ckfree((char *) cmdPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_CreateMathFunc --
|
||
*
|
||
* Creates a new math function for expressions in a given interpreter.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* The Tcl function defined by "name" is created or redefined. If the
|
||
* function already exists then its definition is replaced; this includes
|
||
* the builtin functions. Redefining a builtin function forces all
|
||
* existing code to be invalidated since that code may be compiled using
|
||
* an instruction specific to the replaced function. In addition,
|
||
* redefioning a non-builtin function will force existing code to be
|
||
* invalidated if the number of arguments has changed.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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, /* Nnumber of arguments required by
|
||
* function. */
|
||
Tcl_ValueType *argTypes, /* Array of types acceptable for each
|
||
* argument. */
|
||
Tcl_MathProc *proc, /* C function that implements the math
|
||
* function. */
|
||
ClientData clientData) /* Additional value to pass to the
|
||
* function. */
|
||
{
|
||
Tcl_DString bigName;
|
||
OldMathFuncData *data = (OldMathFuncData *)
|
||
ckalloc(sizeof(OldMathFuncData));
|
||
|
||
data->proc = proc;
|
||
data->numArgs = numArgs;
|
||
data->argTypes = (Tcl_ValueType *)
|
||
ckalloc(numArgs * sizeof(Tcl_ValueType));
|
||
memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
|
||
data->clientData = clientData;
|
||
|
||
Tcl_DStringInit(&bigName);
|
||
Tcl_DStringAppend(&bigName, "::tcl::mathfunc::", -1);
|
||
Tcl_DStringAppend(&bigName, name, -1);
|
||
|
||
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName),
|
||
OldMathFuncProc, data, OldMathFuncDeleteProc);
|
||
Tcl_DStringFree(&bigName);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* OldMathFuncProc --
|
||
*
|
||
* Dispatch to a math function created with Tcl_CreateMathFunc
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl result.
|
||
*
|
||
* Side effects:
|
||
* Whatever the math function does.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
OldMathFuncProc(
|
||
ClientData clientData, /* Ponter to OldMathFuncData describing the
|
||
* function being called */
|
||
Tcl_Interp *interp, /* Tcl interpreter */
|
||
int objc, /* Actual parameter count */
|
||
Tcl_Obj *const *objv) /* Parameter vector */
|
||
{
|
||
Tcl_Obj *valuePtr;
|
||
OldMathFuncData *dataPtr = clientData;
|
||
Tcl_Value funcResult, *args;
|
||
int result;
|
||
int j, k;
|
||
double d;
|
||
|
||
/*
|
||
* Check argument count.
|
||
*/
|
||
|
||
if (objc != dataPtr->numArgs + 1) {
|
||
MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Convert arguments from Tcl_Obj's to Tcl_Value's.
|
||
*/
|
||
|
||
args = (Tcl_Value *) ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
|
||
for (j = 1, k = 0; j < objc; ++j, ++k) {
|
||
|
||
/* TODO: Convert to TclGetNumberFromObj() ? */
|
||
valuePtr = objv[j];
|
||
result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
|
||
#ifdef ACCEPT_NAN
|
||
if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) {
|
||
d = valuePtr->internalRep.doubleValue;
|
||
result = TCL_OK;
|
||
}
|
||
#endif
|
||
if (result != TCL_OK) {
|
||
/*
|
||
* We have a non-numeric argument.
|
||
*/
|
||
|
||
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
||
"argument to math function didn't have numeric value",-1));
|
||
TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
|
||
ckfree((char *)args);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Copy the object's numeric value to the argument record, converting
|
||
* it if necessary.
|
||
*
|
||
* NOTE: no bignum support; use the new mathfunc interface for that.
|
||
*/
|
||
|
||
args[k].type = dataPtr->argTypes[k];
|
||
switch (args[k].type) {
|
||
case TCL_EITHER:
|
||
if (Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue))
|
||
== TCL_OK) {
|
||
args[k].type = TCL_INT;
|
||
break;
|
||
}
|
||
if (Tcl_GetWideIntFromObj(interp, valuePtr, &(args[k].wideValue))
|
||
== TCL_OK) {
|
||
args[k].type = TCL_WIDE_INT;
|
||
break;
|
||
}
|
||
args[k].type = TCL_DOUBLE;
|
||
/* FALLTHROUGH */
|
||
|
||
case TCL_DOUBLE:
|
||
args[k].doubleValue = d;
|
||
break;
|
||
case TCL_INT:
|
||
if (ExprIntFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) {
|
||
ckfree((char *)args);
|
||
return TCL_ERROR;
|
||
}
|
||
valuePtr = Tcl_GetObjResult(interp);
|
||
Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue));
|
||
Tcl_ResetResult(interp);
|
||
break;
|
||
case TCL_WIDE_INT:
|
||
if (ExprWideFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) {
|
||
ckfree((char *)args);
|
||
return TCL_ERROR;
|
||
}
|
||
valuePtr = Tcl_GetObjResult(interp);
|
||
Tcl_GetWideIntFromObj(NULL, valuePtr, &(args[k].wideValue));
|
||
Tcl_ResetResult(interp);
|
||
break;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Call the function.
|
||
*/
|
||
|
||
errno = 0;
|
||
result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult);
|
||
ckfree((char *)args);
|
||
if (result != TCL_OK) {
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
* Return the result of the call.
|
||
*/
|
||
|
||
if (funcResult.type == TCL_INT) {
|
||
TclNewLongObj(valuePtr, funcResult.intValue);
|
||
} else if (funcResult.type == TCL_WIDE_INT) {
|
||
valuePtr = Tcl_NewWideIntObj(funcResult.wideValue);
|
||
} else {
|
||
return CheckDoubleResult(interp, funcResult.doubleValue);
|
||
}
|
||
Tcl_SetObjResult(interp, valuePtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* OldMathFuncDeleteProc --
|
||
*
|
||
* Cleans up after deleting a math function registered with
|
||
* Tcl_CreateMathFunc
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Frees allocated memory.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
OldMathFuncDeleteProc(
|
||
ClientData clientData)
|
||
{
|
||
OldMathFuncData *dataPtr = clientData;
|
||
|
||
ckfree((void *) dataPtr->argTypes);
|
||
ckfree((void *) dataPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GetMathFuncInfo --
|
||
*
|
||
* Discovers how a particular math function was created in a given
|
||
* interpreter.
|
||
*
|
||
* Results:
|
||
* TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the
|
||
* interpreter result if that happens.)
|
||
*
|
||
* Side effects:
|
||
* If this function succeeds, the variables pointed to by the numArgsPtr
|
||
* and argTypePtr arguments will be updated to detail the arguments
|
||
* allowed by the function. The variable pointed to by the procPtr
|
||
* argument will be set to NULL if the function is a builtin function,
|
||
* and will be set to the address of the C function used to implement the
|
||
* math function otherwise (in which case the variable pointed to by the
|
||
* clientDataPtr argument will also be updated.)
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_GetMathFuncInfo(
|
||
Tcl_Interp *interp,
|
||
const char *name,
|
||
int *numArgsPtr,
|
||
Tcl_ValueType **argTypesPtr,
|
||
Tcl_MathProc **procPtr,
|
||
ClientData *clientDataPtr)
|
||
{
|
||
Tcl_Obj *cmdNameObj;
|
||
Command *cmdPtr;
|
||
|
||
/*
|
||
* Get the command that implements the math function.
|
||
*/
|
||
|
||
TclNewLiteralStringObj(cmdNameObj, "tcl::mathfunc::");
|
||
Tcl_AppendToObj(cmdNameObj, name, -1);
|
||
Tcl_IncrRefCount(cmdNameObj);
|
||
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdNameObj);
|
||
Tcl_DecrRefCount(cmdNameObj);
|
||
|
||
/*
|
||
* Report unknown functions.
|
||
*/
|
||
|
||
if (cmdPtr == NULL) {
|
||
Tcl_Obj *message;
|
||
|
||
TclNewLiteralStringObj(message, "unknown math function \"");
|
||
Tcl_AppendToObj(message, name, -1);
|
||
Tcl_AppendToObj(message, "\"", 1);
|
||
Tcl_SetObjResult(interp, message);
|
||
*numArgsPtr = -1;
|
||
*argTypesPtr = NULL;
|
||
*procPtr = NULL;
|
||
*clientDataPtr = NULL;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Retrieve function info for user defined functions; return dummy
|
||
* information for builtins.
|
||
*/
|
||
|
||
if (cmdPtr->objProc == &OldMathFuncProc) {
|
||
OldMathFuncData *dataPtr = cmdPtr->clientData;
|
||
|
||
*procPtr = dataPtr->proc;
|
||
*numArgsPtr = dataPtr->numArgs;
|
||
*argTypesPtr = dataPtr->argTypes;
|
||
*clientDataPtr = dataPtr->clientData;
|
||
} else {
|
||
*procPtr = NULL;
|
||
*numArgsPtr = -1;
|
||
*argTypesPtr = NULL;
|
||
*procPtr = NULL;
|
||
*clientDataPtr = NULL;
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_ListMathFuncs --
|
||
*
|
||
* Produces a list of all the math functions defined in a given
|
||
* interpreter.
|
||
*
|
||
* Results:
|
||
* A pointer to a Tcl_Obj structure with a reference count of zero, or
|
||
* NULL in the case of an error (in which case a suitable error message
|
||
* will be left in the interpreter result.)
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
Tcl_Obj *
|
||
Tcl_ListMathFuncs(
|
||
Tcl_Interp *interp,
|
||
const char *pattern)
|
||
{
|
||
Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1);
|
||
Tcl_Obj *result;
|
||
Tcl_InterpState state;
|
||
|
||
if (pattern) {
|
||
Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1);
|
||
Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj);
|
||
|
||
Tcl_AppendObjToObj(script, arg);
|
||
Tcl_DecrRefCount(arg); /* Should tear down patternObj too */
|
||
}
|
||
|
||
state = Tcl_SaveInterpState(interp, TCL_OK);
|
||
Tcl_IncrRefCount(script);
|
||
if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) {
|
||
result = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
|
||
} else {
|
||
result = Tcl_NewObj();
|
||
}
|
||
Tcl_DecrRefCount(script);
|
||
Tcl_RestoreInterpState(interp, state);
|
||
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclInterpReady --
|
||
*
|
||
* Check if an interpreter is ready to eval commands or scripts, i.e., if
|
||
* it was not deleted and if the nesting level is not too high.
|
||
*
|
||
* Results:
|
||
* The return value is TCL_OK if it the interpreter is ready, TCL_ERROR
|
||
* otherwise.
|
||
*
|
||
* Side effects:
|
||
* The interpreters object and string results are cleared.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclInterpReady(
|
||
Tcl_Interp *interp)
|
||
{
|
||
#if !defined(TCL_NO_STACK_CHECK)
|
||
int localInt; /* used for checking the stack */
|
||
#endif
|
||
register Interp *iPtr = (Interp *) interp;
|
||
|
||
/*
|
||
* Reset both the interpreter's string and object results and clear out
|
||
* any previous error information.
|
||
*/
|
||
|
||
Tcl_ResetResult(interp);
|
||
|
||
/*
|
||
* If the interpreter has been deleted, return an error.
|
||
*/
|
||
|
||
if (iPtr->flags & DELETED) {
|
||
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", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Check depth of nested calls to Tcl_Eval: if this gets too large, it's
|
||
* probably because of an infinite loop somewhere.
|
||
*/
|
||
|
||
if (((iPtr->numLevels) <= iPtr->maxNestingDepth)
|
||
&& CheckCStack(iPtr, &localInt)) {
|
||
return TCL_OK;
|
||
}
|
||
|
||
if (!CheckCStack(iPtr, &localInt)) {
|
||
Tcl_AppendResult(interp,
|
||
"out of stack space (infinite loop?)", NULL);
|
||
} else {
|
||
Tcl_AppendResult(interp,
|
||
"too many nested evaluations (infinite loop?)", NULL);
|
||
}
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclEvalObjvInternal
|
||
*
|
||
* This function evaluates a Tcl command that has already been parsed
|
||
* into words, with one Tcl_Obj holding each word. The caller is
|
||
* responsible for managing the iPtr->numLevels.
|
||
*
|
||
* TclEvalObjvInternal is the backend for Tcl_EvalObjv, the bytecode
|
||
* engine also calls it directly.
|
||
*
|
||
* Results:
|
||
* The return value is a standard Tcl completion code such as TCL_OK or
|
||
* TCL_ERROR. A result or error message is left in interp's result. If an
|
||
* error occurs, this function does NOT add any information to the
|
||
* errorInfo variable.
|
||
*
|
||
* Side effects:
|
||
* Depends on the command.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclEvalObjvInternal(
|
||
Tcl_Interp *interp, /* Interpreter in which to evaluate the
|
||
* command. Also used for error reporting. */
|
||
int objc, /* Number of words in command. */
|
||
Tcl_Obj *const objv[], /* An array of pointers to objects that are
|
||
* the words that make up the command. */
|
||
const char *command, /* Points to the beginning of the string
|
||
* representation of the command; this is used
|
||
* for traces. 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 and TCL_EVAL_INVOKE are
|
||
* currently supported. */
|
||
{
|
||
Command *cmdPtr;
|
||
Interp *iPtr = (Interp *) interp;
|
||
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 (TclInterpReady(interp) == TCL_ERROR) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (objc == 0) {
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* 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 (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;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Find the function to execute this command. If there isn't one, then see
|
||
* if there is an unknown command handler registered for this namespace.
|
||
* If so, create a new word array with the handler as the first words and
|
||
* the original command words as arguments. Then call ourselves
|
||
* recursively to execute it.
|
||
*/
|
||
|
||
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
|
||
if (!cmdPtr) {
|
||
goto notFound;
|
||
}
|
||
|
||
if (savedNsPtr) {
|
||
varFramePtr->nsPtr = savedNsPtr;
|
||
} else if (iPtr->ensembleRewrite.sourceObjs) {
|
||
/*
|
||
* TCL_EVAL_INVOKE was not set: clear rewrite rules
|
||
*/
|
||
|
||
iPtr->ensembleRewrite.sourceObjs = NULL;
|
||
}
|
||
|
||
/*
|
||
* Call trace functions if needed.
|
||
*/
|
||
|
||
traced = (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES));
|
||
if (traced && checkTraces) {
|
||
int cmdEpoch = cmdPtr->cmdEpoch;
|
||
int newEpoch;
|
||
|
||
/*
|
||
* Insure that we have a correct nul-terminated command string for the
|
||
* trace code.
|
||
*/
|
||
|
||
commandPtr = GetCommandSource(iPtr, command, length, objc, objv);
|
||
command = TclGetStringFromObj(commandPtr, &length);
|
||
|
||
/*
|
||
* Execute any command or execution traces. Note that we bump up the
|
||
* command's reference count for the duration of the calling of the
|
||
* traces so that the structure doesn't go away underneath our feet.
|
||
*/
|
||
|
||
cmdPtr->refCount++;
|
||
if (iPtr->tracePtr && (traceCode == TCL_OK)) {
|
||
traceCode = TclCheckInterpTraces(interp, command, length,
|
||
cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
|
||
}
|
||
if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
|
||
traceCode = TclCheckExecutionTraces(interp, command, length,
|
||
cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
|
||
}
|
||
newEpoch = cmdPtr->cmdEpoch;
|
||
TclCleanupCommandMacro(cmdPtr);
|
||
|
||
/*
|
||
* If the traces modified/deleted the command or any existing traces,
|
||
* they will update the command's epoch. When that happens, set
|
||
* checkTraces is set to 0 to prevent the re-calling of traces (and
|
||
* any possible infinite loop) and we go back to re-find the command
|
||
* implementation.
|
||
*/
|
||
|
||
if (traceCode == TCL_OK && cmdEpoch != newEpoch) {
|
||
checkTraces = 0;
|
||
if (commandPtr) {
|
||
Tcl_DecrRefCount(commandPtr);
|
||
commandPtr = NULL;
|
||
}
|
||
goto reparseBecauseOfTraces;
|
||
}
|
||
}
|
||
|
||
#ifdef USE_DTRACE
|
||
if (TCL_DTRACE_CMD_ARGS_ENABLED()) {
|
||
char *a[10];
|
||
int i = 0;
|
||
|
||
while (i < 10) {
|
||
a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
|
||
}
|
||
TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
|
||
a[8], a[9]);
|
||
}
|
||
if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) {
|
||
Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
|
||
char *a[4]; int i[2];
|
||
|
||
TclDTraceInfo(info, a, i);
|
||
TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1]);
|
||
TclDecrRefCount(info);
|
||
}
|
||
#endif /* USE_DTRACE */
|
||
|
||
/*
|
||
* Finally, invoke the command's Tcl_ObjCmdProc.
|
||
*/
|
||
|
||
cmdPtr->refCount++;
|
||
iPtr->cmdCount++;
|
||
if (code == TCL_OK && traceCode == TCL_OK
|
||
&& !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);
|
||
}
|
||
}
|
||
|
||
if (TclAsyncReady(iPtr)) {
|
||
code = Tcl_AsyncInvoke(interp, code);
|
||
}
|
||
if (code == TCL_OK && TclLimitReady(iPtr->limit)) {
|
||
code = Tcl_LimitCheck(interp);
|
||
}
|
||
|
||
/*
|
||
* Call 'leave' command traces
|
||
*/
|
||
|
||
if (traced) {
|
||
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
|
||
if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){
|
||
traceCode = TclCheckExecutionTraces(interp, command, length,
|
||
cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
|
||
}
|
||
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
|
||
traceCode = TclCheckInterpTraces(interp, command, length,
|
||
cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* If one of the trace invocation resulted in error, then change the
|
||
* result code accordingly. Note, that the interp->result should
|
||
* already be set correctly by the call to TraceExecutionProc.
|
||
*/
|
||
|
||
if (traceCode != TCL_OK) {
|
||
code = traceCode;
|
||
}
|
||
if (commandPtr) {
|
||
Tcl_DecrRefCount(commandPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Decrement the reference count of cmdPtr and deallocate it if it has
|
||
* dropped to zero.
|
||
*/
|
||
|
||
TclCleanupCommandMacro(cmdPtr);
|
||
|
||
/*
|
||
* If the interpreter has a non-empty string result, the result object is
|
||
* either empty or stale because some function set interp->result
|
||
* directly. If so, move the string result to the result object, then
|
||
* reset the string result.
|
||
*/
|
||
|
||
if (*(iPtr->result) != 0) {
|
||
(void) Tcl_GetObjResult(interp);
|
||
}
|
||
|
||
#ifdef USE_DTRACE
|
||
if (TCL_DTRACE_CMD_RESULT_ENABLED()) {
|
||
Tcl_Obj *r;
|
||
|
||
r = Tcl_GetObjResult(interp);
|
||
TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r),r);
|
||
}
|
||
#endif /* USE_DTRACE */
|
||
|
||
done:
|
||
if (savedVarFramePtr) {
|
||
iPtr->varFramePtr = savedVarFramePtr;
|
||
}
|
||
return code;
|
||
|
||
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".
|
||
*/
|
||
|
||
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
|
||
* invokation itself.
|
||
*/
|
||
|
||
Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
|
||
&handlerObjc, &handlerObjv);
|
||
newObjc = objc + handlerObjc;
|
||
newObjv = (Tcl_Obj **) TclStackAlloc(interp,
|
||
(int) sizeof(Tcl_Obj *) * newObjc);
|
||
|
||
/*
|
||
* Copy command prefix from unknown handler and add on the real
|
||
* command's full argument list. Note that we only use memcpy() once
|
||
* because we have to increment the reference count of all the handler
|
||
* arguments anyway.
|
||
*/
|
||
|
||
for (i = 0; i < handlerObjc; ++i) {
|
||
newObjv[i] = handlerObjv[i];
|
||
Tcl_IncrRefCount(newObjv[i]);
|
||
}
|
||
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.
|
||
*/
|
||
|
||
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
|
||
* call.
|
||
*/
|
||
|
||
for (i = 0; i < handlerObjc; ++i) {
|
||
Tcl_DecrRefCount(newObjv[i]);
|
||
}
|
||
TclStackFree(interp, newObjv);
|
||
if (savedNsPtr) {
|
||
varFramePtr->nsPtr = savedNsPtr;
|
||
}
|
||
goto done;
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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;
|
||
int code = TCL_OK;
|
||
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
|
||
|
||
iPtr->numLevels++;
|
||
code = TclEvalObjvInternal(interp, objc, objv, NULL, 0, flags);
|
||
iPtr->numLevels--;
|
||
|
||
if (code == TCL_OK) {
|
||
return code;
|
||
} else {
|
||
|
||
/*
|
||
* If we are again at the top level, process any unusual return code
|
||
* returned by the evaluated code.
|
||
*/
|
||
|
||
if (iPtr->numLevels == 0) {
|
||
if (code == TCL_RETURN) {
|
||
code = TclUpdateReturnInfo(iPtr);
|
||
}
|
||
if ((code != TCL_ERROR) && !allowExceptions) {
|
||
ProcessUnexpectedResult(interp, code);
|
||
code = TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
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.
|
||
*/
|
||
|
||
Tcl_Obj *listPtr;
|
||
char *cmdString;
|
||
int cmdLen;
|
||
|
||
listPtr = Tcl_NewListObj(objc, objv);
|
||
cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
|
||
Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
|
||
Tcl_DecrRefCount(listPtr);
|
||
}
|
||
|
||
return code;
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_EvalTokensStandard --
|
||
*
|
||
* Given an array of tokens parsed from a Tcl command (e.g., the tokens
|
||
* that make up a word or the index for an array variable) this function
|
||
* evaluates the tokens and concatenates their values to form a single
|
||
* result value.
|
||
*
|
||
* 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 array of tokens being evaled.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_EvalTokensStandard(
|
||
Tcl_Interp *interp, /* Interpreter in which to lookup variables,
|
||
* execute nested commands, and report
|
||
* errors. */
|
||
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
|
||
* evaluate and concatenate. */
|
||
int count) /* Number of tokens to consider at tokenPtr.
|
||
* Must be at least 1. */
|
||
{
|
||
return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1,
|
||
NULL, NULL);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_EvalTokens --
|
||
*
|
||
* Given an array of tokens parsed from a Tcl command (e.g., the tokens
|
||
* that make up a word or the index for an array variable) this function
|
||
* evaluates the tokens and concatenates their values to form a single
|
||
* result value.
|
||
*
|
||
* Results:
|
||
* The return value is a pointer to a newly allocated Tcl_Obj containing
|
||
* the value of the array of tokens. The reference count of the returned
|
||
* object has been incremented. If an error occurs in evaluating the
|
||
* tokens then a NULL value is returned and an error message is left in
|
||
* interp's result.
|
||
*
|
||
* Side effects:
|
||
* A new object is allocated to hold the result.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* This uses a non-standard return convention; its use is now deprecated. It
|
||
* is a wrapper for the new function Tcl_EvalTokensStandard, and is not used
|
||
* in the core any longer. It is only kept for backward compatibility.
|
||
*/
|
||
|
||
Tcl_Obj *
|
||
Tcl_EvalTokens(
|
||
Tcl_Interp *interp, /* Interpreter in which to lookup variables,
|
||
* execute nested commands, and report
|
||
* errors. */
|
||
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
|
||
* evaluate and concatenate. */
|
||
int count) /* Number of tokens to consider at tokenPtr.
|
||
* Must be at least 1. */
|
||
{
|
||
Tcl_Obj *resPtr;
|
||
|
||
if (Tcl_EvalTokensStandard(interp, tokenPtr, count) != TCL_OK) {
|
||
return NULL;
|
||
}
|
||
resPtr = Tcl_GetObjResult(interp);
|
||
Tcl_IncrRefCount(resPtr);
|
||
Tcl_ResetResult(interp);
|
||
return resPtr;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_EvalEx, TclEvalEx --
|
||
*
|
||
* This function evaluates a Tcl script without using the compiler or
|
||
* byte-code interpreter. It just parses the script, creates values for
|
||
* each word of each command, then calls EvalObjv to execute each
|
||
* command.
|
||
*
|
||
* Results:
|
||
* The return value is a standard Tcl completion code such as TCL_OK or
|
||
* TCL_ERROR. A result or error message is left in interp's result.
|
||
*
|
||
* Side effects:
|
||
* Depends on the script.
|
||
*
|
||
* TIP #280 : Keep public API, internally extended API.
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_EvalEx(
|
||
Tcl_Interp *interp, /* Interpreter in which to evaluate the
|
||
* script. Also used for error reporting. */
|
||
const char *script, /* First character of script to evaluate. */
|
||
int numBytes, /* Number of bytes in script. If < 0, the
|
||
* script consists of all bytes up to the
|
||
* first null character. */
|
||
int flags) /* Collection of OR-ed bits that control the
|
||
* evaluation of the script. Only
|
||
* TCL_EVAL_GLOBAL is currently supported. */
|
||
{
|
||
return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script);
|
||
}
|
||
|
||
int
|
||
TclEvalEx(
|
||
Tcl_Interp *interp, /* Interpreter in which to evaluate the
|
||
* script. Also used for error reporting. */
|
||
const char *script, /* First character of script to evaluate. */
|
||
int numBytes, /* Number of bytes in script. If < 0, the
|
||
* script consists of all bytes up to the
|
||
* first NUL character. */
|
||
int flags, /* Collection of OR-ed bits that control the
|
||
* evaluation of the script. Only
|
||
* TCL_EVAL_GLOBAL is currently supported. */
|
||
int line, /* The line the script starts on. */
|
||
int* clNextOuter, /* Information about an outer context for */
|
||
CONST char* outerScript) /* continuation line data. This is set only in
|
||
* TclSubstTokens(), to properly handle
|
||
* [...]-nested commands. The 'outerScript'
|
||
* refers to the most-outer script containing the
|
||
* embedded command, which is refered to by
|
||
* '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 unsigned int minObjs = 20;
|
||
Tcl_Obj **objv, **objvSpace;
|
||
int *expand, *lines, *lineSpace;
|
||
Tcl_Token *tokenPtr;
|
||
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;
|
||
unsigned int i, objectsUsed = 0;
|
||
/* These variables keep track of how much
|
||
* state has been allocated while evaluating
|
||
* the script, so that it can be freed
|
||
* properly if an error occurs. */
|
||
Tcl_Parse *parsePtr = (Tcl_Parse *)
|
||
TclStackAlloc(interp, sizeof(Tcl_Parse));
|
||
CmdFrame *eeFramePtr = (CmdFrame *)
|
||
TclStackAlloc(interp, sizeof(CmdFrame));
|
||
Tcl_Obj **stackObjArray = (Tcl_Obj **)
|
||
TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *));
|
||
int *expandStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int));
|
||
int *linesStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int));
|
||
/* TIP #280 Structures for tracking of command
|
||
* locations. */
|
||
/*
|
||
* Pointer for the tracking of invisible continuation lines. Initialized
|
||
* only if the caller gave us a table of locations to track, via
|
||
* 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) {
|
||
clNext = clNextOuter;
|
||
} else {
|
||
clNext = &iPtr->scriptCLLocPtr->loc[0];
|
||
}
|
||
}
|
||
|
||
if (numBytes < 0) {
|
||
numBytes = strlen(script);
|
||
}
|
||
Tcl_ResetResult(interp);
|
||
|
||
savedVarFramePtr = iPtr->varFramePtr;
|
||
if (flags & TCL_EVAL_GLOBAL) {
|
||
iPtr->varFramePtr = iPtr->rootFramePtr;
|
||
}
|
||
|
||
/*
|
||
* Each iteration through the following loop parses the next command from
|
||
* the script and then executes it.
|
||
*/
|
||
|
||
objv = objvSpace = stackObjArray;
|
||
lines = lineSpace = linesStack;
|
||
expand = expandStack;
|
||
p = script;
|
||
bytesLeft = numBytes;
|
||
|
||
/*
|
||
* TIP #280 Initialize tracking. Do not push on the frame stack yet.
|
||
*
|
||
* We may continue counting based on a specific context (CTX), or open a
|
||
* new context, either for a sourced script, or 'eval'. For sourced files
|
||
* we always have a path object, even if nothing was specified in the
|
||
* interp itself. That makes code using it simpler as NULL checks can be
|
||
* left out. Sourced file without path in the 'scriptFile' is possible
|
||
* during Tcl initialization.
|
||
*/
|
||
|
||
if (iPtr->evalFlags & TCL_EVAL_CTX) {
|
||
/*
|
||
* Path information comes out of the context.
|
||
*/
|
||
|
||
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.
|
||
*/
|
||
|
||
eeFramePtr->type = TCL_LOCATION_SOURCE;
|
||
|
||
if (iPtr->scriptFile) {
|
||
/*
|
||
* Normalization here, to have the correct pwd. Should have
|
||
* negligible impact on performance, as the norm should have been
|
||
* done already by the 'source' invoking us, and it caches the
|
||
* result.
|
||
*/
|
||
|
||
Tcl_Obj *norm = Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile);
|
||
|
||
if (norm == NULL) {
|
||
/*
|
||
* Error message in the interp result.
|
||
*/
|
||
code = TCL_ERROR;
|
||
goto error;
|
||
}
|
||
eeFramePtr->data.eval.path = norm;
|
||
} else {
|
||
TclNewLiteralStringObj(eeFramePtr->data.eval.path, "");
|
||
}
|
||
Tcl_IncrRefCount(eeFramePtr->data.eval.path);
|
||
} else {
|
||
/*
|
||
* Set up for plain eval.
|
||
*/
|
||
|
||
eeFramePtr->type = TCL_LOCATION_EVAL;
|
||
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;
|
||
goto error;
|
||
}
|
||
|
||
/*
|
||
* TIP #280 Track lines. The parser may have skipped text till it
|
||
* found the command we are now at. We have to count the lines in this
|
||
* block, and do not forget invisible continuation lines.
|
||
*/
|
||
|
||
TclAdvanceLines(&line, p, parsePtr->commandStart);
|
||
TclAdvanceContinuations (&line, &clNext,
|
||
parsePtr->commandStart - outerScript);
|
||
|
||
gotParse = 1;
|
||
if (parsePtr->numWords > 0) {
|
||
/*
|
||
* TIP #280. Track lines within the words of the current
|
||
* command. We use a separate pointer into the table of
|
||
* continuation line locations to not lose our position for the
|
||
* per-command parsing.
|
||
*/
|
||
|
||
int wordLine = line;
|
||
const char *wordStart = parsePtr->commandStart;
|
||
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 = (int *) ckalloc(numWords * sizeof(int));
|
||
}
|
||
expandRequested = 0;
|
||
objv = objvSpace;
|
||
lines = lineSpace;
|
||
|
||
for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr;
|
||
objectsUsed < numWords;
|
||
objectsUsed++, tokenPtr += tokenPtr->numComponents+1) {
|
||
/*
|
||
* TIP #280. Track lines to current word. Save the information
|
||
* on a per-word basis, signaling dynamic words as needed.
|
||
* Make the information available to the recursively called
|
||
* evaluator as well, including the type of context (source
|
||
* vs. eval).
|
||
*/
|
||
|
||
TclAdvanceLines(&wordLine, wordStart, tokenPtr->start);
|
||
TclAdvanceContinuations (&wordLine, &wordCLNext,
|
||
tokenPtr->start - outerScript);
|
||
wordStart = tokenPtr->start;
|
||
|
||
lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL)
|
||
? wordLine : -1;
|
||
|
||
if (eeFramePtr->type == TCL_LOCATION_SOURCE) {
|
||
iPtr->evalFlags |= TCL_EVAL_FILE;
|
||
}
|
||
|
||
code = TclSubstTokens(interp, tokenPtr+1,
|
||
tokenPtr->numComponents, NULL, wordLine,
|
||
wordCLNext, outerScript);
|
||
|
||
iPtr->evalFlags = 0;
|
||
|
||
if (code != TCL_OK) {
|
||
goto error;
|
||
}
|
||
objv[objectsUsed] = Tcl_GetObjResult(interp);
|
||
Tcl_IncrRefCount(objv[objectsUsed]);
|
||
if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
|
||
int numElements;
|
||
|
||
code = TclListObjLength(interp, objv[objectsUsed],
|
||
&numElements);
|
||
if (code == TCL_ERROR) {
|
||
/*
|
||
* Attempt to expand a non-list.
|
||
*/
|
||
|
||
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
|
||
"\n (expanding word %d)", objectsUsed));
|
||
Tcl_DecrRefCount(objv[objectsUsed]);
|
||
goto error;
|
||
}
|
||
expandRequested = 1;
|
||
expand[objectsUsed] = 1;
|
||
|
||
objectsNeeded += (numElements ? numElements : 1);
|
||
} else {
|
||
expand[objectsUsed] = 0;
|
||
objectsNeeded++;
|
||
}
|
||
|
||
if (wordCLNext) {
|
||
TclContinuationsEnterDerived (objv[objectsUsed],
|
||
wordStart - outerScript, wordCLNext);
|
||
}
|
||
} /* for loop */
|
||
if (expandRequested) {
|
||
/*
|
||
* Some word expansion was requested. Check for objv resize.
|
||
*/
|
||
|
||
Tcl_Obj **copy = objvSpace;
|
||
int *lcopy = lineSpace;
|
||
int wordIdx = numWords;
|
||
int objIdx = objectsNeeded - 1;
|
||
|
||
if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
|
||
objv = objvSpace = (Tcl_Obj **)
|
||
ckalloc(objectsNeeded * sizeof(Tcl_Obj *));
|
||
lines = lineSpace = (int *)
|
||
ckalloc(objectsNeeded * sizeof(int));
|
||
}
|
||
|
||
objectsUsed = 0;
|
||
while (wordIdx--) {
|
||
if (expand[wordIdx]) {
|
||
int numElements;
|
||
Tcl_Obj **elements, *temp = copy[wordIdx];
|
||
|
||
Tcl_ListObjGetElements(NULL, temp, &numElements,
|
||
&elements);
|
||
objectsUsed += numElements;
|
||
while (numElements--) {
|
||
lines[objIdx] = -1;
|
||
objv[objIdx--] = elements[numElements];
|
||
Tcl_IncrRefCount(elements[numElements]);
|
||
}
|
||
Tcl_DecrRefCount(temp);
|
||
} else {
|
||
lines[objIdx] = lcopy[wordIdx];
|
||
objv[objIdx--] = copy[wordIdx];
|
||
objectsUsed++;
|
||
}
|
||
}
|
||
objv += objIdx+1;
|
||
|
||
if (copy != stackObjArray) {
|
||
ckfree((char *) copy);
|
||
}
|
||
if (lcopy != linesStack) {
|
||
ckfree((char *) lcopy);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Execute the command and free the objects for its words.
|
||
*
|
||
* TIP #280: Remember the command itself for 'info frame'. We
|
||
* shorten the visible command by one char to exclude the
|
||
* termination character, if necessary. Here is where we put our
|
||
* frame on the stack of frames too. _After_ the nested commands
|
||
* have been executed.
|
||
*/
|
||
|
||
eeFramePtr->cmd.str.cmd = parsePtr->commandStart;
|
||
eeFramePtr->cmd.str.len = parsePtr->commandSize;
|
||
|
||
if (parsePtr->term ==
|
||
parsePtr->commandStart + parsePtr->commandSize - 1) {
|
||
eeFramePtr->cmd.str.len--;
|
||
}
|
||
|
||
eeFramePtr->nline = objectsUsed;
|
||
eeFramePtr->line = lines;
|
||
|
||
TclArgumentEnter (interp, objv, objectsUsed, eeFramePtr);
|
||
iPtr->cmdFramePtr = eeFramePtr;
|
||
iPtr->numLevels++;
|
||
code = TclEvalObjvInternal(interp, objectsUsed, objv,
|
||
parsePtr->commandStart, parsePtr->commandSize, 0);
|
||
iPtr->numLevels--;
|
||
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
|
||
TclArgumentRelease (interp, objv, objectsUsed);
|
||
|
||
eeFramePtr->line = NULL;
|
||
eeFramePtr->nline = 0;
|
||
|
||
if (code != TCL_OK) {
|
||
goto error;
|
||
}
|
||
for (i = 0; i < objectsUsed; i++) {
|
||
Tcl_DecrRefCount(objv[i]);
|
||
}
|
||
objectsUsed = 0;
|
||
if (objvSpace != stackObjArray) {
|
||
ckfree((char *) objvSpace);
|
||
objvSpace = stackObjArray;
|
||
ckfree((char *) lineSpace);
|
||
lineSpace = linesStack;
|
||
}
|
||
|
||
/*
|
||
* Free expand separately since objvSpace could have been
|
||
* reallocated above.
|
||
*/
|
||
|
||
if (expand != expandStack) {
|
||
ckfree((char *) expand);
|
||
expand = expandStack;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Advance to the next command in the script.
|
||
*
|
||
* TIP #280 Track Lines. Now we track how many lines were in the
|
||
* executed command.
|
||
*/
|
||
|
||
next = parsePtr->commandStart + parsePtr->commandSize;
|
||
bytesLeft -= next - p;
|
||
p = next;
|
||
TclAdvanceLines(&line, parsePtr->commandStart, p);
|
||
Tcl_FreeParse(parsePtr);
|
||
gotParse = 0;
|
||
} while (bytesLeft > 0);
|
||
iPtr->varFramePtr = savedVarFramePtr;
|
||
code = TCL_OK;
|
||
goto cleanup_return;
|
||
|
||
error:
|
||
/*
|
||
* Generate and log various pieces of error information.
|
||
*/
|
||
|
||
if (iPtr->numLevels == 0) {
|
||
if (code == TCL_RETURN) {
|
||
code = TclUpdateReturnInfo(iPtr);
|
||
}
|
||
if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) {
|
||
ProcessUnexpectedResult(interp, code);
|
||
code = TCL_ERROR;
|
||
}
|
||
}
|
||
if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
||
commandLength = parsePtr->commandSize;
|
||
if (parsePtr->term == parsePtr->commandStart + commandLength - 1) {
|
||
/*
|
||
* The terminator character (such as ; or ]) of the command where
|
||
* the error occurred is the last character in the parsed command.
|
||
* Reduce the length by one so that the error message doesn't
|
||
* include the terminator character.
|
||
*/
|
||
|
||
commandLength -= 1;
|
||
}
|
||
Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
|
||
commandLength);
|
||
}
|
||
iPtr->flags &= ~ERR_ALREADY_LOGGED;
|
||
|
||
/*
|
||
* Then free resources that had been allocated to the command.
|
||
*/
|
||
|
||
for (i = 0; i < objectsUsed; i++) {
|
||
Tcl_DecrRefCount(objv[i]);
|
||
}
|
||
if (gotParse) {
|
||
Tcl_FreeParse(parsePtr);
|
||
}
|
||
if (objvSpace != stackObjArray) {
|
||
ckfree((char *) objvSpace);
|
||
ckfree((char *) lineSpace);
|
||
}
|
||
if (expand != expandStack) {
|
||
ckfree((char *) expand);
|
||
}
|
||
iPtr->varFramePtr = savedVarFramePtr;
|
||
|
||
cleanup_return:
|
||
/*
|
||
* TIP #280. Release the local CmdFrame, and its contents.
|
||
*/
|
||
|
||
if (eeFramePtr->type == TCL_LOCATION_SOURCE) {
|
||
Tcl_DecrRefCount(eeFramePtr->data.eval.path);
|
||
}
|
||
TclStackFree(interp, linesStack);
|
||
TclStackFree(interp, expandStack);
|
||
TclStackFree(interp, stackObjArray);
|
||
TclStackFree(interp, eeFramePtr);
|
||
TclStackFree(interp, parsePtr);
|
||
|
||
return code;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclAdvanceLines --
|
||
*
|
||
* This function is a helper which counts the number of lines in a block
|
||
* of text and advances an external counter.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* The specified counter is advanced per the number of lines found.
|
||
*
|
||
* TIP #280
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
TclAdvanceLines(
|
||
int *line,
|
||
const char *start,
|
||
const char *end)
|
||
{
|
||
register const char *p;
|
||
|
||
for (p = start; p < end; p++) {
|
||
if (*p == '\n') {
|
||
(*line)++;
|
||
}
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclAdvanceContinuations --
|
||
*
|
||
* This procedure is a helper which counts the number of continuation
|
||
* lines (CL) in a block of text using a table of CL locations and
|
||
* advances an external counter, and the pointer into the table.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* The specified counter is advanced per the number of continuation lines
|
||
* found.
|
||
*
|
||
* TIP #280
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
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().
|
||
*
|
||
* *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)) {
|
||
/*
|
||
* 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) ++;
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
* Note: The whole data structure access for argument location tracking is
|
||
* hidden behind these three functions. The only parts open are the lineLAPtr
|
||
* field in the Interp structure. The CFWord definition is internal to here.
|
||
* Should make it easier to redo the data structures if we find something more
|
||
* space/time efficient.
|
||
*/
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclArgumentEnter --
|
||
*
|
||
* 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.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* May allocate memory.
|
||
*
|
||
* TIP #280
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
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' 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, (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 ++;
|
||
}
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* May release memory.
|
||
*
|
||
* TIP #280
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
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++) {
|
||
hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) objv[i]);
|
||
|
||
if (!hPtr) { continue; }
|
||
cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
|
||
|
||
cfwPtr->refCount --;
|
||
if (cfwPtr->refCount > 0) { continue; }
|
||
|
||
ckfree ((char*) cfwPtr);
|
||
Tcl_DeleteHashEntry (hPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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
|
||
* data, further entries simply count the usage up.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* May allocate memory.
|
||
*
|
||
* TIP #280
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
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;
|
||
|
||
/*
|
||
* 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 (ePtr->nline != objc) {
|
||
Tcl_Panic ("TIP 280 data structure inconsistency");
|
||
}
|
||
|
||
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->framePtr = cfPtr;
|
||
cfwPtr->pc = pc;
|
||
cfwPtr->word = word;
|
||
|
||
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);
|
||
}
|
||
|
||
Tcl_SetHashValue (hPtr, cfwPtr);
|
||
}
|
||
} /* for */
|
||
} /* if */
|
||
} /* if */
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* May release memory.
|
||
*
|
||
* TIP #280
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
TclArgumentBCRelease(interp,objv,objc,codePtr,pc)
|
||
Tcl_Interp* interp;
|
||
Tcl_Obj* objv[];
|
||
int objc;
|
||
void* codePtr;
|
||
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;
|
||
|
||
/*
|
||
* 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((char *) cfwPtr);
|
||
}
|
||
}
|
||
}
|
||
}
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclArgumentGet --
|
||
*
|
||
* This procedure is a helper for the TIP #280 uplevel extension.
|
||
* It find the location references for a Tcl_Obj, if any.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Writes found location information into the result arguments.
|
||
*
|
||
* TIP #280
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
TclArgumentGet(interp,obj,cfPtrPtr,wordPtr)
|
||
Tcl_Interp* interp;
|
||
Tcl_Obj* obj;
|
||
CmdFrame** cfPtrPtr;
|
||
int* wordPtr;
|
||
{
|
||
Interp* iPtr = (Interp*) interp;
|
||
Tcl_HashEntry* hPtr;
|
||
CmdFrame* framePtr;
|
||
|
||
/*
|
||
* An object which either has no string rep or else is a canonical list is
|
||
* guaranteed to have been generated dynamically: bail out, this cannot
|
||
* have a usable absolute location. _Do not touch_ the information the set
|
||
* up by the caller. It knows better than us.
|
||
*/
|
||
|
||
if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) {
|
||
return;
|
||
}
|
||
|
||
/*
|
||
* First look for location information recorded in the argument
|
||
* stack. That is nearest.
|
||
*/
|
||
|
||
hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) obj);
|
||
if (hPtr) {
|
||
CFWord* cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
|
||
*wordPtr = cfwPtr->word;
|
||
*cfPtrPtr = cfwPtr->framePtr;
|
||
return;
|
||
}
|
||
|
||
/*
|
||
* Check if the Tcl_Obj has location information as a bytecode literal, in
|
||
* that stack.
|
||
*/
|
||
|
||
hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj);
|
||
|
||
if (hPtr) {
|
||
CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
|
||
|
||
framePtr = cfwPtr->framePtr;
|
||
framePtr->data.tebc.pc = (char *) (((ByteCode*)
|
||
framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc);
|
||
*cfPtrPtr = cfwPtr->framePtr;
|
||
*wordPtr = cfwPtr->word;
|
||
return;
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_Eval --
|
||
*
|
||
* Execute a Tcl command in a string. This function executes the script
|
||
* directly, rather than compiling it to bytecodes. Before the arrival of
|
||
* the bytecode compiler in Tcl 8.0 Tcl_Eval was the main function used
|
||
* for executing Tcl commands, but nowadays it isn't used much.
|
||
*
|
||
* Results:
|
||
* The return value is one of the return codes defined in tcl.h (such as
|
||
* TCL_OK), and interp's result contains a value to supplement the return
|
||
* code. The value of the result will persist only until the next call to
|
||
* Tcl_Eval or Tcl_EvalObj: you must copy it or lose it!
|
||
*
|
||
* Side effects:
|
||
* Can be almost arbitrary, depending on the commands in the script.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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, -1, 0);
|
||
|
||
/*
|
||
* For backwards compatibility with old C code that predates the object
|
||
* system in Tcl 8.0, we have to mirror the object result back into the
|
||
* string result (some callers may expect it there).
|
||
*/
|
||
|
||
(void) Tcl_GetStringResult(interp);
|
||
return code;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_EvalObj, Tcl_GlobalEvalObj --
|
||
*
|
||
* These functions are deprecated but we keep them around for backwards
|
||
* compatibility reasons.
|
||
*
|
||
* Results:
|
||
* See the functions they call.
|
||
*
|
||
* Side effects:
|
||
* See the functions they call.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
#undef Tcl_EvalObj
|
||
int
|
||
Tcl_EvalObj(
|
||
Tcl_Interp *interp,
|
||
Tcl_Obj *objPtr)
|
||
{
|
||
return Tcl_EvalObjEx(interp, objPtr, 0);
|
||
}
|
||
|
||
#undef Tcl_GlobalEvalObj
|
||
int
|
||
Tcl_GlobalEvalObj(
|
||
Tcl_Interp *interp,
|
||
Tcl_Obj *objPtr)
|
||
{
|
||
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_EvalObjEx, TclEvalObjEx --
|
||
*
|
||
* Execute Tcl commands stored in a Tcl object. These commands are
|
||
* compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is
|
||
* specified.
|
||
*
|
||
* Results:
|
||
* The return value is one of the return codes defined in tcl.h (such as
|
||
* TCL_OK), and the interpreter's result contains a value to supplement
|
||
* the return code.
|
||
*
|
||
* Side effects:
|
||
* The object is converted, if necessary, to a ByteCode object that holds
|
||
* the bytecode instructions for the commands. Executing the commands
|
||
* will almost certainly have side effects that depend on those commands.
|
||
*
|
||
* TIP #280 : Keep public API, internally extended API.
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_EvalObjEx(
|
||
Tcl_Interp *interp, /* Token for command interpreter (returned by
|
||
* a previous call to Tcl_CreateInterp). */
|
||
register Tcl_Obj *objPtr, /* Pointer to object containing commands to
|
||
* execute. */
|
||
int flags) /* Collection of OR-ed bits that control the
|
||
* evaluation of the script. Supported values
|
||
* are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */
|
||
{
|
||
return TclEvalObjEx(interp, objPtr, flags, NULL, 0);
|
||
}
|
||
|
||
int
|
||
TclEvalObjEx(
|
||
Tcl_Interp *interp, /* Token for command interpreter (returned by
|
||
* a previous call to Tcl_CreateInterp). */
|
||
register Tcl_Obj *objPtr, /* Pointer to object containing commands to
|
||
* execute. */
|
||
int flags, /* Collection of OR-ed bits that control the
|
||
* evaluation of the script. Supported values
|
||
* are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */
|
||
const CmdFrame *invoker, /* Frame of the command doing the eval. */
|
||
int word) /* Index of the word which is in objPtr. */
|
||
{
|
||
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. */
|
||
|
||
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)) {
|
||
/*
|
||
* TIP #280 Structures for tracking lines. As we know that this is
|
||
* dynamic execution we ignore the invoker, even if known.
|
||
*/
|
||
|
||
int nelements;
|
||
Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr);
|
||
CmdFrame *eoFramePtr = (CmdFrame *)
|
||
TclStackAlloc(interp, sizeof(CmdFrame));
|
||
|
||
eoFramePtr->type = TCL_LOCATION_EVAL_LIST;
|
||
eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1
|
||
: iPtr->cmdFramePtr->level + 1);
|
||
eoFramePtr->framePtr = iPtr->framePtr;
|
||
eoFramePtr->nextPtr = iPtr->cmdFramePtr;
|
||
|
||
eoFramePtr->nline = 0;
|
||
eoFramePtr->line = NULL;
|
||
|
||
eoFramePtr->cmd.listPtr = objPtr;
|
||
Tcl_IncrRefCount(eoFramePtr->cmd.listPtr);
|
||
eoFramePtr->data.eval.path = NULL;
|
||
|
||
/*
|
||
* TIP #280 We do _not_ compute all the line numbers for the words
|
||
* in the command. For the eval of a pure list the most sensible
|
||
* choice is to put all words on line 1. Given that we neither
|
||
* need memory for them nor compute anything. 'line' is left
|
||
* NULL. The two places using this information (TclInfoFrame, and
|
||
* TclInitCompileEnv), are special-cased to use the proper line
|
||
* number directly instead of accessing the 'line' array.
|
||
*/
|
||
|
||
Tcl_ListObjGetElements(NULL, copyPtr, &nelements, &elements);
|
||
|
||
iPtr->cmdFramePtr = eoFramePtr;
|
||
result = Tcl_EvalObjv(interp, nelements, elements, flags);
|
||
|
||
Tcl_DecrRefCount(copyPtr);
|
||
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
|
||
Tcl_DecrRefCount(eoFramePtr->cmd.listPtr);
|
||
TclStackFree(interp, eoFramePtr);
|
||
} else if (flags & TCL_EVAL_DIRECT) {
|
||
/*
|
||
* We're not supposed to use the compiler or byte-code interpreter.
|
||
* Let Tcl_EvalEx evaluate the command directly (and probably more
|
||
* slowly).
|
||
*/
|
||
|
||
/*
|
||
* TIP #280. Propagate context as much as we can. Especially if the
|
||
* script to evaluate is a single literal it makes sense to look if
|
||
* our context is one with absolute line numbers we can then track
|
||
* into the literal itself too.
|
||
*
|
||
* See also tclCompile.c, TclInitCompileEnv, for the equivalent code
|
||
* in the bytecode compiler.
|
||
*/
|
||
|
||
/*
|
||
* Now we check if we have data about invisible continuation lines for
|
||
* the script, and make it available to the direct script parser and
|
||
* evaluator we are about to call, if so.
|
||
*
|
||
* It may be possible that the script Tcl_Obj* can be free'd while the
|
||
* evaluator is using it, leading to the release of the associated
|
||
* ContLineLoc structure as well. To ensure that the latter doesn't
|
||
* happen we set a lock on it. We release this lock later in this
|
||
* function, after the evaluator is done. The relevant "lineCLPtr"
|
||
* hashtable is managed in the file "tclObj.c".
|
||
*
|
||
* Another important action is to save (and later restore) the
|
||
* continuation line information of the caller, in case we are
|
||
* executing nested commands in the eval/direct path.
|
||
*/
|
||
|
||
ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr;
|
||
ContLineLoc* clLocPtr = TclContinuationsGet (objPtr);
|
||
|
||
if (clLocPtr) {
|
||
iPtr->scriptCLLocPtr = clLocPtr;
|
||
Tcl_Preserve (iPtr->scriptCLLocPtr);
|
||
} else {
|
||
iPtr->scriptCLLocPtr = NULL;
|
||
}
|
||
|
||
if (invoker == NULL) {
|
||
/*
|
||
* No context, force opening of our own.
|
||
*/
|
||
|
||
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
|
||
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
|
||
} else {
|
||
/*
|
||
* We have an invoker, describing the command asking for the
|
||
* evaluation of a subordinate script. This script may originate
|
||
* in a literal word, or from a variable, etc. Using the line
|
||
* array we now check if we have good line information for the
|
||
* relevant word. The type of context is relevant as well. In a
|
||
* non-'source' context we don't have to try tracking lines.
|
||
*
|
||
* First see if the word exists and is a literal. If not we go
|
||
* through the easy dynamic branch. No need to perform more
|
||
* complex invokations.
|
||
*/
|
||
|
||
int pc = 0;
|
||
CmdFrame *ctxPtr = (CmdFrame *)
|
||
TclStackAlloc(interp, sizeof(CmdFrame));
|
||
|
||
*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.
|
||
*/
|
||
|
||
TclGetSrcInfoForPc(ctxPtr);
|
||
pc = 1;
|
||
}
|
||
|
||
script = Tcl_GetStringFromObj(objPtr, &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);
|
||
}
|
||
|
||
/*
|
||
* Now release the lock on the continuation line information, if
|
||
* any, and restore the caller's settings.
|
||
*/
|
||
|
||
if (iPtr->scriptCLLocPtr) {
|
||
Tcl_Release (iPtr->scriptCLLocPtr);
|
||
}
|
||
iPtr->scriptCLLocPtr = saveCLLocPtr;
|
||
} 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);
|
||
|
||
savedVarFramePtr = iPtr->varFramePtr;
|
||
if (flags & TCL_EVAL_GLOBAL) {
|
||
iPtr->varFramePtr = iPtr->rootFramePtr;
|
||
}
|
||
|
||
result = TclCompEvalObj(interp, objPtr, invoker, word);
|
||
|
||
/*
|
||
* If we are again at the top level, process any unusual return code
|
||
* returned by the evaluated code.
|
||
*/
|
||
|
||
if (iPtr->numLevels == 0) {
|
||
if (result == TCL_RETURN) {
|
||
result = TclUpdateReturnInfo(iPtr);
|
||
}
|
||
if ((result != TCL_OK) && (result != TCL_ERROR)
|
||
&& !allowExceptions) {
|
||
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);
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* ProcessUnexpectedResult --
|
||
*
|
||
* Function called by Tcl_EvalObj to set the interpreter's result value
|
||
* to an appropriate error message when the code it evaluates returns an
|
||
* unexpected result code (not TCL_OK and not TCL_ERROR) to the topmost
|
||
* evaluation level.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* The interpreter result is set to an error message appropriate to the
|
||
* result code.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
ProcessUnexpectedResult(
|
||
Tcl_Interp *interp, /* The interpreter in which the unexpected
|
||
* result code was returned. */
|
||
int returnCode) /* The unexpected result code. */
|
||
{
|
||
Tcl_ResetResult(interp);
|
||
if (returnCode == TCL_BREAK) {
|
||
Tcl_AppendResult(interp,
|
||
"invoked \"break\" outside of a loop", NULL);
|
||
} else if (returnCode == TCL_CONTINUE) {
|
||
Tcl_AppendResult(interp,
|
||
"invoked \"continue\" outside of a loop", NULL);
|
||
} else {
|
||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"command returned bad code: %d", returnCode));
|
||
}
|
||
}
|
||
|
||
/*
|
||
*---------------------------------------------------------------------------
|
||
*
|
||
* Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
|
||
*
|
||
* Functions to evaluate an expression and return its value in a
|
||
* particular form.
|
||
*
|
||
* Results:
|
||
* Each of the functions below returns a standard Tcl result. If an error
|
||
* occurs then an error message is left in the interp's result. Otherwise
|
||
* the value of the expression, in the appropriate form, is stored at
|
||
* *ptr. If the expression had a result that was incompatible with the
|
||
* desired form then an error is returned.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*---------------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_ExprLong(
|
||
Tcl_Interp *interp, /* Context in which to evaluate the
|
||
* expression. */
|
||
const char *exprstring, /* Expression to evaluate. */
|
||
long *ptr) /* Where to store result. */
|
||
{
|
||
register Tcl_Obj *exprPtr;
|
||
int result = TCL_OK;
|
||
if (*exprstring == '\0') {
|
||
/*
|
||
* Legacy compatibility - return 0 for the zero-length string.
|
||
*/
|
||
|
||
*ptr = 0;
|
||
} else {
|
||
exprPtr = Tcl_NewStringObj(exprstring, -1);
|
||
Tcl_IncrRefCount(exprPtr);
|
||
result = Tcl_ExprLongObj(interp, exprPtr, ptr);
|
||
Tcl_DecrRefCount(exprPtr);
|
||
if (result != TCL_OK) {
|
||
(void) Tcl_GetStringResult(interp);
|
||
}
|
||
}
|
||
return result;
|
||
}
|
||
|
||
int
|
||
Tcl_ExprDouble(
|
||
Tcl_Interp *interp, /* Context in which to evaluate the
|
||
* expression. */
|
||
const char *exprstring, /* Expression to evaluate. */
|
||
double *ptr) /* Where to store result. */
|
||
{
|
||
register Tcl_Obj *exprPtr;
|
||
int result = TCL_OK;
|
||
|
||
if (*exprstring == '\0') {
|
||
/*
|
||
* Legacy compatibility - return 0 for the zero-length string.
|
||
*/
|
||
|
||
*ptr = 0.0;
|
||
} else {
|
||
exprPtr = Tcl_NewStringObj(exprstring, -1);
|
||
Tcl_IncrRefCount(exprPtr);
|
||
result = Tcl_ExprDoubleObj(interp, exprPtr, ptr);
|
||
Tcl_DecrRefCount(exprPtr);
|
||
/* Discard the expression object. */
|
||
if (result != TCL_OK) {
|
||
(void) Tcl_GetStringResult(interp);
|
||
}
|
||
}
|
||
return result;
|
||
}
|
||
|
||
int
|
||
Tcl_ExprBoolean(
|
||
Tcl_Interp *interp, /* Context in which to evaluate the
|
||
* expression. */
|
||
const char *exprstring, /* Expression to evaluate. */
|
||
int *ptr) /* Where to store 0/1 result. */
|
||
{
|
||
if (*exprstring == '\0') {
|
||
/*
|
||
* An empty string. Just set the result boolean to 0 (false).
|
||
*/
|
||
|
||
*ptr = 0;
|
||
return TCL_OK;
|
||
} else {
|
||
int result;
|
||
Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1);
|
||
|
||
Tcl_IncrRefCount(exprPtr);
|
||
result = Tcl_ExprBooleanObj(interp, exprPtr, ptr);
|
||
Tcl_DecrRefCount(exprPtr);
|
||
if (result != TCL_OK) {
|
||
/*
|
||
* Move the interpreter's object result to the string result, then
|
||
* reset the object result.
|
||
*/
|
||
|
||
(void) Tcl_GetStringResult(interp);
|
||
}
|
||
return result;
|
||
}
|
||
}
|
||
|
||
/*
|
||
*--------------------------------------------------------------
|
||
*
|
||
* Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
|
||
*
|
||
* Functions to evaluate an expression in an object and return its value
|
||
* in a particular form.
|
||
*
|
||
* Results:
|
||
* Each of the functions below returns a standard Tcl result object. If
|
||
* an error occurs then an error message is left in the interpreter's
|
||
* result. Otherwise the value of the expression, in the appropriate
|
||
* form, is stored at *ptr. If the expression had a result that was
|
||
* incompatible with the desired form then an error is returned.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*--------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_ExprLongObj(
|
||
Tcl_Interp *interp, /* Context in which to evaluate the
|
||
* expression. */
|
||
register Tcl_Obj *objPtr, /* Expression to evaluate. */
|
||
long *ptr) /* Where to store long result. */
|
||
{
|
||
Tcl_Obj *resultPtr;
|
||
int result, type;
|
||
double d;
|
||
ClientData internalPtr;
|
||
|
||
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
|
||
if (result != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type) != TCL_OK){
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
switch (type) {
|
||
case TCL_NUMBER_DOUBLE: {
|
||
mp_int big;
|
||
|
||
d = *((const double *) internalPtr);
|
||
Tcl_DecrRefCount(resultPtr);
|
||
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
resultPtr = Tcl_NewBignumObj(&big);
|
||
/* FALLTHROUGH */
|
||
}
|
||
case TCL_NUMBER_LONG:
|
||
case TCL_NUMBER_WIDE:
|
||
case TCL_NUMBER_BIG:
|
||
result = TclGetLongFromObj(interp, resultPtr, ptr);
|
||
break;
|
||
|
||
case TCL_NUMBER_NAN:
|
||
Tcl_GetDoubleFromObj(interp, resultPtr, &d);
|
||
result = TCL_ERROR;
|
||
}
|
||
|
||
Tcl_DecrRefCount(resultPtr);/* Discard the result object. */
|
||
return result;
|
||
}
|
||
|
||
int
|
||
Tcl_ExprDoubleObj(
|
||
Tcl_Interp *interp, /* Context in which to evaluate the
|
||
* expression. */
|
||
register Tcl_Obj *objPtr, /* Expression to evaluate. */
|
||
double *ptr) /* Where to store double result. */
|
||
{
|
||
Tcl_Obj *resultPtr;
|
||
int result, type;
|
||
ClientData internalPtr;
|
||
|
||
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
|
||
if (result != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type);
|
||
if (result == TCL_OK) {
|
||
switch (type) {
|
||
case TCL_NUMBER_NAN:
|
||
#ifndef ACCEPT_NAN
|
||
result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
|
||
break;
|
||
#endif
|
||
case TCL_NUMBER_DOUBLE:
|
||
*ptr = *((const double *) internalPtr);
|
||
result = TCL_OK;
|
||
break;
|
||
default:
|
||
result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
|
||
}
|
||
}
|
||
Tcl_DecrRefCount(resultPtr);/* Discard the result object. */
|
||
return result;
|
||
}
|
||
|
||
int
|
||
Tcl_ExprBooleanObj(
|
||
Tcl_Interp *interp, /* Context in which to evaluate the
|
||
* expression. */
|
||
register Tcl_Obj *objPtr, /* Expression to evaluate. */
|
||
int *ptr) /* Where to store 0/1 result. */
|
||
{
|
||
Tcl_Obj *resultPtr;
|
||
int result;
|
||
|
||
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
|
||
if (result == TCL_OK) {
|
||
result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
|
||
Tcl_DecrRefCount(resultPtr);
|
||
/* Discard the result object. */
|
||
}
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclObjInvokeNamespace --
|
||
*
|
||
* 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.
|
||
*
|
||
* Results:
|
||
* A standard Tcl result.
|
||
*
|
||
* Side effects:
|
||
* Whatever the command does.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclObjInvokeNamespace(
|
||
Tcl_Interp *interp, /* Interpreter in which command is to be
|
||
* invoked. */
|
||
int objc, /* Count of arguments. */
|
||
Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the
|
||
* name of the command to invoke. */
|
||
Tcl_Namespace *nsPtr, /* The namespace to use. */
|
||
int flags) /* Combination of flags controlling the call:
|
||
* TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN,
|
||
* or TCL_INVOKE_NO_TRACEBACK. */
|
||
{
|
||
int result;
|
||
Tcl_CallFrame *framePtr;
|
||
|
||
/*
|
||
* Make the specified namespace the current namespace and invoke the
|
||
* command.
|
||
*/
|
||
|
||
result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0);
|
||
if (result != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
result = TclObjInvoke(interp, objc, objv, flags);
|
||
|
||
TclPopStackFrame(interp);
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclObjInvoke --
|
||
*
|
||
* Invokes a Tcl command, given an objv/objc, from either the exposed or
|
||
* the hidden sets of commands in the given interpreter.
|
||
*
|
||
* Results:
|
||
* A standard Tcl object result.
|
||
*
|
||
* Side effects:
|
||
* Whatever the command does.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclObjInvoke(
|
||
Tcl_Interp *interp, /* Interpreter in which command is to be
|
||
* invoked. */
|
||
int objc, /* Count of arguments. */
|
||
Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the
|
||
* 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_AppendResult(interp, "illegal argument vector", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if ((flags & TCL_INVOKE_HIDDEN) == 0) {
|
||
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
|
||
}
|
||
|
||
if (TclInterpReady(interp) == TCL_ERROR) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
cmdName = TclGetString(objv[0]);
|
||
hTblPtr = iPtr->hiddenCmdTablePtr;
|
||
if (hTblPtr != NULL) {
|
||
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
|
||
}
|
||
if (hPtr == NULL) {
|
||
Tcl_AppendResult(interp, "invalid hidden command name \"",
|
||
cmdName, "\"", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
cmdPtr = Tcl_GetHashValue(hPtr);
|
||
|
||
/*
|
||
* Invoke the command function.
|
||
*/
|
||
|
||
iPtr->cmdCount++;
|
||
result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
|
||
|
||
/*
|
||
* If an error occurred, record information about what was being executed
|
||
* when the error occurred.
|
||
*/
|
||
|
||
if ((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;
|
||
|
||
Tcl_IncrRefCount(command);
|
||
cmdString = Tcl_GetStringFromObj(command, &length);
|
||
Tcl_LogCommandInfo(interp, cmdString, cmdString, length);
|
||
Tcl_DecrRefCount(command);
|
||
iPtr->flags &= ~ERR_ALREADY_LOGGED;
|
||
}
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*---------------------------------------------------------------------------
|
||
*
|
||
* Tcl_ExprString --
|
||
*
|
||
* Evaluate an expression in a string and return its value in string
|
||
* form.
|
||
*
|
||
* Results:
|
||
* A standard Tcl result. If the result is TCL_OK, then the interp's
|
||
* result is set to the string value of the expression. If the result is
|
||
* TCL_ERROR, then the interp's result contains an error message.
|
||
*
|
||
* Side effects:
|
||
* A Tcl object is allocated to hold a copy of the expression string.
|
||
* This expression object is passed to Tcl_ExprObj and then deallocated.
|
||
*
|
||
*---------------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_ExprString(
|
||
Tcl_Interp *interp, /* Context in which to evaluate the
|
||
* expression. */
|
||
const char *expr) /* Expression to evaluate. */
|
||
{
|
||
int code = TCL_OK;
|
||
|
||
if (expr[0] == '\0') {
|
||
/*
|
||
* An empty string. Just set the interpreter's result to 0.
|
||
*/
|
||
|
||
Tcl_SetResult(interp, "0", TCL_VOLATILE);
|
||
} else {
|
||
Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1);
|
||
|
||
Tcl_IncrRefCount(exprObj);
|
||
code = Tcl_ExprObj(interp, exprObj, &resultPtr);
|
||
Tcl_DecrRefCount(exprObj);
|
||
if (code == TCL_OK) {
|
||
Tcl_SetObjResult(interp, resultPtr);
|
||
Tcl_DecrRefCount(resultPtr);
|
||
}
|
||
|
||
/*
|
||
* Force the string rep of the interp result.
|
||
*/
|
||
|
||
(void) Tcl_GetStringResult(interp);
|
||
}
|
||
return code;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_AppendObjToErrorInfo --
|
||
*
|
||
* Add a Tcl_Obj value to the errorInfo field that describes the current
|
||
* error.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* The value of the Tcl_obj is appended to the errorInfo field. If we are
|
||
* just starting to log an error, errorInfo is initialized from the error
|
||
* message in the interpreter's result.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_AppendObjToErrorInfo(
|
||
Tcl_Interp *interp, /* Interpreter to which error information
|
||
* pertains. */
|
||
Tcl_Obj *objPtr) /* Message to record. */
|
||
{
|
||
int length;
|
||
const char *message = TclGetStringFromObj(objPtr, &length);
|
||
|
||
Tcl_IncrRefCount(objPtr);
|
||
Tcl_AddObjErrorInfo(interp, message, length);
|
||
Tcl_DecrRefCount(objPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_AddErrorInfo --
|
||
*
|
||
* Add information to the errorInfo field that describes the current
|
||
* error.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* The contents of message are appended to the errorInfo field. If we are
|
||
* just starting to log an error, errorInfo is initialized from the error
|
||
* message in the interpreter's result.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_AddErrorInfo(
|
||
Tcl_Interp *interp, /* Interpreter to which error information
|
||
* pertains. */
|
||
const char *message) /* Message to record. */
|
||
{
|
||
Tcl_AddObjErrorInfo(interp, message, -1);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_AddObjErrorInfo --
|
||
*
|
||
* Add information to the errorInfo field that describes the current
|
||
* error. This routine differs from Tcl_AddErrorInfo by taking a byte
|
||
* pointer and length.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* "length" bytes from "message" are appended to the errorInfo field. If
|
||
* "length" is negative, use bytes up to the first NULL byte. If we are
|
||
* just starting to log an error, errorInfo is initialized from the error
|
||
* message in the interpreter's result.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_AddObjErrorInfo(
|
||
Tcl_Interp *interp, /* Interpreter to which error information
|
||
* pertains. */
|
||
const char *message, /* Points to the first byte of an array of
|
||
* bytes of the message. */
|
||
int length) /* The number of bytes in the message. If < 0,
|
||
* then append all bytes up to a NULL byte. */
|
||
{
|
||
register Interp *iPtr = (Interp *) interp;
|
||
|
||
/*
|
||
* If we are just starting to log an error, errorInfo is initialized from
|
||
* the error message in the interpreter's result.
|
||
*/
|
||
|
||
iPtr->flags |= ERR_LEGACY_COPY;
|
||
if (iPtr->errorInfo == NULL) {
|
||
if (iPtr->result[0] != 0) {
|
||
/*
|
||
* The interp's string result is set, apparently by some extension
|
||
* making a deprecated direct write to it. That extension may
|
||
* expect interp->result to continue to be set, so we'll take
|
||
* special pains to avoid clearing it, until we drop support for
|
||
* interp->result completely.
|
||
*/
|
||
|
||
iPtr->errorInfo = Tcl_NewStringObj(interp->result, -1);
|
||
} else {
|
||
iPtr->errorInfo = iPtr->objResultPtr;
|
||
}
|
||
Tcl_IncrRefCount(iPtr->errorInfo);
|
||
if (!iPtr->errorCode) {
|
||
Tcl_SetErrorCode(interp, "NONE", NULL);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Now append "message" to the end of errorInfo.
|
||
*/
|
||
|
||
if (length != 0) {
|
||
if (Tcl_IsShared(iPtr->errorInfo)) {
|
||
Tcl_DecrRefCount(iPtr->errorInfo);
|
||
iPtr->errorInfo = Tcl_DuplicateObj(iPtr->errorInfo);
|
||
Tcl_IncrRefCount(iPtr->errorInfo);
|
||
}
|
||
Tcl_AppendToObj(iPtr->errorInfo, message, length);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*---------------------------------------------------------------------------
|
||
*
|
||
* Tcl_VarEvalVA --
|
||
*
|
||
* Given a variable number of string arguments, concatenate them all
|
||
* together and execute the result as a Tcl command.
|
||
*
|
||
* Results:
|
||
* A standard Tcl return result. An error message or other result may be
|
||
* left in the interp's result.
|
||
*
|
||
* Side effects:
|
||
* Depends on what was done by the command.
|
||
*
|
||
*---------------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_VarEvalVA(
|
||
Tcl_Interp *interp, /* Interpreter in which to evaluate command. */
|
||
va_list argList) /* Variable argument list. */
|
||
{
|
||
Tcl_DString buf;
|
||
char *string;
|
||
int result;
|
||
|
||
/*
|
||
* Copy the strings one after the other into a single larger string. Use
|
||
* stack-allocated space for small commands, but if the command gets too
|
||
* large than call ckalloc to create the space.
|
||
*/
|
||
|
||
Tcl_DStringInit(&buf);
|
||
while (1) {
|
||
string = va_arg(argList, char *);
|
||
if (string == NULL) {
|
||
break;
|
||
}
|
||
Tcl_DStringAppend(&buf, string, -1);
|
||
}
|
||
|
||
result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
|
||
Tcl_DStringFree(&buf);
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_VarEval --
|
||
*
|
||
* Given a variable number of string arguments, concatenate them all
|
||
* together and execute the result as a Tcl command.
|
||
*
|
||
* Results:
|
||
* A standard Tcl return result. An error message or other result may be
|
||
* left in interp->result.
|
||
*
|
||
* Side effects:
|
||
* Depends on what was done by the command.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
/* ARGSUSED */
|
||
int
|
||
Tcl_VarEval(
|
||
Tcl_Interp *interp,
|
||
...)
|
||
{
|
||
va_list argList;
|
||
int result;
|
||
|
||
va_start(argList, interp);
|
||
result = Tcl_VarEvalVA(interp, argList);
|
||
va_end(argList);
|
||
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GlobalEval --
|
||
*
|
||
* Evaluate a command at global level in an interpreter.
|
||
*
|
||
* Results:
|
||
* A standard Tcl result is returned, and the interp's result is modified
|
||
* accordingly.
|
||
*
|
||
* Side effects:
|
||
* The command string is executed in interp, and the execution is carried
|
||
* out in the variable context of global level (no functions active),
|
||
* just as if an "uplevel #0" command were being executed.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_GlobalEval(
|
||
Tcl_Interp *interp, /* Interpreter in which to evaluate command. */
|
||
const char *command) /* Command to evaluate. */
|
||
{
|
||
register Interp *iPtr = (Interp *) interp;
|
||
int result;
|
||
CallFrame *savedVarFramePtr;
|
||
|
||
savedVarFramePtr = iPtr->varFramePtr;
|
||
iPtr->varFramePtr = iPtr->rootFramePtr;
|
||
result = Tcl_Eval(interp, command);
|
||
iPtr->varFramePtr = savedVarFramePtr;
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_SetRecursionLimit --
|
||
*
|
||
* Set the maximum number of recursive calls that may be active for an
|
||
* interpreter at once.
|
||
*
|
||
* Results:
|
||
* The return value is the old limit on nesting for interp.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Tcl_SetRecursionLimit(
|
||
Tcl_Interp *interp, /* Interpreter whose nesting limit is to be
|
||
* set. */
|
||
int depth) /* New value for maximimum depth. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
int old;
|
||
|
||
old = iPtr->maxNestingDepth;
|
||
if (depth > 0) {
|
||
iPtr->maxNestingDepth = depth;
|
||
}
|
||
return old;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_AllowExceptions --
|
||
*
|
||
* Sets a flag in an interpreter so that exceptions can occur in the next
|
||
* call to Tcl_Eval without them being turned into errors.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's evalFlags
|
||
* structure. See the reference documentation for more details.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_AllowExceptions(
|
||
Tcl_Interp *interp) /* Interpreter in which to set flag. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
|
||
iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tcl_GetVersion --
|
||
*
|
||
* Get the Tcl major, minor, and patchlevel version numbers and the
|
||
* release type. A patch is a release type TCL_FINAL_RELEASE with a
|
||
* patchLevel > 0.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
Tcl_GetVersion(
|
||
int *majorV,
|
||
int *minorV,
|
||
int *patchLevelV,
|
||
int *type)
|
||
{
|
||
if (majorV != NULL) {
|
||
*majorV = TCL_MAJOR_VERSION;
|
||
}
|
||
if (minorV != NULL) {
|
||
*minorV = TCL_MINOR_VERSION;
|
||
}
|
||
if (patchLevelV != NULL) {
|
||
*patchLevelV = TCL_RELEASE_SERIAL;
|
||
}
|
||
if (type != NULL) {
|
||
*type = TCL_RELEASE_LEVEL;
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Math Functions --
|
||
*
|
||
* This page contains the functions that implement all of the built-in
|
||
* math functions for expressions.
|
||
*
|
||
* Results:
|
||
* Each function returns TCL_OK if it succeeds and pushes an Tcl object
|
||
* holding the result. If it fails it returns TCL_ERROR and leaves an
|
||
* error message in the interpreter's result.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ExprCeilFunc(
|
||
ClientData clientData, /* Ignored */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Actual parameter list. */
|
||
{
|
||
int code;
|
||
double d;
|
||
mp_int big;
|
||
|
||
if (objc != 2) {
|
||
MathFuncWrongNumArgs(interp, 2, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
|
||
#ifdef ACCEPT_NAN
|
||
if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
|
||
Tcl_SetObjResult(interp, objv[1]);
|
||
return TCL_OK;
|
||
}
|
||
#endif
|
||
if (code != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
|
||
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big)));
|
||
mp_clear(&big);
|
||
} else {
|
||
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
static int
|
||
ExprFloorFunc(
|
||
ClientData clientData, /* Ignored */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Actual parameter list. */
|
||
{
|
||
int code;
|
||
double d;
|
||
mp_int big;
|
||
|
||
if (objc != 2) {
|
||
MathFuncWrongNumArgs(interp, 2, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
|
||
#ifdef ACCEPT_NAN
|
||
if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
|
||
Tcl_SetObjResult(interp, objv[1]);
|
||
return TCL_OK;
|
||
}
|
||
#endif
|
||
if (code != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
|
||
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big)));
|
||
mp_clear(&big);
|
||
} else {
|
||
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
static int
|
||
ExprIsqrtFunc(
|
||
ClientData clientData, /* Ignored */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Actual parameter list. */
|
||
{
|
||
ClientData ptr;
|
||
int type;
|
||
double d;
|
||
Tcl_WideInt w;
|
||
mp_int big;
|
||
int exact = 0; /* Flag == 1 if the argument can be
|
||
* represented in a double as an exact
|
||
* integer. */
|
||
|
||
/*
|
||
* Check syntax.
|
||
*/
|
||
|
||
if (objc != 2) {
|
||
MathFuncWrongNumArgs(interp, 2, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Make sure that the arg is a number.
|
||
*/
|
||
|
||
if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
switch (type) {
|
||
case TCL_NUMBER_NAN:
|
||
Tcl_GetDoubleFromObj(interp, objv[1], &d);
|
||
return TCL_ERROR;
|
||
case TCL_NUMBER_DOUBLE:
|
||
d = *((const double *) ptr);
|
||
if (d < 0) {
|
||
goto negarg;
|
||
}
|
||
#ifdef IEEE_FLOATING_POINT
|
||
if (d <= MAX_EXACT) {
|
||
exact = 1;
|
||
}
|
||
#endif
|
||
if (!exact) {
|
||
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
break;
|
||
case TCL_NUMBER_BIG:
|
||
if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (SIGN(&big) == MP_NEG) {
|
||
mp_clear(&big);
|
||
goto negarg;
|
||
}
|
||
break;
|
||
default:
|
||
if (Tcl_GetWideIntFromObj(interp, objv[1], &w) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (w < 0) {
|
||
goto negarg;
|
||
}
|
||
d = (double) w;
|
||
#ifdef IEEE_FLOATING_POINT
|
||
if (d < MAX_EXACT) {
|
||
exact = 1;
|
||
}
|
||
#endif
|
||
if (!exact) {
|
||
Tcl_GetBignumFromObj(interp, objv[1], &big);
|
||
}
|
||
break;
|
||
}
|
||
|
||
if (exact) {
|
||
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d)));
|
||
} else {
|
||
mp_int root;
|
||
|
||
mp_init(&root);
|
||
mp_sqrt(&big, &root);
|
||
mp_clear(&big);
|
||
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
|
||
}
|
||
|
||
return TCL_OK;
|
||
|
||
negarg:
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj("square root of negative argument", -1));
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
static int
|
||
ExprSqrtFunc(
|
||
ClientData clientData, /* Ignored */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Actual parameter list. */
|
||
{
|
||
int code;
|
||
double d;
|
||
mp_int big;
|
||
|
||
if (objc != 2) {
|
||
MathFuncWrongNumArgs(interp, 2, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
|
||
#ifdef ACCEPT_NAN
|
||
if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
|
||
Tcl_SetObjResult(interp, objv[1]);
|
||
return TCL_OK;
|
||
}
|
||
#endif
|
||
if (code != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
if ((d >= 0.0) && TclIsInfinite(d)
|
||
&& (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) {
|
||
mp_int root;
|
||
|
||
mp_init(&root);
|
||
mp_sqrt(&big, &root);
|
||
mp_clear(&big);
|
||
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root)));
|
||
mp_clear(&root);
|
||
} else {
|
||
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d)));
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
static int
|
||
ExprUnaryFunc(
|
||
ClientData clientData, /* Contains the address of a function that
|
||
* takes one double argument and returns a
|
||
* double result. */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count */
|
||
Tcl_Obj *const *objv) /* Actual parameter list */
|
||
{
|
||
int code;
|
||
double d;
|
||
double (*func)(double) = (double (*)(double)) clientData;
|
||
|
||
if (objc != 2) {
|
||
MathFuncWrongNumArgs(interp, 2, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
|
||
#ifdef ACCEPT_NAN
|
||
if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
|
||
d = objv[1]->internalRep.doubleValue;
|
||
Tcl_ResetResult(interp);
|
||
code = TCL_OK;
|
||
}
|
||
#endif
|
||
if (code != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
errno = 0;
|
||
return CheckDoubleResult(interp, (*func)(d));
|
||
}
|
||
|
||
static int
|
||
CheckDoubleResult(
|
||
Tcl_Interp *interp,
|
||
double dResult)
|
||
{
|
||
#ifndef ACCEPT_NAN
|
||
if (TclIsNaN(dResult)) {
|
||
TclExprFloatError(interp, dResult);
|
||
return TCL_ERROR;
|
||
}
|
||
#endif
|
||
if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) {
|
||
/*
|
||
* When ERANGE signals under/overflow, just accept 0.0 or +/-Inf
|
||
*/
|
||
} else if (errno != 0) {
|
||
/*
|
||
* Report other errno values as errors.
|
||
*/
|
||
|
||
TclExprFloatError(interp, dResult);
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
|
||
return TCL_OK;
|
||
}
|
||
|
||
static int
|
||
ExprBinaryFunc(
|
||
ClientData clientData, /* Contains the address of a function that
|
||
* takes two double arguments and returns a
|
||
* double result. */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Parameter vector. */
|
||
{
|
||
int code;
|
||
double d1, d2;
|
||
double (*func)(double, double) = (double (*)(double, double)) clientData;
|
||
|
||
if (objc != 3) {
|
||
MathFuncWrongNumArgs(interp, 3, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
|
||
#ifdef ACCEPT_NAN
|
||
if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
|
||
d1 = objv[1]->internalRep.doubleValue;
|
||
Tcl_ResetResult(interp);
|
||
code = TCL_OK;
|
||
}
|
||
#endif
|
||
if (code != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
|
||
#ifdef ACCEPT_NAN
|
||
if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) {
|
||
d2 = objv[2]->internalRep.doubleValue;
|
||
Tcl_ResetResult(interp);
|
||
code = TCL_OK;
|
||
}
|
||
#endif
|
||
if (code != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
errno = 0;
|
||
return CheckDoubleResult(interp, (*func)(d1, d2));
|
||
}
|
||
|
||
static int
|
||
ExprAbsFunc(
|
||
ClientData clientData, /* Ignored. */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Parameter vector. */
|
||
{
|
||
ClientData ptr;
|
||
int type;
|
||
mp_int big;
|
||
|
||
if (objc != 2) {
|
||
MathFuncWrongNumArgs(interp, 2, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (type == TCL_NUMBER_LONG) {
|
||
long l = *((const long *) ptr);
|
||
|
||
if (l > (long)0) {
|
||
goto unChanged;
|
||
} else if (l == (long)0) {
|
||
const char *string = objv[1]->bytes;
|
||
if (string) {
|
||
while (*string != '0') {
|
||
if (*string == '-') {
|
||
Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
|
||
return TCL_OK;
|
||
}
|
||
string++;
|
||
}
|
||
}
|
||
goto unChanged;
|
||
} else if (l == LONG_MIN) {
|
||
TclBNInitBignumFromLong(&big, l);
|
||
goto tooLarge;
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewLongObj(-l));
|
||
return TCL_OK;
|
||
}
|
||
|
||
if (type == TCL_NUMBER_DOUBLE) {
|
||
double d = *((const double *) ptr);
|
||
static const double poszero = 0.0;
|
||
|
||
/* We need to distinguish here between positive 0.0 and
|
||
* negative -0.0, see Bug ID #2954959.
|
||
*/
|
||
if (d == -0.0) {
|
||
if (!memcmp(&d, &poszero, sizeof(double))) {
|
||
goto unChanged;
|
||
}
|
||
} else {
|
||
if (d > -0.0) {
|
||
goto unChanged;
|
||
}
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d));
|
||
return TCL_OK;
|
||
}
|
||
|
||
#ifndef NO_WIDE_TYPE
|
||
if (type == TCL_NUMBER_WIDE) {
|
||
Tcl_WideInt w = *((const Tcl_WideInt *) ptr);
|
||
|
||
if (w >= (Tcl_WideInt)0) {
|
||
goto unChanged;
|
||
}
|
||
if (w == LLONG_MIN) {
|
||
TclBNInitBignumFromWideInt(&big, w);
|
||
goto tooLarge;
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w));
|
||
return TCL_OK;
|
||
}
|
||
#endif
|
||
|
||
if (type == TCL_NUMBER_BIG) {
|
||
/* TODO: const correctness ? */
|
||
if (mp_cmp_d((mp_int *) ptr, 0) == MP_LT) {
|
||
Tcl_GetBignumFromObj(NULL, objv[1], &big);
|
||
tooLarge:
|
||
mp_neg(&big, &big);
|
||
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
|
||
} else {
|
||
unChanged:
|
||
Tcl_SetObjResult(interp, objv[1]);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
if (type == TCL_NUMBER_NAN) {
|
||
#ifdef ACCEPT_NAN
|
||
Tcl_SetObjResult(interp, objv[1]);
|
||
return TCL_OK;
|
||
#else
|
||
double d;
|
||
Tcl_GetDoubleFromObj(interp, objv[1], &d);
|
||
return TCL_ERROR;
|
||
#endif
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
static int
|
||
ExprBoolFunc(
|
||
ClientData clientData, /* Ignored. */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Actual parameter vector. */
|
||
{
|
||
int value;
|
||
|
||
if (objc != 2) {
|
||
MathFuncWrongNumArgs(interp, 2, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tcl_GetBooleanFromObj(interp, objv[1], &value) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
|
||
return TCL_OK;
|
||
}
|
||
|
||
static int
|
||
ExprDoubleFunc(
|
||
ClientData clientData, /* Ignored. */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Actual parameter vector. */
|
||
{
|
||
double dResult;
|
||
if (objc != 2) {
|
||
MathFuncWrongNumArgs(interp, 2, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
|
||
#ifdef ACCEPT_NAN
|
||
if (objv[1]->typePtr == &tclDoubleType) {
|
||
Tcl_SetObjResult(interp, objv[1]);
|
||
return TCL_OK;
|
||
}
|
||
#endif
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
|
||
return TCL_OK;
|
||
}
|
||
|
||
static int
|
||
ExprEntierFunc(
|
||
ClientData clientData, /* Ignored. */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Actual parameter vector. */
|
||
{
|
||
double d;
|
||
int type;
|
||
ClientData ptr;
|
||
|
||
if (objc != 2) {
|
||
MathFuncWrongNumArgs(interp, 2, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (type == TCL_NUMBER_DOUBLE) {
|
||
d = *((const double *) ptr);
|
||
if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) {
|
||
mp_int big;
|
||
|
||
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
|
||
/* Infinity */
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
|
||
return TCL_OK;
|
||
} else {
|
||
long result = (long) d;
|
||
|
||
Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
|
||
return TCL_OK;
|
||
}
|
||
}
|
||
|
||
if (type != TCL_NUMBER_NAN) {
|
||
/*
|
||
* All integers are already of integer type.
|
||
*/
|
||
|
||
Tcl_SetObjResult(interp, objv[1]);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* Get the error message for NaN.
|
||
*/
|
||
|
||
Tcl_GetDoubleFromObj(interp, objv[1], &d);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
static int
|
||
ExprIntFunc(
|
||
ClientData clientData, /* Ignored. */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Actual parameter vector. */
|
||
{
|
||
long iResult;
|
||
Tcl_Obj *objPtr;
|
||
if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
objPtr = Tcl_GetObjResult(interp);
|
||
if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
|
||
/*
|
||
* Truncate the bignum; keep only bits in long range.
|
||
*/
|
||
|
||
mp_int big;
|
||
|
||
Tcl_GetBignumFromObj(NULL, objPtr, &big);
|
||
mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
|
||
objPtr = Tcl_NewBignumObj(&big);
|
||
Tcl_IncrRefCount(objPtr);
|
||
TclGetLongFromObj(NULL, objPtr, &iResult);
|
||
Tcl_DecrRefCount(objPtr);
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult));
|
||
return TCL_OK;
|
||
}
|
||
|
||
static int
|
||
ExprWideFunc(
|
||
ClientData clientData, /* Ignored. */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Actual parameter vector. */
|
||
{
|
||
Tcl_WideInt wResult;
|
||
Tcl_Obj *objPtr;
|
||
if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
objPtr = Tcl_GetObjResult(interp);
|
||
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
|
||
/*
|
||
* Truncate the bignum; keep only bits in wide int range.
|
||
*/
|
||
|
||
mp_int big;
|
||
|
||
Tcl_GetBignumFromObj(NULL, objPtr, &big);
|
||
mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
|
||
objPtr = Tcl_NewBignumObj(&big);
|
||
Tcl_IncrRefCount(objPtr);
|
||
Tcl_GetWideIntFromObj(NULL, objPtr, &wResult);
|
||
Tcl_DecrRefCount(objPtr);
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
|
||
return TCL_OK;
|
||
}
|
||
|
||
static int
|
||
ExprRandFunc(
|
||
ClientData clientData, /* Ignored. */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Actual parameter vector. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
double dResult;
|
||
long tmp; /* Algorithm assumes at least 32 bits. Only
|
||
* long guarantees that. See below. */
|
||
Tcl_Obj *oResult;
|
||
|
||
if (objc != 1) {
|
||
MathFuncWrongNumArgs(interp, 1, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
|
||
iPtr->flags |= RAND_SEED_INITIALIZED;
|
||
|
||
/*
|
||
* Take into consideration the thread this interp is running in order
|
||
* to insure different seeds in different threads (bug #416643)
|
||
*/
|
||
|
||
iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12);
|
||
|
||
/*
|
||
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
|
||
*/
|
||
|
||
iPtr->randSeed &= (unsigned long) 0x7fffffff;
|
||
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
|
||
iPtr->randSeed ^= 123459876;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Generate the random number using the linear congruential generator
|
||
* defined by the following recurrence:
|
||
* seed = ( IA * seed ) mod IM
|
||
* where IA is 16807 and IM is (2^31) - 1. The recurrence maps a seed in
|
||
* the range [1, IM - 1] to a new seed in that same range. The recurrence
|
||
* maps IM to 0, and maps 0 back to 0, so those two values must not be
|
||
* allowed as initial values of seed.
|
||
*
|
||
* In order to avoid potential problems with integer overflow, the
|
||
* recurrence is implemented in terms of additional constants IQ and IR
|
||
* such that
|
||
* IM = IA*IQ + IR
|
||
* None of the operations in the implementation overflows a 32-bit signed
|
||
* integer, and the C type long is guaranteed to be at least 32 bits wide.
|
||
*
|
||
* For more details on how this algorithm works, refer to the following
|
||
* papers:
|
||
*
|
||
* S.K. Park & K.W. Miller, "Random number generators: good ones are hard
|
||
* to find," Comm ACM 31(10):1192-1201, Oct 1988
|
||
*
|
||
* W.H. Press & S.A. Teukolsky, "Portable random number generators,"
|
||
* Computers in Physics 6(5):522-524, Sep/Oct 1992.
|
||
*/
|
||
|
||
#define RAND_IA 16807
|
||
#define RAND_IM 2147483647
|
||
#define RAND_IQ 127773
|
||
#define RAND_IR 2836
|
||
#define RAND_MASK 123459876
|
||
|
||
tmp = iPtr->randSeed/RAND_IQ;
|
||
iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
|
||
if (iPtr->randSeed < 0) {
|
||
iPtr->randSeed += RAND_IM;
|
||
}
|
||
|
||
/*
|
||
* Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
|
||
* dividing by RAND_IM yields a double in the range (0, 1).
|
||
*/
|
||
|
||
dResult = iPtr->randSeed * (1.0/RAND_IM);
|
||
|
||
/*
|
||
* Push a Tcl object with the result.
|
||
*/
|
||
|
||
TclNewDoubleObj(oResult, dResult);
|
||
Tcl_SetObjResult(interp, oResult);
|
||
return TCL_OK;
|
||
}
|
||
|
||
static int
|
||
ExprRoundFunc(
|
||
ClientData clientData, /* Ignored. */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Parameter vector. */
|
||
{
|
||
double d;
|
||
ClientData ptr;
|
||
int type;
|
||
|
||
if (objc != 2) {
|
||
MathFuncWrongNumArgs(interp, 2, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (type == TCL_NUMBER_DOUBLE) {
|
||
double fractPart, intPart;
|
||
long max = LONG_MAX, min = LONG_MIN;
|
||
|
||
fractPart = modf(*((const double *) ptr), &intPart);
|
||
if (fractPart <= -0.5) {
|
||
min++;
|
||
} else if (fractPart >= 0.5) {
|
||
max--;
|
||
}
|
||
if ((intPart >= (double)max) || (intPart <= (double)min)) {
|
||
mp_int big;
|
||
|
||
if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) {
|
||
/* Infinity */
|
||
return TCL_ERROR;
|
||
}
|
||
if (fractPart <= -0.5) {
|
||
mp_sub_d(&big, 1, &big);
|
||
} else if (fractPart >= 0.5) {
|
||
mp_add_d(&big, 1, &big);
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
|
||
return TCL_OK;
|
||
} else {
|
||
long result = (long)intPart;
|
||
|
||
if (fractPart <= -0.5) {
|
||
result--;
|
||
} else if (fractPart >= 0.5) {
|
||
result++;
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
|
||
return TCL_OK;
|
||
}
|
||
}
|
||
|
||
if (type != TCL_NUMBER_NAN) {
|
||
/*
|
||
* All integers are already rounded
|
||
*/
|
||
|
||
Tcl_SetObjResult(interp, objv[1]);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* Get the error message for NaN.
|
||
*/
|
||
|
||
Tcl_GetDoubleFromObj(interp, objv[1], &d);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
static int
|
||
ExprSrandFunc(
|
||
ClientData clientData, /* Ignored. */
|
||
Tcl_Interp *interp, /* The interpreter in which to execute the
|
||
* function. */
|
||
int objc, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Parameter vector. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
long i = 0; /* Initialized to avoid compiler warning. */
|
||
|
||
/*
|
||
* Convert argument and use it to reset the seed.
|
||
*/
|
||
|
||
if (objc != 2) {
|
||
MathFuncWrongNumArgs(interp, 2, objc, objv);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) {
|
||
Tcl_Obj *objPtr;
|
||
mp_int big;
|
||
|
||
if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
|
||
/* TODO: more ::errorInfo here? or in caller? */
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
|
||
objPtr = Tcl_NewBignumObj(&big);
|
||
Tcl_IncrRefCount(objPtr);
|
||
TclGetLongFromObj(NULL, objPtr, &i);
|
||
Tcl_DecrRefCount(objPtr);
|
||
}
|
||
|
||
/*
|
||
* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in
|
||
* ExprRandFunc() for more details.
|
||
*/
|
||
|
||
iPtr->flags |= RAND_SEED_INITIALIZED;
|
||
iPtr->randSeed = i;
|
||
iPtr->randSeed &= (unsigned long) 0x7fffffff;
|
||
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
|
||
iPtr->randSeed ^= 123459876;
|
||
}
|
||
|
||
/*
|
||
* To avoid duplicating the random number generation code we simply clean
|
||
* up our state and call the real random number function. That function
|
||
* will always succeed.
|
||
*/
|
||
|
||
return ExprRandFunc(clientData, interp, 1, objv);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* MathFuncWrongNumArgs --
|
||
*
|
||
* Generate an error message when a math function presents the wrong
|
||
* number of arguments.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* An error message is stored in the interpreter result.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
MathFuncWrongNumArgs(
|
||
Tcl_Interp *interp, /* Tcl interpreter */
|
||
int expected, /* Formal parameter count. */
|
||
int found, /* Actual parameter count. */
|
||
Tcl_Obj *const *objv) /* Actual parameter vector. */
|
||
{
|
||
const char *name = Tcl_GetString(objv[0]);
|
||
const char *tail = name + strlen(name);
|
||
|
||
while (tail > name+1) {
|
||
--tail;
|
||
if (*tail == ':' && tail[-1] == ':') {
|
||
name = tail+1;
|
||
break;
|
||
}
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||
"too %s arguments for math function \"%s\"",
|
||
(found < expected ? "few" : "many"), name));
|
||
}
|
||
#ifdef USE_DTRACE
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* DTraceObjCmd --
|
||
*
|
||
* This function is invoked to process the "::tcl::dtrace" Tcl command.
|
||
*
|
||
* Results:
|
||
* A standard Tcl object result.
|
||
*
|
||
* Side effects:
|
||
* The 'tcl-probe' DTrace probe is triggered (if it is enabled).
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
DTraceObjCmd(
|
||
ClientData dummy, /* Not used. */
|
||
Tcl_Interp *interp, /* Current interpreter. */
|
||
int objc, /* Number of arguments. */
|
||
Tcl_Obj *const objv[]) /* Argument objects. */
|
||
{
|
||
if (TCL_DTRACE_TCL_PROBE_ENABLED()) {
|
||
char *a[10];
|
||
int i = 0;
|
||
|
||
while (i++ < 10) {
|
||
a[i-1] = i < objc ? TclGetString(objv[i]) : NULL;
|
||
}
|
||
TCL_DTRACE_TCL_PROBE(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
|
||
a[8], a[9]);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclDTraceInfo --
|
||
*
|
||
* Extract information from a TIP280 dict for use by DTrace probes.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
TclDTraceInfo(
|
||
Tcl_Obj *info,
|
||
char **args,
|
||
int *argsi)
|
||
{
|
||
static Tcl_Obj *keys[7] = { NULL };
|
||
Tcl_Obj **k = keys, *val;
|
||
int i;
|
||
|
||
if (!*k) {
|
||
TclNewLiteralStringObj(keys[0], "cmd");
|
||
TclNewLiteralStringObj(keys[1], "type");
|
||
TclNewLiteralStringObj(keys[2], "proc");
|
||
TclNewLiteralStringObj(keys[3], "file");
|
||
TclNewLiteralStringObj(keys[4], "lambda");
|
||
TclNewLiteralStringObj(keys[5], "line");
|
||
TclNewLiteralStringObj(keys[6], "level");
|
||
}
|
||
for (i = 0; i < 4; i++) {
|
||
Tcl_DictObjGet(NULL, info, *k++, &val);
|
||
args[i] = val ? TclGetString(val) : NULL;
|
||
}
|
||
if (!args[2]) {
|
||
Tcl_DictObjGet(NULL, info, *k, &val);
|
||
args[2] = val ? TclGetString(val) : NULL;
|
||
}
|
||
k++;
|
||
for (i = 0; i < 2; i++) {
|
||
Tcl_DictObjGet(NULL, info, *k++, &val);
|
||
if (val) {
|
||
TclGetIntFromObj(NULL, val, &(argsi[i]));
|
||
} else {
|
||
argsi[i] = 0;
|
||
}
|
||
}
|
||
}
|
||
|
||
TCL_DTRACE_DEBUG_LOG()
|
||
|
||
#endif /* USE_DTRACE */
|
||
|
||
/*
|
||
* Local Variables:
|
||
* mode: c
|
||
* c-basic-offset: 4
|
||
* fill-column: 78
|
||
* End:
|
||
*/
|