Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2018 Conference, Houston/TX, US, Oct 15-19
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Aug 20.

Artifact 6f1e1e3358c10b4f8a6c06abc6d7e22ff538dc27:


     1  /*
     2   * tclBasic.c --
     3   *
     4   *	Contains the basic facilities for TCL command interpretation,
     5   *	including interpreter creation and deletion, command creation and
     6   *	deletion, and command/script execution.
     7   *
     8   * Copyright (c) 1987-1994 The Regents of the University of California.
     9   * Copyright (c) 1994-1997 Sun Microsystems, Inc.
    10   * Copyright (c) 1998-1999 by Scriptics Corporation.
    11   * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
    12   * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
    13   * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
    14   * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net>
    15   *
    16   * See the file "license.terms" for information on usage and redistribution of
    17   * this file, and for a DISCLAIMER OF ALL WARRANTIES.
    18   */
    19  
    20  #include "tclInt.h"
    21  #include "tclOOInt.h"
    22  #include "tclCompile.h"
    23  #include "tommath.h"
    24  #include <math.h>
    25  
    26  #if NRE_ENABLE_ASSERTS
    27  #include <assert.h>
    28  #endif
    29  
    30  #define INTERP_STACK_INITIAL_SIZE 2000
    31  #define CORO_STACK_INITIAL_SIZE    200
    32  
    33  /*
    34   * Determine whether we're using IEEE floating point
    35   */
    36  
    37  #if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024)
    38  #   define IEEE_FLOATING_POINT
    39  /* Largest odd integer that can be represented exactly in a double */
    40  #   define MAX_EXACT 9007199254740991.0
    41  #endif
    42  
    43  /*
    44   * The following structure defines the client data for a math function
    45   * registered with Tcl_CreateMathFunc
    46   */
    47  
    48  typedef struct OldMathFuncData {
    49      Tcl_MathProc *proc;		/* Handler function */
    50      int numArgs;		/* Number of args expected */
    51      Tcl_ValueType *argTypes;	/* Types of the args */
    52      ClientData clientData;	/* Client data for the handler function */
    53  } OldMathFuncData;
    54  
    55  /*
    56   * This is the script cancellation struct and hash table. The hash table is
    57   * used to keep track of the information necessary to process script
    58   * cancellation requests, including the original interp, asynchronous handler
    59   * tokens (created by Tcl_AsyncCreate), and the clientData and flags arguments
    60   * passed to Tcl_CancelEval on a per-interp basis. The cancelLock mutex is
    61   * used for protecting calls to Tcl_CancelEval as well as protecting access to
    62   * the hash table below.
    63   */
    64  
    65  typedef struct {
    66      Tcl_Interp *interp;		/* Interp this struct belongs to. */
    67      Tcl_AsyncHandler async;	/* Async handler token for script
    68  				 * cancellation. */
    69      char *result;		/* The script cancellation result or NULL for
    70  				 * a default result. */
    71      int length;			/* Length of the above error message. */
    72      ClientData clientData;	/* Ignored */
    73      int flags;			/* Additional flags */
    74  } CancelInfo;
    75  static Tcl_HashTable cancelTable;
    76  static int cancelTableInitialized = 0;	/* 0 means not yet initialized. */
    77  TCL_DECLARE_MUTEX(cancelLock)
    78  
    79  /*
    80   * Declarations for managing contexts for non-recursive coroutines. Contexts
    81   * are used to save the evaluation state between NR calls to each coro.
    82   */
    83  
    84  #define SAVE_CONTEXT(context)				\
    85      (context).framePtr = iPtr->framePtr;		\
    86      (context).varFramePtr = iPtr->varFramePtr;		\
    87      (context).cmdFramePtr = iPtr->cmdFramePtr;		\
    88      (context).lineLABCPtr = iPtr->lineLABCPtr
    89  
    90  #define RESTORE_CONTEXT(context)			\
    91      iPtr->framePtr = (context).framePtr;		\
    92      iPtr->varFramePtr = (context).varFramePtr;		\
    93      iPtr->cmdFramePtr = (context).cmdFramePtr;		\
    94      iPtr->lineLABCPtr = (context).lineLABCPtr
    95  
    96  /*
    97   * Static functions in this file:
    98   */
    99  
   100  static char *		CallCommandTraces(Interp *iPtr, Command *cmdPtr,
   101  			    const char *oldName, const char *newName,
   102  			    int flags);
   103  static int		CancelEvalProc(ClientData clientData,
   104  			    Tcl_Interp *interp, int code);
   105  static int		CheckDoubleResult(Tcl_Interp *interp, double dResult);
   106  static void		DeleteCoroutine(ClientData clientData);
   107  static void		DeleteInterpProc(Tcl_Interp *interp);
   108  static void		DeleteOpCmdClientData(ClientData clientData);
   109  #ifdef USE_DTRACE
   110  static Tcl_ObjCmdProc	DTraceObjCmd;
   111  static Tcl_NRPostProc	DTraceCmdReturn;
   112  #else
   113  #   define DTraceCmdReturn	NULL
   114  #endif /* USE_DTRACE */
   115  static Tcl_ObjCmdProc	ExprAbsFunc;
   116  static Tcl_ObjCmdProc	ExprBinaryFunc;
   117  static Tcl_ObjCmdProc	ExprBoolFunc;
   118  static Tcl_ObjCmdProc	ExprCeilFunc;
   119  static Tcl_ObjCmdProc	ExprDoubleFunc;
   120  static Tcl_ObjCmdProc	ExprEntierFunc;
   121  static Tcl_ObjCmdProc	ExprFloorFunc;
   122  static Tcl_ObjCmdProc	ExprIntFunc;
   123  static Tcl_ObjCmdProc	ExprIsqrtFunc;
   124  static Tcl_ObjCmdProc	ExprRandFunc;
   125  static Tcl_ObjCmdProc	ExprRoundFunc;
   126  static Tcl_ObjCmdProc	ExprSqrtFunc;
   127  static Tcl_ObjCmdProc	ExprSrandFunc;
   128  static Tcl_ObjCmdProc	ExprUnaryFunc;
   129  static Tcl_ObjCmdProc	ExprWideFunc;
   130  static void		MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
   131  			    int actual, Tcl_Obj *const *objv);
   132  static Tcl_NRPostProc	NRCoroutineCallerCallback;
   133  static Tcl_NRPostProc	NRCoroutineExitCallback;
   134  static int NRCommand(ClientData data[], Tcl_Interp *interp, int result);
   135  
   136  static Tcl_ObjCmdProc	OldMathFuncProc;
   137  static void		OldMathFuncDeleteProc(ClientData clientData);
   138  static void		ProcessUnexpectedResult(Tcl_Interp *interp,
   139  			    int returnCode);
   140  static int		RewindCoroutine(CoroutineData *corPtr, int result);
   141  static void		TEOV_SwitchVarFrame(Tcl_Interp *interp);
   142  static void		TEOV_PushExceptionHandlers(Tcl_Interp *interp,
   143  			    int objc, Tcl_Obj *const objv[], int flags);
   144  static inline Command *	TEOV_LookupCmdFromObj(Tcl_Interp *interp,
   145  			    Tcl_Obj *namePtr, Namespace *lookupNsPtr);
   146  static int		TEOV_NotFound(Tcl_Interp *interp, int objc,
   147  			    Tcl_Obj *const objv[], Namespace *lookupNsPtr);
   148  static int		TEOV_RunEnterTraces(Tcl_Interp *interp,
   149  			    Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc,
   150  			    Tcl_Obj *const objv[]);
   151  static Tcl_NRPostProc	RewindCoroutineCallback;
   152  static Tcl_NRPostProc	TailcallCleanup;
   153  static Tcl_NRPostProc	TEOEx_ByteCodeCallback;
   154  static Tcl_NRPostProc	TEOEx_ListCallback;
   155  static Tcl_NRPostProc	TEOV_Error;
   156  static Tcl_NRPostProc	TEOV_Exception;
   157  static Tcl_NRPostProc	TEOV_NotFoundCallback;
   158  static Tcl_NRPostProc	TEOV_RestoreVarFrame;
   159  static Tcl_NRPostProc	TEOV_RunLeaveTraces;
   160  static Tcl_NRPostProc	EvalObjvCore;
   161  static Tcl_NRPostProc	Dispatch;
   162  
   163  static Tcl_ObjCmdProc NRCoroInjectObjCmd;
   164  static Tcl_NRPostProc NRPostInvoke;
   165  
   166  MODULE_SCOPE const TclStubs tclStubs;
   167  
   168  /*
   169   * Magical counts for the number of arguments accepted by a coroutine command
   170   * after particular kinds of [yield].
   171   */
   172  
   173  #define CORO_ACTIVATE_YIELD    PTR2INT(NULL)
   174  #define CORO_ACTIVATE_YIELDM   PTR2INT(NULL)+1
   175  
   176  #define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL     (-1)
   177  #define COROUTINE_ARGUMENTS_ARBITRARY           (-2)
   178  
   179  /*
   180   * The following structure define the commands in the Tcl core.
   181   */
   182  
   183  typedef struct {
   184      const char *name;		/* Name of object-based command. */
   185      Tcl_ObjCmdProc *objProc;	/* Object-based function for command. */
   186      CompileProc *compileProc;	/* Function called to compile command. */
   187      Tcl_ObjCmdProc *nreProc;	/* NR-based function for command */
   188      int flags;			/* Various flag bits, as defined below. */
   189  } CmdInfo;
   190  
   191  #define CMD_IS_SAFE         1   /* Whether this command is part of the set of
   192                                   * commands present by default in a safe
   193                                   * interpreter. */
   194  /* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle
   195   * expansion for itself rather than needing the generic layer to take care of
   196   * it for it. Defined in tclInt.h. */
   197  
   198  /*
   199   * The built-in commands, and the functions that implement them:
   200   */
   201  
   202  static const CmdInfo builtInCmds[] = {
   203      /*
   204       * Commands in the generic core.
   205       */
   206  
   207      {"append",		Tcl_AppendObjCmd,	TclCompileAppendCmd,	NULL,	CMD_IS_SAFE},
   208      {"apply",		Tcl_ApplyObjCmd,	NULL,			TclNRApplyObjCmd,	CMD_IS_SAFE},
   209      {"break",		Tcl_BreakObjCmd,	TclCompileBreakCmd,	NULL,	CMD_IS_SAFE},
   210  #ifndef EXCLUDE_OBSOLETE_COMMANDS
   211      {"case",		Tcl_CaseObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   212  #endif
   213      {"catch",		Tcl_CatchObjCmd,	TclCompileCatchCmd,	TclNRCatchObjCmd,	CMD_IS_SAFE},
   214      {"concat",		Tcl_ConcatObjCmd,	TclCompileConcatCmd,	NULL,	CMD_IS_SAFE},
   215      {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	NULL,	CMD_IS_SAFE},
   216      {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	CMD_IS_SAFE},
   217      {"error",		Tcl_ErrorObjCmd,	TclCompileErrorCmd,	NULL,	CMD_IS_SAFE},
   218      {"eval",		Tcl_EvalObjCmd,		NULL,			TclNREvalObjCmd,	CMD_IS_SAFE},
   219      {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	CMD_IS_SAFE},
   220      {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	CMD_IS_SAFE},
   221      {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	CMD_IS_SAFE},
   222      {"format",		Tcl_FormatObjCmd,	TclCompileFormatCmd,	NULL,	CMD_IS_SAFE},
   223      {"global",		Tcl_GlobalObjCmd,	TclCompileGlobalCmd,	NULL,	CMD_IS_SAFE},
   224      {"if",		Tcl_IfObjCmd,		TclCompileIfCmd,	TclNRIfObjCmd,	CMD_IS_SAFE},
   225      {"incr",		Tcl_IncrObjCmd,		TclCompileIncrCmd,	NULL,	CMD_IS_SAFE},
   226      {"join",		Tcl_JoinObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   227      {"lappend",		Tcl_LappendObjCmd,	TclCompileLappendCmd,	NULL,	CMD_IS_SAFE},
   228      {"lassign",		Tcl_LassignObjCmd,	TclCompileLassignCmd,	NULL,	CMD_IS_SAFE},
   229      {"lindex",		Tcl_LindexObjCmd,	TclCompileLindexCmd,	NULL,	CMD_IS_SAFE},
   230      {"linsert",		Tcl_LinsertObjCmd,	TclCompileLinsertCmd,	NULL,	CMD_IS_SAFE},
   231      {"list",		Tcl_ListObjCmd,		TclCompileListCmd,	NULL,	CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
   232      {"llength",		Tcl_LlengthObjCmd,	TclCompileLlengthCmd,	NULL,	CMD_IS_SAFE},
   233      {"lmap",		Tcl_LmapObjCmd,		TclCompileLmapCmd,	TclNRLmapCmd,	CMD_IS_SAFE},
   234      {"lrange",		Tcl_LrangeObjCmd,	TclCompileLrangeCmd,	NULL,	CMD_IS_SAFE},
   235      {"lrepeat",		Tcl_LrepeatObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   236      {"lreplace",	Tcl_LreplaceObjCmd,	TclCompileLreplaceCmd,	NULL,	CMD_IS_SAFE},
   237      {"lreverse",	Tcl_LreverseObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   238      {"lsearch",		Tcl_LsearchObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   239      {"lset",		Tcl_LsetObjCmd,		TclCompileLsetCmd,	NULL,	CMD_IS_SAFE},
   240      {"lsort",		Tcl_LsortObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   241      {"package",		Tcl_PackageObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   242      {"proc",		Tcl_ProcObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   243      {"regexp",		Tcl_RegexpObjCmd,	TclCompileRegexpCmd,	NULL,	CMD_IS_SAFE},
   244      {"regsub",		Tcl_RegsubObjCmd,	TclCompileRegsubCmd,	NULL,	CMD_IS_SAFE},
   245      {"rename",		Tcl_RenameObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   246      {"return",		Tcl_ReturnObjCmd,	TclCompileReturnCmd,	NULL,	CMD_IS_SAFE},
   247      {"scan",		Tcl_ScanObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   248      {"set",		Tcl_SetObjCmd,		TclCompileSetCmd,	NULL,	CMD_IS_SAFE},
   249      {"split",		Tcl_SplitObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   250      {"subst",		Tcl_SubstObjCmd,	TclCompileSubstCmd,	TclNRSubstObjCmd,	CMD_IS_SAFE},
   251      {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	TclNRSwitchObjCmd, CMD_IS_SAFE},
   252      {"tailcall",	NULL,			TclCompileTailcallCmd,	TclNRTailcallObjCmd,	CMD_IS_SAFE},
   253      {"throw",		Tcl_ThrowObjCmd,	TclCompileThrowCmd,	NULL,	CMD_IS_SAFE},
   254      {"trace",		Tcl_TraceObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   255      {"try",		Tcl_TryObjCmd,		TclCompileTryCmd,	TclNRTryObjCmd,	CMD_IS_SAFE},
   256      {"unset",		Tcl_UnsetObjCmd,	TclCompileUnsetCmd,	NULL,	CMD_IS_SAFE},
   257      {"uplevel",		Tcl_UplevelObjCmd,	NULL,			TclNRUplevelObjCmd,	CMD_IS_SAFE},
   258      {"upvar",		Tcl_UpvarObjCmd,	TclCompileUpvarCmd,	NULL,	CMD_IS_SAFE},
   259      {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	CMD_IS_SAFE},
   260      {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	CMD_IS_SAFE},
   261      {"yield",		NULL,			TclCompileYieldCmd,	TclNRYieldObjCmd,	CMD_IS_SAFE},
   262      {"yieldto",		NULL,			TclCompileYieldToCmd,	TclNRYieldToObjCmd,	CMD_IS_SAFE},
   263  
   264      /*
   265       * Commands in the OS-interface. Note that many of these are unsafe.
   266       */
   267  
   268      {"after",		Tcl_AfterObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   269      {"cd",		Tcl_CdObjCmd,		NULL,			NULL,	0},
   270      {"close",		Tcl_CloseObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   271      {"eof",		Tcl_EofObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   272      {"encoding",	Tcl_EncodingObjCmd,	NULL,			NULL,	0},
   273      {"exec",		Tcl_ExecObjCmd,		NULL,			NULL,	0},
   274      {"exit",		Tcl_ExitObjCmd,		NULL,			NULL,	0},
   275      {"fblocked",	Tcl_FblockedObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   276      {"fconfigure",	Tcl_FconfigureObjCmd,	NULL,			NULL,	0},
   277      {"fcopy",		Tcl_FcopyObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   278      {"fileevent",	Tcl_FileEventObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   279      {"flush",		Tcl_FlushObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   280      {"gets",		Tcl_GetsObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   281      {"glob",		Tcl_GlobObjCmd,		NULL,			NULL,	0},
   282      {"load",		Tcl_LoadObjCmd,		NULL,			NULL,	0},
   283      {"open",		Tcl_OpenObjCmd,		NULL,			NULL,	0},
   284      {"pid",		Tcl_PidObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   285      {"puts",		Tcl_PutsObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   286      {"pwd",		Tcl_PwdObjCmd,		NULL,			NULL,	0},
   287      {"read",		Tcl_ReadObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   288      {"seek",		Tcl_SeekObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   289      {"socket",		Tcl_SocketObjCmd,	NULL,			NULL,	0},
   290      {"source",		Tcl_SourceObjCmd,	NULL,			TclNRSourceObjCmd,	0},
   291      {"tell",		Tcl_TellObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   292      {"time",		Tcl_TimeObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
   293      {"unload",		Tcl_UnloadObjCmd,	NULL,			NULL,	0},
   294      {"update",		Tcl_UpdateObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   295      {"vwait",		Tcl_VwaitObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
   296      {NULL,		NULL,			NULL,			NULL,	0}
   297  };
   298  
   299  /*
   300   * Math functions. All are safe.
   301   */
   302  
   303  typedef struct {
   304      const char *name;		/* Name of the function. The full name is
   305  				 * "::tcl::mathfunc::<name>". */
   306      Tcl_ObjCmdProc *objCmdProc;	/* Function that evaluates the function */
   307      ClientData clientData;	/* Client data for the function */
   308  } BuiltinFuncDef;
   309  static const BuiltinFuncDef BuiltinFuncTable[] = {
   310      { "abs",	ExprAbsFunc,	NULL			},
   311      { "acos",	ExprUnaryFunc,	(ClientData) acos	},
   312      { "asin",	ExprUnaryFunc,	(ClientData) asin	},
   313      { "atan",	ExprUnaryFunc,	(ClientData) atan	},
   314      { "atan2",	ExprBinaryFunc,	(ClientData) atan2	},
   315      { "bool",	ExprBoolFunc,	NULL			},
   316      { "ceil",	ExprCeilFunc,	NULL			},
   317      { "cos",	ExprUnaryFunc,	(ClientData) cos	},
   318      { "cosh",	ExprUnaryFunc,	(ClientData) cosh	},
   319      { "double",	ExprDoubleFunc,	NULL			},
   320      { "entier",	ExprEntierFunc,	NULL			},
   321      { "exp",	ExprUnaryFunc,	(ClientData) exp	},
   322      { "floor",	ExprFloorFunc,	NULL			},
   323      { "fmod",	ExprBinaryFunc,	(ClientData) fmod	},
   324      { "hypot",	ExprBinaryFunc,	(ClientData) hypot	},
   325      { "int",	ExprIntFunc,	NULL			},
   326      { "isqrt",	ExprIsqrtFunc,	NULL			},
   327      { "log",	ExprUnaryFunc,	(ClientData) log	},
   328      { "log10",	ExprUnaryFunc,	(ClientData) log10	},
   329      { "pow",	ExprBinaryFunc,	(ClientData) pow	},
   330      { "rand",	ExprRandFunc,	NULL			},
   331      { "round",	ExprRoundFunc,	NULL			},
   332      { "sin",	ExprUnaryFunc,	(ClientData) sin	},
   333      { "sinh",	ExprUnaryFunc,	(ClientData) sinh	},
   334      { "sqrt",	ExprSqrtFunc,	NULL			},
   335      { "srand",	ExprSrandFunc,	NULL			},
   336      { "tan",	ExprUnaryFunc,	(ClientData) tan	},
   337      { "tanh",	ExprUnaryFunc,	(ClientData) tanh	},
   338      { "wide",	ExprWideFunc,	NULL			},
   339      { NULL, NULL, NULL }
   340  };
   341  
   342  /*
   343   * TIP#174's math operators. All are safe.
   344   */
   345  
   346  typedef struct {
   347      const char *name;		/* Name of object-based command. */
   348      Tcl_ObjCmdProc *objProc;	/* Object-based function for command. */
   349      CompileProc *compileProc;	/* Function called to compile command. */
   350      union {
   351  	int numArgs;
   352  	int identity;
   353      } i;
   354      const char *expected;	/* For error message, what argument(s)
   355  				 * were expected. */
   356  } OpCmdInfo;
   357  static const OpCmdInfo mathOpCmds[] = {
   358      { "~",	TclSingleOpCmd,		TclCompileInvertOpCmd,
   359  		/* numArgs */ {1},	"integer"},
   360      { "!",	TclSingleOpCmd,		TclCompileNotOpCmd,
   361  		/* numArgs */ {1},	"boolean"},
   362      { "+",	TclVariadicOpCmd,	TclCompileAddOpCmd,
   363  		/* identity */ {0},	NULL},
   364      { "*",	TclVariadicOpCmd,	TclCompileMulOpCmd,
   365  		/* identity */ {1},	NULL},
   366      { "&",	TclVariadicOpCmd,	TclCompileAndOpCmd,
   367  		/* identity */ {-1},	NULL},
   368      { "|",	TclVariadicOpCmd,	TclCompileOrOpCmd,
   369  		/* identity */ {0},	NULL},
   370      { "^",	TclVariadicOpCmd,	TclCompileXorOpCmd,
   371  		/* identity */ {0},	NULL},
   372      { "**",	TclVariadicOpCmd,	TclCompilePowOpCmd,
   373  		/* identity */ {1},	NULL},
   374      { "<<",	TclSingleOpCmd,		TclCompileLshiftOpCmd,
   375  		/* numArgs */ {2},	"integer shift"},
   376      { ">>",	TclSingleOpCmd,		TclCompileRshiftOpCmd,
   377  		/* numArgs */ {2},	"integer shift"},
   378      { "%",	TclSingleOpCmd,		TclCompileModOpCmd,
   379  		/* numArgs */ {2},	"integer integer"},
   380      { "!=",	TclSingleOpCmd,		TclCompileNeqOpCmd,
   381  		/* numArgs */ {2},	"value value"},
   382      { "ne",	TclSingleOpCmd,		TclCompileStrneqOpCmd,
   383  		/* numArgs */ {2},	"value value"},
   384      { "in",	TclSingleOpCmd,		TclCompileInOpCmd,
   385  		/* numArgs */ {2},	"value list"},
   386      { "ni",	TclSingleOpCmd,		TclCompileNiOpCmd,
   387  		/* numArgs */ {2},	"value list"},
   388      { "-",	TclNoIdentOpCmd,	TclCompileMinusOpCmd,
   389  		/* unused */ {0},	"value ?value ...?"},
   390      { "/",	TclNoIdentOpCmd,	TclCompileDivOpCmd,
   391  		/* unused */ {0},	"value ?value ...?"},
   392      { "<",	TclSortingOpCmd,	TclCompileLessOpCmd,
   393  		/* unused */ {0},	NULL},
   394      { "<=",	TclSortingOpCmd,	TclCompileLeqOpCmd,
   395  		/* unused */ {0},	NULL},
   396      { ">",	TclSortingOpCmd,	TclCompileGreaterOpCmd,
   397  		/* unused */ {0},	NULL},
   398      { ">=",	TclSortingOpCmd,	TclCompileGeqOpCmd,
   399  		/* unused */ {0},	NULL},
   400      { "==",	TclSortingOpCmd,	TclCompileEqOpCmd,
   401  		/* unused */ {0},	NULL},
   402      { "eq",	TclSortingOpCmd,	TclCompileStreqOpCmd,
   403  		/* unused */ {0},	NULL},
   404      { NULL,	NULL,			NULL,
   405  		{0},			NULL}
   406  };
   407  
   408  /*
   409   *----------------------------------------------------------------------
   410   *
   411   * TclFinalizeEvaluation --
   412   *
   413   *	Finalizes the script cancellation hash table.
   414   *
   415   * Results:
   416   *	None.
   417   *
   418   * Side effects:
   419   *	None.
   420   *
   421   *----------------------------------------------------------------------
   422   */
   423  
   424  void
   425  TclFinalizeEvaluation(void)
   426  {
   427      Tcl_MutexLock(&cancelLock);
   428      if (cancelTableInitialized == 1) {
   429  	Tcl_DeleteHashTable(&cancelTable);
   430  	cancelTableInitialized = 0;
   431      }
   432      Tcl_MutexUnlock(&cancelLock);
   433  }
   434  
   435  /*
   436   *----------------------------------------------------------------------
   437   *
   438   * Tcl_CreateInterp --
   439   *
   440   *	Create a new TCL command interpreter.
   441   *
   442   * Results:
   443   *	The return value is a token for the interpreter, which may be used in
   444   *	calls to functions like Tcl_CreateCmd, Tcl_Eval, or Tcl_DeleteInterp.
   445   *
   446   * Side effects:
   447   *	The command interpreter is initialized with the built-in commands and
   448   *	with the variables documented in tclvars(n).
   449   *
   450   *----------------------------------------------------------------------
   451   */
   452  
   453  Tcl_Interp *
   454  Tcl_CreateInterp(void)
   455  {
   456      Interp *iPtr;
   457      Tcl_Interp *interp;
   458      Command *cmdPtr;
   459      const BuiltinFuncDef *builtinFuncPtr;
   460      const OpCmdInfo *opcmdInfoPtr;
   461      const CmdInfo *cmdInfoPtr;
   462      Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr;
   463      Tcl_HashEntry *hPtr;
   464      int isNew;
   465      CancelInfo *cancelInfo;
   466      union {
   467  	char c[sizeof(short)];
   468  	short s;
   469      } order;
   470  #ifdef TCL_COMPILE_STATS
   471      ByteCodeStats *statsPtr;
   472  #endif /* TCL_COMPILE_STATS */
   473      char mathFuncName[32];
   474      CallFrame *framePtr;
   475      int result;
   476  
   477      TclInitSubsystems();
   478  
   479      /*
   480       * Panic if someone updated the CallFrame structure without also updating
   481       * the Tcl_CallFrame structure (or vice versa).
   482       */
   483  
   484      if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) {
   485  	/*NOTREACHED*/
   486  	Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
   487      }
   488  
   489  #if defined(_WIN32) && !defined(_WIN64)
   490      if (sizeof(time_t) != 4) {
   491  	/*NOTREACHED*/
   492  	Tcl_Panic("<time.h> is not compatible with MSVC");
   493      }
   494      if ((TclOffset(Tcl_StatBuf,st_atime) != 32)
   495  	    || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) {
   496  	/*NOTREACHED*/
   497  	Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
   498      }
   499  #endif
   500  
   501      if (cancelTableInitialized == 0) {
   502  	Tcl_MutexLock(&cancelLock);
   503  	if (cancelTableInitialized == 0) {
   504  	    Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS);
   505  	    cancelTableInitialized = 1;
   506  	}
   507  	Tcl_MutexUnlock(&cancelLock);
   508      }
   509  
   510      /*
   511       * Initialize support for namespaces and create the global namespace
   512       * (whose name is ""; an alias is "::"). This also initializes the Tcl
   513       * object type table and other object management code.
   514       */
   515  
   516      iPtr = ckalloc(sizeof(Interp));
   517      interp = (Tcl_Interp *) iPtr;
   518  
   519      iPtr->result = iPtr->resultSpace;
   520      iPtr->freeProc = NULL;
   521      iPtr->errorLine = 0;
   522      iPtr->objResultPtr = Tcl_NewObj();
   523      Tcl_IncrRefCount(iPtr->objResultPtr);
   524      iPtr->handle = TclHandleCreate(iPtr);
   525      iPtr->globalNsPtr = NULL;
   526      iPtr->hiddenCmdTablePtr = NULL;
   527      iPtr->interpInfo = NULL;
   528  
   529      TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable));
   530      iPtr->extra.optimizer = TclOptimizeBytecode;
   531  
   532      iPtr->numLevels = 0;
   533      iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
   534      iPtr->framePtr = NULL;	/* Initialise as soon as :: is available */
   535      iPtr->varFramePtr = NULL;	/* Initialise as soon as :: is available */
   536  
   537      /*
   538       * TIP #280 - Initialize the arrays used to extend the ByteCode and Proc
   539       * structures.
   540       */
   541  
   542      iPtr->cmdFramePtr = NULL;
   543      iPtr->linePBodyPtr = ckalloc(sizeof(Tcl_HashTable));
   544      iPtr->lineBCPtr = ckalloc(sizeof(Tcl_HashTable));
   545      iPtr->lineLAPtr = ckalloc(sizeof(Tcl_HashTable));
   546      iPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable));
   547      Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
   548      Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
   549      Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
   550      Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
   551      iPtr->scriptCLLocPtr = NULL;
   552  
   553      iPtr->activeVarTracePtr = NULL;
   554  
   555      iPtr->returnOpts = NULL;
   556      iPtr->errorInfo = NULL;
   557      TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo");
   558      Tcl_IncrRefCount(iPtr->eiVar);
   559      iPtr->errorStack = Tcl_NewListObj(0, NULL);
   560      Tcl_IncrRefCount(iPtr->errorStack);
   561      iPtr->resetErrorStack = 1;
   562      TclNewLiteralStringObj(iPtr->upLiteral,"UP");
   563      Tcl_IncrRefCount(iPtr->upLiteral);
   564      TclNewLiteralStringObj(iPtr->callLiteral,"CALL");
   565      Tcl_IncrRefCount(iPtr->callLiteral);
   566      TclNewLiteralStringObj(iPtr->innerLiteral,"INNER");
   567      Tcl_IncrRefCount(iPtr->innerLiteral);
   568      iPtr->innerContext = Tcl_NewListObj(0, NULL);
   569      Tcl_IncrRefCount(iPtr->innerContext);
   570      iPtr->errorCode = NULL;
   571      TclNewLiteralStringObj(iPtr->ecVar, "::errorCode");
   572      Tcl_IncrRefCount(iPtr->ecVar);
   573      iPtr->returnLevel = 1;
   574      iPtr->returnCode = TCL_OK;
   575  
   576      iPtr->rootFramePtr = NULL;	/* Initialise as soon as :: is available */
   577      iPtr->lookupNsPtr = NULL;
   578  
   579      iPtr->appendResult = NULL;
   580      iPtr->appendAvl = 0;
   581      iPtr->appendUsed = 0;
   582  
   583      Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
   584      iPtr->packageUnknown = NULL;
   585  
   586      /* TIP #268 */
   587      if (getenv("TCL_PKG_PREFER_LATEST") == NULL) {
   588  	iPtr->packagePrefer = PKG_PREFER_STABLE;
   589      } else {
   590  	iPtr->packagePrefer = PKG_PREFER_LATEST;
   591      }
   592  
   593      iPtr->cmdCount = 0;
   594      TclInitLiteralTable(&iPtr->literalTable);
   595      iPtr->compileEpoch = 0;
   596      iPtr->compiledProcPtr = NULL;
   597      iPtr->resolverPtr = NULL;
   598      iPtr->evalFlags = 0;
   599      iPtr->scriptFile = NULL;
   600      iPtr->flags = 0;
   601      iPtr->tracePtr = NULL;
   602      iPtr->tracesForbiddingInline = 0;
   603      iPtr->activeCmdTracePtr = NULL;
   604      iPtr->activeInterpTracePtr = NULL;
   605      iPtr->assocData = NULL;
   606      iPtr->execEnvPtr = NULL;	/* Set after namespaces initialized. */
   607      iPtr->emptyObjPtr = Tcl_NewObj();
   608  				/* Another empty object. */
   609      Tcl_IncrRefCount(iPtr->emptyObjPtr);
   610      iPtr->resultSpace[0] = 0;
   611      iPtr->threadId = Tcl_GetCurrentThread();
   612  
   613      /* TIP #378 */
   614  #ifdef TCL_INTERP_DEBUG_FRAME
   615      iPtr->flags |= INTERP_DEBUG_FRAME;
   616  #else
   617      if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) {
   618          iPtr->flags |= INTERP_DEBUG_FRAME;
   619      }
   620  #endif
   621  
   622      /*
   623       * Initialise the tables for variable traces and searches *before*
   624       * creating the global ns - so that the trace on errorInfo can be
   625       * recorded.
   626       */
   627  
   628      Tcl_InitHashTable(&iPtr->varTraces, TCL_ONE_WORD_KEYS);
   629      Tcl_InitHashTable(&iPtr->varSearches, TCL_ONE_WORD_KEYS);
   630  
   631      iPtr->globalNsPtr = NULL;	/* Force creation of global ns below. */
   632      iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
   633  	    NULL, NULL);
   634      if (iPtr->globalNsPtr == NULL) {
   635  	Tcl_Panic("Tcl_CreateInterp: can't create global namespace");
   636      }
   637  
   638      /*
   639       * Initialise the rootCallframe. It cannot be allocated on the stack, as
   640       * it has to be in place before TclCreateExecEnv tries to use a variable.
   641       */
   642  
   643      /* This is needed to satisfy GCC 3.3's strict aliasing rules */
   644      framePtr = ckalloc(sizeof(CallFrame));
   645      result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
   646  	    (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0);
   647      if (result != TCL_OK) {
   648  	Tcl_Panic("Tcl_CreateInterp: failed to push the root stack frame");
   649      }
   650      framePtr->objc = 0;
   651  
   652      iPtr->framePtr = framePtr;
   653      iPtr->varFramePtr = framePtr;
   654      iPtr->rootFramePtr = framePtr;
   655  
   656      /*
   657       * Initialize support for code compilation and execution. We call
   658       * TclCreateExecEnv after initializing namespaces since it tries to
   659       * reference a Tcl variable (it links to the Tcl "tcl_traceExec"
   660       * variable).
   661       */
   662  
   663      iPtr->execEnvPtr = TclCreateExecEnv(interp, INTERP_STACK_INITIAL_SIZE);
   664  
   665      /*
   666       * TIP #219, Tcl Channel Reflection API support.
   667       */
   668  
   669      iPtr->chanMsg = NULL;
   670  
   671      /*
   672       * TIP #285, Script cancellation support.
   673       */
   674  
   675      iPtr->asyncCancelMsg = Tcl_NewObj();
   676  
   677      cancelInfo = ckalloc(sizeof(CancelInfo));
   678      cancelInfo->interp = interp;
   679  
   680      iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo);
   681      cancelInfo->async = iPtr->asyncCancel;
   682      cancelInfo->result = NULL;
   683      cancelInfo->length = 0;
   684  
   685      Tcl_MutexLock(&cancelLock);
   686      hPtr = Tcl_CreateHashEntry(&cancelTable, iPtr, &isNew);
   687      Tcl_SetHashValue(hPtr, cancelInfo);
   688      Tcl_MutexUnlock(&cancelLock);
   689  
   690      /*
   691       * Initialize the compilation and execution statistics kept for this
   692       * interpreter.
   693       */
   694  
   695  #ifdef TCL_COMPILE_STATS
   696      statsPtr = &iPtr->stats;
   697      statsPtr->numExecutions = 0;
   698      statsPtr->numCompilations = 0;
   699      statsPtr->numByteCodesFreed = 0;
   700      memset(statsPtr->instructionCount, 0,
   701  	    sizeof(statsPtr->instructionCount));
   702  
   703      statsPtr->totalSrcBytes = 0.0;
   704      statsPtr->totalByteCodeBytes = 0.0;
   705      statsPtr->currentSrcBytes = 0.0;
   706      statsPtr->currentByteCodeBytes = 0.0;
   707      memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
   708      memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount));
   709      memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount));
   710  
   711      statsPtr->currentInstBytes = 0.0;
   712      statsPtr->currentLitBytes = 0.0;
   713      statsPtr->currentExceptBytes = 0.0;
   714      statsPtr->currentAuxBytes = 0.0;
   715      statsPtr->currentCmdMapBytes = 0.0;
   716  
   717      statsPtr->numLiteralsCreated = 0;
   718      statsPtr->totalLitStringBytes = 0.0;
   719      statsPtr->currentLitStringBytes = 0.0;
   720      memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount));
   721  #endif /* TCL_COMPILE_STATS */
   722  
   723      /*
   724       * Initialise the stub table pointer.
   725       */
   726  
   727      iPtr->stubTable = &tclStubs;
   728  
   729      /*
   730       * Initialize the ensemble error message rewriting support.
   731       */
   732  
   733      iPtr->ensembleRewrite.sourceObjs = NULL;
   734      iPtr->ensembleRewrite.numRemovedObjs = 0;
   735      iPtr->ensembleRewrite.numInsertedObjs = 0;
   736  
   737      /*
   738       * TIP#143: Initialise the resource limit support.
   739       */
   740  
   741      TclInitLimitSupport(interp);
   742  
   743      /*
   744       * Initialise the thread-specific data ekeko. Note that the thread's alloc
   745       * cache was already initialised by the call to alloc the interp struct.
   746       */
   747  
   748  #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
   749      iPtr->allocCache = TclpGetAllocCache();
   750  #else
   751      iPtr->allocCache = NULL;
   752  #endif
   753      iPtr->pendingObjDataPtr = NULL;
   754      iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
   755      iPtr->deferredCallbacks = NULL;
   756  
   757      /*
   758       * Create the core commands. Do it here, rather than calling
   759       * Tcl_CreateCommand, because it's faster (there's no need to check for a
   760       * pre-existing command by the same name). If a command has a Tcl_CmdProc
   761       * but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
   762       * TclInvokeStringCommand. This is an object-based wrapper function that
   763       * extracts strings, calls the string function, and creates an object for
   764       * the result. Similarly, if a command has a Tcl_ObjCmdProc but no
   765       * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
   766       */
   767  
   768      for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
   769  	if ((cmdInfoPtr->objProc == NULL)
   770  		&& (cmdInfoPtr->compileProc == NULL)
   771  		&& (cmdInfoPtr->nreProc == NULL)) {
   772  	    Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc");
   773  	}
   774  
   775  	hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
   776  		cmdInfoPtr->name, &isNew);
   777  	if (isNew) {
   778  	    cmdPtr = ckalloc(sizeof(Command));
   779  	    cmdPtr->hPtr = hPtr;
   780  	    cmdPtr->nsPtr = iPtr->globalNsPtr;
   781  	    cmdPtr->refCount = 1;
   782  	    cmdPtr->cmdEpoch = 0;
   783  	    cmdPtr->compileProc = cmdInfoPtr->compileProc;
   784  	    cmdPtr->proc = TclInvokeObjectCommand;
   785  	    cmdPtr->clientData = cmdPtr;
   786  	    cmdPtr->objProc = cmdInfoPtr->objProc;
   787  	    cmdPtr->objClientData = NULL;
   788  	    cmdPtr->deleteProc = NULL;
   789  	    cmdPtr->deleteData = NULL;
   790  	    cmdPtr->flags = 0;
   791              if (cmdInfoPtr->flags & CMD_COMPILES_EXPANDED) {
   792                  cmdPtr->flags |= CMD_COMPILES_EXPANDED;
   793              }
   794  	    cmdPtr->importRefPtr = NULL;
   795  	    cmdPtr->tracePtr = NULL;
   796  	    cmdPtr->nreProc = cmdInfoPtr->nreProc;
   797  	    Tcl_SetHashValue(hPtr, cmdPtr);
   798  	}
   799      }
   800  
   801      /*
   802       * Create the "array", "binary", "chan", "dict", "file", "info",
   803       * "namespace" and "string" ensembles. Note that all these commands (and
   804       * their subcommands that are not present in the global namespace) are
   805       * wholly safe *except* for "file".
   806       */
   807  
   808      TclInitArrayCmd(interp);
   809      TclInitBinaryCmd(interp);
   810      TclInitChanCmd(interp);
   811      TclInitDictCmd(interp);
   812      TclInitFileCmd(interp);
   813      TclInitInfoCmd(interp);
   814      TclInitNamespaceCmd(interp);
   815      TclInitStringCmd(interp);
   816      TclInitPrefixCmd(interp);
   817  
   818      /*
   819       * Register "clock" subcommands. These *do* go through
   820       * Tcl_CreateObjCommand, since they aren't in the global namespace and
   821       * involve ensembles.
   822       */
   823  
   824      TclClockInit(interp);
   825  
   826      /*
   827       * Register the built-in functions. This is empty now that they are
   828       * implemented as commands in the ::tcl::mathfunc namespace.
   829       */
   830  
   831      /*
   832       * Register the default [interp bgerror] handler.
   833       */
   834  
   835      Tcl_CreateObjCommand(interp, "::tcl::Bgerror",
   836  	    TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
   837  
   838      /*
   839       * Create unsupported commands for debugging bytecode and objects.
   840       */
   841  
   842      Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
   843  	    Tcl_DisassembleObjCmd, NULL, NULL);
   844      Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
   845  	    Tcl_RepresentationCmd, NULL, NULL);
   846  
   847      /* Adding the bytecode assembler command */
   848      cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
   849              "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
   850              TclNRAssembleObjCmd, NULL, NULL);
   851      cmdPtr->compileProc = &TclCompileAssembleCmd;
   852  
   853      Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
   854  	    NRCoroInjectObjCmd, NULL, NULL);
   855  
   856  #ifdef USE_DTRACE
   857      /*
   858       * Register the tcl::dtrace command.
   859       */
   860  
   861      Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
   862  #endif /* USE_DTRACE */
   863  
   864      /*
   865       * Register the builtin math functions.
   866       */
   867  
   868      mathfuncNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL);
   869      if (mathfuncNSPtr == NULL) {
   870  	Tcl_Panic("Can't create math function namespace");
   871      }
   872  #define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
   873      memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN);
   874      for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
   875  	    builtinFuncPtr++) {
   876  	strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
   877  	Tcl_CreateObjCommand(interp, mathFuncName,
   878  		builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL);
   879  	Tcl_Export(interp, mathfuncNSPtr, builtinFuncPtr->name, 0);
   880      }
   881  
   882      /*
   883       * Register the mathematical "operator" commands. [TIP #174]
   884       */
   885  
   886      mathopNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL);
   887      if (mathopNSPtr == NULL) {
   888  	Tcl_Panic("can't create math operator namespace");
   889      }
   890      Tcl_Export(interp, mathopNSPtr, "*", 1);
   891  #define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */
   892      memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN);
   893      for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){
   894  	TclOpCmdClientData *occdPtr = ckalloc(sizeof(TclOpCmdClientData));
   895  
   896  	occdPtr->op = opcmdInfoPtr->name;
   897  	occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs;
   898  	occdPtr->expected = opcmdInfoPtr->expected;
   899  	strcpy(mathFuncName + MATH_OP_PREFIX_LEN, opcmdInfoPtr->name);
   900  	cmdPtr = (Command *) Tcl_CreateObjCommand(interp, mathFuncName,
   901  		opcmdInfoPtr->objProc, occdPtr, DeleteOpCmdClientData);
   902  	if (cmdPtr == NULL) {
   903  	    Tcl_Panic("failed to create math operator %s",
   904  		    opcmdInfoPtr->name);
   905  	} else if (opcmdInfoPtr->compileProc != NULL) {
   906  	    cmdPtr->compileProc = opcmdInfoPtr->compileProc;
   907  	}
   908      }
   909  
   910      /*
   911       * Do Multiple/Safe Interps Tcl init stuff
   912       */
   913  
   914      TclInterpInit(interp);
   915      TclSetupEnv(interp);
   916  
   917      /*
   918       * TIP #59: Make embedded configuration information available.
   919       */
   920  
   921      TclInitEmbeddedConfigurationInformation(interp);
   922  
   923      /*
   924       * Compute the byte order of this machine.
   925       */
   926  
   927      order.s = 1;
   928      Tcl_SetVar2(interp, "tcl_platform", "byteOrder",
   929  	    ((order.c[0] == 1) ? "littleEndian" : "bigEndian"),
   930  	    TCL_GLOBAL_ONLY);
   931  
   932      Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize",
   933  	    Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY);
   934  
   935      /* TIP #291 */
   936      Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize",
   937  	    Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY);
   938  
   939      /*
   940       * Set up other variables such as tcl_version and tcl_library
   941       */
   942  
   943      Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
   944      Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
   945      Tcl_TraceVar2(interp, "tcl_precision", NULL,
   946  	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
   947  	    TclPrecTraceProc, NULL);
   948      TclpSetVariables(interp);
   949  
   950  #ifdef TCL_THREADS
   951      /*
   952       * The existence of the "threaded" element of the tcl_platform array
   953       * indicates that this particular Tcl shell has been compiled with threads
   954       * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can
   955       * introspect on the interpreter level of thread safety.
   956       */
   957  
   958      Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY);
   959  #endif
   960  
   961      /*
   962       * Register Tcl's version number.
   963       * TIP #268: Full patchlevel instead of just major.minor
   964       */
   965  
   966      Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
   967  
   968      if (TclTommath_Init(interp) != TCL_OK) {
   969  	Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
   970      }
   971  
   972      if (TclOOInit(interp) != TCL_OK) {
   973  	Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
   974      }
   975  
   976      /*
   977       * Only build in zlib support if we've successfully detected a library to
   978       * compile and link against.
   979       */
   980  
   981  #ifdef HAVE_ZLIB
   982      if (TclZlibInit(interp) != TCL_OK) {
   983  	Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
   984      }
   985  #endif
   986  
   987      TOP_CB(iPtr) = NULL;
   988      return interp;
   989  }
   990  
   991  static void
   992  DeleteOpCmdClientData(
   993      ClientData clientData)
   994  {
   995      TclOpCmdClientData *occdPtr = clientData;
   996  
   997      ckfree(occdPtr);
   998  }
   999  
  1000  /*
  1001   *----------------------------------------------------------------------
  1002   *
  1003   * TclHideUnsafeCommands --
  1004   *
  1005   *	Hides base commands that are not marked as safe from this interpreter.
  1006   *
  1007   * Results:
  1008   *	TCL_OK if it succeeds, TCL_ERROR else.
  1009   *
  1010   * Side effects:
  1011   *	Hides functionality in an interpreter.
  1012   *
  1013   *----------------------------------------------------------------------
  1014   */
  1015  
  1016  int
  1017  TclHideUnsafeCommands(
  1018      Tcl_Interp *interp)		/* Hide commands in this interpreter. */
  1019  {
  1020      register const CmdInfo *cmdInfoPtr;
  1021  
  1022      if (interp == NULL) {
  1023  	return TCL_ERROR;
  1024      }
  1025      for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
  1026  	if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) {
  1027  	    Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
  1028  	}
  1029      }
  1030      TclMakeFileCommandSafe(interp);     /* Ugh! */
  1031      return TCL_OK;
  1032  }
  1033  
  1034  /*
  1035   *--------------------------------------------------------------
  1036   *
  1037   * Tcl_CallWhenDeleted --
  1038   *
  1039   *	Arrange for a function to be called before a given interpreter is
  1040   *	deleted. The function is called as soon as Tcl_DeleteInterp is called;
  1041   *	if Tcl_CallWhenDeleted is called on an interpreter that has already
  1042   *	been deleted, the function will be called when the last Tcl_Release is
  1043   *	done on the interpreter.
  1044   *
  1045   * Results:
  1046   *	None.
  1047   *
  1048   * Side effects:
  1049   *	When Tcl_DeleteInterp is invoked to delete interp, proc will be
  1050   *	invoked. See the manual entry for details.
  1051   *
  1052   *--------------------------------------------------------------
  1053   */
  1054  
  1055  void
  1056  Tcl_CallWhenDeleted(
  1057      Tcl_Interp *interp,		/* Interpreter to watch. */
  1058      Tcl_InterpDeleteProc *proc,	/* Function to call when interpreter is about
  1059  				 * to be deleted. */
  1060      ClientData clientData)	/* One-word value to pass to proc. */
  1061  {
  1062      Interp *iPtr = (Interp *) interp;
  1063      static Tcl_ThreadDataKey assocDataCounterKey;
  1064      int *assocDataCounterPtr =
  1065  	    Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int));
  1066      int isNew;
  1067      char buffer[32 + TCL_INTEGER_SPACE];
  1068      AssocData *dPtr = ckalloc(sizeof(AssocData));
  1069      Tcl_HashEntry *hPtr;
  1070  
  1071      sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
  1072      (*assocDataCounterPtr)++;
  1073  
  1074      if (iPtr->assocData == NULL) {
  1075  	iPtr->assocData = ckalloc(sizeof(Tcl_HashTable));
  1076  	Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
  1077      }
  1078      hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew);
  1079      dPtr->proc = proc;
  1080      dPtr->clientData = clientData;
  1081      Tcl_SetHashValue(hPtr, dPtr);
  1082  }
  1083  
  1084  /*
  1085   *--------------------------------------------------------------
  1086   *
  1087   * Tcl_DontCallWhenDeleted --
  1088   *
  1089   *	Cancel the arrangement for a function to be called when a given
  1090   *	interpreter is deleted.
  1091   *
  1092   * Results:
  1093   *	None.
  1094   *
  1095   * Side effects:
  1096   *	If proc and clientData were previously registered as a callback via
  1097   *	Tcl_CallWhenDeleted, they are unregistered. If they weren't previously
  1098   *	registered then nothing happens.
  1099   *
  1100   *--------------------------------------------------------------
  1101   */
  1102  
  1103  void
  1104  Tcl_DontCallWhenDeleted(
  1105      Tcl_Interp *interp,		/* Interpreter to watch. */
  1106      Tcl_InterpDeleteProc *proc,	/* Function to call when interpreter is about
  1107  				 * to be deleted. */
  1108      ClientData clientData)	/* One-word value to pass to proc. */
  1109  {
  1110      Interp *iPtr = (Interp *) interp;
  1111      Tcl_HashTable *hTablePtr;
  1112      Tcl_HashSearch hSearch;
  1113      Tcl_HashEntry *hPtr;
  1114      AssocData *dPtr;
  1115  
  1116      hTablePtr = iPtr->assocData;
  1117      if (hTablePtr == NULL) {
  1118  	return;
  1119      }
  1120      for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
  1121  	    hPtr = Tcl_NextHashEntry(&hSearch)) {
  1122  	dPtr = Tcl_GetHashValue(hPtr);
  1123  	if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
  1124  	    ckfree(dPtr);
  1125  	    Tcl_DeleteHashEntry(hPtr);
  1126  	    return;
  1127  	}
  1128      }
  1129  }
  1130  
  1131  /*
  1132   *----------------------------------------------------------------------
  1133   *
  1134   * Tcl_SetAssocData --
  1135   *
  1136   *	Creates a named association between user-specified data, a delete
  1137   *	function and this interpreter. If the association already exists the
  1138   *	data is overwritten with the new data. The delete function will be
  1139   *	invoked when the interpreter is deleted.
  1140   *
  1141   * Results:
  1142   *	None.
  1143   *
  1144   * Side effects:
  1145   *	Sets the associated data, creates the association if needed.
  1146   *
  1147   *----------------------------------------------------------------------
  1148   */
  1149  
  1150  void
  1151  Tcl_SetAssocData(
  1152      Tcl_Interp *interp,		/* Interpreter to associate with. */
  1153      const char *name,		/* Name for association. */
  1154      Tcl_InterpDeleteProc *proc,	/* Proc to call when interpreter is about to
  1155  				 * be deleted. */
  1156      ClientData clientData)	/* One-word value to pass to proc. */
  1157  {
  1158      Interp *iPtr = (Interp *) interp;
  1159      AssocData *dPtr;
  1160      Tcl_HashEntry *hPtr;
  1161      int isNew;
  1162  
  1163      if (iPtr->assocData == NULL) {
  1164  	iPtr->assocData = ckalloc(sizeof(Tcl_HashTable));
  1165  	Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
  1166      }
  1167      hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew);
  1168      if (isNew == 0) {
  1169  	dPtr = Tcl_GetHashValue(hPtr);
  1170      } else {
  1171  	dPtr = ckalloc(sizeof(AssocData));
  1172      }
  1173      dPtr->proc = proc;
  1174      dPtr->clientData = clientData;
  1175  
  1176      Tcl_SetHashValue(hPtr, dPtr);
  1177  }
  1178  
  1179  /*
  1180   *----------------------------------------------------------------------
  1181   *
  1182   * Tcl_DeleteAssocData --
  1183   *
  1184   *	Deletes a named association of user-specified data with the specified
  1185   *	interpreter.
  1186   *
  1187   * Results:
  1188   *	None.
  1189   *
  1190   * Side effects:
  1191   *	Deletes the association.
  1192   *
  1193   *----------------------------------------------------------------------
  1194   */
  1195  
  1196  void
  1197  Tcl_DeleteAssocData(
  1198      Tcl_Interp *interp,		/* Interpreter to associate with. */
  1199      const char *name)		/* Name of association. */
  1200  {
  1201      Interp *iPtr = (Interp *) interp;
  1202      AssocData *dPtr;
  1203      Tcl_HashEntry *hPtr;
  1204  
  1205      if (iPtr->assocData == NULL) {
  1206  	return;
  1207      }
  1208      hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
  1209      if (hPtr == NULL) {
  1210  	return;
  1211      }
  1212      dPtr = Tcl_GetHashValue(hPtr);
  1213      if (dPtr->proc != NULL) {
  1214  	dPtr->proc(dPtr->clientData, interp);
  1215      }
  1216      ckfree(dPtr);
  1217      Tcl_DeleteHashEntry(hPtr);
  1218  }
  1219  
  1220  /*
  1221   *----------------------------------------------------------------------
  1222   *
  1223   * Tcl_GetAssocData --
  1224   *
  1225   *	Returns the client data associated with this name in the specified
  1226   *	interpreter.
  1227   *
  1228   * Results:
  1229   *	The client data in the AssocData record denoted by the named
  1230   *	association, or NULL.
  1231   *
  1232   * Side effects:
  1233   *	None.
  1234   *
  1235   *----------------------------------------------------------------------
  1236   */
  1237  
  1238  ClientData
  1239  Tcl_GetAssocData(
  1240      Tcl_Interp *interp,		/* Interpreter associated with. */
  1241      const char *name,		/* Name of association. */
  1242      Tcl_InterpDeleteProc **procPtr)
  1243  				/* Pointer to place to store address of
  1244  				 * current deletion callback. */
  1245  {
  1246      Interp *iPtr = (Interp *) interp;
  1247      AssocData *dPtr;
  1248      Tcl_HashEntry *hPtr;
  1249  
  1250      if (iPtr->assocData == NULL) {
  1251  	return NULL;
  1252      }
  1253      hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
  1254      if (hPtr == NULL) {
  1255  	return NULL;
  1256      }
  1257      dPtr = Tcl_GetHashValue(hPtr);
  1258      if (procPtr != NULL) {
  1259  	*procPtr = dPtr->proc;
  1260      }
  1261      return dPtr->clientData;
  1262  }
  1263  
  1264  /*
  1265   *----------------------------------------------------------------------
  1266   *
  1267   * Tcl_InterpDeleted --
  1268   *
  1269   *	Returns nonzero if the interpreter has been deleted with a call to
  1270   *	Tcl_DeleteInterp.
  1271   *
  1272   * Results:
  1273   *	Nonzero if the interpreter is deleted, zero otherwise.
  1274   *
  1275   * Side effects:
  1276   *	None.
  1277   *
  1278   *----------------------------------------------------------------------
  1279   */
  1280  
  1281  int
  1282  Tcl_InterpDeleted(
  1283      Tcl_Interp *interp)
  1284  {
  1285      return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
  1286  }
  1287  
  1288  /*
  1289   *----------------------------------------------------------------------
  1290   *
  1291   * Tcl_DeleteInterp --
  1292   *
  1293   *	Ensures that the interpreter will be deleted eventually. If there are
  1294   *	no Tcl_Preserve calls in effect for this interpreter, it is deleted
  1295   *	immediately, otherwise the interpreter is deleted when the last
  1296   *	Tcl_Preserve is matched by a call to Tcl_Release. In either case, the
  1297   *	function runs the currently registered deletion callbacks.
  1298   *
  1299   * Results:
  1300   *	None.
  1301   *
  1302   * Side effects:
  1303   *	The interpreter is marked as deleted. The caller may still use it
  1304   *	safely if there are calls to Tcl_Preserve in effect for the
  1305   *	interpreter, but further calls to Tcl_Eval etc in this interpreter
  1306   *	will fail.
  1307   *
  1308   *----------------------------------------------------------------------
  1309   */
  1310  
  1311  void
  1312  Tcl_DeleteInterp(
  1313      Tcl_Interp *interp)		/* Token for command interpreter (returned by
  1314  				 * a previous call to Tcl_CreateInterp). */
  1315  {
  1316      Interp *iPtr = (Interp *) interp;
  1317  
  1318      /*
  1319       * If the interpreter has already been marked deleted, just punt.
  1320       */
  1321  
  1322      if (iPtr->flags & DELETED) {
  1323  	return;
  1324      }
  1325  
  1326      /*
  1327       * Mark the interpreter as deleted. No further evals will be allowed.
  1328       * Increase the compileEpoch as a signal to compiled bytecodes.
  1329       */
  1330  
  1331      iPtr->flags |= DELETED;
  1332      iPtr->compileEpoch++;
  1333  
  1334      /*
  1335       * Ensure that the interpreter is eventually deleted.
  1336       */
  1337  
  1338      Tcl_EventuallyFree(interp, (Tcl_FreeProc *) DeleteInterpProc);
  1339  }
  1340  
  1341  /*
  1342   *----------------------------------------------------------------------
  1343   *
  1344   * DeleteInterpProc --
  1345   *
  1346   *	Helper function to delete an interpreter. This function is called when
  1347   *	the last call to Tcl_Preserve on this interpreter is matched by a call
  1348   *	to Tcl_Release. The function cleans up all resources used in the
  1349   *	interpreter and calls all currently registered interpreter deletion
  1350   *	callbacks.
  1351   *
  1352   * Results:
  1353   *	None.
  1354   *
  1355   * Side effects:
  1356   *	Whatever the interpreter deletion callbacks do. Frees resources used
  1357   *	by the interpreter.
  1358   *
  1359   *----------------------------------------------------------------------
  1360   */
  1361  
  1362  static void
  1363  DeleteInterpProc(
  1364      Tcl_Interp *interp)		/* Interpreter to delete. */
  1365  {
  1366      Interp *iPtr = (Interp *) interp;
  1367      Tcl_HashEntry *hPtr;
  1368      Tcl_HashSearch search;
  1369      Tcl_HashTable *hTablePtr;
  1370      ResolverScheme *resPtr, *nextResPtr;
  1371      int i;
  1372  
  1373      /*
  1374       * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup,
  1375  	 * unless we are exiting.
  1376       */
  1377  
  1378      if ((iPtr->numLevels > 0) && !TclInExit()) {
  1379  	Tcl_Panic("DeleteInterpProc called with active evals");
  1380      }
  1381  
  1382      /*
  1383       * The interpreter should already be marked deleted; otherwise how did we
  1384       * get here?
  1385       */
  1386  
  1387      if (!(iPtr->flags & DELETED)) {
  1388  	Tcl_Panic("DeleteInterpProc called on interpreter not marked deleted");
  1389      }
  1390  
  1391      /*
  1392       * TIP #219, Tcl Channel Reflection API. Discard a leftover state.
  1393       */
  1394  
  1395      if (iPtr->chanMsg != NULL) {
  1396  	Tcl_DecrRefCount(iPtr->chanMsg);
  1397  	iPtr->chanMsg = NULL;
  1398      }
  1399  
  1400      /*
  1401       * TIP #285, Script cancellation support. Delete this interp from the
  1402       * global hash table of CancelInfo structs.
  1403       */
  1404  
  1405      Tcl_MutexLock(&cancelLock);
  1406      hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
  1407      if (hPtr != NULL) {
  1408  	CancelInfo *cancelInfo = Tcl_GetHashValue(hPtr);
  1409  
  1410  	if (cancelInfo != NULL) {
  1411  	    if (cancelInfo->result != NULL) {
  1412  		ckfree(cancelInfo->result);
  1413  	    }
  1414  	    ckfree(cancelInfo);
  1415  	}
  1416  
  1417  	Tcl_DeleteHashEntry(hPtr);
  1418      }
  1419  
  1420      if (iPtr->asyncCancel != NULL) {
  1421  	Tcl_AsyncDelete(iPtr->asyncCancel);
  1422  	iPtr->asyncCancel = NULL;
  1423      }
  1424  
  1425      if (iPtr->asyncCancelMsg != NULL) {
  1426  	Tcl_DecrRefCount(iPtr->asyncCancelMsg);
  1427  	iPtr->asyncCancelMsg = NULL;
  1428      }
  1429      Tcl_MutexUnlock(&cancelLock);
  1430  
  1431      /*
  1432       * Shut down all limit handler callback scripts that call back into this
  1433       * interpreter. Then eliminate all limit handlers for this interpreter.
  1434       */
  1435  
  1436      TclRemoveScriptLimitCallbacks(interp);
  1437      TclLimitRemoveAllHandlers(interp);
  1438  
  1439      /*
  1440       * Dismantle the namespace here, before we clear the assocData. If any
  1441       * background errors occur here, they will be deleted below.
  1442       *
  1443       * Dismantle the namespace after freeing the iPtr->handle so that each
  1444       * bytecode releases its literals without caring to update the literal
  1445       * table, as it will be freed later in this function without further use.
  1446       */
  1447  
  1448      TclHandleFree(iPtr->handle);
  1449      TclTeardownNamespace(iPtr->globalNsPtr);
  1450  
  1451      /*
  1452       * Delete all the hidden commands.
  1453       */
  1454  
  1455      hTablePtr = iPtr->hiddenCmdTablePtr;
  1456      if (hTablePtr != NULL) {
  1457  	/*
  1458  	 * Non-pernicious deletion. The deletion callbacks will not be allowed
  1459  	 * to create any new hidden or non-hidden commands.
  1460  	 * Tcl_DeleteCommandFromToken will remove the entry from the
  1461  	 * hiddenCmdTablePtr.
  1462  	 */
  1463  
  1464  	hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
  1465  	for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1466  	    Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr));
  1467  	}
  1468  	Tcl_DeleteHashTable(hTablePtr);
  1469  	ckfree(hTablePtr);
  1470      }
  1471  
  1472      /*
  1473       * Invoke deletion callbacks; note that a callback can create new
  1474       * callbacks, so we iterate.
  1475       */
  1476  
  1477      while (iPtr->assocData != NULL) {
  1478  	AssocData *dPtr;
  1479  
  1480  	hTablePtr = iPtr->assocData;
  1481  	iPtr->assocData = NULL;
  1482  	for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
  1483  		hPtr != NULL;
  1484  		hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
  1485  	    dPtr = Tcl_GetHashValue(hPtr);
  1486  	    Tcl_DeleteHashEntry(hPtr);
  1487  	    if (dPtr->proc != NULL) {
  1488  		dPtr->proc(dPtr->clientData, interp);
  1489  	    }
  1490  	    ckfree(dPtr);
  1491  	}
  1492  	Tcl_DeleteHashTable(hTablePtr);
  1493  	ckfree(hTablePtr);
  1494      }
  1495  
  1496      /*
  1497       * Pop the root frame pointer and finish deleting the global
  1498       * namespace. The order is important [Bug 1658572].
  1499       */
  1500  
  1501      if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) {
  1502  	Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top");
  1503      }
  1504      Tcl_PopCallFrame(interp);
  1505      ckfree(iPtr->rootFramePtr);
  1506      iPtr->rootFramePtr = NULL;
  1507      Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
  1508  
  1509      /*
  1510       * Free up the result *after* deleting variables, since variable deletion
  1511       * could have transferred ownership of the result string to Tcl.
  1512       */
  1513  
  1514      Tcl_FreeResult(interp);
  1515      iPtr->result = NULL;
  1516      Tcl_DecrRefCount(iPtr->objResultPtr);
  1517      iPtr->objResultPtr = NULL;
  1518      Tcl_DecrRefCount(iPtr->ecVar);
  1519      if (iPtr->errorCode) {
  1520  	Tcl_DecrRefCount(iPtr->errorCode);
  1521  	iPtr->errorCode = NULL;
  1522      }
  1523      Tcl_DecrRefCount(iPtr->eiVar);
  1524      if (iPtr->errorInfo) {
  1525  	Tcl_DecrRefCount(iPtr->errorInfo);
  1526  	iPtr->errorInfo = NULL;
  1527      }
  1528      Tcl_DecrRefCount(iPtr->errorStack);
  1529      iPtr->errorStack = NULL;
  1530      Tcl_DecrRefCount(iPtr->upLiteral);
  1531      Tcl_DecrRefCount(iPtr->callLiteral);
  1532      Tcl_DecrRefCount(iPtr->innerLiteral);
  1533      Tcl_DecrRefCount(iPtr->innerContext);
  1534      if (iPtr->returnOpts) {
  1535  	Tcl_DecrRefCount(iPtr->returnOpts);
  1536      }
  1537      if (iPtr->appendResult != NULL) {
  1538  	ckfree(iPtr->appendResult);
  1539  	iPtr->appendResult = NULL;
  1540      }
  1541      TclFreePackageInfo(iPtr);
  1542      while (iPtr->tracePtr != NULL) {
  1543  	Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr);
  1544      }
  1545      if (iPtr->execEnvPtr != NULL) {
  1546  	TclDeleteExecEnv(iPtr->execEnvPtr);
  1547      }
  1548      if (iPtr->scriptFile) {
  1549  	Tcl_DecrRefCount(iPtr->scriptFile);
  1550  	iPtr->scriptFile = NULL;
  1551      }
  1552      Tcl_DecrRefCount(iPtr->emptyObjPtr);
  1553      iPtr->emptyObjPtr = NULL;
  1554  
  1555      resPtr = iPtr->resolverPtr;
  1556      while (resPtr) {
  1557  	nextResPtr = resPtr->nextPtr;
  1558  	ckfree(resPtr->name);
  1559  	ckfree(resPtr);
  1560  	resPtr = nextResPtr;
  1561      }
  1562  
  1563      /*
  1564       * Free up literal objects created for scripts compiled by the
  1565       * interpreter.
  1566       */
  1567  
  1568      TclDeleteLiteralTable(interp, &iPtr->literalTable);
  1569  
  1570      /*
  1571       * TIP #280 - Release the arrays for ByteCode/Proc extension, and
  1572       * contents.
  1573       */
  1574  
  1575      for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search);
  1576  	    hPtr != NULL;
  1577  	    hPtr = Tcl_NextHashEntry(&search)) {
  1578  	CmdFrame *cfPtr = Tcl_GetHashValue(hPtr);
  1579  	Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr);
  1580  
  1581  	procPtr->iPtr = NULL;
  1582  	if (cfPtr) {
  1583  	    if (cfPtr->type == TCL_LOCATION_SOURCE) {
  1584  		Tcl_DecrRefCount(cfPtr->data.eval.path);
  1585  	    }
  1586  	    ckfree(cfPtr->line);
  1587  	    ckfree(cfPtr);
  1588  	}
  1589  	Tcl_DeleteHashEntry(hPtr);
  1590      }
  1591      Tcl_DeleteHashTable(iPtr->linePBodyPtr);
  1592      ckfree(iPtr->linePBodyPtr);
  1593      iPtr->linePBodyPtr = NULL;
  1594  
  1595      /*
  1596       * See also tclCompile.c, TclCleanupByteCode
  1597       */
  1598  
  1599      for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &search);
  1600  	    hPtr != NULL;
  1601  	    hPtr = Tcl_NextHashEntry(&search)) {
  1602  	ExtCmdLoc *eclPtr = Tcl_GetHashValue(hPtr);
  1603  
  1604  	if (eclPtr->type == TCL_LOCATION_SOURCE) {
  1605  	    Tcl_DecrRefCount(eclPtr->path);
  1606  	}
  1607  	for (i=0; i< eclPtr->nuloc; i++) {
  1608  	    ckfree(eclPtr->loc[i].line);
  1609  	}
  1610  
  1611  	if (eclPtr->loc != NULL) {
  1612  	    ckfree(eclPtr->loc);
  1613  	}
  1614  
  1615  	ckfree(eclPtr);
  1616  	Tcl_DeleteHashEntry(hPtr);
  1617      }
  1618      Tcl_DeleteHashTable(iPtr->lineBCPtr);
  1619      ckfree(iPtr->lineBCPtr);
  1620      iPtr->lineBCPtr = NULL;
  1621  
  1622      /*
  1623       * Location stack for uplevel/eval/... scripts which were passed through
  1624       * proc arguments. Actually we track all arguments as we do not and cannot
  1625       * know which arguments will be used as scripts and which will not.
  1626       */
  1627  
  1628      if (iPtr->lineLAPtr->numEntries && !TclInExit()) {
  1629  	/*
  1630  	 * When the interp goes away we have nothing on the stack, so there
  1631  	 * are no arguments, so this table has to be empty.
  1632  	 */
  1633  
  1634  	Tcl_Panic("Argument location tracking table not empty");
  1635      }
  1636  
  1637      Tcl_DeleteHashTable(iPtr->lineLAPtr);
  1638      ckfree((char *) iPtr->lineLAPtr);
  1639      iPtr->lineLAPtr = NULL;
  1640  
  1641      if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
  1642  	/*
  1643  	 * When the interp goes away we have nothing on the stack, so there
  1644  	 * are no arguments, so this table has to be empty.
  1645  	 */
  1646  
  1647  	Tcl_Panic("Argument location tracking table not empty");
  1648      }
  1649  
  1650      Tcl_DeleteHashTable(iPtr->lineLABCPtr);
  1651      ckfree(iPtr->lineLABCPtr);
  1652      iPtr->lineLABCPtr = NULL;
  1653  
  1654      /*
  1655       * Squelch the tables of traces on variables and searches over arrays in
  1656       * the in the interpreter.
  1657       */
  1658  
  1659      Tcl_DeleteHashTable(&iPtr->varTraces);
  1660      Tcl_DeleteHashTable(&iPtr->varSearches);
  1661  
  1662      ckfree(iPtr);
  1663  }
  1664  
  1665  /*
  1666   *---------------------------------------------------------------------------
  1667   *
  1668   * Tcl_HideCommand --
  1669   *
  1670   *	Makes a command hidden so that it cannot be invoked from within an
  1671   *	interpreter, only from within an ancestor.
  1672   *
  1673   * Results:
  1674   *	A standard Tcl result; also leaves a message in the interp's result if
  1675   *	an error occurs.
  1676   *
  1677   * Side effects:
  1678   *	Removes a command from the command table and create an entry into the
  1679   *	hidden command table under the specified token name.
  1680   *
  1681   *---------------------------------------------------------------------------
  1682   */
  1683  
  1684  int
  1685  Tcl_HideCommand(
  1686      Tcl_Interp *interp,		/* Interpreter in which to hide command. */
  1687      const char *cmdName,	/* Name of command to hide. */
  1688      const char *hiddenCmdToken)	/* Token name of the to-be-hidden command. */
  1689  {
  1690      Interp *iPtr = (Interp *) interp;
  1691      Tcl_Command cmd;
  1692      Command *cmdPtr;
  1693      Tcl_HashTable *hiddenCmdTablePtr;
  1694      Tcl_HashEntry *hPtr;
  1695      int isNew;
  1696  
  1697      if (iPtr->flags & DELETED) {
  1698  	/*
  1699  	 * The interpreter is being deleted. Do not create any new structures,
  1700  	 * because it is not safe to modify the interpreter.
  1701  	 */
  1702  
  1703  	return TCL_ERROR;
  1704      }
  1705  
  1706      /*
  1707       * Disallow hiding of commands that are currently in a namespace or
  1708       * renaming (as part of hiding) into a namespace (because the current
  1709       * implementation with a single global table and the needed uniqueness of
  1710       * names cause problems with namespaces).
  1711       *
  1712       * We don't need to check for "::" in cmdName because the real check is on
  1713       * the nsPtr below.
  1714       *
  1715       * hiddenCmdToken is just a string which is not interpreted in any way. It
  1716       * may contain :: but the string is not interpreted as a namespace
  1717       * qualifier command name. Thus, hiding foo::bar to foo::bar and then
  1718       * trying to expose or invoke ::foo::bar will NOT work; but if the
  1719       * application always uses the same strings it will get consistent
  1720       * behaviour.
  1721       *
  1722       * But as we currently limit ourselves to the global namespace only for
  1723       * the source, in order to avoid potential confusion, lets prevent "::" in
  1724       * the token too. - dl
  1725       */
  1726  
  1727      if (strstr(hiddenCmdToken, "::") != NULL) {
  1728  	Tcl_SetObjResult(interp, Tcl_NewStringObj(
  1729  		"cannot use namespace qualifiers in hidden command"
  1730  		" token (rename)", -1));
  1731          Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL);
  1732  	return TCL_ERROR;
  1733      }
  1734  
  1735      /*
  1736       * Find the command to hide. An error is returned if cmdName can't be
  1737       * found. Look up the command only from the global namespace. Full path of
  1738       * the command must be given if using namespaces.
  1739       */
  1740  
  1741      cmd = Tcl_FindCommand(interp, cmdName, NULL,
  1742  	    /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
  1743      if (cmd == (Tcl_Command) NULL) {
  1744  	return TCL_ERROR;
  1745      }
  1746      cmdPtr = (Command *) cmd;
  1747  
  1748      /*
  1749       * Check that the command is really in global namespace
  1750       */
  1751  
  1752      if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
  1753  	Tcl_SetObjResult(interp, Tcl_NewStringObj(
  1754                  "can only hide global namespace commands (use rename then hide)",
  1755                  -1));
  1756          Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL);
  1757  	return TCL_ERROR;
  1758      }
  1759  
  1760      /*
  1761       * Initialize the hidden command table if necessary.
  1762       */
  1763  
  1764      hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
  1765      if (hiddenCmdTablePtr == NULL) {
  1766  	hiddenCmdTablePtr = ckalloc(sizeof(Tcl_HashTable));
  1767  	Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
  1768  	iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
  1769      }
  1770  
  1771      /*
  1772       * It is an error to move an exposed command to a hidden command with
  1773       * hiddenCmdToken if a hidden command with the name hiddenCmdToken already
  1774       * exists.
  1775       */
  1776  
  1777      hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew);
  1778      if (!isNew) {
  1779  	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  1780                  "hidden command named \"%s\" already exists",
  1781                  hiddenCmdToken));
  1782          Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL);
  1783  	return TCL_ERROR;
  1784      }
  1785  
  1786      /*
  1787       * NB: This code is currently 'like' a rename to a specialy set apart name
  1788       * table. Changes here and in TclRenameCommand must be kept in synch until
  1789       * the common parts are actually factorized out.
  1790       */
  1791  
  1792      /*
  1793       * Remove the hash entry for the command from the interpreter command
  1794       * table. This is like deleting the command, so bump its command epoch;
  1795       * this invalidates any cached references that point to the command.
  1796       */
  1797  
  1798      if (cmdPtr->hPtr != NULL) {
  1799  	Tcl_DeleteHashEntry(cmdPtr->hPtr);
  1800  	cmdPtr->hPtr = NULL;
  1801  	cmdPtr->cmdEpoch++;
  1802      }
  1803  
  1804      /*
  1805       * The list of command exported from the namespace might have changed.
  1806       * However, we do not need to recompute this just yet; next time we need
  1807       * the info will be soon enough.
  1808       */
  1809  
  1810      TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
  1811  
  1812      /*
  1813       * Now link the hash table entry with the command structure. We ensured
  1814       * above that the nsPtr was right.
  1815       */
  1816  
  1817      cmdPtr->hPtr = hPtr;
  1818      Tcl_SetHashValue(hPtr, cmdPtr);
  1819  
  1820      /*
  1821       * If the command being hidden has a compile function, increment the
  1822       * interpreter's compileEpoch to invalidate its compiled code. This makes
  1823       * sure that we don't later try to execute old code compiled with
  1824       * command-specific (i.e., inline) bytecodes for the now-hidden command.
  1825       * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose
  1826       * compilation epoch doesn't match is recompiled.
  1827       */
  1828  
  1829      if (cmdPtr->compileProc != NULL) {
  1830  	iPtr->compileEpoch++;
  1831      }
  1832      return TCL_OK;
  1833  }
  1834  
  1835  /*
  1836   *----------------------------------------------------------------------
  1837   *
  1838   * Tcl_ExposeCommand --
  1839   *
  1840   *	Makes a previously hidden command callable from inside the interpreter
  1841   *	instead of only by its ancestors.
  1842   *
  1843   * Results:
  1844   *	A standard Tcl result. If an error occurs, a message is left in the
  1845   *	interp's result.
  1846   *
  1847   * Side effects:
  1848   *	Moves commands from one hash table to another.
  1849   *
  1850   *----------------------------------------------------------------------
  1851   */
  1852  
  1853  int
  1854  Tcl_ExposeCommand(
  1855      Tcl_Interp *interp,		/* Interpreter in which to make command
  1856  				 * callable. */
  1857      const char *hiddenCmdToken,	/* Name of hidden command. */
  1858      const char *cmdName)	/* Name of to-be-exposed command. */
  1859  {
  1860      Interp *iPtr = (Interp *) interp;
  1861      Command *cmdPtr;
  1862      Namespace *nsPtr;
  1863      Tcl_HashEntry *hPtr;
  1864      Tcl_HashTable *hiddenCmdTablePtr;
  1865      int isNew;
  1866  
  1867      if (iPtr->flags & DELETED) {
  1868  	/*
  1869  	 * The interpreter is being deleted. Do not create any new structures,
  1870  	 * because it is not safe to modify the interpreter.
  1871  	 */
  1872  
  1873  	return TCL_ERROR;
  1874      }
  1875  
  1876      /*
  1877       * Check that we have a regular name for the command (that the user is not
  1878       * trying to do an expose and a rename (to another namespace) at the same
  1879       * time).
  1880       */
  1881  
  1882      if (strstr(cmdName, "::") != NULL) {
  1883  	Tcl_SetObjResult(interp, Tcl_NewStringObj(
  1884                  "cannot expose to a namespace (use expose to toplevel, then rename)",
  1885                  -1));
  1886          Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL);
  1887  	return TCL_ERROR;
  1888      }
  1889  
  1890      /*
  1891       * Get the command from the hidden command table:
  1892       */
  1893  
  1894      hPtr = NULL;
  1895      hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
  1896      if (hiddenCmdTablePtr != NULL) {
  1897  	hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
  1898      }
  1899      if (hPtr == NULL) {
  1900  	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  1901                  "unknown hidden command \"%s\"", hiddenCmdToken));
  1902          Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN",
  1903                  hiddenCmdToken, NULL);
  1904  	return TCL_ERROR;
  1905      }
  1906      cmdPtr = Tcl_GetHashValue(hPtr);
  1907  
  1908      /*
  1909       * Check that we have a true global namespace command (enforced by
  1910       * Tcl_HideCommand but let's double check. (If it was not, we would not
  1911       * really know how to handle it).
  1912       */
  1913  
  1914      if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
  1915  	/*
  1916  	 * This case is theoritically impossible, we might rather Tcl_Panic
  1917  	 * than 'nicely' erroring out ?
  1918  	 */
  1919  
  1920  	Tcl_SetObjResult(interp, Tcl_NewStringObj(
  1921  		"trying to expose a non-global command namespace command",
  1922  		-1));
  1923  	return TCL_ERROR;
  1924      }
  1925  
  1926      /*
  1927       * This is the global table.
  1928       */
  1929  
  1930      nsPtr = cmdPtr->nsPtr;
  1931  
  1932      /*
  1933       * It is an error to overwrite an existing exposed command as a result of
  1934       * exposing a previously hidden command.
  1935       */
  1936  
  1937      hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
  1938      if (!isNew) {
  1939  	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  1940                  "exposed command \"%s\" already exists", cmdName));
  1941          Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL);
  1942  	return TCL_ERROR;
  1943      }
  1944  
  1945      /*
  1946       * Command resolvers (per-interp, per-namespace) might have resolved to a
  1947       * command for the given namespace scope with this command not being
  1948       * registered with the namespace's command table. During BC compilation,
  1949       * the so-resolved command turns into a CmdName literal. Without
  1950       * invalidating a possible CmdName literal here explicitly, such literals
  1951       * keep being reused while pointing to overhauled commands.
  1952       */
  1953  
  1954      TclInvalidateCmdLiteral(interp, cmdName, nsPtr);
  1955  
  1956      /*
  1957       * The list of command exported from the namespace might have changed.
  1958       * However, we do not need to recompute this just yet; next time we need
  1959       * the info will be soon enough.
  1960       */
  1961  
  1962      TclInvalidateNsCmdLookup(nsPtr);
  1963  
  1964      /*
  1965       * Remove the hash entry for the command from the interpreter hidden
  1966       * command table.
  1967       */
  1968  
  1969      if (cmdPtr->hPtr != NULL) {
  1970  	Tcl_DeleteHashEntry(cmdPtr->hPtr);
  1971  	cmdPtr->hPtr = NULL;
  1972      }
  1973  
  1974      /*
  1975       * Now link the hash table entry with the command structure. This is like
  1976       * creating a new command, so deal with any shadowing of commands in the
  1977       * global namespace.
  1978       */
  1979  
  1980      cmdPtr->hPtr = hPtr;
  1981  
  1982      Tcl_SetHashValue(hPtr, cmdPtr);
  1983  
  1984      /*
  1985       * Not needed as we are only in the global namespace (but would be needed
  1986       * again if we supported namespace command hiding)
  1987       *
  1988       * TclResetShadowedCmdRefs(interp, cmdPtr);
  1989       */
  1990  
  1991      /*
  1992       * If the command being exposed has a compile function, increment
  1993       * interpreter's compileEpoch to invalidate its compiled code. This makes
  1994       * sure that we don't later try to execute old code compiled assuming the
  1995       * command is hidden. This field is checked in Tcl_EvalObj and
  1996       * ObjInterpProc, and code whose compilation epoch doesn't match is
  1997       * recompiled.
  1998       */
  1999  
  2000      if (cmdPtr->compileProc != NULL) {
  2001  	iPtr->compileEpoch++;
  2002      }
  2003      return TCL_OK;
  2004  }
  2005  
  2006  /*
  2007   *----------------------------------------------------------------------
  2008   *
  2009   * Tcl_CreateCommand --
  2010   *
  2011   *	Define a new command in a command table.
  2012   *
  2013   * Results:
  2014   *	The return value is a token for the command, which can be used in
  2015   *	future calls to Tcl_GetCommandName.
  2016   *
  2017   * Side effects:
  2018   *	If a command named cmdName already exists for interp, it is deleted.
  2019   *	In the future, when cmdName is seen as the name of a command by
  2020   *	Tcl_Eval, proc will be called. To support the bytecode interpreter,
  2021   *	the command is created with a wrapper Tcl_ObjCmdProc
  2022   *	(TclInvokeStringCommand) that eventially calls proc. When the command
  2023   *	is deleted from the table, deleteProc will be called. See the manual
  2024   *	entry for details on the calling sequence.
  2025   *
  2026   *----------------------------------------------------------------------
  2027   */
  2028  
  2029  Tcl_Command
  2030  Tcl_CreateCommand(
  2031      Tcl_Interp *interp,		/* Token for command interpreter returned by a
  2032  				 * previous call to Tcl_CreateInterp. */
  2033      const char *cmdName,	/* Name of command. If it contains namespace
  2034  				 * qualifiers, the new command is put in the
  2035  				 * specified namespace; otherwise it is put in
  2036  				 * the global namespace. */
  2037      Tcl_CmdProc *proc,		/* Function to associate with cmdName. */
  2038      ClientData clientData,	/* Arbitrary value passed to string proc. */
  2039      Tcl_CmdDeleteProc *deleteProc)
  2040  				/* If not NULL, gives a function to call when
  2041  				 * this command is deleted. */
  2042  {
  2043      Interp *iPtr = (Interp *) interp;
  2044      ImportRef *oldRefPtr = NULL;
  2045      Namespace *nsPtr, *dummy1, *dummy2;
  2046      Command *cmdPtr, *refCmdPtr;
  2047      Tcl_HashEntry *hPtr;
  2048      const char *tail;
  2049      int isNew;
  2050      ImportedCmdData *dataPtr;
  2051  
  2052      if (iPtr->flags & DELETED) {
  2053  	/*
  2054  	 * The interpreter is being deleted. Don't create any new commands;
  2055  	 * it's not safe to muck with the interpreter anymore.
  2056  	 */
  2057  
  2058  	return (Tcl_Command) NULL;
  2059      }
  2060  
  2061      /*
  2062       * Determine where the command should reside. If its name contains
  2063       * namespace qualifiers, we put it in the specified namespace; otherwise,
  2064       * we always put it in the global namespace.
  2065       */
  2066  
  2067      if (strstr(cmdName, "::") != NULL) {
  2068  	TclGetNamespaceForQualName(interp, cmdName, NULL,
  2069  		TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
  2070  	if ((nsPtr == NULL) || (tail == NULL)) {
  2071  	    return (Tcl_Command) NULL;
  2072  	}
  2073      } else {
  2074  	nsPtr = iPtr->globalNsPtr;
  2075  	tail = cmdName;
  2076      }
  2077  
  2078      hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
  2079      if (!isNew) {
  2080  	/*
  2081  	 * Command already exists. Delete the old one. Be careful to preserve
  2082  	 * any existing import links so we can restore them down below. That
  2083  	 * way, you can redefine a command and its import status will remain
  2084  	 * intact.
  2085  	 */
  2086  
  2087  	cmdPtr = Tcl_GetHashValue(hPtr);
  2088  	cmdPtr->refCount++;
  2089  	if (cmdPtr->importRefPtr) {
  2090  	    cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
  2091  	}
  2092  
  2093  	Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
  2094  
  2095  	if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
  2096  	    oldRefPtr = cmdPtr->importRefPtr;
  2097  	    cmdPtr->importRefPtr = NULL;
  2098  	}
  2099  	TclCleanupCommandMacro(cmdPtr);
  2100  
  2101  	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
  2102  	if (!isNew) {
  2103  	    /*
  2104  	     * If the deletion callback recreated the command, just throw away
  2105  	     * the new command (if we try to delete it again, we could get
  2106  	     * stuck in an infinite loop).
  2107  	     */
  2108  
  2109  	    ckfree(Tcl_GetHashValue(hPtr));
  2110  	}
  2111      } else {
  2112  	/*
  2113  	 * Command resolvers (per-interp, per-namespace) might have resolved
  2114  	 * to a command for the given namespace scope with this command not
  2115  	 * being registered with the namespace's command table. During BC
  2116  	 * compilation, the so-resolved command turns into a CmdName literal.
  2117  	 * Without invalidating a possible CmdName literal here explicitly,
  2118  	 * such literals keep being reused while pointing to overhauled
  2119  	 * commands.
  2120  	 */
  2121  
  2122  	TclInvalidateCmdLiteral(interp, tail, nsPtr);
  2123  
  2124  	/*
  2125  	 * The list of command exported from the namespace might have changed.
  2126  	 * However, we do not need to recompute this just yet; next time we
  2127  	 * need the info will be soon enough.
  2128  	 */
  2129  
  2130  	TclInvalidateNsCmdLookup(nsPtr);
  2131  	TclInvalidateNsPath(nsPtr);
  2132      }
  2133      cmdPtr = ckalloc(sizeof(Command));
  2134      Tcl_SetHashValue(hPtr, cmdPtr);
  2135      cmdPtr->hPtr = hPtr;
  2136      cmdPtr->nsPtr = nsPtr;
  2137      cmdPtr->refCount = 1;
  2138      cmdPtr->cmdEpoch = 0;
  2139      cmdPtr->compileProc = NULL;
  2140      cmdPtr->objProc = TclInvokeStringCommand;
  2141      cmdPtr->objClientData = cmdPtr;
  2142      cmdPtr->proc = proc;
  2143      cmdPtr->clientData = clientData;
  2144      cmdPtr->deleteProc = deleteProc;
  2145      cmdPtr->deleteData = clientData;
  2146      cmdPtr->flags = 0;
  2147      cmdPtr->importRefPtr = NULL;
  2148      cmdPtr->tracePtr = NULL;
  2149      cmdPtr->nreProc = NULL;
  2150  
  2151      /*
  2152       * Plug in any existing import references found above. Be sure to update
  2153       * all of these references to point to the new command.
  2154       */
  2155  
  2156      if (oldRefPtr != NULL) {
  2157  	cmdPtr->importRefPtr = oldRefPtr;
  2158  	while (oldRefPtr != NULL) {
  2159  	    refCmdPtr = oldRefPtr->importedCmdPtr;
  2160  	    dataPtr = refCmdPtr->objClientData;
  2161  	    dataPtr->realCmdPtr = cmdPtr;
  2162  	    oldRefPtr = oldRefPtr->nextPtr;
  2163  	}
  2164      }
  2165  
  2166      /*
  2167       * We just created a command, so in its namespace and all of its parent
  2168       * namespaces, it may shadow global commands with the same name. If any
  2169       * shadowed commands are found, invalidate all cached command references
  2170       * in the affected namespaces.
  2171       */
  2172  
  2173      TclResetShadowedCmdRefs(interp, cmdPtr);
  2174      return (Tcl_Command) cmdPtr;
  2175  }
  2176  
  2177  /*
  2178   *----------------------------------------------------------------------
  2179   *
  2180   * Tcl_CreateObjCommand --
  2181   *
  2182   *	Define a new object-based command in a command table.
  2183   *
  2184   * Results:
  2185   *	The return value is a token for the command, which can be used in
  2186   *	future calls to Tcl_GetCommandName.
  2187   *
  2188   * Side effects:
  2189   *	If a command named "cmdName" already exists for interp, it is
  2190   *	first deleted.  Then the new command is created from the arguments.
  2191   *	[***] (See below for exception).
  2192   *
  2193   *	In the future, during bytecode evaluation when "cmdName" is seen as
  2194   *	the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
  2195   *	Tcl_ObjCmdProc proc will be called. When the command is deleted from
  2196   *	the table, deleteProc will be called. See the manual entry for details
  2197   *	on the calling sequence.
  2198   *
  2199   *----------------------------------------------------------------------
  2200   */
  2201  
  2202  Tcl_Command
  2203  Tcl_CreateObjCommand(
  2204      Tcl_Interp *interp,		/* Token for command interpreter (returned by
  2205  				 * previous call to Tcl_CreateInterp). */
  2206      const char *cmdName,	/* Name of command. If it contains namespace
  2207  				 * qualifiers, the new command is put in the
  2208  				 * specified namespace; otherwise it is put in
  2209  				 * the global namespace. */
  2210      Tcl_ObjCmdProc *proc,	/* Object-based function to associate with
  2211  				 * name. */
  2212      ClientData clientData,	/* Arbitrary value to pass to object
  2213  				 * function. */
  2214      Tcl_CmdDeleteProc *deleteProc)
  2215  				/* If not NULL, gives a function to call when
  2216  				 * this command is deleted. */
  2217  {
  2218      Interp *iPtr = (Interp *) interp;
  2219      ImportRef *oldRefPtr = NULL;
  2220      Namespace *nsPtr, *dummy1, *dummy2;
  2221      Command *cmdPtr, *refCmdPtr;
  2222      Tcl_HashEntry *hPtr;
  2223      const char *tail;
  2224      int isNew;
  2225      ImportedCmdData *dataPtr;
  2226  
  2227      if (iPtr->flags & DELETED) {
  2228  	/*
  2229  	 * The interpreter is being deleted. Don't create any new commands;
  2230  	 * it's not safe to muck with the interpreter anymore.
  2231  	 */
  2232  
  2233  	return (Tcl_Command) NULL;
  2234      }
  2235  
  2236      /*
  2237       * Determine where the command should reside. If its name contains
  2238       * namespace qualifiers, we put it in the specified namespace; otherwise,
  2239       * we always put it in the global namespace.
  2240       */
  2241  
  2242      if (strstr(cmdName, "::") != NULL) {
  2243  	TclGetNamespaceForQualName(interp, cmdName, NULL,
  2244  		TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
  2245  	if ((nsPtr == NULL) || (tail == NULL)) {
  2246  	    return (Tcl_Command) NULL;
  2247  	}
  2248      } else {
  2249  	nsPtr = iPtr->globalNsPtr;
  2250  	tail = cmdName;
  2251      }
  2252  
  2253      hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
  2254      TclInvalidateNsPath(nsPtr);
  2255      if (!isNew) {
  2256  	cmdPtr = Tcl_GetHashValue(hPtr);
  2257  
  2258  	/* Command already exists. */
  2259  
  2260  	/*
  2261  	 * [***] This is wrong.  See Tcl Bug a16752c252.  
  2262  	 * However, this buggy behavior is kept under particular
  2263  	 * circumstances to accommodate deployed binaries of the
  2264  	 * "tclcompiler" program. http://sourceforge.net/projects/tclpro/
  2265  	 * that crash if the bug is fixed.
  2266  	 */
  2267  
  2268  	if (cmdPtr->objProc == TclInvokeStringCommand
  2269  		&& cmdPtr->clientData == clientData
  2270  		&& cmdPtr->deleteData == clientData
  2271  		&& cmdPtr->deleteProc == deleteProc) {
  2272  	    cmdPtr->objProc = proc;
  2273  	    cmdPtr->objClientData = clientData;
  2274  	    return (Tcl_Command) cmdPtr;
  2275  	}
  2276  
  2277  	/*
  2278  	 * Otherwise, we delete the old command. Be careful to preserve any
  2279  	 * existing import links so we can restore them down below. That way,
  2280  	 * you can redefine a command and its import status will remain
  2281  	 * intact.
  2282  	 */
  2283  
  2284  	cmdPtr->refCount++;
  2285  	if (cmdPtr->importRefPtr) {
  2286  	    cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
  2287  	}
  2288  
  2289  	Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
  2290  
  2291  	if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
  2292  	    oldRefPtr = cmdPtr->importRefPtr;
  2293  	    cmdPtr->importRefPtr = NULL;
  2294  	}
  2295  	TclCleanupCommandMacro(cmdPtr);
  2296  
  2297  	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
  2298  	if (!isNew) {
  2299  	    /*
  2300  	     * If the deletion callback recreated the command, just throw away
  2301  	     * the new command (if we try to delete it again, we could get
  2302  	     * stuck in an infinite loop).
  2303  	     */
  2304  
  2305  	    ckfree(Tcl_GetHashValue(hPtr));
  2306  	}
  2307      } else {
  2308  	/*
  2309  	 * Command resolvers (per-interp, per-namespace) might have resolved
  2310  	 * to a command for the given namespace scope with this command not
  2311  	 * being registered with the namespace's command table. During BC
  2312  	 * compilation, the so-resolved command turns into a CmdName literal.
  2313  	 * Without invalidating a possible CmdName literal here explicitly,
  2314  	 * such literals keep being reused while pointing to overhauled
  2315  	 * commands.
  2316  	 */
  2317  
  2318  	TclInvalidateCmdLiteral(interp, tail, nsPtr);
  2319  
  2320  	/*
  2321  	 * The list of command exported from the namespace might have changed.
  2322  	 * However, we do not need to recompute this just yet; next time we
  2323  	 * need the info will be soon enough.
  2324  	 */
  2325  
  2326  	TclInvalidateNsCmdLookup(nsPtr);
  2327      }
  2328      cmdPtr = ckalloc(sizeof(Command));
  2329      Tcl_SetHashValue(hPtr, cmdPtr);
  2330      cmdPtr->hPtr = hPtr;
  2331      cmdPtr->nsPtr = nsPtr;
  2332      cmdPtr->refCount = 1;
  2333      cmdPtr->cmdEpoch = 0;
  2334      cmdPtr->compileProc = NULL;
  2335      cmdPtr->objProc = proc;
  2336      cmdPtr->objClientData = clientData;
  2337      cmdPtr->proc = TclInvokeObjectCommand;
  2338      cmdPtr->clientData = cmdPtr;
  2339      cmdPtr->deleteProc = deleteProc;
  2340      cmdPtr->deleteData = clientData;
  2341      cmdPtr->flags = 0;
  2342      cmdPtr->importRefPtr = NULL;
  2343      cmdPtr->tracePtr = NULL;
  2344      cmdPtr->nreProc = NULL;
  2345  
  2346      /*
  2347       * Plug in any existing import references found above. Be sure to update
  2348       * all of these references to point to the new command.
  2349       */
  2350  
  2351      if (oldRefPtr != NULL) {
  2352  	cmdPtr->importRefPtr = oldRefPtr;
  2353  	while (oldRefPtr != NULL) {
  2354  	    refCmdPtr = oldRefPtr->importedCmdPtr;
  2355  	    dataPtr = refCmdPtr->objClientData;
  2356  	    dataPtr->realCmdPtr = cmdPtr;
  2357  	    oldRefPtr = oldRefPtr->nextPtr;
  2358  	}
  2359      }
  2360  
  2361      /*
  2362       * We just created a command, so in its namespace and all of its parent
  2363       * namespaces, it may shadow global commands with the same name. If any
  2364       * shadowed commands are found, invalidate all cached command references
  2365       * in the affected namespaces.
  2366       */
  2367  
  2368      TclResetShadowedCmdRefs(interp, cmdPtr);
  2369      return (Tcl_Command) cmdPtr;
  2370  }
  2371  
  2372  /*
  2373   *----------------------------------------------------------------------
  2374   *
  2375   * TclInvokeStringCommand --
  2376   *
  2377   *	"Wrapper" Tcl_ObjCmdProc used to call an existing string-based
  2378   *	Tcl_CmdProc if no object-based function exists for a command. A
  2379   *	pointer to this function is stored as the Tcl_ObjCmdProc in a Command
  2380   *	structure. It simply turns around and calls the string Tcl_CmdProc in
  2381   *	the Command structure.
  2382   *
  2383   * Results:
  2384   *	A standard Tcl object result value.
  2385   *
  2386   * Side effects:
  2387   *	Besides those side effects of the called Tcl_CmdProc,
  2388   *	TclInvokeStringCommand allocates and frees storage.
  2389   *
  2390   *----------------------------------------------------------------------
  2391   */
  2392  
  2393  int
  2394  TclInvokeStringCommand(
  2395      ClientData clientData,	/* Points to command's Command structure. */
  2396      Tcl_Interp *interp,		/* Current interpreter. */
  2397      register int objc,		/* Number of arguments. */
  2398      Tcl_Obj *const objv[])	/* Argument objects. */
  2399  {
  2400      Command *cmdPtr = clientData;
  2401      int i, result;
  2402      const char **argv =
  2403  	    TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *));
  2404  
  2405      for (i = 0; i < objc; i++) {
  2406  	argv[i] = Tcl_GetString(objv[i]);
  2407      }
  2408      argv[objc] = 0;
  2409  
  2410      /*
  2411       * Invoke the command's string-based Tcl_CmdProc.
  2412       */
  2413  
  2414      result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv);
  2415  
  2416      TclStackFree(interp, (void *) argv);
  2417      return result;
  2418  }
  2419  
  2420  /*
  2421   *----------------------------------------------------------------------
  2422   *
  2423   * TclInvokeObjectCommand --
  2424   *
  2425   *	"Wrapper" Tcl_CmdProc used to call an existing object-based
  2426   *	Tcl_ObjCmdProc if no string-based function exists for a command. A
  2427   *	pointer to this function is stored as the Tcl_CmdProc in a Command
  2428   *	structure. It simply turns around and calls the object Tcl_ObjCmdProc
  2429   *	in the Command structure.
  2430   *
  2431   * Results:
  2432   *	A standard Tcl string result value.
  2433   *
  2434   * Side effects:
  2435   *	Besides those side effects of the called Tcl_ObjCmdProc,
  2436   *	TclInvokeObjectCommand allocates and frees storage.
  2437   *
  2438   *----------------------------------------------------------------------
  2439   */
  2440  
  2441  int
  2442  TclInvokeObjectCommand(
  2443      ClientData clientData,	/* Points to command's Command structure. */
  2444      Tcl_Interp *interp,		/* Current interpreter. */
  2445      int argc,			/* Number of arguments. */
  2446      register const char **argv)	/* Argument strings. */
  2447  {
  2448      Command *cmdPtr = clientData;
  2449      Tcl_Obj *objPtr;
  2450      int i, length, result;
  2451      Tcl_Obj **objv =
  2452  	    TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *)));
  2453  
  2454      for (i = 0; i < argc; i++) {
  2455  	length = strlen(argv[i]);
  2456  	TclNewStringObj(objPtr, argv[i], length);
  2457  	Tcl_IncrRefCount(objPtr);
  2458  	objv[i] = objPtr;
  2459      }
  2460  
  2461      /*
  2462       * Invoke the command's object-based Tcl_ObjCmdProc.
  2463       */
  2464  
  2465      if (cmdPtr->objProc != NULL) {
  2466  	result = cmdPtr->objProc(cmdPtr->objClientData, interp, argc, objv);
  2467      } else {
  2468  	result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc,
  2469  		cmdPtr->objClientData, argc, objv);
  2470      }
  2471  
  2472      /*
  2473       * Move the interpreter's object result to the string result, then reset
  2474       * the object result.
  2475       */
  2476  
  2477      (void) Tcl_GetStringResult(interp);
  2478  
  2479      /*
  2480       * Decrement the ref counts for the argument objects created above, then
  2481       * free the objv array if malloc'ed storage was used.
  2482       */
  2483  
  2484      for (i = 0; i < argc; i++) {
  2485  	objPtr = objv[i];
  2486  	Tcl_DecrRefCount(objPtr);
  2487      }
  2488      TclStackFree(interp, objv);
  2489      return result;
  2490  }
  2491  
  2492  /*
  2493   *----------------------------------------------------------------------
  2494   *
  2495   * TclRenameCommand --
  2496   *
  2497   *	Called to give an existing Tcl command a different name. Both the old
  2498   *	command name and the new command name can have "::" namespace
  2499   *	qualifiers. If the new command has a different namespace context, the
  2500   *	command will be moved to that namespace and will execute in the
  2501   *	context of that new namespace.
  2502   *
  2503   *	If the new command name is NULL or the null string, the command is
  2504   *	deleted.
  2505   *
  2506   * Results:
  2507   *	Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
  2508   *
  2509   * Side effects:
  2510   *	If anything goes wrong, an error message is returned in the
  2511   *	interpreter's result object.
  2512   *
  2513   *----------------------------------------------------------------------
  2514   */
  2515  
  2516  int
  2517  TclRenameCommand(
  2518      Tcl_Interp *interp,		/* Current interpreter. */
  2519      const char *oldName,	/* Existing command name. */
  2520      const char *newName)	/* New command name. */
  2521  {
  2522      Interp *iPtr = (Interp *) interp;
  2523      const char *newTail;
  2524      Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
  2525      Tcl_Command cmd;
  2526      Command *cmdPtr;
  2527      Tcl_HashEntry *hPtr, *oldHPtr;
  2528      int isNew, result;
  2529      Tcl_Obj *oldFullName;
  2530      Tcl_DString newFullName;
  2531  
  2532      /*
  2533       * Find the existing command. An error is returned if cmdName can't be
  2534       * found.
  2535       */
  2536  
  2537      cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0);
  2538      cmdPtr = (Command *) cmd;
  2539      if (cmdPtr == NULL) {
  2540  	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  2541                  "can't %s \"%s\": command doesn't exist",
  2542  		((newName == NULL)||(*newName == '\0'))? "delete":"rename",
  2543  		oldName));
  2544          Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL);
  2545  	return TCL_ERROR;
  2546      }
  2547      cmdNsPtr = cmdPtr->nsPtr;
  2548      oldFullName = Tcl_NewObj();
  2549      Tcl_IncrRefCount(oldFullName);
  2550      Tcl_GetCommandFullName(interp, cmd, oldFullName);
  2551  
  2552      /*
  2553       * If the new command name is NULL or empty, delete the command. Do this
  2554       * with Tcl_DeleteCommandFromToken, since we already have the command.
  2555       */
  2556  
  2557      if ((newName == NULL) || (*newName == '\0')) {
  2558  	Tcl_DeleteCommandFromToken(interp, cmd);
  2559  	result = TCL_OK;
  2560  	goto done;
  2561      }
  2562  
  2563      /*
  2564       * Make sure that the destination command does not already exist. The
  2565       * rename operation is like creating a command, so we should automatically
  2566       * create the containing namespaces just like Tcl_CreateCommand would.
  2567       */
  2568  
  2569      TclGetNamespaceForQualName(interp, newName, NULL,
  2570  	    TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
  2571  
  2572      if ((newNsPtr == NULL) || (newTail == NULL)) {
  2573  	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  2574                  "can't rename to \"%s\": bad command name", newName));
  2575          Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
  2576  	result = TCL_ERROR;
  2577  	goto done;
  2578      }
  2579      if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
  2580  	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  2581                  "can't rename to \"%s\": command already exists", newName));
  2582          Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME",
  2583                  "TARGET_EXISTS", NULL);
  2584  	result = TCL_ERROR;
  2585  	goto done;
  2586      }
  2587  
  2588      /*
  2589       * Warning: any changes done in the code here are likely to be needed in
  2590       * Tcl_HideCommand code too (until the common parts are extracted out).
  2591       * - dl
  2592       */
  2593  
  2594      /*
  2595       * Put the command in the new namespace so we can check for an alias loop.
  2596       * Since we are adding a new command to a namespace, we must handle any
  2597       * shadowing of the global commands that this might create.
  2598       */
  2599  
  2600      oldHPtr = cmdPtr->hPtr;
  2601      hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &isNew);
  2602      Tcl_SetHashValue(hPtr, cmdPtr);
  2603      cmdPtr->hPtr = hPtr;
  2604      cmdPtr->nsPtr = newNsPtr;
  2605      TclResetShadowedCmdRefs(interp, cmdPtr);
  2606  
  2607      /*
  2608       * Now check for an alias loop. If we detect one, put everything back the
  2609       * way it was and report the error.
  2610       */
  2611  
  2612      result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
  2613      if (result != TCL_OK) {
  2614  	Tcl_DeleteHashEntry(cmdPtr->hPtr);
  2615  	cmdPtr->hPtr = oldHPtr;
  2616  	cmdPtr->nsPtr = cmdNsPtr;
  2617  	goto done;
  2618      }
  2619  
  2620      /*
  2621       * The list of command exported from the namespace might have changed.
  2622       * However, we do not need to recompute this just yet; next time we need
  2623       * the info will be soon enough. These might refer to the same variable,
  2624       * but that's no big deal.
  2625       */
  2626  
  2627      TclInvalidateNsCmdLookup(cmdNsPtr);
  2628      TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
  2629  
  2630      /*
  2631       * Command resolvers (per-interp, per-namespace) might have resolved to a
  2632       * command for the given namespace scope with this command not being
  2633       * registered with the namespace's command table. During BC compilation,
  2634       * the so-resolved command turns into a CmdName literal. Without
  2635       * invalidating a possible CmdName literal here explicitly, such literals
  2636       * keep being reused while pointing to overhauled commands.
  2637       */
  2638  
  2639      TclInvalidateCmdLiteral(interp, newTail, cmdPtr->nsPtr);
  2640  
  2641      /*
  2642       * Script for rename traces can delete the command "oldName". Therefore
  2643       * increment the reference count for cmdPtr so that it's Command structure
  2644       * is freed only towards the end of this function by calling
  2645       * TclCleanupCommand.
  2646       *
  2647       * The trace function needs to get a fully qualified name for old and new
  2648       * commands [Tcl bug #651271], or else there's no way for the trace
  2649       * function to get the namespace from which the old command is being
  2650       * renamed!
  2651       */
  2652  
  2653      Tcl_DStringInit(&newFullName);
  2654      Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1);
  2655      if (newNsPtr != iPtr->globalNsPtr) {
  2656  	TclDStringAppendLiteral(&newFullName, "::");
  2657      }
  2658      Tcl_DStringAppend(&newFullName, newTail, -1);
  2659      cmdPtr->refCount++;
  2660      CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName),
  2661  	    Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
  2662      Tcl_DStringFree(&newFullName);
  2663  
  2664      /*
  2665       * The new command name is okay, so remove the command from its current
  2666       * namespace. This is like deleting the command, so bump the cmdEpoch to
  2667       * invalidate any cached references to the command.
  2668       */
  2669  
  2670      Tcl_DeleteHashEntry(oldHPtr);
  2671      cmdPtr->cmdEpoch++;
  2672  
  2673      /*
  2674       * If the command being renamed has a compile function, increment the
  2675       * interpreter's compileEpoch to invalidate its compiled code. This makes
  2676       * sure that we don't later try to execute old code compiled for the
  2677       * now-renamed command.
  2678       */
  2679  
  2680      if (cmdPtr->compileProc != NULL) {
  2681  	iPtr->compileEpoch++;
  2682      }
  2683  
  2684      /*
  2685       * Now free the Command structure, if the "oldName" command has been
  2686       * deleted by invocation of rename traces.
  2687       */
  2688  
  2689      TclCleanupCommandMacro(cmdPtr);
  2690      result = TCL_OK;
  2691  
  2692    done:
  2693      TclDecrRefCount(oldFullName);
  2694      return result;
  2695  }
  2696  
  2697  /*
  2698   *----------------------------------------------------------------------
  2699   *
  2700   * Tcl_SetCommandInfo --
  2701   *
  2702   *	Modifies various information about a Tcl command. Note that this
  2703   *	function will not change a command's namespace; use TclRenameCommand
  2704   *	to do that. Also, the isNativeObjectProc member of *infoPtr is
  2705   *	ignored.
  2706   *
  2707   * Results:
  2708   *	If cmdName exists in interp, then the information at *infoPtr is
  2709   *	stored with the command in place of the current information and 1 is
  2710   *	returned. If the command doesn't exist then 0 is returned.
  2711   *
  2712   * Side effects:
  2713   *	None.
  2714   *
  2715   *----------------------------------------------------------------------
  2716   */
  2717  
  2718  int
  2719  Tcl_SetCommandInfo(
  2720      Tcl_Interp *interp,		/* Interpreter in which to look for
  2721  				 * command. */
  2722      const char *cmdName,	/* Name of desired command. */
  2723      const Tcl_CmdInfo *infoPtr)	/* Where to find information to store in the
  2724  				 * command. */
  2725  {
  2726      Tcl_Command cmd;
  2727  
  2728      cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0);
  2729      return Tcl_SetCommandInfoFromToken(cmd, infoPtr);
  2730  }
  2731  
  2732  /*
  2733   *----------------------------------------------------------------------
  2734   *
  2735   * Tcl_SetCommandInfoFromToken --
  2736   *
  2737   *	Modifies various information about a Tcl command. Note that this
  2738   *	function will not change a command's namespace; use TclRenameCommand
  2739   *	to do that. Also, the isNativeObjectProc member of *infoPtr is
  2740   *	ignored.
  2741   *
  2742   * Results:
  2743   *	If cmdName exists in interp, then the information at *infoPtr is
  2744   *	stored with the command in place of the current information and 1 is
  2745   *	returned. If the command doesn't exist then 0 is returned.
  2746   *
  2747   * Side effects:
  2748   *	None.
  2749   *
  2750   *----------------------------------------------------------------------
  2751   */
  2752  
  2753  int
  2754  Tcl_SetCommandInfoFromToken(
  2755      Tcl_Command cmd,
  2756      const Tcl_CmdInfo *infoPtr)
  2757  {
  2758      Command *cmdPtr;		/* Internal representation of the command */
  2759  
  2760      if (cmd == NULL) {
  2761  	return 0;
  2762      }
  2763  
  2764      /*
  2765       * The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
  2766       */
  2767  
  2768      cmdPtr = (Command *) cmd;
  2769      cmdPtr->proc = infoPtr->proc;
  2770      cmdPtr->clientData = infoPtr->clientData;
  2771      if (infoPtr->objProc == NULL) {
  2772  	cmdPtr->objProc = TclInvokeStringCommand;
  2773  	cmdPtr->objClientData = cmdPtr;
  2774  	cmdPtr->nreProc = NULL;
  2775      } else {
  2776  	if (infoPtr->objProc != cmdPtr->objProc) {
  2777  	    cmdPtr->nreProc = NULL;
  2778  	    cmdPtr->objProc = infoPtr->objProc;
  2779  	}
  2780  	cmdPtr->objClientData = infoPtr->objClientData;
  2781      }
  2782      cmdPtr->deleteProc = infoPtr->deleteProc;
  2783      cmdPtr->deleteData = infoPtr->deleteData;
  2784      return 1;
  2785  }
  2786  
  2787  /*
  2788   *----------------------------------------------------------------------
  2789   *
  2790   * Tcl_GetCommandInfo --
  2791   *
  2792   *	Returns various information about a Tcl command.
  2793   *
  2794   * Results:
  2795   *	If cmdName exists in interp, then *infoPtr is modified to hold
  2796   *	information about cmdName and 1 is returned. If the command doesn't
  2797   *	exist then 0 is returned and *infoPtr isn't modified.
  2798   *
  2799   * Side effects:
  2800   *	None.
  2801   *
  2802   *----------------------------------------------------------------------
  2803   */
  2804  
  2805  int
  2806  Tcl_GetCommandInfo(
  2807      Tcl_Interp *interp,		/* Interpreter in which to look for
  2808  				 * command. */
  2809      const char *cmdName,	/* Name of desired command. */
  2810      Tcl_CmdInfo *infoPtr)	/* Where to store information about
  2811  				 * command. */
  2812  {
  2813      Tcl_Command cmd;
  2814  
  2815      cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0);
  2816      return Tcl_GetCommandInfoFromToken(cmd, infoPtr);
  2817  }
  2818  
  2819  /*
  2820   *----------------------------------------------------------------------
  2821   *
  2822   * Tcl_GetCommandInfoFromToken --
  2823   *
  2824   *	Returns various information about a Tcl command.
  2825   *
  2826   * Results:
  2827   *	Copies information from the command identified by 'cmd' into a
  2828   *	caller-supplied structure and returns 1. If the 'cmd' is NULL, leaves
  2829   *	the structure untouched and returns 0.
  2830   *
  2831   * Side effects:
  2832   *	None.
  2833   *
  2834   *----------------------------------------------------------------------
  2835   */
  2836  
  2837  int
  2838  Tcl_GetCommandInfoFromToken(
  2839      Tcl_Command cmd,
  2840      Tcl_CmdInfo *infoPtr)
  2841  {
  2842      Command *cmdPtr;		/* Internal representation of the command */
  2843  
  2844      if (cmd == NULL) {
  2845  	return 0;
  2846      }
  2847  
  2848      /*
  2849       * Set isNativeObjectProc 1 if objProc was registered by a call to
  2850       * Tcl_CreateObjCommand. Otherwise set it to 0.
  2851       */
  2852  
  2853      cmdPtr = (Command *) cmd;
  2854      infoPtr->isNativeObjectProc =
  2855  	    (cmdPtr->objProc != TclInvokeStringCommand);
  2856      infoPtr->objProc = cmdPtr->objProc;
  2857      infoPtr->objClientData = cmdPtr->objClientData;
  2858      infoPtr->proc = cmdPtr->proc;
  2859      infoPtr->clientData = cmdPtr->clientData;
  2860      infoPtr->deleteProc = cmdPtr->deleteProc;
  2861      infoPtr->deleteData = cmdPtr->deleteData;
  2862      infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
  2863  
  2864      return 1;
  2865  }
  2866  
  2867  /*
  2868   *----------------------------------------------------------------------
  2869   *
  2870   * Tcl_GetCommandName --
  2871   *
  2872   *	Given a token returned by Tcl_CreateCommand, this function returns the
  2873   *	current name of the command (which may have changed due to renaming).
  2874   *
  2875   * Results:
  2876   *	The return value is the name of the given command.
  2877   *
  2878   * Side effects:
  2879   *	None.
  2880   *
  2881   *----------------------------------------------------------------------
  2882   */
  2883  
  2884  const char *
  2885  Tcl_GetCommandName(
  2886      Tcl_Interp *interp,		/* Interpreter containing the command. */
  2887      Tcl_Command command)	/* Token for command returned by a previous
  2888  				 * call to Tcl_CreateCommand. The command must
  2889  				 * not have been deleted. */
  2890  {
  2891      Command *cmdPtr = (Command *) command;
  2892  
  2893      if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
  2894  	/*
  2895  	 * This should only happen if command was "created" after the
  2896  	 * interpreter began to be deleted, so there isn't really any command.
  2897  	 * Just return an empty string.
  2898  	 */
  2899  
  2900  	return "";
  2901      }
  2902  
  2903      return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
  2904  }
  2905  
  2906  /*
  2907   *----------------------------------------------------------------------
  2908   *
  2909   * Tcl_GetCommandFullName --
  2910   *
  2911   *	Given a token returned by, e.g., Tcl_CreateCommand or Tcl_FindCommand,
  2912   *	this function appends to an object the command's full name, qualified
  2913   *	by a sequence of parent namespace names. The command's fully-qualified
  2914   *	name may have changed due to renaming.
  2915   *
  2916   * Results:
  2917   *	None.
  2918   *
  2919   * Side effects:
  2920   *	The command's fully-qualified name is appended to the string
  2921   *	representation of objPtr.
  2922   *
  2923   *----------------------------------------------------------------------
  2924   */
  2925  
  2926  void
  2927  Tcl_GetCommandFullName(
  2928      Tcl_Interp *interp,		/* Interpreter containing the command. */
  2929      Tcl_Command command,	/* Token for command returned by a previous
  2930  				 * call to Tcl_CreateCommand. The command must
  2931  				 * not have been deleted. */
  2932      Tcl_Obj *objPtr)		/* Points to the object onto which the
  2933  				 * command's full name is appended. */
  2934  
  2935  {
  2936      Interp *iPtr = (Interp *) interp;
  2937      register Command *cmdPtr = (Command *) command;
  2938      char *name;
  2939  
  2940      /*
  2941       * Add the full name of the containing namespace, followed by the "::"
  2942       * separator, and the command name.
  2943       */
  2944  
  2945      if (cmdPtr != NULL) {
  2946  	if (cmdPtr->nsPtr != NULL) {
  2947  	    Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
  2948  	    if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
  2949  		Tcl_AppendToObj(objPtr, "::", 2);
  2950  	    }
  2951  	}
  2952  	if (cmdPtr->hPtr != NULL) {
  2953  	    name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
  2954  	    Tcl_AppendToObj(objPtr, name, -1);
  2955  	}
  2956      }
  2957  }
  2958  
  2959  /*
  2960   *----------------------------------------------------------------------
  2961   *
  2962   * Tcl_DeleteCommand --
  2963   *
  2964   *	Remove the given command from the given interpreter.
  2965   *
  2966   * Results:
  2967   *	0 is returned if the command was deleted successfully. -1 is returned
  2968   *	if there didn't exist a command by that name.
  2969   *
  2970   * Side effects:
  2971   *	cmdName will no longer be recognized as a valid command for interp.
  2972   *
  2973   *----------------------------------------------------------------------
  2974   */
  2975  
  2976  int
  2977  Tcl_DeleteCommand(
  2978      Tcl_Interp *interp,		/* Token for command interpreter (returned by
  2979  				 * a previous Tcl_CreateInterp call). */
  2980      const char *cmdName)	/* Name of command to remove. */
  2981  {
  2982      Tcl_Command cmd;
  2983  
  2984      /*
  2985       * Find the desired command and delete it.
  2986       */
  2987  
  2988      cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0);
  2989      if (cmd == NULL) {
  2990  	return -1;
  2991      }
  2992      return Tcl_DeleteCommandFromToken(interp, cmd);
  2993  }
  2994  
  2995  /*
  2996   *----------------------------------------------------------------------
  2997   *
  2998   * Tcl_DeleteCommandFromToken --
  2999   *
  3000   *	Removes the given command from the given interpreter. This function
  3001   *	resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead of
  3002   *	a command name for efficiency.
  3003   *
  3004   * Results:
  3005   *	0 is returned if the command was deleted successfully. -1 is returned
  3006   *	if there didn't exist a command by that name.
  3007   *
  3008   * Side effects:
  3009   *	The command specified by "cmd" will no longer be recognized as a valid
  3010   *	command for "interp".
  3011   *
  3012   *----------------------------------------------------------------------
  3013   */
  3014  
  3015  int
  3016  Tcl_DeleteCommandFromToken(
  3017      Tcl_Interp *interp,		/* Token for command interpreter returned by a
  3018  				 * previous call to Tcl_CreateInterp. */
  3019      Tcl_Command cmd)		/* Token for command to delete. */
  3020  {
  3021      Interp *iPtr = (Interp *) interp;
  3022      Command *cmdPtr = (Command *) cmd;
  3023      ImportRef *refPtr, *nextRefPtr;
  3024      Tcl_Command importCmd;
  3025  
  3026      /*
  3027       * Bump the command epoch counter. This will invalidate all cached
  3028       * references that point to this command.
  3029       */
  3030  
  3031      cmdPtr->cmdEpoch++;
  3032  
  3033      /*
  3034       * The code here is tricky. We can't delete the hash table entry before
  3035       * invoking the deletion callback because there are cases where the
  3036       * deletion callback needs to invoke the command (e.g. object systems such
  3037       * as OTcl). However, this means that the callback could try to delete or
  3038       * rename the command. The deleted flag allows us to detect these cases
  3039       * and skip nested deletes.
  3040       */
  3041  
  3042      if (cmdPtr->flags & CMD_IS_DELETED) {
  3043  	/*
  3044  	 * Another deletion is already in progress. Remove the hash table
  3045  	 * entry now, but don't invoke a callback or free the command
  3046  	 * structure. Take care to only remove the hash entry if it has not
  3047  	 * already been removed; otherwise if we manage to hit this function
  3048  	 * three times, everything goes up in smoke. [Bug 1220058]
  3049  	 */
  3050  
  3051  	if (cmdPtr->hPtr != NULL) {
  3052  	    Tcl_DeleteHashEntry(cmdPtr->hPtr);
  3053  	    cmdPtr->hPtr = NULL;
  3054  	}
  3055  	return 0;
  3056      }
  3057  
  3058      /*
  3059       * We must delete this command, even though both traces and delete procs
  3060       * may try to avoid this (renaming the command etc). Also traces and
  3061       * delete procs may try to delete the command themsevles. This flag
  3062       * declares that a delete is in progress and that recursive deletes should
  3063       * be ignored.
  3064       */
  3065  
  3066      cmdPtr->flags |= CMD_IS_DELETED;
  3067  
  3068      /*
  3069       * Call trace functions for the command being deleted. Then delete its
  3070       * traces.
  3071       */
  3072  
  3073      if (cmdPtr->tracePtr != NULL) {
  3074  	CommandTrace *tracePtr;
  3075  	CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
  3076  
  3077  	/*
  3078  	 * Now delete these traces.
  3079  	 */
  3080  
  3081  	tracePtr = cmdPtr->tracePtr;
  3082  	while (tracePtr != NULL) {
  3083  	    CommandTrace *nextPtr = tracePtr->nextPtr;
  3084  
  3085  	    if ((--tracePtr->refCount) <= 0) {
  3086  		ckfree(tracePtr);
  3087  	    }
  3088  	    tracePtr = nextPtr;
  3089  	}
  3090  	cmdPtr->tracePtr = NULL;
  3091      }
  3092  
  3093      /*
  3094       * The list of command exported from the namespace might have changed.
  3095       * However, we do not need to recompute this just yet; next time we need
  3096       * the info will be soon enough.
  3097       */
  3098  
  3099      TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
  3100  
  3101      /*
  3102       * If the command being deleted has a compile function, increment the
  3103       * interpreter's compileEpoch to invalidate its compiled code. This makes
  3104       * sure that we don't later try to execute old code compiled with
  3105       * command-specific (i.e., inline) bytecodes for the now-deleted command.
  3106       * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose
  3107       * compilation epoch doesn't match is recompiled.
  3108       */
  3109  
  3110      if (cmdPtr->compileProc != NULL) {
  3111  	iPtr->compileEpoch++;
  3112      }
  3113  
  3114      if (cmdPtr->deleteProc != NULL) {
  3115  	/*
  3116  	 * Delete the command's client data. If this was an imported command
  3117  	 * created when a command was imported into a namespace, this client
  3118  	 * data will be a pointer to a ImportedCmdData structure describing
  3119  	 * the "real" command that this imported command refers to.
  3120  	 *
  3121  	 * If you are getting a crash during the call to deleteProc and
  3122  	 * cmdPtr->deleteProc is a pointer to the function free(), the most
  3123  	 * likely cause is that your extension allocated memory for the
  3124  	 * clientData argument to Tcl_CreateObjCommand with the ckalloc()
  3125  	 * macro and you are now trying to deallocate this memory with free()
  3126  	 * instead of ckfree(). You should pass a pointer to your own method
  3127  	 * that calls ckfree().
  3128  	 */
  3129  
  3130  	cmdPtr->deleteProc(cmdPtr->deleteData);
  3131      }
  3132  
  3133      /*
  3134       * If this command was imported into other namespaces, then imported
  3135       * commands were created that refer back to this command. Delete these
  3136       * imported commands now.
  3137       */
  3138      if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) {
  3139  	for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
  3140  		refPtr = nextRefPtr) {
  3141  	    nextRefPtr = refPtr->nextPtr;
  3142  	    importCmd = (Tcl_Command) refPtr->importedCmdPtr;
  3143  	    Tcl_DeleteCommandFromToken(interp, importCmd);
  3144  	}
  3145      }
  3146  
  3147      /*
  3148       * Don't use hPtr to delete the hash entry here, because it's possible
  3149       * that the deletion callback renamed the command. Instead, use
  3150       * cmdPtr->hptr, and make sure that no-one else has already deleted the
  3151       * hash entry.
  3152       */
  3153  
  3154      if (cmdPtr->hPtr != NULL) {
  3155  	Tcl_DeleteHashEntry(cmdPtr->hPtr);
  3156  	cmdPtr->hPtr = NULL;
  3157      }
  3158  
  3159      /*
  3160       * A number of tests for particular kinds of commands are done by checking
  3161       * whether the objProc field holds a known value. Set the field to NULL so
  3162       * that such tests won't have false positives when applied to deleted
  3163       * commands.
  3164       */
  3165  
  3166      cmdPtr->objProc = NULL;
  3167  
  3168      /*
  3169       * Now free the Command structure, unless there is another reference to it
  3170       * from a CmdName Tcl object in some ByteCode code sequence. In that case,
  3171       * delay the cleanup until all references are either discarded (when a
  3172       * ByteCode is freed) or replaced by a new reference (when a cached
  3173       * CmdName Command reference is found to be invalid and
  3174       * TclNRExecuteByteCode looks up the command in the command hashtable).
  3175       */
  3176  
  3177      TclCleanupCommandMacro(cmdPtr);
  3178      return 0;
  3179  }
  3180  
  3181  /*
  3182   *----------------------------------------------------------------------
  3183   *
  3184   * CallCommandTraces --
  3185   *
  3186   *	Abstraction of the code to call traces on a command.
  3187   *
  3188   * Results:
  3189   *	Currently always NULL.
  3190   *
  3191   * Side effects:
  3192   *	Anything; this may recursively evaluate scripts and code exists to do
  3193   *	just that.
  3194   *
  3195   *----------------------------------------------------------------------
  3196   */
  3197  
  3198  static char *
  3199  CallCommandTraces(
  3200      Interp *iPtr,		/* Interpreter containing command. */
  3201      Command *cmdPtr,		/* Command whose traces are to be invoked. */
  3202      const char *oldName,	/* Command's old name, or NULL if we must get
  3203  				 * the name from cmdPtr */
  3204      const char *newName,	/* Command's new name, or NULL if the command
  3205  				 * is not being renamed */
  3206      int flags)			/* Flags indicating the type of traces to
  3207  				 * trigger, either TCL_TRACE_DELETE or
  3208  				 * TCL_TRACE_RENAME. */
  3209  {
  3210      register CommandTrace *tracePtr;
  3211      ActiveCommandTrace active;
  3212      char *result;
  3213      Tcl_Obj *oldNamePtr = NULL;
  3214      Tcl_InterpState state = NULL;
  3215  
  3216      if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
  3217  	/*
  3218  	 * While a rename trace is active, we will not process any more rename
  3219  	 * traces; while a delete trace is active we will never reach here -
  3220  	 * because Tcl_DeleteCommandFromToken checks for the condition
  3221  	 * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a
  3222  	 * command deletion is in progress. For all other traces, delete
  3223  	 * traces will not be invoked but a call to TraceCommandProc will
  3224  	 * ensure that tracePtr->clientData is freed whenever the command
  3225  	 * "oldName" is deleted.
  3226  	 */
  3227  
  3228  	if (cmdPtr->flags & TCL_TRACE_RENAME) {
  3229  	    flags &= ~TCL_TRACE_RENAME;
  3230  	}
  3231  	if (flags == 0) {
  3232  	    return NULL;
  3233  	}
  3234      }
  3235      cmdPtr->flags |= CMD_TRACE_ACTIVE;
  3236      cmdPtr->refCount++;
  3237  
  3238      result = NULL;
  3239      active.nextPtr = iPtr->activeCmdTracePtr;
  3240      active.reverseScan = 0;
  3241      iPtr->activeCmdTracePtr = &active;
  3242  
  3243      if (flags & TCL_TRACE_DELETE) {
  3244  	flags |= TCL_TRACE_DESTROYED;
  3245      }
  3246      active.cmdPtr = cmdPtr;
  3247  
  3248      Tcl_Preserve(iPtr);
  3249  
  3250      for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
  3251  	    tracePtr = active.nextTracePtr) {
  3252  	active.nextTracePtr = tracePtr->nextPtr;
  3253  	if (!(tracePtr->flags & flags)) {
  3254  	    continue;
  3255  	}
  3256  	cmdPtr->flags |= tracePtr->flags;
  3257  	if (oldName == NULL) {
  3258  	    TclNewObj(oldNamePtr);
  3259  	    Tcl_IncrRefCount(oldNamePtr);
  3260  	    Tcl_GetCommandFullName((Tcl_Interp *) iPtr,
  3261  		    (Tcl_Command) cmdPtr, oldNamePtr);
  3262  	    oldName = TclGetString(oldNamePtr);
  3263  	}
  3264  	tracePtr->refCount++;
  3265  	if (state == NULL) {
  3266  	    state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK);
  3267  	}
  3268  	tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr,
  3269  		oldName, newName, flags);
  3270  	cmdPtr->flags &= ~tracePtr->flags;
  3271  	if ((--tracePtr->refCount) <= 0) {
  3272  	    ckfree(tracePtr);
  3273  	}
  3274      }
  3275  
  3276      if (state) {
  3277  	Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
  3278      }
  3279  
  3280      /*
  3281       * If a new object was created to hold the full oldName, free it now.
  3282       */
  3283  
  3284      if (oldNamePtr != NULL) {
  3285  	TclDecrRefCount(oldNamePtr);
  3286      }
  3287  
  3288      /*
  3289       * Restore the variable's flags, remove the record of our active traces,
  3290       * and then return.
  3291       */
  3292  
  3293      cmdPtr->flags &= ~CMD_TRACE_ACTIVE;
  3294      cmdPtr->refCount--;
  3295      iPtr->activeCmdTracePtr = active.nextPtr;
  3296      Tcl_Release(iPtr);
  3297      return result;
  3298  }
  3299  
  3300  /*
  3301   *----------------------------------------------------------------------
  3302   *
  3303   * CancelEvalProc --
  3304   *
  3305   *	Marks this interpreter as being canceled. This causes current
  3306   *	executions to be unwound as the interpreter enters a state where it
  3307   *	refuses to execute more commands or handle [catch] or [try], yet the
  3308   *	interpreter is still able to execute further commands after the
  3309   *	cancelation is cleared (unlike if it is deleted).
  3310   *
  3311   * Results:
  3312   *	The value given for the code argument.
  3313   *
  3314   * Side effects:
  3315   *	Transfers a message from the cancelation message to the interpreter.
  3316   *
  3317   *----------------------------------------------------------------------
  3318   */
  3319  
  3320  static int
  3321  CancelEvalProc(
  3322      ClientData clientData,	/* Interp to cancel the script in progress. */
  3323      Tcl_Interp *interp,		/* Ignored */
  3324      int code)			/* Current return code from command. */
  3325  {
  3326      CancelInfo *cancelInfo = clientData;
  3327      Interp *iPtr;
  3328  
  3329      if (cancelInfo != NULL) {
  3330  	Tcl_MutexLock(&cancelLock);
  3331  	iPtr = (Interp *) cancelInfo->interp;
  3332  
  3333  	if (iPtr != NULL) {
  3334  	    /*
  3335  	     * Setting the CANCELED flag will cause the script in progress to
  3336  	     * be canceled as soon as possible. The core honors this flag at
  3337  	     * all the necessary places to ensure script cancellation is
  3338  	     * responsive. Extensions can check for this flag by calling
  3339  	     * Tcl_Canceled and checking if TCL_ERROR is returned or they can
  3340  	     * choose to ignore the script cancellation flag and the
  3341  	     * associated functionality altogether. Currently, the only other
  3342  	     * flag we care about here is the TCL_CANCEL_UNWIND flag (from
  3343  	     * Tcl_CancelEval). We do not want to simply combine all the flags
  3344  	     * from original Tcl_CancelEval call with the interp flags here
  3345  	     * just in case the caller passed flags that might cause behaviour
  3346  	     * unrelated to script cancellation.
  3347  	     */
  3348  
  3349  	    TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED);
  3350  
  3351  	    /*
  3352  	     * Now, we must set the script cancellation flags on all the slave
  3353  	     * interpreters belonging to this one.
  3354  	     */
  3355  
  3356  	    TclSetSlaveCancelFlags((Tcl_Interp *) iPtr,
  3357  		    cancelInfo->flags | CANCELED, 0);
  3358  
  3359  	    /*
  3360  	     * Create the result object now so that Tcl_Canceled can avoid
  3361  	     * locking the cancelLock mutex.
  3362  	     */
  3363  
  3364  	    if (cancelInfo->result != NULL) {
  3365  		Tcl_SetStringObj(iPtr->asyncCancelMsg, cancelInfo->result,
  3366  			cancelInfo->length);
  3367  	    } else {
  3368  		Tcl_SetObjLength(iPtr->asyncCancelMsg, 0);
  3369  	    }
  3370  	}
  3371  	Tcl_MutexUnlock(&cancelLock);
  3372      }
  3373  
  3374      return code;
  3375  }
  3376  
  3377  /*
  3378   *----------------------------------------------------------------------
  3379   *
  3380   * TclCleanupCommand --
  3381   *
  3382   *	This function frees up a Command structure unless it is still
  3383   *	referenced from an interpreter's command hashtable or from a CmdName
  3384   *	Tcl object representing the name of a command in a ByteCode
  3385   *	instruction sequence.
  3386   *
  3387   * Results:
  3388   *	None.
  3389   *
  3390   * Side effects:
  3391   *	Memory gets freed unless a reference to the Command structure still
  3392   *	exists. In that case the cleanup is delayed until the command is
  3393   *	deleted or when the last ByteCode referring to it is freed.
  3394   *
  3395   *----------------------------------------------------------------------
  3396   */
  3397  
  3398  void
  3399  TclCleanupCommand(
  3400      register Command *cmdPtr)	/* Points to the Command structure to
  3401  				 * be freed. */
  3402  {
  3403      cmdPtr->refCount--;
  3404      if (cmdPtr->refCount <= 0) {
  3405  	ckfree(cmdPtr);
  3406      }
  3407  }
  3408  
  3409  /*
  3410   *----------------------------------------------------------------------
  3411   *
  3412   * Tcl_CreateMathFunc --
  3413   *
  3414   *	Creates a new math function for expressions in a given interpreter.
  3415   *
  3416   * Results:
  3417   *	None.
  3418   *
  3419   * Side effects:
  3420   *	The Tcl function defined by "name" is created or redefined. If the
  3421   *	function already exists then its definition is replaced; this includes
  3422   *	the builtin functions. Redefining a builtin function forces all
  3423   *	existing code to be invalidated since that code may be compiled using
  3424   *	an instruction specific to the replaced function. In addition,
  3425   *	redefioning a non-builtin function will force existing code to be
  3426   *	invalidated if the number of arguments has changed.
  3427   *
  3428   *----------------------------------------------------------------------
  3429   */
  3430  
  3431  void
  3432  Tcl_CreateMathFunc(
  3433      Tcl_Interp *interp,		/* Interpreter in which function is to be
  3434  				 * available. */
  3435      const char *name,		/* Name of function (e.g. "sin"). */
  3436      int numArgs,		/* Nnumber of arguments required by
  3437  				 * function. */
  3438      Tcl_ValueType *argTypes,	/* Array of types acceptable for each
  3439  				 * argument. */
  3440      Tcl_MathProc *proc,		/* C function that implements the math
  3441  				 * function. */
  3442      ClientData clientData)	/* Additional value to pass to the
  3443  				 * function. */
  3444  {
  3445      Tcl_DString bigName;
  3446      OldMathFuncData *data = ckalloc(sizeof(OldMathFuncData));
  3447  
  3448      data->proc = proc;
  3449      data->numArgs = numArgs;
  3450      data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType));
  3451      memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
  3452      data->clientData = clientData;
  3453  
  3454      Tcl_DStringInit(&bigName);
  3455      TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::");
  3456      Tcl_DStringAppend(&bigName, name, -1);
  3457  
  3458      Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName),
  3459  	    OldMathFuncProc, data, OldMathFuncDeleteProc);
  3460      Tcl_DStringFree(&bigName);
  3461  }
  3462  
  3463  /*
  3464   *----------------------------------------------------------------------
  3465   *
  3466   * OldMathFuncProc --
  3467   *
  3468   *	Dispatch to a math function created with Tcl_CreateMathFunc
  3469   *
  3470   * Results:
  3471   *	Returns a standard Tcl result.
  3472   *
  3473   * Side effects:
  3474   *	Whatever the math function does.
  3475   *
  3476   *----------------------------------------------------------------------
  3477   */
  3478  
  3479  static int
  3480  OldMathFuncProc(
  3481      ClientData clientData,	/* Ponter to OldMathFuncData describing the
  3482  				 * function being called */
  3483      Tcl_Interp *interp,		/* Tcl interpreter */
  3484      int objc,			/* Actual parameter count */
  3485      Tcl_Obj *const *objv)	/* Parameter vector */
  3486  {
  3487      Tcl_Obj *valuePtr;
  3488      OldMathFuncData *dataPtr = clientData;
  3489      Tcl_Value funcResult, *args;
  3490      int result;
  3491      int j, k;
  3492      double d;
  3493  
  3494      /*
  3495       * Check argument count.
  3496       */
  3497  
  3498      if (objc != dataPtr->numArgs + 1) {
  3499  	MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv);
  3500  	return TCL_ERROR;
  3501      }
  3502  
  3503      /*
  3504       * Convert arguments from Tcl_Obj's to Tcl_Value's.
  3505       */
  3506  
  3507      args = ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
  3508      for (j = 1, k = 0; j < objc; ++j, ++k) {
  3509  	/* TODO: Convert to TclGetNumberFromObj? */
  3510  	valuePtr = objv[j];
  3511  	result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
  3512  #ifdef ACCEPT_NAN
  3513  	if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) {
  3514  	    d = valuePtr->internalRep.doubleValue;
  3515  	    result = TCL_OK;
  3516  	}
  3517  #endif
  3518  	if (result != TCL_OK) {
  3519  	    /*
  3520  	     * We have a non-numeric argument.
  3521  	     */
  3522  
  3523  	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
  3524  		    "argument to math function didn't have numeric value",
  3525  		    -1));
  3526  	    TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
  3527  	    ckfree(args);
  3528  	    return TCL_ERROR;
  3529  	}
  3530  
  3531  	/*
  3532  	 * Copy the object's numeric value to the argument record, converting
  3533  	 * it if necessary.
  3534  	 *
  3535  	 * NOTE: no bignum support; use the new mathfunc interface for that.
  3536  	 */
  3537  
  3538  	args[k].type = dataPtr->argTypes[k];
  3539  	switch (args[k].type) {
  3540  	case TCL_EITHER:
  3541  	    if (Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue)
  3542  		    == TCL_OK) {
  3543  		args[k].type = TCL_INT;
  3544  		break;
  3545  	    }
  3546  	    if (Tcl_GetWideIntFromObj(interp, valuePtr, &args[k].wideValue)
  3547  		    == TCL_OK) {
  3548  		args[k].type = TCL_WIDE_INT;
  3549  		break;
  3550  	    }
  3551  	    args[k].type = TCL_DOUBLE;
  3552  	    /* FALLTHROUGH */
  3553  
  3554  	case TCL_DOUBLE:
  3555  	    args[k].doubleValue = d;
  3556  	    break;
  3557  	case TCL_INT:
  3558  	    if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) {
  3559  		ckfree(args);
  3560  		return TCL_ERROR;
  3561  	    }
  3562  	    valuePtr = Tcl_GetObjResult(interp);
  3563  	    Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue);
  3564  	    Tcl_ResetResult(interp);
  3565  	    break;
  3566  	case TCL_WIDE_INT:
  3567  	    if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) {
  3568  		ckfree(args);
  3569  		return TCL_ERROR;
  3570  	    }
  3571  	    valuePtr = Tcl_GetObjResult(interp);
  3572  	    Tcl_GetWideIntFromObj(NULL, valuePtr, &args[k].wideValue);
  3573  	    Tcl_ResetResult(interp);
  3574  	    break;
  3575  	}
  3576      }
  3577  
  3578      /*
  3579       * Call the function.
  3580       */
  3581  
  3582      errno = 0;
  3583      result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult);
  3584      ckfree(args);
  3585      if (result != TCL_OK) {
  3586  	return result;
  3587      }
  3588  
  3589      /*
  3590       * Return the result of the call.
  3591       */
  3592  
  3593      if (funcResult.type == TCL_INT) {
  3594  	TclNewLongObj(valuePtr, funcResult.intValue);
  3595      } else if (funcResult.type == TCL_WIDE_INT) {
  3596  	valuePtr = Tcl_NewWideIntObj(funcResult.wideValue);
  3597      } else {
  3598  	return CheckDoubleResult(interp, funcResult.doubleValue);
  3599      }
  3600      Tcl_SetObjResult(interp, valuePtr);
  3601      return TCL_OK;
  3602  }
  3603  
  3604  /*
  3605   *----------------------------------------------------------------------
  3606   *
  3607   * OldMathFuncDeleteProc --
  3608   *
  3609   *	Cleans up after deleting a math function registered with
  3610   *	Tcl_CreateMathFunc
  3611   *
  3612   * Results:
  3613   *	None.
  3614   *
  3615   * Side effects:
  3616   *	Frees allocated memory.
  3617   *
  3618   *----------------------------------------------------------------------
  3619   */
  3620  
  3621  static void
  3622  OldMathFuncDeleteProc(
  3623      ClientData clientData)
  3624  {
  3625      OldMathFuncData *dataPtr = clientData;
  3626  
  3627      ckfree(dataPtr->argTypes);
  3628      ckfree(dataPtr);
  3629  }
  3630  
  3631  /*
  3632   *----------------------------------------------------------------------
  3633   *
  3634   * Tcl_GetMathFuncInfo --
  3635   *
  3636   *	Discovers how a particular math function was created in a given
  3637   *	interpreter.
  3638   *
  3639   * Results:
  3640   *	TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the
  3641   *	interpreter result if that happens.)
  3642   *
  3643   * Side effects:
  3644   *	If this function succeeds, the variables pointed to by the numArgsPtr
  3645   *	and argTypePtr arguments will be updated to detail the arguments
  3646   *	allowed by the function. The variable pointed to by the procPtr
  3647   *	argument will be set to NULL if the function is a builtin function,
  3648   *	and will be set to the address of the C function used to implement the
  3649   *	math function otherwise (in which case the variable pointed to by the
  3650   *	clientDataPtr argument will also be updated.)
  3651   *
  3652   *----------------------------------------------------------------------
  3653   */
  3654  
  3655  int
  3656  Tcl_GetMathFuncInfo(
  3657      Tcl_Interp *interp,
  3658      const char *name,
  3659      int *numArgsPtr,
  3660      Tcl_ValueType **argTypesPtr,
  3661      Tcl_MathProc **procPtr,
  3662      ClientData *clientDataPtr)
  3663  {
  3664      Tcl_Obj *cmdNameObj;
  3665      Command *cmdPtr;
  3666  
  3667      /*
  3668       * Get the command that implements the math function.
  3669       */
  3670  
  3671      TclNewLiteralStringObj(cmdNameObj, "tcl::mathfunc::");
  3672      Tcl_AppendToObj(cmdNameObj, name, -1);
  3673      Tcl_IncrRefCount(cmdNameObj);
  3674      cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdNameObj);
  3675      Tcl_DecrRefCount(cmdNameObj);
  3676  
  3677      /*
  3678       * Report unknown functions.
  3679       */
  3680  
  3681      if (cmdPtr == NULL) {
  3682          Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  3683                  "unknown math function \"%s\"", name));
  3684  	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL);
  3685  	*numArgsPtr = -1;
  3686  	*argTypesPtr = NULL;
  3687  	*procPtr = NULL;
  3688  	*clientDataPtr = NULL;
  3689  	return TCL_ERROR;
  3690      }
  3691  
  3692      /*
  3693       * Retrieve function info for user defined functions; return dummy
  3694       * information for builtins.
  3695       */
  3696  
  3697      if (cmdPtr->objProc == &OldMathFuncProc) {
  3698  	OldMathFuncData *dataPtr = cmdPtr->clientData;
  3699  
  3700  	*procPtr = dataPtr->proc;
  3701  	*numArgsPtr = dataPtr->numArgs;
  3702  	*argTypesPtr = dataPtr->argTypes;
  3703  	*clientDataPtr = dataPtr->clientData;
  3704      } else {
  3705  	*procPtr = NULL;
  3706  	*numArgsPtr = -1;
  3707  	*argTypesPtr = NULL;
  3708  	*procPtr = NULL;
  3709  	*clientDataPtr = NULL;
  3710      }
  3711      return TCL_OK;
  3712  }
  3713  
  3714  /*
  3715   *----------------------------------------------------------------------
  3716   *
  3717   * Tcl_ListMathFuncs --
  3718   *
  3719   *	Produces a list of all the math functions defined in a given
  3720   *	interpreter.
  3721   *
  3722   * Results:
  3723   *	A pointer to a Tcl_Obj structure with a reference count of zero, or
  3724   *	NULL in the case of an error (in which case a suitable error message
  3725   *	will be left in the interpreter result.)
  3726   *
  3727   * Side effects:
  3728   *	None.
  3729   *
  3730   *----------------------------------------------------------------------
  3731   */
  3732  
  3733  Tcl_Obj *
  3734  Tcl_ListMathFuncs(
  3735      Tcl_Interp *interp,
  3736      const char *pattern)
  3737  {
  3738      Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1);
  3739      Tcl_Obj *result;
  3740      Tcl_InterpState state;
  3741  
  3742      if (pattern) {
  3743  	Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1);
  3744  	Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj);
  3745  
  3746  	Tcl_AppendObjToObj(script, arg);
  3747  	Tcl_DecrRefCount(arg);	/* Should tear down patternObj too */
  3748      }
  3749  
  3750      state = Tcl_SaveInterpState(interp, TCL_OK);
  3751      Tcl_IncrRefCount(script);
  3752      if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) {
  3753  	result = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
  3754      } else {
  3755  	result = Tcl_NewObj();
  3756      }
  3757      Tcl_DecrRefCount(script);
  3758      Tcl_RestoreInterpState(interp, state);
  3759  
  3760      return result;
  3761  }
  3762  
  3763  /*
  3764   *----------------------------------------------------------------------
  3765   *
  3766   * TclInterpReady --
  3767   *
  3768   *	Check if an interpreter is ready to eval commands or scripts, i.e., if
  3769   *	it was not deleted and if the nesting level is not too high.
  3770   *
  3771   * Results:
  3772   *	The return value is TCL_OK if it the interpreter is ready, TCL_ERROR
  3773   *	otherwise.
  3774   *
  3775   * Side effects:
  3776   *	The interpreters object and string results are cleared.
  3777   *
  3778   *----------------------------------------------------------------------
  3779   */
  3780  
  3781  int
  3782  TclInterpReady(
  3783      Tcl_Interp *interp)
  3784  {
  3785      register Interp *iPtr = (Interp *) interp;
  3786  
  3787      /*
  3788       * Reset both the interpreter's string and object results and clear out
  3789       * any previous error information.
  3790       */
  3791  
  3792      Tcl_ResetResult(interp);
  3793  
  3794      /*
  3795       * If the interpreter has been deleted, return an error.
  3796       */
  3797  
  3798      if (iPtr->flags & DELETED) {
  3799  	Tcl_SetObjResult(interp, Tcl_NewStringObj(
  3800  		"attempt to call eval in deleted interpreter", -1));
  3801  	Tcl_SetErrorCode(interp, "TCL", "IDELETE",
  3802  		"attempt to call eval in deleted interpreter", NULL);
  3803  	return TCL_ERROR;
  3804      }
  3805  
  3806      if (iPtr->execEnvPtr->rewind) {
  3807  	return TCL_ERROR;
  3808      }
  3809  
  3810      /*
  3811       * Make sure the script being evaluated (if any) has not been canceled.
  3812       */
  3813  
  3814      if (TclCanceled(iPtr) &&
  3815  	    (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) {
  3816  	return TCL_ERROR;
  3817      }
  3818  
  3819      /*
  3820       * Check depth of nested calls to Tcl_Eval: if this gets too large, it's
  3821       * probably because of an infinite loop somewhere.
  3822       */
  3823  
  3824      if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) {
  3825  	return TCL_OK;
  3826      }
  3827  
  3828      Tcl_SetObjResult(interp, Tcl_NewStringObj(
  3829  	    "too many nested evaluations (infinite loop?)", -1));
  3830      Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
  3831      return TCL_ERROR;
  3832  }
  3833  
  3834  /*
  3835   *----------------------------------------------------------------------
  3836   *
  3837   * TclResetCancellation --
  3838   *
  3839   *	Reset the script cancellation flags if the nesting level
  3840   *	(iPtr->numLevels) for the interp is zero or argument force is
  3841   *	non-zero.
  3842   *
  3843   * Results:
  3844   *	A standard Tcl result.
  3845   *
  3846   * Side effects:
  3847   *	The script cancellation flags for the interp may be reset.
  3848   *
  3849   *----------------------------------------------------------------------
  3850   */
  3851  
  3852  int
  3853  TclResetCancellation(
  3854      Tcl_Interp *interp,
  3855      int force)
  3856  {
  3857      register Interp *iPtr = (Interp *) interp;
  3858  
  3859      if (iPtr == NULL) {
  3860  	return TCL_ERROR;
  3861      }
  3862  
  3863      if (force || (iPtr->numLevels == 0)) {
  3864  	TclUnsetCancelFlags(iPtr);
  3865      }
  3866      return TCL_OK;
  3867  }
  3868  
  3869  /*
  3870   *----------------------------------------------------------------------
  3871   *
  3872   * Tcl_Canceled --
  3873   *
  3874   *	Check if the script in progress has been canceled, i.e.,
  3875   *	Tcl_CancelEval was called for this interpreter or any of its master
  3876   *	interpreters.
  3877   *
  3878   * Results:
  3879   *	The return value is TCL_OK if the script evaluation has not been
  3880   *	canceled, TCL_ERROR otherwise.
  3881   *
  3882   *	If "flags" contains TCL_LEAVE_ERR_MSG, an error message is returned in
  3883   *	the interpreter's result object. Otherwise, the interpreter's result
  3884   *	object is left unchanged. If "flags" contains TCL_CANCEL_UNWIND,
  3885   *	TCL_ERROR will only be returned if the script evaluation is being
  3886   *	completely unwound.
  3887   *
  3888   * Side effects:
  3889   *	The CANCELED flag for the interp will be reset if it is set.
  3890   *
  3891   *----------------------------------------------------------------------
  3892   */
  3893  
  3894  int
  3895  Tcl_Canceled(
  3896      Tcl_Interp *interp,
  3897      int flags)
  3898  {
  3899      register Interp *iPtr = (Interp *) interp;
  3900  
  3901      /*
  3902       * Has the current script in progress for this interpreter been canceled
  3903       * or is the stack being unwound due to the previous script cancellation?
  3904       */
  3905  
  3906      if (!TclCanceled(iPtr)) {
  3907          return TCL_OK;
  3908      }
  3909  
  3910      /*
  3911       * The CANCELED flag is a one-shot flag that is reset immediately upon
  3912       * being detected; however, if the TCL_CANCEL_UNWIND flag is set we will
  3913       * continue to report that the script in progress has been canceled
  3914       * thereby allowing the evaluation stack for the interp to be fully
  3915       * unwound.
  3916       */
  3917  
  3918      iPtr->flags &= ~CANCELED;
  3919  
  3920      /*
  3921       * The CANCELED flag was detected and reset; however, if the caller
  3922       * specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR
  3923       * (indicating that the script in progress has been canceled) if the
  3924       * evaluation stack for the interp is being fully unwound.
  3925       */
  3926  
  3927      if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) {
  3928          return TCL_OK;
  3929      }
  3930  
  3931      /*
  3932       * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
  3933       * interp's result; otherwise, we leave it alone.
  3934       */
  3935  
  3936      if (flags & TCL_LEAVE_ERR_MSG) {
  3937          const char *id, *message = NULL;
  3938          int length;
  3939  
  3940          /*
  3941           * Setup errorCode variables so that we can differentiate between
  3942           * being canceled and unwound.
  3943           */
  3944  
  3945          if (iPtr->asyncCancelMsg != NULL) {
  3946              message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
  3947          } else {
  3948              length = 0;
  3949          }
  3950  
  3951          if (iPtr->flags & TCL_CANCEL_UNWIND) {
  3952              id = "IUNWIND";
  3953              if (length == 0) {
  3954                  message = "eval unwound";
  3955              }
  3956          } else {
  3957              id = "ICANCEL";
  3958              if (length == 0) {
  3959                  message = "eval canceled";
  3960              }
  3961          }
  3962  
  3963          Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1));
  3964          Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL);
  3965      }
  3966  
  3967      /*
  3968       * Return TCL_ERROR to the caller (not necessarily just the Tcl core
  3969       * itself) that indicates further processing of the script or command in
  3970       * progress should halt gracefully and as soon as possible.
  3971       */
  3972  
  3973      return TCL_ERROR;
  3974  }
  3975  
  3976  /*
  3977   *----------------------------------------------------------------------
  3978   *
  3979   * Tcl_CancelEval --
  3980   *
  3981   *	This function schedules the cancellation of the current script in the
  3982   *	given interpreter.
  3983   *
  3984   * Results:
  3985   *	The return value is a standard Tcl completion code such as TCL_OK or
  3986   *	TCL_ERROR. Since the interp may belong to a different thread, no error
  3987   *	message can be left in the interp's result.
  3988   *
  3989   * Side effects:
  3990   *	The script in progress in the specified interpreter will be canceled
  3991   *	with TCL_ERROR after asynchronous handlers are invoked at the next
  3992   *	Tcl_Canceled check.
  3993   *
  3994   *----------------------------------------------------------------------
  3995   */
  3996  
  3997  int
  3998  Tcl_CancelEval(
  3999      Tcl_Interp *interp,		/* Interpreter in which to cancel the
  4000  				 * script. */
  4001      Tcl_Obj *resultObjPtr,	/* The script cancellation error message or
  4002  				 * NULL for a default error message. */
  4003      ClientData clientData,	/* Passed to CancelEvalProc. */
  4004      int flags)			/* Collection of OR-ed bits that control
  4005  				 * the cancellation of the script. Only
  4006  				 * TCL_CANCEL_UNWIND is currently
  4007  				 * supported. */
  4008  {
  4009      Tcl_HashEntry *hPtr;
  4010      CancelInfo *cancelInfo;
  4011      int code = TCL_ERROR;
  4012      const char *result;
  4013  
  4014      if (interp == NULL) {
  4015  	return TCL_ERROR;
  4016      }
  4017  
  4018      Tcl_MutexLock(&cancelLock);
  4019      if (cancelTableInitialized != 1) {
  4020  	/*
  4021  	 * No CancelInfo hash table (Tcl_CreateInterp has never been called?)
  4022  	 */
  4023  
  4024  	goto done;
  4025      }
  4026      hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp);
  4027      if (hPtr == NULL) {
  4028  	/*
  4029  	 * No CancelInfo record for this interpreter.
  4030  	 */
  4031  
  4032  	goto done;
  4033      }
  4034      cancelInfo = Tcl_GetHashValue(hPtr);
  4035  
  4036      /*
  4037       * Populate information needed by the interpreter thread to fulfill the
  4038       * cancellation request. Currently, clientData is ignored. If the
  4039       * TCL_CANCEL_UNWIND flags bit is set, the script in progress is not
  4040       * allowed to catch the script cancellation because the evaluation stack
  4041       * for the interp is completely unwound.
  4042       */
  4043  
  4044      if (resultObjPtr != NULL) {
  4045  	result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length);
  4046  	cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length);
  4047  	memcpy(cancelInfo->result, result, (size_t) cancelInfo->length);
  4048  	TclDecrRefCount(resultObjPtr);	/* Discard their result object. */
  4049      } else {
  4050  	cancelInfo->result = NULL;
  4051  	cancelInfo->length = 0;
  4052      }
  4053      cancelInfo->clientData = clientData;
  4054      cancelInfo->flags = flags;
  4055      Tcl_AsyncMark(cancelInfo->async);
  4056      code = TCL_OK;
  4057  
  4058    done:
  4059      Tcl_MutexUnlock(&cancelLock);
  4060      return code;
  4061  }
  4062  
  4063  /*
  4064   *----------------------------------------------------------------------
  4065   *
  4066   * Tcl_InterpActive --
  4067   *
  4068   *	Returns non-zero if the specified interpreter is in use, i.e. if there
  4069   *	is an evaluation currently active in the interpreter.
  4070   *
  4071   * Results:
  4072   *	See above.
  4073   *
  4074   * Side effects:
  4075   *	None.
  4076   *
  4077   *----------------------------------------------------------------------
  4078   */
  4079  
  4080  int
  4081  Tcl_InterpActive(
  4082      Tcl_Interp *interp)
  4083  {
  4084      return ((Interp *) interp)->numLevels > 0;
  4085  }
  4086  
  4087  /*
  4088   *----------------------------------------------------------------------
  4089   *
  4090   * Tcl_EvalObjv --
  4091   *
  4092   *	This function evaluates a Tcl command that has already been parsed
  4093   *	into words, with one Tcl_Obj holding each word.
  4094   *
  4095   * Results:
  4096   *	The return value is a standard Tcl completion code such as TCL_OK or
  4097   *	TCL_ERROR. A result or error message is left in interp's result.
  4098   *
  4099   * Side effects:
  4100   *	Always pushes a callback. Other side effects depend on the command.
  4101   *
  4102   *----------------------------------------------------------------------
  4103   */
  4104  
  4105  int
  4106  Tcl_EvalObjv(
  4107      Tcl_Interp *interp,		/* Interpreter in which to evaluate the
  4108  				 * command. Also used for error reporting. */
  4109      int objc,			/* Number of words in command. */
  4110      Tcl_Obj *const objv[],	/* An array of pointers to objects that are
  4111  				 * the words that make up the command. */
  4112      int flags)			/* Collection of OR-ed bits that control the
  4113  				 * evaluation of the script. Only
  4114  				 * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
  4115  				 * TCL_EVAL_NOERR are currently supported. */
  4116  {
  4117      int result;
  4118      NRE_callback *rootPtr = TOP_CB(interp);
  4119  
  4120      result = TclNREvalObjv(interp, objc, objv, flags, NULL);
  4121      return TclNRRunCallbacks(interp, result, rootPtr);
  4122  }
  4123  
  4124  int
  4125  TclNREvalObjv(
  4126      Tcl_Interp *interp,		/* Interpreter in which to evaluate the
  4127  				 * command. Also used for error reporting. */
  4128      int objc,			/* Number of words in command. */
  4129      Tcl_Obj *const objv[],	/* An array of pointers to objects that are
  4130  				 * the words that make up the command. */
  4131      int flags,			/* Collection of OR-ed bits that control the
  4132  				 * evaluation of the script. Only
  4133  				 * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
  4134  				 * TCL_EVAL_NOERR are currently supported. */
  4135      Command *cmdPtr)		/* NULL if the Command is to be looked up
  4136  				 * here, otherwise the pointer to the
  4137  				 * requested Command struct to be invoked. */
  4138  {
  4139      Interp *iPtr = (Interp *) interp;
  4140  
  4141      /*
  4142       * data[1] stores a marker for use by tailcalls; it will be set to 1 by
  4143       * command redirectors (imports, alias, ensembles) so that tailcalls
  4144       * finishes the source command and not just the target.
  4145       */
  4146  
  4147      if (iPtr->deferredCallbacks) {
  4148          iPtr->deferredCallbacks = NULL;
  4149      } else {
  4150  	TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
  4151      }
  4152  
  4153      iPtr->numLevels++;
  4154      TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags),
  4155  	    INT2PTR(objc), objv);
  4156      return TCL_OK;
  4157  }
  4158  
  4159  static int
  4160  EvalObjvCore(
  4161      ClientData data[],
  4162      Tcl_Interp *interp,
  4163      int result)
  4164  {
  4165      Command *cmdPtr = NULL, *preCmdPtr = data[0];
  4166      int flags = PTR2INT(data[1]);
  4167      int objc = PTR2INT(data[2]);
  4168      Tcl_Obj **objv = data[3];
  4169      Interp *iPtr = (Interp *) interp;
  4170      Namespace *lookupNsPtr = NULL;
  4171      int enterTracesDone = 0;
  4172      
  4173      /*
  4174       * Push records for task to be done on return, in INVERSE order. First, if
  4175       * needed, the exception handlers (as they should happen last).
  4176       */
  4177  
  4178      if (!(flags & TCL_EVAL_NOERR)) {
  4179  	TEOV_PushExceptionHandlers(interp, objc, objv, flags);
  4180      }
  4181  
  4182      if (TCL_OK != TclInterpReady(interp)) {
  4183  	return TCL_ERROR;
  4184      }
  4185  
  4186      if (objc == 0) {
  4187  	return TCL_OK;
  4188      }
  4189  
  4190      if (TclLimitExceeded(iPtr->limit)) {
  4191  	return TCL_ERROR;
  4192      }
  4193  
  4194      /*
  4195       * Configure evaluation context to match the requested flags.
  4196       */
  4197  
  4198      if (iPtr->lookupNsPtr) {
  4199  
  4200  	/*
  4201  	 * Capture the namespace we should do command name resolution in, as
  4202  	 * instructed by our caller sneaking it in to us in a private interp
  4203  	 * field.  Clear that field right away so we cannot possibly have its
  4204  	 * use leak where it should not.  The sneaky message pass is done.
  4205  	 *
  4206  	 * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag.
  4207  	 * TODO: Is that a bug?
  4208  	 */
  4209  
  4210  	lookupNsPtr = iPtr->lookupNsPtr;
  4211  	iPtr->lookupNsPtr = NULL;
  4212      } else if (flags & TCL_EVAL_INVOKE) {
  4213  	lookupNsPtr = iPtr->globalNsPtr;
  4214      } else {
  4215  
  4216  	/*
  4217  	 * TCL_EVAL_INVOKE was not set: clear rewrite rules
  4218  	 */
  4219  
  4220  	iPtr->ensembleRewrite.sourceObjs = NULL;
  4221  
  4222  	if (flags & TCL_EVAL_GLOBAL) {
  4223  	    TEOV_SwitchVarFrame(interp);
  4224  	    lookupNsPtr = iPtr->globalNsPtr;
  4225  	}
  4226      }
  4227  
  4228      /*
  4229       * Lookup the Command to dispatch.
  4230       */
  4231  
  4232      reresolve:
  4233      assert(cmdPtr == NULL);
  4234      if (preCmdPtr) {
  4235  	/* Caller gave it to us */
  4236  	if (!(preCmdPtr->flags & CMD_IS_DELETED)) {
  4237  	    /* So long as it exists, use it. */
  4238  	    cmdPtr = preCmdPtr;
  4239  	} else if (flags & TCL_EVAL_NORESOLVE) {
  4240  	    /*
  4241  	     * When it's been deleted, and we're told not to attempt
  4242  	     * resolving it ourselves, all we can do is raise an error.
  4243  	     */
  4244  	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  4245  		    "attempt to invoke a deleted command"));
  4246  	    Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
  4247  	    return TCL_ERROR;
  4248  	}
  4249      }
  4250      if (cmdPtr == NULL) {
  4251  	cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
  4252  	if (!cmdPtr) {
  4253  	    return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
  4254  	}
  4255      }
  4256  
  4257      if (enterTracesDone || iPtr->tracePtr
  4258  	    || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
  4259  
  4260  	Tcl_Obj *commandPtr = TclGetSourceFromFrame(
  4261  		flags & TCL_EVAL_SOURCE_IN_FRAME ?  iPtr->cmdFramePtr : NULL,
  4262  		objc, objv);
  4263  	Tcl_IncrRefCount(commandPtr);
  4264  
  4265  	if (!enterTracesDone) {
  4266  
  4267  	    int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
  4268  		    objc, objv);
  4269  
  4270  	    /*
  4271  	     * Send any exception from enter traces back as an exception
  4272  	     * raised by the traced command.
  4273  	     * TODO: Is this a bug?  Letting an execution trace BREAK or
  4274  	     * CONTINUE or RETURN in the place of the traced command?
  4275  	     * Would either converting all exceptions to TCL_ERROR, or
  4276  	     * just swallowing them be better?  (Swallowing them has the
  4277  	     * problem of permanently hiding program errors.)
  4278  	     */
  4279  
  4280  	    if (code != TCL_OK) {
  4281  		Tcl_DecrRefCount(commandPtr);
  4282  		return code;
  4283  	    }
  4284  
  4285  	    /*
  4286  	     * If the enter traces made the resolved cmdPtr unusable, go
  4287  	     * back and resolve again, but next time don't run enter
  4288  	     * traces again.
  4289  	     */
  4290  
  4291  	    if (cmdPtr == NULL) {
  4292  		enterTracesDone = 1;
  4293  		Tcl_DecrRefCount(commandPtr);
  4294  		goto reresolve;
  4295  	    }
  4296  	}
  4297  
  4298  	/* 
  4299  	 * Schedule leave traces.  Raise the refCount on the resolved
  4300  	 * cmdPtr, so that when it passes to the leave traces we know
  4301  	 * it's still valid.
  4302  	 */
  4303  
  4304  	cmdPtr->refCount++;
  4305  	TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc),
  4306  		    commandPtr, cmdPtr, objv);
  4307      }
  4308  
  4309      TclNRAddCallback(interp, Dispatch,
  4310  	    cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc,
  4311  	    cmdPtr->objClientData, INT2PTR(objc), objv);
  4312      return TCL_OK;
  4313  }
  4314  
  4315  static int
  4316  Dispatch(
  4317      ClientData data[],
  4318      Tcl_Interp *interp,
  4319      int result)
  4320  {
  4321      Tcl_ObjCmdProc *objProc = data[0];
  4322      ClientData clientData = data[1];
  4323      int objc = PTR2INT(data[2]);
  4324      Tcl_Obj **objv = data[3];
  4325      Interp *iPtr = (Interp *) interp;
  4326  
  4327  #ifdef USE_DTRACE
  4328      if (TCL_DTRACE_CMD_ARGS_ENABLED()) {
  4329  	const char *a[10];
  4330  	int i = 0;
  4331  
  4332  	while (i < 10) {
  4333  	    a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
  4334  	}
  4335  	TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
  4336  		a[8], a[9]);
  4337      }
  4338      if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) {
  4339  	Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
  4340  	const char *a[6]; int i[2];
  4341  
  4342  	TclDTraceInfo(info, a, i);
  4343  	TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
  4344  	TclDecrRefCount(info);
  4345      }
  4346      if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED())
  4347  	    && objc) {
  4348  	TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL);
  4349      }
  4350      if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) {
  4351  	TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1,
  4352  		(Tcl_Obj **)(objv + 1));
  4353      }
  4354  #endif /* USE_DTRACE */
  4355  
  4356      iPtr->cmdCount++;
  4357      return objProc(clientData, interp, objc, objv);
  4358  }
  4359  
  4360  int
  4361  TclNRRunCallbacks(
  4362      Tcl_Interp *interp,
  4363      int result,
  4364      struct NRE_callback *rootPtr)
  4365  				/* All callbacks down to rootPtr not inclusive
  4366  				 * are to be run. */
  4367  {
  4368      Interp *iPtr = (Interp *) interp;
  4369      NRE_callback *callbackPtr;
  4370      Tcl_NRPostProc *procPtr;
  4371  
  4372      /*
  4373       * If the interpreter has a non-empty string result, the result object is
  4374       * either empty or stale because some function set interp->result
  4375       * directly. If so, move the string result to the result object, then
  4376       * reset the string result.
  4377       *
  4378       * This only needs to be done for the first item in the list: all other
  4379       * are for NR function calls, and those are Tcl_Obj based.
  4380       */
  4381  
  4382      if (*(iPtr->result) != 0) {
  4383  	(void) Tcl_GetObjResult(interp);
  4384      }
  4385  
  4386      while (TOP_CB(interp) != rootPtr) {
  4387  	callbackPtr = TOP_CB(interp);
  4388  	procPtr = callbackPtr->procPtr;
  4389  	TOP_CB(interp) = callbackPtr->nextPtr;
  4390  	result = procPtr(callbackPtr->data, interp, result);
  4391  	TCLNR_FREE(interp, callbackPtr);
  4392      }
  4393      return result;
  4394  }
  4395  
  4396  static int
  4397  NRCommand(
  4398      ClientData data[],
  4399      Tcl_Interp *interp,
  4400      int result)
  4401  {
  4402      Interp *iPtr = (Interp *) interp;
  4403  
  4404      iPtr->numLevels--;
  4405  
  4406       /*
  4407        * If there is a tailcall, schedule it
  4408        */
  4409   
  4410      if (data[1] && (data[1] != INT2PTR(1))) {
  4411          TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
  4412      }
  4413  
  4414      /* OPT ??
  4415       * Do not interrupt a series of cleanups with async or limit checks:
  4416       * just check at the end?
  4417       */
  4418  
  4419      if (TclAsyncReady(iPtr)) {
  4420  	result = Tcl_AsyncInvoke(interp, result);
  4421      }
  4422      if ((result == TCL_OK) && TclCanceled(iPtr)) {
  4423  	result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG);
  4424      }
  4425      if (result == TCL_OK && TclLimitReady(iPtr->limit)) {
  4426  	result = Tcl_LimitCheck(interp);
  4427      }
  4428  
  4429      return result;
  4430  }
  4431  
  4432  /*
  4433   *----------------------------------------------------------------------
  4434   *
  4435   * TEOV_Exception	 -
  4436   * TEOV_LookupCmdFromObj -
  4437   * TEOV_RunEnterTraces	 -
  4438   * TEOV_RunLeaveTraces	 -
  4439   * TEOV_NotFound	 -
  4440   *
  4441   *	These are helper functions for Tcl_EvalObjv.
  4442   *
  4443   *----------------------------------------------------------------------
  4444   */
  4445  
  4446  static void
  4447  TEOV_PushExceptionHandlers(
  4448      Tcl_Interp *interp,
  4449      int objc,
  4450      Tcl_Obj *const objv[],
  4451      int flags)
  4452  {
  4453      Interp *iPtr = (Interp *) interp;
  4454  
  4455      /*
  4456       * If any error processing is necessary, push the appropriate records.
  4457       * Note that we have to push them in the inverse order: first the one that
  4458       * has to run last.
  4459       */
  4460  
  4461      if (!(flags & TCL_EVAL_INVOKE)) {
  4462  	/*
  4463  	 * Error messages
  4464  	 */
  4465  
  4466  	TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc),
  4467  		(ClientData) objv, NULL, NULL);
  4468      }
  4469  
  4470      if (iPtr->numLevels == 1) {
  4471  	/*
  4472  	 * No CONTINUE or BREAK at level 0, manage RETURN
  4473  	 */
  4474  
  4475  	TclNRAddCallback(interp, TEOV_Exception, INT2PTR(iPtr->evalFlags),
  4476  		NULL, NULL, NULL);
  4477      }
  4478  }
  4479  
  4480  static void
  4481  TEOV_SwitchVarFrame(
  4482      Tcl_Interp *interp)
  4483  {
  4484      Interp *iPtr = (Interp *) interp;
  4485  
  4486      /*
  4487       * Change the varFrame to be the rootVarFrame, and push a record to
  4488       * restore things at the end.
  4489       */
  4490  
  4491      TclNRAddCallback(interp, TEOV_RestoreVarFrame, iPtr->varFramePtr, NULL,
  4492  	    NULL, NULL);
  4493      iPtr->varFramePtr = iPtr->rootFramePtr;
  4494  }
  4495  
  4496  static int
  4497  TEOV_RestoreVarFrame(
  4498      ClientData data[],
  4499      Tcl_Interp *interp,
  4500      int result)
  4501  {
  4502      ((Interp *) interp)->varFramePtr = data[0];
  4503      return result;
  4504  }
  4505  
  4506  static int
  4507  TEOV_Exception(
  4508      ClientData data[],
  4509      Tcl_Interp *interp,
  4510      int result)
  4511  {
  4512      Interp *iPtr = (Interp *) interp;
  4513      int allowExceptions = (PTR2INT(data[0]) & TCL_ALLOW_EXCEPTIONS);
  4514  
  4515      if (result != TCL_OK) {
  4516  	if (result == TCL_RETURN) {
  4517  	    result = TclUpdateReturnInfo(iPtr);
  4518  	}
  4519  	if ((result != TCL_ERROR) && !allowExceptions) {
  4520  	    ProcessUnexpectedResult(interp, result);
  4521  	    result = TCL_ERROR;
  4522  	}
  4523      }
  4524  
  4525      /*
  4526       * We are returning to level 0, so should process TclResetCancellation. As
  4527       * numLevels has not *yet* been decreased, do not call it: do the thing
  4528       * here directly.
  4529       */
  4530  
  4531      TclUnsetCancelFlags(iPtr);
  4532      return result;
  4533  }
  4534  
  4535  static int
  4536  TEOV_Error(
  4537      ClientData data[],
  4538      Tcl_Interp *interp,
  4539      int result)
  4540  {
  4541      Interp *iPtr = (Interp *) interp;
  4542      Tcl_Obj *listPtr;
  4543      const char *cmdString;
  4544      int cmdLen;
  4545      int objc = PTR2INT(data[0]);
  4546      Tcl_Obj **objv = data[1];
  4547  
  4548      if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){
  4549  	/*
  4550  	 * If there was an error, a command string will be needed for the
  4551  	 * error log: get it out of the itemPtr. The details depend on the
  4552  	 * type.
  4553  	 */
  4554  
  4555  	listPtr = Tcl_NewListObj(objc, objv);
  4556  	cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
  4557  	Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
  4558  	Tcl_DecrRefCount(listPtr);
  4559      }
  4560      iPtr->flags &= ~ERR_ALREADY_LOGGED;
  4561      return result;
  4562  }
  4563  
  4564  static int
  4565  TEOV_NotFound(
  4566      Tcl_Interp *interp,
  4567      int objc,
  4568      Tcl_Obj *const objv[],
  4569      Namespace *lookupNsPtr)
  4570  {
  4571      Command * cmdPtr;
  4572      Interp *iPtr = (Interp *) interp;
  4573      int i, newObjc, handlerObjc;
  4574      Tcl_Obj **newObjv, **handlerObjv;
  4575      CallFrame *varFramePtr = iPtr->varFramePtr;
  4576      Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered
  4577  				 * unknown command handler for the current
  4578  				 * namespace (TIP 181). */
  4579      Namespace *savedNsPtr = NULL;
  4580  
  4581      currNsPtr = varFramePtr->nsPtr;
  4582      if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) {
  4583  	currNsPtr = iPtr->globalNsPtr;
  4584  	if (currNsPtr == NULL) {
  4585  	    Tcl_Panic("Tcl_EvalObjv: NULL global namespace pointer");
  4586  	}
  4587      }
  4588  
  4589      /*
  4590       * Check to see if the resolution namespace has lost its unknown handler.
  4591       * If so, reset it to "::unknown".
  4592       */
  4593  
  4594      if (currNsPtr->unknownHandlerPtr == NULL) {
  4595  	TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown");
  4596  	Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr);
  4597      }
  4598  
  4599      /*
  4600       * Get the list of words for the unknown handler and allocate enough space
  4601       * to hold both the handler prefix and all words of the command invokation
  4602       * itself.
  4603       */
  4604  
  4605      Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
  4606  	    &handlerObjc, &handlerObjv);
  4607      newObjc = objc + handlerObjc;
  4608      newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc);
  4609  
  4610      /*
  4611       * Copy command prefix from unknown handler and add on the real command's
  4612       * full argument list. Note that we only use memcpy() once because we have
  4613       * to increment the reference count of all the handler arguments anyway.
  4614       */
  4615  
  4616      for (i = 0; i < handlerObjc; ++i) {
  4617  	newObjv[i] = handlerObjv[i];
  4618  	Tcl_IncrRefCount(newObjv[i]);
  4619      }
  4620      memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc);
  4621  
  4622      /*
  4623       * Look up and invoke the handler (by recursive call to this function). If
  4624       * there is no handler at all, instead of doing the recursive call we just
  4625       * generate a generic error message; it would be an infinite-recursion
  4626       * nightmare otherwise.
  4627       *
  4628       * In this case we worry a bit less about recursion for now, and call the
  4629       * "blocking" interface.
  4630       */
  4631  
  4632      cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr);
  4633      if (cmdPtr == NULL) {
  4634  	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  4635                  "invalid command name \"%s\"", TclGetString(objv[0])));
  4636          Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
  4637                  TclGetString(objv[0]), NULL);
  4638  
  4639  	/*
  4640  	 * Release any resources we locked and allocated during the handler
  4641  	 * call.
  4642  	 */
  4643  
  4644  	for (i = 0; i < handlerObjc; ++i) {
  4645  	    Tcl_DecrRefCount(newObjv[i]);
  4646  	}
  4647  	TclStackFree(interp, newObjv);
  4648  	return TCL_ERROR;
  4649      }
  4650  
  4651      if (lookupNsPtr) {
  4652  	savedNsPtr = varFramePtr->nsPtr;
  4653  	varFramePtr->nsPtr = lookupNsPtr;
  4654      }
  4655      TclSkipTailcall(interp);
  4656      TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
  4657  	    newObjv, savedNsPtr, NULL);
  4658      return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL);
  4659  }
  4660  
  4661  static int
  4662  TEOV_NotFoundCallback(
  4663      ClientData data[],
  4664      Tcl_Interp *interp,
  4665      int result)
  4666  {
  4667      Interp *iPtr = (Interp *) interp;
  4668      int objc = PTR2INT(data[0]);
  4669      Tcl_Obj **objv = data[1];
  4670      Namespace *savedNsPtr = data[2];
  4671  
  4672      int i;
  4673  
  4674      if (savedNsPtr) {
  4675  	iPtr->varFramePtr->nsPtr = savedNsPtr;
  4676      }
  4677  
  4678      /*
  4679       * Release any resources we locked and allocated during the handler call.
  4680       */
  4681  
  4682      for (i = 0; i < objc; ++i) {
  4683  	Tcl_DecrRefCount(objv[i]);
  4684      }
  4685      TclStackFree(interp, objv);
  4686  
  4687      return result;
  4688  }
  4689  
  4690  static int
  4691  TEOV_RunEnterTraces(
  4692      Tcl_Interp *interp,
  4693      Command **cmdPtrPtr,
  4694      Tcl_Obj *commandPtr,
  4695      int objc,
  4696      Tcl_Obj *const objv[])
  4697  {
  4698      Interp *iPtr = (Interp *) interp;
  4699      Command *cmdPtr = *cmdPtrPtr;
  4700      int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
  4701      int length, traceCode = TCL_OK;
  4702      const char *command = Tcl_GetStringFromObj(commandPtr, &length);
  4703  
  4704      /*
  4705       * Call trace functions.
  4706       * Execute any command or execution traces. Note that we bump up the
  4707       * command's reference count for the duration of the calling of the
  4708       * traces so that the structure doesn't go away underneath our feet.
  4709       */
  4710  
  4711      cmdPtr->refCount++;
  4712      if (iPtr->tracePtr) {
  4713  	traceCode = TclCheckInterpTraces(interp, command, length,
  4714  		cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv);
  4715      }
  4716      if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
  4717  	traceCode = TclCheckExecutionTraces(interp, command, length,
  4718  		cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv);
  4719      }
  4720      newEpoch = cmdPtr->cmdEpoch;
  4721      TclCleanupCommandMacro(cmdPtr);
  4722  
  4723      if (traceCode != TCL_OK) {
  4724  	if (traceCode == TCL_ERROR) {
  4725  	    Tcl_Obj *info;
  4726  
  4727  	    TclNewLiteralStringObj(info, "\n    (enter trace on \"");
  4728  	    Tcl_AppendLimitedToObj(info, command, length, 55, "...");
  4729  	    Tcl_AppendToObj(info, "\")", 2);
  4730  	    Tcl_AppendObjToErrorInfo(interp, info);
  4731  	    iPtr->flags |= ERR_ALREADY_LOGGED;
  4732  	}
  4733  	return traceCode;
  4734      }
  4735      if (cmdEpoch != newEpoch) {
  4736  	*cmdPtrPtr = NULL;
  4737      }
  4738      return TCL_OK;
  4739  }
  4740  
  4741  static int
  4742  TEOV_RunLeaveTraces(
  4743      ClientData data[],
  4744      Tcl_Interp *interp,
  4745      int result)
  4746  {
  4747      Interp *iPtr = (Interp *) interp;
  4748      int traceCode = TCL_OK;
  4749      int objc = PTR2INT(data[0]);
  4750      Tcl_Obj *commandPtr = data[1];
  4751      Command *cmdPtr = data[2];
  4752      Tcl_Obj **objv = data[3];
  4753      int length;
  4754      const char *command = Tcl_GetStringFromObj(commandPtr, &length);
  4755  
  4756      if (!(cmdPtr->flags & CMD_IS_DELETED)) {
  4757  	if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){
  4758  	    traceCode = TclCheckExecutionTraces(interp, command, length,
  4759  		    cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
  4760  	}
  4761  	if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
  4762  	    traceCode = TclCheckInterpTraces(interp, command, length,
  4763  		    cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
  4764  	}
  4765      }
  4766  
  4767      /*
  4768       * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels.
  4769       * Prevent that by resetting the cmdPtr field and dealing right here with
  4770       * cmdPtr->refCount.
  4771       */
  4772  
  4773      TclCleanupCommandMacro(cmdPtr);
  4774  
  4775      if (traceCode != TCL_OK) {
  4776  	if (traceCode == TCL_ERROR) {
  4777  	    Tcl_Obj *info;
  4778  
  4779  	    TclNewLiteralStringObj(info, "\n    (leave trace on \"");
  4780  	    Tcl_AppendLimitedToObj(info, command, length, 55, "...");
  4781  	    Tcl_AppendToObj(info, "\")", 2);
  4782  	    Tcl_AppendObjToErrorInfo(interp, info);
  4783  	    iPtr->flags |= ERR_ALREADY_LOGGED;
  4784  	}
  4785  	result = traceCode;
  4786      }
  4787      Tcl_DecrRefCount(commandPtr);
  4788      return result;
  4789  }
  4790  
  4791  static inline Command *
  4792  TEOV_LookupCmdFromObj(
  4793      Tcl_Interp *interp,
  4794      Tcl_Obj *namePtr,
  4795      Namespace *lookupNsPtr)
  4796  {
  4797      Interp *iPtr = (Interp *) interp;
  4798      Command *cmdPtr;
  4799      Namespace *savedNsPtr = iPtr->varFramePtr->nsPtr;
  4800  
  4801      if (lookupNsPtr) {
  4802  	iPtr->varFramePtr->nsPtr = lookupNsPtr;
  4803      }
  4804      cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr);
  4805      iPtr->varFramePtr->nsPtr = savedNsPtr;
  4806      return cmdPtr;
  4807  }
  4808  
  4809  /*
  4810   *----------------------------------------------------------------------
  4811   *
  4812   * Tcl_EvalTokensStandard --
  4813   *
  4814   *	Given an array of tokens parsed from a Tcl command (e.g., the tokens
  4815   *	that make up a word or the index for an array variable) this function
  4816   *	evaluates the tokens and concatenates their values to form a single
  4817   *	result value.
  4818   *
  4819   * Results:
  4820   *	The return value is a standard Tcl completion code such as TCL_OK or
  4821   *	TCL_ERROR. A result or error message is left in interp's result.
  4822   *
  4823   * Side effects:
  4824   *	Depends on the array of tokens being evaled.
  4825   *
  4826   *----------------------------------------------------------------------
  4827   */
  4828  
  4829  int
  4830  Tcl_EvalTokensStandard(
  4831      Tcl_Interp *interp,		/* Interpreter in which to lookup variables,
  4832  				 * execute nested commands, and report
  4833  				 * errors. */
  4834      Tcl_Token *tokenPtr,	/* Pointer to first in an array of tokens to
  4835  				 * evaluate and concatenate. */
  4836      int count)			/* Number of tokens to consider at tokenPtr.
  4837  				 * Must be at least 1. */
  4838  {
  4839      return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1,
  4840  	    NULL, NULL);
  4841  }
  4842  
  4843  /*
  4844   *----------------------------------------------------------------------
  4845   *
  4846   * Tcl_EvalTokens --
  4847   *
  4848   *	Given an array of tokens parsed from a Tcl command (e.g., the tokens
  4849   *	that make up a word or the index for an array variable) this function
  4850   *	evaluates the tokens and concatenates their values to form a single
  4851   *	result value.
  4852   *
  4853   * Results:
  4854   *	The return value is a pointer to a newly allocated Tcl_Obj containing
  4855   *	the value of the array of tokens. The reference count of the returned
  4856   *	object has been incremented. If an error occurs in evaluating the
  4857   *	tokens then a NULL value is returned and an error message is left in
  4858   *	interp's result.
  4859   *
  4860   * Side effects:
  4861   *	A new object is allocated to hold the result.
  4862   *
  4863   *----------------------------------------------------------------------
  4864   *
  4865   * This uses a non-standard return convention; its use is now deprecated. It
  4866   * is a wrapper for the new function Tcl_EvalTokensStandard, and is not used
  4867   * in the core any longer. It is only kept for backward compatibility.
  4868   */
  4869  
  4870  Tcl_Obj *
  4871  Tcl_EvalTokens(
  4872      Tcl_Interp *interp,		/* Interpreter in which to lookup variables,
  4873  				 * execute nested commands, and report
  4874  				 * errors. */
  4875      Tcl_Token *tokenPtr,	/* Pointer to first in an array of tokens to
  4876  				 * evaluate and concatenate. */
  4877      int count)			/* Number of tokens to consider at tokenPtr.
  4878  				 * Must be at least 1. */
  4879  {
  4880      Tcl_Obj *resPtr;
  4881  
  4882      if (Tcl_EvalTokensStandard(interp, tokenPtr, count) != TCL_OK) {
  4883  	return NULL;
  4884      }
  4885      resPtr = Tcl_GetObjResult(interp);
  4886      Tcl_IncrRefCount(resPtr);
  4887      Tcl_ResetResult(interp);
  4888      return resPtr;
  4889  }
  4890  
  4891  /*
  4892   *----------------------------------------------------------------------
  4893   *
  4894   * Tcl_EvalEx, TclEvalEx --
  4895   *
  4896   *	This function evaluates a Tcl script without using the compiler or
  4897   *	byte-code interpreter. It just parses the script, creates values for
  4898   *	each word of each command, then calls EvalObjv to execute each
  4899   *	command.
  4900   *
  4901   * Results:
  4902   *	The return value is a standard Tcl completion code such as TCL_OK or
  4903   *	TCL_ERROR. A result or error message is left in interp's result.
  4904   *
  4905   * Side effects:
  4906   *	Depends on the script.
  4907   *
  4908   * TIP #280 : Keep public API, internally extended API.
  4909   *----------------------------------------------------------------------
  4910   */
  4911  
  4912  int
  4913  Tcl_EvalEx(
  4914      Tcl_Interp *interp,		/* Interpreter in which to evaluate the
  4915  				 * script. Also used for error reporting. */
  4916      const char *script,		/* First character of script to evaluate. */
  4917      int numBytes,		/* Number of bytes in script. If < 0, the
  4918  				 * script consists of all bytes up to the
  4919  				 * first null character. */
  4920      int flags)			/* Collection of OR-ed bits that control the
  4921  				 * evaluation of the script. Only
  4922  				 * TCL_EVAL_GLOBAL is currently supported. */
  4923  {
  4924      return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script);
  4925  }
  4926  
  4927  int
  4928  TclEvalEx(
  4929      Tcl_Interp *interp,		/* Interpreter in which to evaluate the
  4930  				 * script. Also used for error reporting. */
  4931      const char *script,		/* First character of script to evaluate. */
  4932      int numBytes,		/* Number of bytes in script. If < 0, the
  4933  				 * script consists of all bytes up to the
  4934  				 * first NUL character. */
  4935      int flags,			/* Collection of OR-ed bits that control the
  4936  				 * evaluation of the script. Only
  4937  				 * TCL_EVAL_GLOBAL is currently supported. */
  4938      int line,			/* The line the script starts on. */
  4939      int *clNextOuter,		/* Information about an outer context for */
  4940      const char *outerScript)	/* continuation line data. This is set only in
  4941  				 * TclSubstTokens(), to properly handle
  4942  				 * [...]-nested commands. The 'outerScript'
  4943  				 * refers to the most-outer script containing
  4944  				 * the embedded command, which is refered to
  4945  				 * by 'script'. The 'clNextOuter' refers to
  4946  				 * the current entry in the table of
  4947  				 * continuation lines in this "master script",
  4948  				 * and the character offsets are relative to
  4949  				 * the 'outerScript' as well.
  4950  				 *
  4951  				 * If outerScript == script, then this call is
  4952  				 * for the outer-most script/command. See
  4953  				 * Tcl_EvalEx() and TclEvalObjEx() for places
  4954  				 * generating arguments for which this is
  4955  				 * true. */
  4956  {
  4957      Interp *iPtr = (Interp *) interp;
  4958      const char *p, *next;
  4959      const unsigned int minObjs = 20;
  4960      Tcl_Obj **objv, **objvSpace;
  4961      int *expand, *lines, *lineSpace;
  4962      Tcl_Token *tokenPtr;
  4963      int commandLength, bytesLeft, expandRequested, code = TCL_OK;
  4964      CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
  4965  				 * TCL_EVAL_GLOBAL was set. */
  4966      int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
  4967      int gotParse = 0;
  4968      unsigned int i, objectsUsed = 0;
  4969  				/* These variables keep track of how much
  4970  				 * state has been allocated while evaluating
  4971  				 * the script, so that it can be freed
  4972  				 * properly if an error occurs. */
  4973      Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
  4974      CmdFrame *eeFramePtr = TclStackAlloc(interp, sizeof(CmdFrame));
  4975      Tcl_Obj **stackObjArray =
  4976  	    TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *));
  4977      int *expandStack = TclStackAlloc(interp, minObjs * sizeof(int));
  4978      int *linesStack = TclStackAlloc(interp, minObjs * sizeof(int));
  4979  				/* TIP #280 Structures for tracking of command
  4980  				 * locations. */
  4981      int *clNext = NULL;		/* Pointer for the tracking of invisible
  4982  				 * continuation lines. Initialized only if the
  4983  				 * caller gave us a table of locations to
  4984  				 * track, via scriptCLLocPtr. It always refers
  4985  				 * to the table entry holding the location of
  4986  				 * the next invisible continuation line to
  4987  				 * look for, while parsing the script. */
  4988  
  4989      if (iPtr->scriptCLLocPtr) {
  4990  	if (clNextOuter) {
  4991  	    clNext = clNextOuter;
  4992  	} else {
  4993  	    clNext = &iPtr->scriptCLLocPtr->loc[0];
  4994  	}
  4995      }
  4996  
  4997      if (numBytes < 0) {
  4998  	numBytes = strlen(script);
  4999      }
  5000      Tcl_ResetResult(interp);
  5001  
  5002      savedVarFramePtr = iPtr->varFramePtr;
  5003      if (flags & TCL_EVAL_GLOBAL) {
  5004  	iPtr->varFramePtr = iPtr->rootFramePtr;
  5005      }
  5006  
  5007      /*
  5008       * Each iteration through the following loop parses the next command from
  5009       * the script and then executes it.
  5010       */
  5011  
  5012      objv = objvSpace = stackObjArray;
  5013      lines = lineSpace = linesStack;
  5014      expand = expandStack;
  5015      p = script;
  5016      bytesLeft = numBytes;
  5017  
  5018      /*
  5019       * TIP #280 Initialize tracking. Do not push on the frame stack yet.
  5020       *
  5021       * We open a new context, either for a sourced script, or 'eval'.
  5022       * For sourced files we always have a path object, even if nothing was
  5023       * specified in the interp itself. That makes code using it simpler as
  5024       * NULL checks can be left out. Sourced file without path in the
  5025       * 'scriptFile' is possible during Tcl initialization.
  5026       */
  5027  
  5028      eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1;
  5029      eeFramePtr->framePtr = iPtr->framePtr;
  5030      eeFramePtr->nextPtr = iPtr->cmdFramePtr;
  5031      eeFramePtr->nline = 0;
  5032      eeFramePtr->line = NULL;
  5033      eeFramePtr->cmdObj = NULL;
  5034  
  5035      iPtr->cmdFramePtr = eeFramePtr;
  5036      if (iPtr->evalFlags & TCL_EVAL_FILE) {
  5037  	/*
  5038  	 * Set up for a sourced file.
  5039  	 */
  5040  
  5041  	eeFramePtr->type = TCL_LOCATION_SOURCE;
  5042  
  5043  	if (iPtr->scriptFile) {
  5044  	    /*
  5045  	     * Normalization here, to have the correct pwd. Should have
  5046  	     * negligible impact on performance, as the norm should have been
  5047  	     * done already by the 'source' invoking us, and it caches the
  5048  	     * result.
  5049  	     */
  5050  
  5051  	    Tcl_Obj *norm = Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile);
  5052  
  5053  	    if (norm == NULL) {
  5054  		/*
  5055  		 * Error message in the interp result.
  5056  		 */
  5057  
  5058  		code = TCL_ERROR;
  5059  		goto error;
  5060  	    }
  5061  	    eeFramePtr->data.eval.path = norm;
  5062  	} else {
  5063  	    TclNewLiteralStringObj(eeFramePtr->data.eval.path, "");
  5064  	}
  5065  	Tcl_IncrRefCount(eeFramePtr->data.eval.path);
  5066      } else {
  5067  	/*
  5068  	 * Set up for plain eval.
  5069  	 */
  5070  
  5071  	eeFramePtr->type = TCL_LOCATION_EVAL;
  5072  	eeFramePtr->data.eval.path = NULL;
  5073      }
  5074  
  5075      iPtr->evalFlags = 0;
  5076      do {
5077 if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { 5078 code = TCL_ERROR; 5079 Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, 5080 parsePtr->term + 1 - parsePtr->commandStart); 5081 goto posterror; 5082 } 5083 5084 /* 5085 * TIP #280 Track lines. The parser may have skipped text till it 5086 * found the command we are now at. We have to count the lines in this 5087 * block, and do not forget invisible continuation lines. 5088 */ 5089 5090 TclAdvanceLines(&line, p, parsePtr->commandStart); 5091 TclAdvanceContinuations(&line, &clNext, 5092 parsePtr->commandStart - outerScript); 5093 5094 gotParse = 1; 5095 if (parsePtr->numWords > 0) {
5096 /* 5097 * TIP #280. Track lines within the words of the current 5098 * command. We use a separate pointer into the table of 5099 * continuation line locations to not lose our position for the 5100 * per-command parsing. 5101 */ 5102 5103 int wordLine = line; 5104 const char *wordStart = parsePtr->commandStart; 5105 int *wordCLNext = clNext; 5106 unsigned int objectsNeeded = 0; 5107 unsigned int numWords = parsePtr->numWords; 5108 5109 /* 5110 * Generate an array of objects for the words of the command. 5111 */ 5112 5113 if (numWords > minObjs) { 5114 expand = ckalloc(numWords * sizeof(int)); 5115 objvSpace = ckalloc(numWords * sizeof(Tcl_Obj *)); 5116 lineSpace = ckalloc(numWords * sizeof(int)); 5117 } 5118 expandRequested = 0; 5119 objv = objvSpace; 5120 lines = lineSpace; 5121 5122 iPtr->cmdFramePtr = eeFramePtr->nextPtr; 5123 for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr; 5124 objectsUsed < numWords; 5125 objectsUsed++, tokenPtr += tokenPtr->numComponents+1) { 5126 /* 5127 * TIP #280. Track lines to current word. Save the information 5128 * on a per-word basis, signaling dynamic words as needed. 5129 * Make the information available to the recursively called 5130 * evaluator as well, including the type of context (source 5131 * vs. eval). 5132 */ 5133 5134 TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); 5135 TclAdvanceContinuations(&wordLine, &wordCLNext, 5136 tokenPtr->start - outerScript); 5137 wordStart = tokenPtr->start; 5138 5139 lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) 5140 ? wordLine : -1; 5141 5142 if (eeFramePtr->type == TCL_LOCATION_SOURCE) { 5143 iPtr->evalFlags |= TCL_EVAL_FILE; 5144 } 5145 5146 code = TclSubstTokens(interp, tokenPtr+1, 5147 tokenPtr->numComponents, NULL, wordLine, 5148 wordCLNext, outerScript); 5149 5150 iPtr->evalFlags = 0; 5151 5152 if (code != TCL_OK) { 5153 break; 5154 } 5155 objv[objectsUsed] = Tcl_GetObjResult(interp); 5156 Tcl_IncrRefCount(objv[objectsUsed]); 5157 if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { 5158 int numElements; 5159 5160 code = TclListObjLength(interp, objv[objectsUsed], 5161 &numElements); 5162 if (code == TCL_ERROR) { 5163 /* 5164 * Attempt to expand a non-list. 5165 */ 5166 5167 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 5168 "\n (expanding word %d)", objectsUsed)); 5169 Tcl_DecrRefCount(objv[objectsUsed]); 5170 break; 5171 } 5172 expandRequested = 1; 5173 expand[objectsUsed] = 1; 5174 5175 objectsNeeded += (numElements ? numElements : 1); 5176 } else { 5177 expand[objectsUsed] = 0; 5178 objectsNeeded++; 5179 } 5180 5181 if (wordCLNext) { 5182 TclContinuationsEnterDerived(objv[objectsUsed], 5183 wordStart - outerScript, wordCLNext); 5184 } 5185 } /* for loop */ 5186 iPtr->cmdFramePtr = eeFramePtr; 5187 if (code != TCL_OK) { 5188 goto error; 5189 } 5190 if (expandRequested) { 5191 /* 5192 * Some word expansion was requested. Check for objv resize. 5193 */ 5194 5195 Tcl_Obj **copy = objvSpace; 5196 int *lcopy = lineSpace; 5197 int wordIdx = numWords; 5198 int objIdx = objectsNeeded - 1; 5199 5200 if ((numWords > minObjs) || (objectsNeeded > minObjs)) { 5201 objv = objvSpace = 5202 ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); 5203 lines = lineSpace = ckalloc(objectsNeeded * sizeof(int)); 5204 } 5205 5206 objectsUsed = 0; 5207 while (wordIdx--) { 5208 if (expand[wordIdx]) { 5209 int numElements; 5210 Tcl_Obj **elements, *temp = copy[wordIdx]; 5211 5212 Tcl_ListObjGetElements(NULL, temp, &numElements, 5213 &elements); 5214 objectsUsed += numElements; 5215 while (numElements--) { 5216 lines[objIdx] = -1; 5217 objv[objIdx--] = elements[numElements]; 5218 Tcl_IncrRefCount(elements[numElements]); 5219 } 5220 Tcl_DecrRefCount(temp); 5221 } else { 5222 lines[objIdx] = lcopy[wordIdx]; 5223 objv[objIdx--] = copy[wordIdx]; 5224 objectsUsed++; 5225 } 5226 } 5227 objv += objIdx+1; 5228 5229 if (copy != stackObjArray) { 5230 ckfree(copy); 5231 } 5232 if (lcopy != linesStack) { 5233 ckfree(lcopy); 5234 } 5235 } 5236 5237 /* 5238 * Execute the command and free the objects for its words. 5239 * 5240 * TIP #280: Remember the command itself for 'info frame'. We 5241 * shorten the visible command by one char to exclude the 5242 * termination character, if necessary. Here is where we put our 5243 * frame on the stack of frames too. _After_ the nested commands 5244 * have been executed. 5245 */ 5246 5247 eeFramePtr->cmd = parsePtr->commandStart; 5248 eeFramePtr->len = parsePtr->commandSize; 5249 5250 if (parsePtr->term == 5251 parsePtr->commandStart + parsePtr->commandSize - 1) { 5252 eeFramePtr->len--; 5253 } 5254 5255 eeFramePtr->nline = objectsUsed; 5256 eeFramePtr->line = lines; 5257 5258 TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); 5259 code = Tcl_EvalObjv(interp, objectsUsed, objv, 5260 TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME); 5261 TclArgumentRelease(interp, objv, objectsUsed); 5262 5263 eeFramePtr->line = NULL; 5264 eeFramePtr->nline = 0; 5265 if (eeFramePtr->cmdObj) { 5266 Tcl_DecrRefCount(eeFramePtr->cmdObj); 5267 eeFramePtr->cmdObj = NULL; 5268 } 5269 5270 if (code != TCL_OK) { 5271 goto error; 5272 } 5273 for (i = 0; i < objectsUsed; i++) { 5274 Tcl_DecrRefCount(objv[i]); 5275 } 5276 objectsUsed = 0; 5277 if (objvSpace != stackObjArray) { 5278 ckfree(objvSpace); 5279 objvSpace = stackObjArray; 5280 ckfree(lineSpace); 5281 lineSpace = linesStack; 5282 } 5283 5284 /* 5285 * Free expand separately since objvSpace could have been 5286 * reallocated above. 5287 */ 5288 5289 if (expand != expandStack) { 5290 ckfree(expand); 5291 expand = expandStack; 5292 } 5293 } 5294 5295 /* 5296 * Advance to the next command in the script. 5297 * 5298 * TIP #280 Track Lines. Now we track how many lines were in the 5299 * executed command. 5300 */ 5301 5302 next = parsePtr->commandStart + parsePtr->commandSize; 5303 bytesLeft -= next - p; 5304 p = next; 5305 TclAdvanceLines(&line, parsePtr->commandStart, p); 5306 Tcl_FreeParse(parsePtr); 5307 gotParse = 0; 5308 } while (bytesLeft > 0); 5309 iPtr->varFramePtr = savedVarFramePtr; 5310 code = TCL_OK; 5311 goto cleanup_return; 5312 5313 error: 5314 /* 5315 * Generate and log various pieces of error information. 5316 */ 5317 5318 if (iPtr->numLevels == 0) { 5319 if (code == TCL_RETURN) { 5320 code = TclUpdateReturnInfo(iPtr); 5321 } 5322 if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { 5323 ProcessUnexpectedResult(interp, code); 5324 code = TCL_ERROR; 5325 } 5326 } 5327 if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { 5328 commandLength = parsePtr->commandSize; 5329 if (parsePtr->term == parsePtr->commandStart + commandLength - 1) { 5330 /* 5331 * The terminator character (such as ; or ]) of the command where 5332 * the error occurred is the last character in the parsed command. 5333 * Reduce the length by one so that the error message doesn't 5334 * include the terminator character. 5335 */ 5336 5337 commandLength -= 1; 5338 } 5339 Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, 5340 commandLength); 5341 } 5342 posterror: 5343 iPtr->flags &= ~ERR_ALREADY_LOGGED; 5344 5345 /* 5346 * Then free resources that had been allocated to the command. 5347 */ 5348 5349 for (i = 0; i < objectsUsed; i++) { 5350 Tcl_DecrRefCount(objv[i]); 5351 } 5352 if (gotParse) { 5353 Tcl_FreeParse(parsePtr); 5354 } 5355 if (objvSpace != stackObjArray) { 5356 ckfree(objvSpace); 5357 ckfree(lineSpace); 5358 } 5359 if (expand != expandStack) { 5360 ckfree(expand); 5361 } 5362 iPtr->varFramePtr = savedVarFramePtr; 5363 5364 cleanup_return: 5365 /* 5366 * TIP #280. Release the local CmdFrame, and its contents. 5367 */ 5368 5369 iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; 5370 if (eeFramePtr->type == TCL_LOCATION_SOURCE) { 5371 Tcl_DecrRefCount(eeFramePtr->data.eval.path); 5372 } 5373 TclStackFree(interp, linesStack); 5374 TclStackFree(interp, expandStack); 5375 TclStackFree(interp, stackObjArray); 5376 TclStackFree(interp, eeFramePtr); 5377 TclStackFree(interp, parsePtr); 5378 5379 return code; 5380 } 5381 5382 /* 5383 *---------------------------------------------------------------------- 5384 * 5385 * TclAdvanceLines -- 5386 * 5387 * This function is a helper which counts the number of lines in a block 5388 * of text and advances an external counter. 5389 * 5390 * Results: 5391 * None. 5392 * 5393 * Side effects: 5394 * The specified counter is advanced per the number of lines found. 5395 * 5396 * TIP #280 5397 *---------------------------------------------------------------------- 5398 */ 5399 5400 void 5401 TclAdvanceLines( 5402 int *line, 5403 const char *start, 5404 const char *end) 5405 { 5406 register const char *p; 5407 5408 for (p = start; p < end; p++) { 5409 if (*p == '\n') { 5410 (*line)++; 5411 } 5412 } 5413 } 5414 5415 /* 5416 *---------------------------------------------------------------------- 5417 * 5418 * TclAdvanceContinuations -- 5419 * 5420 * This procedure is a helper which counts the number of continuation 5421 * lines (CL) in a block of text using a table of CL locations and 5422 * advances an external counter, and the pointer into the table. 5423 * 5424 * Results: 5425 * None. 5426 * 5427 * Side effects: 5428 * The specified counter is advanced per the number of continuation lines 5429 * found. 5430 * 5431 * TIP #280 5432 *---------------------------------------------------------------------- 5433 */ 5434 5435 void 5436 TclAdvanceContinuations( 5437 int *line, 5438 int **clNextPtrPtr, 5439 int loc) 5440 { 5441 /* 5442 * Track the invisible continuation lines embedded in a script, if any. 5443 * Here they are just spaces (already). They were removed by 5444 * TclSubstTokens via TclParseBackslash. 5445 * 5446 * *clNextPtrPtr <=> We have continuation lines to track. 5447 * **clNextPtrPtr >= 0 <=> We are not beyond the last possible location. 5448 * loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line. 5449 */ 5450 5451 while (*clNextPtrPtr && (**clNextPtrPtr >= 0) 5452 && (loc >= **clNextPtrPtr)) { 5453 /* 5454 * We just stepped over an invisible continuation line. Adjust the 5455 * line counter and step to the table entry holding the location of 5456 * the next continuation line to track. 5457 */ 5458 5459 (*line)++; 5460 (*clNextPtrPtr)++; 5461 } 5462 } 5463 5464 /* 5465 *---------------------------------------------------------------------- 5466 * Note: The whole data structure access for argument location tracking is 5467 * hidden behind these three functions. The only parts open are the lineLAPtr 5468 * field in the Interp structure. The CFWord definition is internal to here. 5469 * Should make it easier to redo the data structures if we find something more 5470 * space/time efficient. 5471 */ 5472 5473 /* 5474 *---------------------------------------------------------------------- 5475 * 5476 * TclArgumentEnter -- 5477 * 5478 * This procedure is a helper for the TIP #280 uplevel extension. It 5479 * enters location references for the arguments of a command to be 5480 * invoked. Only the first entry has the actual data, further entries 5481 * simply count the usage up. 5482 * 5483 * Results: 5484 * None. 5485 * 5486 * Side effects: 5487 * May allocate memory. 5488 * 5489 * TIP #280 5490 *---------------------------------------------------------------------- 5491 */ 5492 5493 void 5494 TclArgumentEnter( 5495 Tcl_Interp *interp, 5496 Tcl_Obj **objv, 5497 int objc, 5498 CmdFrame *cfPtr) 5499 { 5500 Interp *iPtr = (Interp *) interp; 5501 int new, i; 5502 Tcl_HashEntry *hPtr; 5503 CFWord *cfwPtr; 5504 5505 for (i = 1; i < objc; i++) { 5506 /* 5507 * Ignore argument words without line information (= dynamic). If they 5508 * are variables they may have location information associated with 5509 * that, either through globally recorded 'set' invokations, or 5510 * literals in bytecode. Eitehr way there is no need to record 5511 * something here. 5512 */ 5513 5514 if (cfPtr->line[i] < 0) { 5515 continue; 5516 } 5517 hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &new); 5518 if (new) { 5519 /* 5520 * The word is not on the stack yet, remember the current location 5521 * and initialize references. 5522 */ 5523 5524 cfwPtr = ckalloc(sizeof(CFWord)); 5525 cfwPtr->framePtr = cfPtr; 5526 cfwPtr->word = i; 5527 cfwPtr->refCount = 1; 5528 Tcl_SetHashValue(hPtr, cfwPtr); 5529 } else { 5530 /* 5531 * The word is already on the stack, its current location is not 5532 * relevant. Just remember the reference to prevent early removal. 5533 */ 5534 5535 cfwPtr = Tcl_GetHashValue(hPtr); 5536 cfwPtr->refCount++; 5537 } 5538 } 5539 } 5540 5541 /* 5542 *---------------------------------------------------------------------- 5543 * 5544 * TclArgumentRelease -- 5545 * 5546 * This procedure is a helper for the TIP #280 uplevel extension. It 5547 * removes the location references for the arguments of a command just 5548 * done. Usage is counted down, the data is removed only when no user is 5549 * left over. 5550 * 5551 * Results: 5552 * None. 5553 * 5554 * Side effects: 5555 * May release memory. 5556 * 5557 * TIP #280 5558 *---------------------------------------------------------------------- 5559 */ 5560 5561 void 5562 TclArgumentRelease( 5563 Tcl_Interp *interp, 5564 Tcl_Obj **objv, 5565 int objc) 5566 { 5567 Interp *iPtr = (Interp *) interp; 5568 int i; 5569 5570 for (i = 1; i < objc; i++) { 5571 CFWord *cfwPtr; 5572 Tcl_HashEntry *hPtr = 5573 Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]); 5574 5575 if (!hPtr) { 5576 continue; 5577 } 5578 cfwPtr = Tcl_GetHashValue(hPtr); 5579 5580 cfwPtr->refCount--; 5581 if (cfwPtr->refCount > 0) { 5582 continue; 5583 } 5584 5585 ckfree(cfwPtr); 5586 Tcl_DeleteHashEntry(hPtr); 5587 } 5588 } 5589 5590 /* 5591 *---------------------------------------------------------------------- 5592 * 5593 * TclArgumentBCEnter -- 5594 * 5595 * This procedure is a helper for the TIP #280 uplevel extension. It 5596 * enters location references for the literal arguments of commands in 5597 * bytecode about to be invoked. Only the first entry has the actual 5598 * data, further entries simply count the usage up. 5599 * 5600 * Results: 5601 * None. 5602 * 5603 * Side effects: 5604 * May allocate memory. 5605 * 5606 * TIP #280 5607 *---------------------------------------------------------------------- 5608 */ 5609 5610 void 5611 TclArgumentBCEnter( 5612 Tcl_Interp *interp, 5613 Tcl_Obj *objv[], 5614 int objc, 5615 void *codePtr, 5616 CmdFrame *cfPtr, 5617 int cmd, 5618 int pc) 5619 { 5620 ExtCmdLoc *eclPtr; 5621 int word; 5622 ECL *ePtr; 5623 CFWordBC *lastPtr = NULL; 5624 Interp *iPtr = (Interp *) interp; 5625 Tcl_HashEntry *hePtr = 5626 Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); 5627 5628 if (!hePtr) { 5629 return; 5630 } 5631 eclPtr = Tcl_GetHashValue(hePtr); 5632 ePtr = &eclPtr->loc[cmd]; 5633 5634 /* 5635 * ePtr->nline is the number of words originally parsed. 5636 * 5637 * objc is the number of elements getting invoked. 5638 * 5639 * If they are not the same, we arrived here by compiling an 5640 * ensemble dispatch. Ensemble subcommands that lead to script 5641 * evaluation are not supposed to get compiled, because a command 5642 * such as [info level] in the script can expose some of the dispatch 5643 * shenanigans. This means that we don't have to tend to the 5644 * housekeeping, and can escape now. 5645 */ 5646 5647 if (ePtr->nline != objc) { 5648 return; 5649 } 5650 5651 /* 5652 * Having disposed of the ensemble cases, we can state... 5653 * A few truths ... 5654 * (1) ePtr->nline == objc 5655 * (2) (ePtr->line[word] < 0) => !literal, for all words 5656 * (3) (word == 0) => !literal 5657 * 5658 * Item (2) is why we can use objv to get the literals, and do not 5659 * have to save them at compile time. 5660 */ 5661 5662 for (word = 1; word < objc; word++) { 5663 if (ePtr->line[word] >= 0) { 5664 int isnew; 5665 Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, 5666 objv[word], &isnew); 5667 CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); 5668 5669 cfwPtr->framePtr = cfPtr; 5670 cfwPtr->obj = objv[word]; 5671 cfwPtr->pc = pc; 5672 cfwPtr->word = word; 5673 cfwPtr->nextPtr = lastPtr; 5674 lastPtr = cfwPtr; 5675 5676 if (isnew) { 5677 /* 5678 * The word is not on the stack yet, remember the current 5679 * location and initialize references. 5680 */ 5681 5682 cfwPtr->prevPtr = NULL; 5683 } else { 5684 /* 5685 * The object is already on the stack, however it may have 5686 * a different location now (literal sharing may map 5687 * multiple location to a single Tcl_Obj*. Save the old 5688 * information in the new structure. 5689 */ 5690 5691 cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); 5692 } 5693 5694 Tcl_SetHashValue(hPtr, cfwPtr); 5695 } 5696 } /* for */ 5697 5698 cfPtr->litarg = lastPtr; 5699 } 5700 5701 /* 5702 *---------------------------------------------------------------------- 5703 * 5704 * TclArgumentBCRelease -- 5705 * 5706 * This procedure is a helper for the TIP #280 uplevel extension. It 5707 * removes the location references for the literal arguments of commands 5708 * in bytecode just done. Usage is counted down, the data is removed only 5709 * when no user is left over. 5710 * 5711 * Results: 5712 * None. 5713 * 5714 * Side effects: 5715 * May release memory. 5716 * 5717 * TIP #280 5718 *---------------------------------------------------------------------- 5719 */ 5720 5721 void 5722 TclArgumentBCRelease( 5723 Tcl_Interp *interp, 5724 CmdFrame *cfPtr) 5725 { 5726 Interp *iPtr = (Interp *) interp; 5727 CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg; 5728 5729 while (cfwPtr) { 5730 CFWordBC *nextPtr = cfwPtr->nextPtr; 5731 Tcl_HashEntry *hPtr = 5732 Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj); 5733 CFWordBC *xPtr = Tcl_GetHashValue(hPtr); 5734 5735 if (xPtr != cfwPtr) { 5736 Tcl_Panic("TclArgumentBC Enter/Release Mismatch"); 5737 } 5738 5739 if (cfwPtr->prevPtr) { 5740 Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); 5741 } else { 5742 Tcl_DeleteHashEntry(hPtr); 5743 } 5744 5745 ckfree(cfwPtr); 5746 cfwPtr = nextPtr; 5747 } 5748 5749 cfPtr->litarg = NULL; 5750 } 5751 5752 /* 5753 *---------------------------------------------------------------------- 5754 * 5755 * TclArgumentGet -- 5756 * 5757 * This procedure is a helper for the TIP #280 uplevel extension. It 5758 * finds the location references for a Tcl_Obj, if any. 5759 * 5760 * Results: 5761 * None. 5762 * 5763 * Side effects: 5764 * Writes found location information into the result arguments. 5765 * 5766 * TIP #280 5767 *---------------------------------------------------------------------- 5768 */ 5769 5770 void 5771 TclArgumentGet( 5772 Tcl_Interp *interp, 5773 Tcl_Obj *obj, 5774 CmdFrame **cfPtrPtr, 5775 int *wordPtr) 5776 { 5777 Interp *iPtr = (Interp *) interp; 5778 Tcl_HashEntry *hPtr; 5779 CmdFrame *framePtr; 5780 5781 /* 5782 * An object which either has no string rep or else is a canonical list is 5783 * guaranteed to have been generated dynamically: bail out, this cannot 5784 * have a usable absolute location. _Do not touch_ the information the set 5785 * up by the caller. It knows better than us. 5786 */ 5787 5788 if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { 5789 return; 5790 } 5791 5792 /* 5793 * First look for location information recorded in the argument 5794 * stack. That is nearest. 5795 */ 5796 5797 hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj); 5798 if (hPtr) { 5799 CFWord *cfwPtr = Tcl_GetHashValue(hPtr); 5800 5801 *wordPtr = cfwPtr->word; 5802 *cfPtrPtr = cfwPtr->framePtr; 5803 return; 5804 } 5805 5806 /* 5807 * Check if the Tcl_Obj has location information as a bytecode literal, in 5808 * that stack. 5809 */ 5810 5811 hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj); 5812 if (hPtr) { 5813 CFWordBC *cfwPtr = Tcl_GetHashValue(hPtr); 5814 5815 framePtr = cfwPtr->framePtr; 5816 framePtr->data.tebc.pc = (char *) (((ByteCode *) 5817 framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc); 5818 *cfPtrPtr = cfwPtr->framePtr; 5819 *wordPtr = cfwPtr->word; 5820 return; 5821 } 5822 } 5823 5824 /* 5825 *---------------------------------------------------------------------- 5826 * 5827 * Tcl_Eval -- 5828 * 5829 * Execute a Tcl command in a string. This function executes the script 5830 * directly, rather than compiling it to bytecodes. Before the arrival of 5831 * the bytecode compiler in Tcl 8.0 Tcl_Eval was the main function used 5832 * for executing Tcl commands, but nowadays it isn't used much. 5833 * 5834 * Results: 5835 * The return value is one of the return codes defined in tcl.h (such as 5836 * TCL_OK), and interp's result contains a value to supplement the return 5837 * code. The value of the result will persist only until the next call to 5838 * Tcl_Eval or Tcl_EvalObj: you must copy it or lose it! 5839 * 5840 * Side effects: 5841 * Can be almost arbitrary, depending on the commands in the script. 5842 * 5843 *---------------------------------------------------------------------- 5844 */ 5845 5846 #undef Tcl_Eval 5847 int 5848 Tcl_Eval( 5849 Tcl_Interp *interp, /* Token for command interpreter (returned by 5850 * previous call to Tcl_CreateInterp). */ 5851 const char *script) /* Pointer to TCL command to execute. */ 5852 { 5853 int code = Tcl_EvalEx(interp, script, -1, 0); 5854 5855 /* 5856 * For backwards compatibility with old C code that predates the object 5857 * system in Tcl 8.0, we have to mirror the object result back into the 5858 * string result (some callers may expect it there). 5859 */ 5860 5861 (void) Tcl_GetStringResult(interp); 5862 return code; 5863 } 5864 5865 /* 5866 *---------------------------------------------------------------------- 5867 * 5868 * Tcl_EvalObj, Tcl_GlobalEvalObj -- 5869 * 5870 * These functions are deprecated but we keep them around for backwards 5871 * compatibility reasons. 5872 * 5873 * Results: 5874 * See the functions they call. 5875 * 5876 * Side effects: 5877 * See the functions they call. 5878 * 5879 *---------------------------------------------------------------------- 5880 */ 5881 5882 #undef Tcl_EvalObj 5883 int 5884 Tcl_EvalObj( 5885 Tcl_Interp *interp, 5886 Tcl_Obj *objPtr) 5887 { 5888 return Tcl_EvalObjEx(interp, objPtr, 0); 5889 } 5890 #undef Tcl_GlobalEvalObj 5891 int 5892 Tcl_GlobalEvalObj( 5893 Tcl_Interp *interp, 5894 Tcl_Obj *objPtr) 5895 { 5896 return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); 5897 } 5898 5899 /* 5900 *---------------------------------------------------------------------- 5901 * 5902 * Tcl_EvalObjEx, TclEvalObjEx -- 5903 * 5904 * Execute Tcl commands stored in a Tcl object. These commands are 5905 * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is 5906 * specified. 5907 * 5908 * If the flag TCL_EVAL_DIRECT is passed in, the value of invoker 5909 * must be NULL. Support for non-NULL invokers in that mode has 5910 * been removed since it was unused and untested. Failure to 5911 * follow this limitation will lead to an assertion panic. 5912 * 5913 * Results: 5914 * The return value is one of the return codes defined in tcl.h (such as 5915 * TCL_OK), and the interpreter's result contains a value to supplement 5916 * the return code. 5917 * 5918 * Side effects: 5919 * The object is converted, if necessary, to a ByteCode object that holds 5920 * the bytecode instructions for the commands. Executing the commands 5921 * will almost certainly have side effects that depend on those commands. 5922 * 5923 * TIP #280 : Keep public API, internally extended API. 5924 *---------------------------------------------------------------------- 5925 */ 5926 5927 int 5928 Tcl_EvalObjEx( 5929 Tcl_Interp *interp, /* Token for command interpreter (returned by 5930 * a previous call to Tcl_CreateInterp). */ 5931 register Tcl_Obj *objPtr, /* Pointer to object containing commands to 5932 * execute. */ 5933 int flags) /* Collection of OR-ed bits that control the 5934 * evaluation of the script. Supported values 5935 * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ 5936 { 5937 return TclEvalObjEx(interp, objPtr, flags, NULL, 0); 5938 } 5939 5940 int 5941 TclEvalObjEx( 5942 Tcl_Interp *interp, /* Token for command interpreter (returned by 5943 * a previous call to Tcl_CreateInterp). */ 5944 register Tcl_Obj *objPtr, /* Pointer to object containing commands to 5945 * execute. */ 5946 int flags, /* Collection of OR-ed bits that control the 5947 * evaluation of the script. Supported values 5948 * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ 5949 const CmdFrame *invoker, /* Frame of the command doing the eval. */ 5950 int word) /* Index of the word which is in objPtr. */ 5951 { 5952 int result = TCL_OK; 5953 NRE_callback *rootPtr = TOP_CB(interp); 5954 5955 result = TclNREvalObjEx(interp, objPtr, flags, invoker, word); 5956 return TclNRRunCallbacks(interp, result, rootPtr); 5957 } 5958 5959 int 5960 TclNREvalObjEx( 5961 Tcl_Interp *interp, /* Token for command interpreter (returned by 5962 * a previous call to Tcl_CreateInterp). */ 5963 register Tcl_Obj *objPtr, /* Pointer to object containing commands to 5964 * execute. */ 5965 int flags, /* Collection of OR-ed bits that control the 5966 * evaluation of the script. Supported values 5967 * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ 5968 const CmdFrame *invoker, /* Frame of the command doing the eval. */ 5969 int word) /* Index of the word which is in objPtr. */ 5970 { 5971 Interp *iPtr = (Interp *) interp; 5972 int result; 5973 5974 /* 5975 * This function consists of three independent blocks for: direct 5976 * evaluation of canonical lists, compilation and bytecode execution and 5977 * finally direct evaluation. Precisely one of these blocks will be run. 5978 */ 5979 5980 if (TclListObjIsCanonical(objPtr)) { 5981 CmdFrame *eoFramePtr = NULL; 5982 int objc; 5983 Tcl_Obj *listPtr, **objv; 5984 5985 /* 5986 * Canonical List Optimization: In this case, we 5987 * can safely use Tcl_EvalObjv instead and get an appreciable 5988 * improvement in execution speed. This is because it allows us to 5989 * avoid a setFromAny step that would just pack everything into a 5990 * string and back out again. 5991 * 5992 * This also preserves any associations between list elements and 5993 * location information for such elements. 5994 */ 5995 5996 /* 5997 * Shimmer protection! Always pass an unshared obj. The caller could 5998 * incr the refCount of objPtr AFTER calling us! To be completely safe 5999 * we always make a copy. The callback takes care od the refCounts for 6000 * both listPtr and objPtr. 6001 * 6002 * TODO: Create a test to demo this need, or eliminate it. 6003 * FIXME OPT: preserve just the internal rep? 6004 */ 6005 6006 Tcl_IncrRefCount(objPtr); 6007 listPtr = TclListObjCopy(interp, objPtr); 6008 Tcl_IncrRefCount(listPtr); 6009 6010 if (word != INT_MIN) { 6011 /* 6012 * TIP #280 Structures for tracking lines. As we know that this is 6013 * dynamic execution we ignore the invoker, even if known. 6014 * 6015 * TIP #280. We do _not_ compute all the line numbers for the 6016 * words in the command. For the eval of a pure list the most 6017 * sensible choice is to put all words on line 1. Given that we 6018 * neither need memory for them nor compute anything. 'line' is 6019 * left NULL. The two places using this information (TclInfoFrame, 6020 * and TclInitCompileEnv), are special-cased to use the proper 6021 * line number directly instead of accessing the 'line' array. 6022 * 6023 * Note that we use (word==INTMIN) to signal that no command frame 6024 * should be pushed, as needed by alias and ensemble redirections. 6025 */ 6026 6027 eoFramePtr = TclStackAlloc(interp, sizeof(CmdFrame)); 6028 eoFramePtr->nline = 0; 6029 eoFramePtr->line = NULL; 6030 6031 eoFramePtr->type = TCL_LOCATION_EVAL; 6032 eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 6033 1 : iPtr->cmdFramePtr->level + 1); 6034 eoFramePtr->framePtr = iPtr->framePtr; 6035 eoFramePtr->nextPtr = iPtr->cmdFramePtr; 6036 6037 eoFramePtr->cmdObj = objPtr; 6038 eoFramePtr->cmd = NULL; 6039 eoFramePtr->len = 0; 6040 eoFramePtr->data.eval.path = NULL; 6041 6042 iPtr->cmdFramePtr = eoFramePtr; 6043 6044 flags |= TCL_EVAL_SOURCE_IN_FRAME; 6045 } 6046 6047 TclMarkTailcall(interp); 6048 TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, 6049 objPtr, NULL); 6050 6051 ListObjGetElements(listPtr, objc, objv); 6052 return TclNREvalObjv(interp, objc, objv, flags, NULL); 6053 } 6054 6055 if (!(flags & TCL_EVAL_DIRECT)) { 6056 /* 6057 * Let the compiler/engine subsystem do the evaluation. 6058 * 6059 * TIP #280 The invoker provides us with the context for the script. 6060 * We transfer this to the byte code compiler. 6061 */ 6062 6063 int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); 6064 ByteCode *codePtr; 6065 CallFrame *savedVarFramePtr = NULL; /* Saves old copy of 6066 * iPtr->varFramePtr in case 6067 * TCL_EVAL_GLOBAL was set. */ 6068 6069 if (TclInterpReady(interp) != TCL_OK) { 6070 return TCL_ERROR; 6071 } 6072 if (flags & TCL_EVAL_GLOBAL) { 6073 savedVarFramePtr = iPtr->varFramePtr; 6074 iPtr->varFramePtr = iPtr->rootFramePtr; 6075 } 6076 Tcl_IncrRefCount(objPtr); 6077 codePtr = TclCompileObj(interp, objPtr, invoker, word); 6078 6079 TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr, 6080 objPtr, INT2PTR(allowExceptions), NULL); 6081 return TclNRExecuteByteCode(interp, codePtr); 6082 } 6083 6084 { 6085 /* 6086 * We're not supposed to use the compiler or byte-code 6087 * interpreter. Let Tcl_EvalEx evaluate the command directly (and 6088 * probably more slowly). 6089 */ 6090 6091 const char *script; 6092 int numSrcBytes; 6093 6094 /* 6095 * Now we check if we have data about invisible continuation lines for 6096 * the script, and make it available to the direct script parser and 6097 * evaluator we are about to call, if so. 6098 * 6099 * It may be possible that the script Tcl_Obj* can be free'd while the 6100 * evaluator is using it, leading to the release of the associated 6101 * ContLineLoc structure as well. To ensure that the latter doesn't 6102 * happen we set a lock on it. We release this lock later in this 6103 * function, after the evaluator is done. The relevant "lineCLPtr" 6104 * hashtable is managed in the file "tclObj.c". 6105 * 6106 * Another important action is to save (and later restore) the 6107 * continuation line information of the caller, in case we are 6108 * executing nested commands in the eval/direct path. 6109 */ 6110 6111 ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; 6112 6113 assert(invoker == NULL); 6114 6115 iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); 6116 6117 Tcl_IncrRefCount(objPtr); 6118 6119 script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); 6120 result = Tcl_EvalEx(interp, script, numSrcBytes, flags); 6121 6122 TclDecrRefCount(objPtr); 6123 6124 iPtr->scriptCLLocPtr = saveCLLocPtr; 6125 return result; 6126 } 6127 } 6128 6129 static int 6130 TEOEx_ByteCodeCallback( 6131 ClientData data[], 6132 Tcl_Interp *interp, 6133 int result) 6134 { 6135 Interp *iPtr = (Interp *) interp; 6136 CallFrame *savedVarFramePtr = data[0]; 6137 Tcl_Obj *objPtr = data[1]; 6138 int allowExceptions = PTR2INT(data[2]); 6139 6140 if (iPtr->numLevels == 0) { 6141 if (result == TCL_RETURN) { 6142 result = TclUpdateReturnInfo(iPtr); 6143 } 6144 if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { 6145 const char *script; 6146 int numSrcBytes; 6147 6148 ProcessUnexpectedResult(interp, result); 6149 result = TCL_ERROR; 6150 script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); 6151 Tcl_LogCommandInfo(interp, script, script, numSrcBytes); 6152 } 6153 6154 /* 6155 * We are returning to level 0, so should call TclResetCancellation. 6156 * Let us just unset the flags inline. 6157 */ 6158 6159 TclUnsetCancelFlags(iPtr); 6160 } 6161 iPtr->evalFlags = 0; 6162 6163 /* 6164 * Restore the callFrame if this was a TCL_EVAL_GLOBAL. 6165 */ 6166 6167 if (savedVarFramePtr) { 6168 iPtr->varFramePtr = savedVarFramePtr; 6169 } 6170 6171 TclDecrRefCount(objPtr); 6172 return result; 6173 } 6174 6175 static int 6176 TEOEx_ListCallback( 6177 ClientData data[], 6178 Tcl_Interp *interp, 6179 int result) 6180 { 6181 Interp *iPtr = (Interp *) interp; 6182 Tcl_Obj *listPtr = data[0]; 6183 CmdFrame *eoFramePtr = data[1]; 6184 Tcl_Obj *objPtr = data[2]; 6185 6186 /* 6187 * Remove the cmdFrame 6188 */ 6189 6190 if (eoFramePtr) { 6191 iPtr->cmdFramePtr = eoFramePtr->nextPtr; 6192 TclStackFree(interp, eoFramePtr); 6193 } 6194 TclDecrRefCount(objPtr); 6195 TclDecrRefCount(listPtr); 6196 6197 return result; 6198 } 6199 6200 /* 6201 *---------------------------------------------------------------------- 6202 * 6203 * ProcessUnexpectedResult -- 6204 * 6205 * Function called by Tcl_EvalObj to set the interpreter's result value 6206 * to an appropriate error message when the code it evaluates returns an 6207 * unexpected result code (not TCL_OK and not TCL_ERROR) to the topmost 6208 * evaluation level. 6209 * 6210 * Results: 6211 * None. 6212 * 6213 * Side effects: 6214 * The interpreter result is set to an error message appropriate to the 6215 * result code. 6216 * 6217 *---------------------------------------------------------------------- 6218 */ 6219 6220 static void 6221 ProcessUnexpectedResult( 6222 Tcl_Interp *interp, /* The interpreter in which the unexpected 6223 * result code was returned. */ 6224 int returnCode) /* The unexpected result code. */ 6225 { 6226 char buf[TCL_INTEGER_SPACE]; 6227 6228 Tcl_ResetResult(interp); 6229 if (returnCode == TCL_BREAK) { 6230 Tcl_SetObjResult(interp, Tcl_NewStringObj( 6231 "invoked \"break\" outside of a loop", -1)); 6232 } else if (returnCode == TCL_CONTINUE) { 6233 Tcl_SetObjResult(interp, Tcl_NewStringObj( 6234 "invoked \"continue\" outside of a loop", -1)); 6235 } else { 6236 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 6237 "command returned bad code: %d", returnCode)); 6238 } 6239 sprintf(buf, "%d", returnCode); 6240 Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, NULL); 6241 } 6242 6243 /* 6244 *--------------------------------------------------------------------------- 6245 * 6246 * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- 6247 * 6248 * Functions to evaluate an expression and return its value in a 6249 * particular form. 6250 * 6251 * Results: 6252 * Each of the functions below returns a standard Tcl result. If an error 6253 * occurs then an error message is left in the interp's result. Otherwise 6254 * the value of the expression, in the appropriate form, is stored at 6255 * *ptr. If the expression had a result that was incompatible with the 6256 * desired form then an error is returned. 6257 * 6258 * Side effects: 6259 * None. 6260 * 6261 *--------------------------------------------------------------------------- 6262 */ 6263 6264 int 6265 Tcl_ExprLong( 6266 Tcl_Interp *interp, /* Context in which to evaluate the 6267 * expression. */ 6268 const char *exprstring, /* Expression to evaluate. */ 6269 long *ptr) /* Where to store result. */ 6270 { 6271 register Tcl_Obj *exprPtr; 6272 int result = TCL_OK; 6273 if (*exprstring == '\0') { 6274 /* 6275 * Legacy compatibility - return 0 for the zero-length string. 6276 */ 6277 6278 *ptr = 0; 6279 } else { 6280 exprPtr = Tcl_NewStringObj(exprstring, -1); 6281 Tcl_IncrRefCount(exprPtr); 6282 result = Tcl_ExprLongObj(interp, exprPtr, ptr); 6283 Tcl_DecrRefCount(exprPtr); 6284 if (result != TCL_OK) { 6285 (void) Tcl_GetStringResult(interp); 6286 } 6287 } 6288 return result; 6289 } 6290 6291 int 6292 Tcl_ExprDouble( 6293 Tcl_Interp *interp, /* Context in which to evaluate the 6294 * expression. */ 6295 const char *exprstring, /* Expression to evaluate. */ 6296 double *ptr) /* Where to store result. */ 6297 { 6298 register Tcl_Obj *exprPtr; 6299 int result = TCL_OK; 6300 6301 if (*exprstring == '\0') { 6302 /* 6303 * Legacy compatibility - return 0 for the zero-length string. 6304 */ 6305 6306 *ptr = 0.0; 6307 } else { 6308 exprPtr = Tcl_NewStringObj(exprstring, -1); 6309 Tcl_IncrRefCount(exprPtr); 6310 result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); 6311 Tcl_DecrRefCount(exprPtr); 6312 /* Discard the expression object. */ 6313 if (result != TCL_OK) { 6314 (void) Tcl_GetStringResult(interp); 6315 } 6316 } 6317 return result; 6318 } 6319 6320 int 6321 Tcl_ExprBoolean( 6322 Tcl_Interp *interp, /* Context in which to evaluate the 6323 * expression. */ 6324 const char *exprstring, /* Expression to evaluate. */ 6325 int *ptr) /* Where to store 0/1 result. */ 6326 { 6327 if (*exprstring == '\0') { 6328 /* 6329 * An empty string. Just set the result boolean to 0 (false). 6330 */ 6331 6332 *ptr = 0; 6333 return TCL_OK; 6334 } else { 6335 int result; 6336 Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); 6337 6338 Tcl_IncrRefCount(exprPtr); 6339 result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); 6340 Tcl_DecrRefCount(exprPtr); 6341 if (result != TCL_OK) { 6342 /* 6343 * Move the interpreter's object result to the string result, then 6344 * reset the object result. 6345 */ 6346 6347 (void) Tcl_GetStringResult(interp); 6348 } 6349 return result; 6350 } 6351 } 6352 6353 /* 6354 *-------------------------------------------------------------- 6355 * 6356 * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- 6357 * 6358 * Functions to evaluate an expression in an object and return its value 6359 * in a particular form. 6360 * 6361 * Results: 6362 * Each of the functions below returns a standard Tcl result object. If 6363 * an error occurs then an error message is left in the interpreter's 6364 * result. Otherwise the value of the expression, in the appropriate 6365 * form, is stored at *ptr. If the expression had a result that was 6366 * incompatible with the desired form then an error is returned. 6367 * 6368 * Side effects: 6369 * None. 6370 * 6371 *-------------------------------------------------------------- 6372 */ 6373 6374 int 6375 Tcl_ExprLongObj( 6376 Tcl_Interp *interp, /* Context in which to evaluate the 6377 * expression. */ 6378 register Tcl_Obj *objPtr, /* Expression to evaluate. */ 6379 long *ptr) /* Where to store long result. */ 6380 { 6381 Tcl_Obj *resultPtr; 6382 int result, type; 6383 double d; 6384 ClientData internalPtr; 6385 6386 result = Tcl_ExprObj(interp, objPtr, &resultPtr); 6387 if (result != TCL_OK) { 6388 return TCL_ERROR; 6389 } 6390 6391 if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) { 6392 return TCL_ERROR; 6393 } 6394 6395 switch (type) { 6396 case TCL_NUMBER_DOUBLE: { 6397 mp_int big; 6398 6399 d = *((const double *) internalPtr); 6400 Tcl_DecrRefCount(resultPtr); 6401 if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { 6402 return TCL_ERROR; 6403 } 6404 resultPtr = Tcl_NewBignumObj(&big); 6405 /* FALLTHROUGH */ 6406 } 6407 case TCL_NUMBER_LONG: 6408 case TCL_NUMBER_WIDE: 6409 case TCL_NUMBER_BIG: 6410 result = TclGetLongFromObj(interp, resultPtr, ptr); 6411 break; 6412 6413 case TCL_NUMBER_NAN: 6414 Tcl_GetDoubleFromObj(interp, resultPtr, &d); 6415 result = TCL_ERROR; 6416 } 6417 6418 Tcl_DecrRefCount(resultPtr);/* Discard the result object. */ 6419 return result; 6420 } 6421 6422 int 6423 Tcl_ExprDoubleObj( 6424 Tcl_Interp *interp, /* Context in which to evaluate the 6425 * expression. */ 6426 register Tcl_Obj *objPtr, /* Expression to evaluate. */ 6427 double *ptr) /* Where to store double result. */ 6428 { 6429 Tcl_Obj *resultPtr; 6430 int result, type; 6431 ClientData internalPtr; 6432 6433 result = Tcl_ExprObj(interp, objPtr, &resultPtr); 6434 if (result != TCL_OK) { 6435 return TCL_ERROR; 6436 } 6437 6438 result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type); 6439 if (result == TCL_OK) { 6440 switch (type) { 6441 case TCL_NUMBER_NAN: 6442 #ifndef ACCEPT_NAN 6443 result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); 6444 break; 6445 #endif 6446 case TCL_NUMBER_DOUBLE: 6447 *ptr = *((const double *) internalPtr); 6448 result = TCL_OK; 6449 break; 6450 default: 6451 result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); 6452 } 6453 } 6454 Tcl_DecrRefCount(resultPtr);/* Discard the result object. */ 6455 return result; 6456 } 6457 6458 int 6459 Tcl_ExprBooleanObj( 6460 Tcl_Interp *interp, /* Context in which to evaluate the 6461 * expression. */ 6462 register Tcl_Obj *objPtr, /* Expression to evaluate. */ 6463 int *ptr) /* Where to store 0/1 result. */ 6464 { 6465 Tcl_Obj *resultPtr; 6466 int result; 6467 6468 result = Tcl_ExprObj(interp, objPtr, &resultPtr); 6469 if (result == TCL_OK) { 6470 result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); 6471 Tcl_DecrRefCount(resultPtr); 6472 /* Discard the result object. */ 6473 } 6474 return result; 6475 } 6476 6477 /* 6478 *---------------------------------------------------------------------- 6479 * 6480 * TclObjInvokeNamespace -- 6481 * 6482 * Object version: Invokes a Tcl command, given an objv/objc, from either 6483 * the exposed or hidden set of commands in the given interpreter. 6484 * 6485 * NOTE: The command is invoked in the global stack frame of the 6486 * interpreter or namespace, thus it cannot see any current state on the 6487 * stack of that interpreter. 6488 * 6489 * Results: 6490 * A standard Tcl result. 6491 * 6492 * Side effects: 6493 * Whatever the command does. 6494 * 6495 *---------------------------------------------------------------------- 6496 */ 6497 6498 int 6499 TclObjInvokeNamespace( 6500 Tcl_Interp *interp, /* Interpreter in which command is to be 6501 * invoked. */ 6502 int objc, /* Count of arguments. */ 6503 Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the 6504 * name of the command to invoke. */ 6505 Tcl_Namespace *nsPtr, /* The namespace to use. */ 6506 int flags) /* Combination of flags controlling the call: 6507 * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, 6508 * or TCL_INVOKE_NO_TRACEBACK. */ 6509 { 6510 int result; 6511 Tcl_CallFrame *framePtr; 6512 6513 /* 6514 * Make the specified namespace the current namespace and invoke the 6515 * command. 6516 */ 6517 6518 result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0); 6519 if (result != TCL_OK) { 6520 return TCL_ERROR; 6521 } 6522 6523 result = TclObjInvoke(interp, objc, objv, flags); 6524 6525 TclPopStackFrame(interp); 6526 return result; 6527 } 6528 6529 /* 6530 *---------------------------------------------------------------------- 6531 * 6532 * TclObjInvoke -- 6533 * 6534 * Invokes a Tcl command, given an objv/objc, from either the exposed or 6535 * the hidden sets of commands in the given interpreter. 6536 * 6537 * Results: 6538 * A standard Tcl object result. 6539 * 6540 * Side effects: 6541 * Whatever the command does. 6542 * 6543 *---------------------------------------------------------------------- 6544 */ 6545 6546 int 6547 TclObjInvoke( 6548 Tcl_Interp *interp, /* Interpreter in which command is to be 6549 * invoked. */ 6550 int objc, /* Count of arguments. */ 6551 Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the 6552 * name of the command to invoke. */ 6553 int flags) /* Combination of flags controlling the call: 6554 * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, 6555 * or TCL_INVOKE_NO_TRACEBACK. */ 6556 { 6557 if (interp == NULL) { 6558 return TCL_ERROR; 6559 } 6560 if ((objc < 1) || (objv == NULL)) { 6561 Tcl_SetObjResult(interp, Tcl_NewStringObj( 6562 "illegal argument vector", -1)); 6563 return TCL_ERROR; 6564 } 6565 if ((flags & TCL_INVOKE_HIDDEN) == 0) { 6566 Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); 6567 } 6568 return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); 6569 } 6570 6571 int 6572 TclNRInvoke( 6573 ClientData clientData, 6574 Tcl_Interp *interp, 6575 int objc, 6576 Tcl_Obj *const objv[]) 6577 { 6578 register Interp *iPtr = (Interp *) interp; 6579 Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ 6580 const char *cmdName; /* Name of the command from objv[0]. */ 6581 Tcl_HashEntry *hPtr = NULL; 6582 Command *cmdPtr; 6583 6584 cmdName = TclGetString(objv[0]); 6585 hTblPtr = iPtr->hiddenCmdTablePtr; 6586 if (hTblPtr != NULL) { 6587 hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); 6588 } 6589 if (hPtr == NULL) { 6590 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 6591 "invalid hidden command name \"%s\"", cmdName)); 6592 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName, 6593 NULL); 6594 return TCL_ERROR; 6595 } 6596 cmdPtr = Tcl_GetHashValue(hPtr); 6597 6598 /* Avoid the exception-handling brain damage when numLevels == 0 . */ 6599 iPtr->numLevels++; 6600 Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); 6601 6602 /* 6603 * Normal command resolution of objv[0] isn't going to find cmdPtr. 6604 * That's the whole point of **hidden** commands. So tell the 6605 * Eval core machinery not to even try (and risk finding something wrong). 6606 */ 6607 6608 return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); 6609 } 6610 6611 static int 6612 NRPostInvoke( 6613 ClientData clientData[], 6614 Tcl_Interp *interp, 6615 int result) 6616 { 6617 Interp *iPtr = (Interp *)interp; 6618 iPtr->numLevels--; 6619 return result; 6620 } 6621 6622 /* 6623 *--------------------------------------------------------------------------- 6624 * 6625 * Tcl_ExprString -- 6626 * 6627 * Evaluate an expression in a string and return its value in string 6628 * form. 6629 * 6630 * Results: 6631 * A standard Tcl result. If the result is TCL_OK, then the interp's 6632 * result is set to the string value of the expression. If the result is 6633 * TCL_ERROR, then the interp's result contains an error message. 6634 * 6635 * Side effects: 6636 * A Tcl object is allocated to hold a copy of the expression string. 6637 * This expression object is passed to Tcl_ExprObj and then deallocated. 6638 * 6639 *--------------------------------------------------------------------------- 6640 */ 6641 6642 int 6643 Tcl_ExprString( 6644 Tcl_Interp *interp, /* Context in which to evaluate the 6645 * expression. */ 6646 const char *expr) /* Expression to evaluate. */ 6647 { 6648 int code = TCL_OK; 6649 6650 if (expr[0] == '\0') { 6651 /* 6652 * An empty string. Just set the interpreter's result to 0. 6653 */ 6654 6655 Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); 6656 } else { 6657 Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); 6658 6659 Tcl_IncrRefCount(exprObj); 6660 code = Tcl_ExprObj(interp, exprObj, &resultPtr); 6661 Tcl_DecrRefCount(exprObj); 6662 if (code == TCL_OK) { 6663 Tcl_SetObjResult(interp, resultPtr); 6664 Tcl_DecrRefCount(resultPtr); 6665 } 6666 } 6667 6668 /* 6669 * Force the string rep of the interp result. 6670 */ 6671 6672 (void) Tcl_GetStringResult(interp); 6673 return code; 6674 } 6675 6676 /* 6677 *---------------------------------------------------------------------- 6678 * 6679 * Tcl_AppendObjToErrorInfo -- 6680 * 6681 * Add a Tcl_Obj value to the errorInfo field that describes the current 6682 * error. 6683 * 6684 * Results: 6685 * None. 6686 * 6687 * Side effects: 6688 * The value of the Tcl_obj is appended to the errorInfo field. If we are 6689 * just starting to log an error, errorInfo is initialized from the error 6690 * message in the interpreter's result. 6691 * 6692 *---------------------------------------------------------------------- 6693 */ 6694 6695 #undef Tcl_AddObjErrorInfo 6696 void 6697 Tcl_AppendObjToErrorInfo( 6698 Tcl_Interp *interp, /* Interpreter to which error information 6699 * pertains. */ 6700 Tcl_Obj *objPtr) /* Message to record. */ 6701 { 6702 int length; 6703 const char *message = TclGetStringFromObj(objPtr, &length); 6704 6705 Tcl_IncrRefCount(objPtr); 6706 Tcl_AddObjErrorInfo(interp, message, length); 6707 Tcl_DecrRefCount(objPtr); 6708 } 6709 6710 /* 6711 *---------------------------------------------------------------------- 6712 * 6713 * Tcl_AddErrorInfo -- 6714 * 6715 * Add information to the errorInfo field that describes the current 6716 * error. 6717 * 6718 * Results: 6719 * None. 6720 * 6721 * Side effects: 6722 * The contents of message are appended to the errorInfo field. If we are 6723 * just starting to log an error, errorInfo is initialized from the error 6724 * message in the interpreter's result. 6725 * 6726 *---------------------------------------------------------------------- 6727 */ 6728 6729 #undef Tcl_AddErrorInfo 6730 void 6731 Tcl_AddErrorInfo( 6732 Tcl_Interp *interp, /* Interpreter to which error information 6733 * pertains. */ 6734 const char *message) /* Message to record. */ 6735 { 6736 Tcl_AddObjErrorInfo(interp, message, -1); 6737 } 6738 6739 /* 6740 *---------------------------------------------------------------------- 6741 * 6742 * Tcl_AddObjErrorInfo -- 6743 * 6744 * Add information to the errorInfo field that describes the current 6745 * error. This routine differs from Tcl_AddErrorInfo by taking a byte 6746 * pointer and length. 6747 * 6748 * Results: 6749 * None. 6750 * 6751 * Side effects: 6752 * "length" bytes from "message" are appended to the errorInfo field. If 6753 * "length" is negative, use bytes up to the first NULL byte. If we are 6754 * just starting to log an error, errorInfo is initialized from the error 6755 * message in the interpreter's result. 6756 * 6757 *---------------------------------------------------------------------- 6758 */ 6759 6760 void 6761 Tcl_AddObjErrorInfo( 6762 Tcl_Interp *interp, /* Interpreter to which error information 6763 * pertains. */ 6764 const char *message, /* Points to the first byte of an array of 6765 * bytes of the message. */ 6766 int length) /* The number of bytes in the message. If < 0, 6767 * then append all bytes up to a NULL byte. */ 6768 { 6769 register Interp *iPtr = (Interp *) interp; 6770 6771 /* 6772 * If we are just starting to log an error, errorInfo is initialized from 6773 * the error message in the interpreter's result. 6774 */ 6775 6776 iPtr->flags |= ERR_LEGACY_COPY; 6777 if (iPtr->errorInfo == NULL) { 6778 if (iPtr->result[0] != 0) { 6779 /* 6780 * The interp's string result is set, apparently by some extension 6781 * making a deprecated direct write to it. That extension may 6782 * expect interp->result to continue to be set, so we'll take 6783 * special pains to avoid clearing it, until we drop support for 6784 * interp->result completely. 6785 */ 6786 6787 iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); 6788 } else { 6789 iPtr->errorInfo = iPtr->objResultPtr; 6790 } 6791 Tcl_IncrRefCount(iPtr->errorInfo); 6792 if (!iPtr->errorCode) { 6793 Tcl_SetErrorCode(interp, "NONE", NULL); 6794 } 6795 } 6796 6797 /* 6798 * Now append "message" to the end of errorInfo. 6799 */ 6800 6801 if (length != 0) { 6802 if (Tcl_IsShared(iPtr->errorInfo)) { 6803 Tcl_DecrRefCount(iPtr->errorInfo); 6804 iPtr->errorInfo = Tcl_DuplicateObj(iPtr->errorInfo); 6805 Tcl_IncrRefCount(iPtr->errorInfo); 6806 } 6807 Tcl_AppendToObj(iPtr->errorInfo, message, length); 6808 } 6809 } 6810 6811 /* 6812 *--------------------------------------------------------------------------- 6813 * 6814 * Tcl_VarEvalVA -- 6815 * 6816 * Given a variable number of string arguments, concatenate them all 6817 * together and execute the result as a Tcl command. 6818 * 6819 * Results: 6820 * A standard Tcl return result. An error message or other result may be 6821 * left in the interp's result. 6822 * 6823 * Side effects: 6824 * Depends on what was done by the command. 6825 * 6826 *--------------------------------------------------------------------------- 6827 */ 6828 6829 int 6830 Tcl_VarEvalVA( 6831 Tcl_Interp *interp, /* Interpreter in which to evaluate command */ 6832 va_list argList) /* Variable argument list. */ 6833 { 6834 Tcl_DString buf; 6835 char *string; 6836 int result; 6837 6838 /* 6839 * Copy the strings one after the other into a single larger string. Use 6840 * stack-allocated space for small commands, but if the command gets too 6841 * large than call ckalloc to create the space. 6842 */ 6843 6844 Tcl_DStringInit(&buf); 6845 while (1) { 6846 string = va_arg(argList, char *); 6847 if (string == NULL) { 6848 break; 6849 } 6850 Tcl_DStringAppend(&buf, string, -1); 6851 } 6852 6853 result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); 6854 Tcl_DStringFree(&buf); 6855 return result; 6856 } 6857 6858 /* 6859 *---------------------------------------------------------------------- 6860 * 6861 * Tcl_VarEval -- 6862 * 6863 * Given a variable number of string arguments, concatenate them all 6864 * together and execute the result as a Tcl command. 6865 * 6866 * Results: 6867 * A standard Tcl return result. An error message or other result may be 6868 * left in interp->result. 6869 * 6870 * Side effects: 6871 * Depends on what was done by the command. 6872 * 6873 *---------------------------------------------------------------------- 6874 */ 6875 /* ARGSUSED */ 6876 int 6877 Tcl_VarEval( 6878 Tcl_Interp *interp, 6879 ...) 6880 { 6881 va_list argList; 6882 int result; 6883 6884 va_start(argList, interp); 6885 result = Tcl_VarEvalVA(interp, argList); 6886 va_end(argList); 6887 6888 return result; 6889 } 6890 6891 /* 6892 *---------------------------------------------------------------------- 6893 * 6894 * Tcl_GlobalEval -- 6895 * 6896 * Evaluate a command at global level in an interpreter. 6897 * 6898 * Results: 6899 * A standard Tcl result is returned, and the interp's result is modified 6900 * accordingly. 6901 * 6902 * Side effects: 6903 * The command string is executed in interp, and the execution is carried 6904 * out in the variable context of global level (no functions active), 6905 * just as if an "uplevel #0" command were being executed. 6906 * 6907 *---------------------------------------------------------------------- 6908 */ 6909 6910 #undef Tcl_GlobalEval 6911 int 6912 Tcl_GlobalEval( 6913 Tcl_Interp *interp, /* Interpreter in which to evaluate 6914 * command. */ 6915 const char *command) /* Command to evaluate. */ 6916 { 6917 register Interp *iPtr = (Interp *) interp; 6918 int result; 6919 CallFrame *savedVarFramePtr; 6920 6921 savedVarFramePtr = iPtr->varFramePtr; 6922 iPtr->varFramePtr = iPtr->rootFramePtr; 6923 result = Tcl_Eval(interp, command); 6924 iPtr->varFramePtr = savedVarFramePtr; 6925 return result; 6926 } 6927 6928 /* 6929 *---------------------------------------------------------------------- 6930 * 6931 * Tcl_SetRecursionLimit -- 6932 * 6933 * Set the maximum number of recursive calls that may be active for an 6934 * interpreter at once. 6935 * 6936 * Results: 6937 * The return value is the old limit on nesting for interp. 6938 * 6939 * Side effects: 6940 * None. 6941 * 6942 *---------------------------------------------------------------------- 6943 */ 6944 6945 int 6946 Tcl_SetRecursionLimit( 6947 Tcl_Interp *interp, /* Interpreter whose nesting limit is to be 6948 * set. */ 6949 int depth) /* New value for maximimum depth. */ 6950 { 6951 Interp *iPtr = (Interp *) interp; 6952 int old; 6953 6954 old = iPtr->maxNestingDepth; 6955 if (depth > 0) { 6956 iPtr->maxNestingDepth = depth; 6957 } 6958 return old; 6959 } 6960 6961 /* 6962 *---------------------------------------------------------------------- 6963 * 6964 * Tcl_AllowExceptions -- 6965 * 6966 * Sets a flag in an interpreter so that exceptions can occur in the next 6967 * call to Tcl_Eval without them being turned into errors. 6968 * 6969 * Results: 6970 * None. 6971 * 6972 * Side effects: 6973 * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's evalFlags 6974 * structure. See the reference documentation for more details. 6975 * 6976 *---------------------------------------------------------------------- 6977 */ 6978 6979 void 6980 Tcl_AllowExceptions( 6981 Tcl_Interp *interp) /* Interpreter in which to set flag. */ 6982 { 6983 Interp *iPtr = (Interp *) interp; 6984 6985 iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; 6986 } 6987 6988 /* 6989 *---------------------------------------------------------------------- 6990 * 6991 * Tcl_GetVersion -- 6992 * 6993 * Get the Tcl major, minor, and patchlevel version numbers and the 6994 * release type. A patch is a release type TCL_FINAL_RELEASE with a 6995 * patchLevel > 0. 6996 * 6997 * Results: 6998 * None. 6999 * 7000 * Side effects: 7001 * None. 7002 * 7003 *---------------------------------------------------------------------- 7004 */ 7005 7006 void 7007 Tcl_GetVersion( 7008 int *majorV, 7009 int *minorV, 7010 int *patchLevelV, 7011 int *type) 7012 { 7013 if (majorV != NULL) { 7014 *majorV = TCL_MAJOR_VERSION; 7015 } 7016 if (minorV != NULL) { 7017 *minorV = TCL_MINOR_VERSION; 7018 } 7019 if (patchLevelV != NULL) { 7020 *patchLevelV = TCL_RELEASE_SERIAL; 7021 } 7022 if (type != NULL) { 7023 *type = TCL_RELEASE_LEVEL; 7024 } 7025 } 7026 7027 /* 7028 *---------------------------------------------------------------------- 7029 * 7030 * Math Functions -- 7031 * 7032 * This page contains the functions that implement all of the built-in 7033 * math functions for expressions. 7034 * 7035 * Results: 7036 * Each function returns TCL_OK if it succeeds and pushes an Tcl object 7037 * holding the result. If it fails it returns TCL_ERROR and leaves an 7038 * error message in the interpreter's result. 7039 * 7040 * Side effects: 7041 * None. 7042 * 7043 *---------------------------------------------------------------------- 7044 */ 7045 7046 static int 7047 ExprCeilFunc( 7048 ClientData clientData, /* Ignored */ 7049 Tcl_Interp *interp, /* The interpreter in which to execute the 7050 * function. */ 7051 int objc, /* Actual parameter count. */ 7052 Tcl_Obj *const *objv) /* Actual parameter list. */ 7053 { 7054 int code; 7055 double d; 7056 mp_int big; 7057 7058 if (objc != 2) { 7059 MathFuncWrongNumArgs(interp, 2, objc, objv); 7060 return TCL_ERROR; 7061 } 7062 code = Tcl_GetDoubleFromObj(interp, objv[1], &d); 7063 #ifdef ACCEPT_NAN 7064 if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { 7065 Tcl_SetObjResult(interp, objv[1]); 7066 return TCL_OK; 7067 } 7068 #endif 7069 if (code != TCL_OK) { 7070 return TCL_ERROR; 7071 } 7072 7073 if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { 7074 Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big))); 7075 mp_clear(&big); 7076 } else { 7077 Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d))); 7078 } 7079 return TCL_OK; 7080 } 7081 7082 static int 7083 ExprFloorFunc( 7084 ClientData clientData, /* Ignored */ 7085 Tcl_Interp *interp, /* The interpreter in which to execute the 7086 * function. */ 7087 int objc, /* Actual parameter count. */ 7088 Tcl_Obj *const *objv) /* Actual parameter list. */ 7089 { 7090 int code; 7091 double d; 7092 mp_int big; 7093 7094 if (objc != 2) { 7095 MathFuncWrongNumArgs(interp, 2, objc, objv); 7096 return TCL_ERROR; 7097 } 7098 code = Tcl_GetDoubleFromObj(interp, objv[1], &d); 7099 #ifdef ACCEPT_NAN 7100 if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { 7101 Tcl_SetObjResult(interp, objv[1]); 7102 return TCL_OK; 7103 } 7104 #endif 7105 if (code != TCL_OK) { 7106 return TCL_ERROR; 7107 } 7108 7109 if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { 7110 Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big))); 7111 mp_clear(&big); 7112 } else { 7113 Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d))); 7114 } 7115 return TCL_OK; 7116 } 7117 7118 static int 7119 ExprIsqrtFunc( 7120 ClientData clientData, /* Ignored */ 7121 Tcl_Interp *interp, /* The interpreter in which to execute. */ 7122 int objc, /* Actual parameter count. */ 7123 Tcl_Obj *const *objv) /* Actual parameter list. */ 7124 { 7125 ClientData ptr; 7126 int type; 7127 double d; 7128 Tcl_WideInt w; 7129 mp_int big; 7130 int exact = 0; /* Flag ==1 if the argument can be represented 7131 * in a double as an exact integer. */ 7132 7133 /* 7134 * Check syntax. 7135 */ 7136 7137 if (objc != 2) { 7138 MathFuncWrongNumArgs(interp, 2, objc, objv); 7139 return TCL_ERROR; 7140 } 7141 7142 /* 7143 * Make sure that the arg is a number. 7144 */ 7145 7146 if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { 7147 return TCL_ERROR; 7148 } 7149 7150 switch (type) { 7151 case TCL_NUMBER_NAN: 7152 Tcl_GetDoubleFromObj(interp, objv[1], &d); 7153 return TCL_ERROR; 7154 case TCL_NUMBER_DOUBLE: 7155 d = *((const double *) ptr); 7156 if (d < 0) { 7157 goto negarg; 7158 } 7159 #ifdef IEEE_FLOATING_POINT 7160 if (d <= MAX_EXACT) { 7161 exact = 1; 7162 } 7163 #endif 7164 if (!exact) { 7165 if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { 7166 return TCL_ERROR; 7167 } 7168 } 7169 break; 7170 case TCL_NUMBER_BIG: 7171 if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { 7172 return TCL_ERROR; 7173 } 7174 if (SIGN(&big) == MP_NEG) { 7175 mp_clear(&big); 7176 goto negarg; 7177 } 7178 break; 7179 default: 7180 if (Tcl_GetWideIntFromObj(interp, objv[1], &w) != TCL_OK) { 7181 return TCL_ERROR; 7182 } 7183 if (w < 0) { 7184 goto negarg; 7185 } 7186 d = (double) w; 7187 #ifdef IEEE_FLOATING_POINT 7188 if (d < MAX_EXACT) { 7189 exact = 1; 7190 } 7191 #endif 7192 if (!exact) { 7193 Tcl_GetBignumFromObj(interp, objv[1], &big); 7194 } 7195 break; 7196 } 7197 7198 if (exact) { 7199 Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d))); 7200 } else { 7201 mp_int root; 7202 7203 mp_init(&root); 7204 mp_sqrt(&big, &root); 7205 mp_clear(&big); 7206 Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root)); 7207 } 7208 return TCL_OK; 7209 7210 negarg: 7211 Tcl_SetObjResult(interp, Tcl_NewStringObj( 7212 "square root of negative argument", -1)); 7213 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", 7214 "domain error: argument not in valid range", NULL); 7215 return TCL_ERROR; 7216 } 7217 7218 static int 7219 ExprSqrtFunc( 7220 ClientData clientData, /* Ignored */ 7221 Tcl_Interp *interp, /* The interpreter in which to execute the 7222 * function. */ 7223 int objc, /* Actual parameter count. */ 7224 Tcl_Obj *const *objv) /* Actual parameter list. */ 7225 { 7226 int code; 7227 double d; 7228 mp_int big; 7229 7230 if (objc != 2) { 7231 MathFuncWrongNumArgs(interp, 2, objc, objv); 7232 return TCL_ERROR; 7233 } 7234 code = Tcl_GetDoubleFromObj(interp, objv[1], &d); 7235 #ifdef ACCEPT_NAN 7236 if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { 7237 Tcl_SetObjResult(interp, objv[1]); 7238 return TCL_OK; 7239 } 7240 #endif 7241 if (code != TCL_OK) { 7242 return TCL_ERROR; 7243 } 7244 if ((d >= 0.0) && TclIsInfinite(d) 7245 && (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) { 7246 mp_int root; 7247 7248 mp_init(&root); 7249 mp_sqrt(&big, &root); 7250 mp_clear(&big); 7251 Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root))); 7252 mp_clear(&root); 7253 } else { 7254 Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d))); 7255 } 7256 return TCL_OK; 7257 } 7258 7259 static int 7260 ExprUnaryFunc( 7261 ClientData clientData, /* Contains the address of a function that 7262 * takes one double argument and returns a 7263 * double result. */ 7264 Tcl_Interp *interp, /* The interpreter in which to execute the 7265 * function. */ 7266 int objc, /* Actual parameter count */ 7267 Tcl_Obj *const *objv) /* Actual parameter list */ 7268 { 7269 int code; 7270 double d; 7271 double (*func)(double) = (double (*)(double)) clientData; 7272 7273 if (objc != 2) { 7274 MathFuncWrongNumArgs(interp, 2, objc, objv); 7275 return TCL_ERROR; 7276 } 7277 code = Tcl_GetDoubleFromObj(interp, objv[1], &d); 7278 #ifdef ACCEPT_NAN 7279 if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { 7280 d = objv[1]->internalRep.doubleValue; 7281 Tcl_ResetResult(interp); 7282 code = TCL_OK; 7283 } 7284 #endif 7285 if (code != TCL_OK) { 7286 return TCL_ERROR; 7287 } 7288 errno = 0; 7289 return CheckDoubleResult(interp, func(d)); 7290 } 7291 7292 static int 7293 CheckDoubleResult( 7294 Tcl_Interp *interp, 7295 double dResult) 7296 { 7297 #ifndef ACCEPT_NAN 7298 if (TclIsNaN(dResult)) { 7299 TclExprFloatError(interp, dResult); 7300 return TCL_ERROR; 7301 } 7302 #endif 7303 if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) { 7304 /* 7305 * When ERANGE signals under/overflow, just accept 0.0 or +/-Inf 7306 */ 7307 } else if (errno != 0) { 7308 /* 7309 * Report other errno values as errors. 7310 */ 7311 7312 TclExprFloatError(interp, dResult); 7313 return TCL_ERROR; 7314 } 7315 Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); 7316 return TCL_OK; 7317 } 7318 7319 static int 7320 ExprBinaryFunc( 7321 ClientData clientData, /* Contains the address of a function that 7322 * takes two double arguments and returns a 7323 * double result. */ 7324 Tcl_Interp *interp, /* The interpreter in which to execute the 7325 * function. */ 7326 int objc, /* Actual parameter count. */ 7327 Tcl_Obj *const *objv) /* Parameter vector. */ 7328 { 7329 int code; 7330 double d1, d2; 7331 double (*func)(double, double) = (double (*)(double, double)) clientData; 7332 7333 if (objc != 3) { 7334 MathFuncWrongNumArgs(interp, 3, objc, objv); 7335 return TCL_ERROR; 7336 } 7337 code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); 7338 #ifdef ACCEPT_NAN 7339 if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { 7340 d1 = objv[1]->internalRep.doubleValue; 7341 Tcl_ResetResult(interp); 7342 code = TCL_OK; 7343 } 7344 #endif 7345 if (code != TCL_OK) { 7346 return TCL_ERROR; 7347 } 7348 code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); 7349 #ifdef ACCEPT_NAN 7350 if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) { 7351 d2 = objv[2]->internalRep.doubleValue; 7352 Tcl_ResetResult(interp); 7353 code = TCL_OK; 7354 } 7355 #endif 7356 if (code != TCL_OK) { 7357 return TCL_ERROR; 7358 } 7359 errno = 0; 7360 return CheckDoubleResult(interp, func(d1, d2)); 7361 } 7362 7363 static int 7364 ExprAbsFunc( 7365 ClientData clientData, /* Ignored. */ 7366 Tcl_Interp *interp, /* The interpreter in which to execute the 7367 * function. */ 7368 int objc, /* Actual parameter count. */ 7369 Tcl_Obj *const *objv) /* Parameter vector. */ 7370 { 7371 ClientData ptr; 7372 int type; 7373 mp_int big; 7374 7375 if (objc != 2) { 7376 MathFuncWrongNumArgs(interp, 2, objc, objv); 7377 return TCL_ERROR; 7378 } 7379 7380 if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { 7381 return TCL_ERROR; 7382 } 7383 7384 if (type == TCL_NUMBER_LONG) { 7385 long l = *((const long *) ptr); 7386 7387 if (l > (long)0) { 7388 goto unChanged; 7389 } else if (l == (long)0) { 7390 const char *string = objv[1]->bytes; 7391 if (string) { 7392 while (*string != '0') { 7393 if (*string == '-') { 7394 Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); 7395 return TCL_OK; 7396 } 7397 string++; 7398 } 7399 } 7400 goto unChanged; 7401 } else if (l == LONG_MIN) { 7402 TclBNInitBignumFromLong(&big, l); 7403 goto tooLarge; 7404 } 7405 Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); 7406 return TCL_OK; 7407 } 7408 7409 if (type == TCL_NUMBER_DOUBLE) { 7410 double d = *((const double *) ptr); 7411 static const double poszero = 0.0; 7412 7413 /* 7414 * We need to distinguish here between positive 0.0 and negative -0.0. 7415 * [Bug 2954959] 7416 */ 7417 7418 if (d == -0.0) { 7419 if (!memcmp(&d, &poszero, sizeof(double))) { 7420 goto unChanged; 7421 } 7422 } else if (d > -0.0) { 7423 goto unChanged; 7424 } 7425 Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); 7426 return TCL_OK; 7427 } 7428 7429 #ifndef TCL_WIDE_INT_IS_LONG 7430 if (type == TCL_NUMBER_WIDE) { 7431 Tcl_WideInt w = *((const Tcl_WideInt *) ptr); 7432 7433 if (w >= (Tcl_WideInt)0) { 7434 goto unChanged; 7435 } 7436 if (w == LLONG_MIN) { 7437 TclBNInitBignumFromWideInt(&big, w); 7438 goto tooLarge; 7439 } 7440 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); 7441 return TCL_OK; 7442 } 7443 #endif 7444 7445 if (type == TCL_NUMBER_BIG) { 7446 if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { 7447 Tcl_GetBignumFromObj(NULL, objv[1], &big); 7448 tooLarge: 7449 mp_neg(&big, &big); 7450 Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); 7451 } else { 7452 unChanged: 7453 Tcl_SetObjResult(interp, objv[1]); 7454 } 7455 return TCL_OK; 7456 } 7457 7458 if (type == TCL_NUMBER_NAN) { 7459 #ifdef ACCEPT_NAN 7460 Tcl_SetObjResult(interp, objv[1]); 7461 return TCL_OK; 7462 #else 7463 double d; 7464 7465 Tcl_GetDoubleFromObj(interp, objv[1], &d); 7466 return TCL_ERROR; 7467 #endif 7468 } 7469 return TCL_OK; 7470 } 7471 7472 static int 7473 ExprBoolFunc( 7474 ClientData clientData, /* Ignored. */ 7475 Tcl_Interp *interp, /* The interpreter in which to execute the 7476 * function. */ 7477 int objc, /* Actual parameter count. */ 7478 Tcl_Obj *const *objv) /* Actual parameter vector. */ 7479 { 7480 int value; 7481 7482 if (objc != 2) { 7483 MathFuncWrongNumArgs(interp, 2, objc, objv); 7484 return TCL_ERROR; 7485 } 7486 if (Tcl_GetBooleanFromObj(interp, objv[1], &value) != TCL_OK) { 7487 return TCL_ERROR; 7488 } 7489 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); 7490 return TCL_OK; 7491 } 7492 7493 static int 7494 ExprDoubleFunc( 7495 ClientData clientData, /* Ignored. */ 7496 Tcl_Interp *interp, /* The interpreter in which to execute the 7497 * function. */ 7498 int objc, /* Actual parameter count. */ 7499 Tcl_Obj *const *objv) /* Actual parameter vector. */ 7500 { 7501 double dResult; 7502 7503 if (objc != 2) { 7504 MathFuncWrongNumArgs(interp, 2, objc, objv); 7505 return TCL_ERROR; 7506 } 7507 if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { 7508 #ifdef ACCEPT_NAN 7509 if (objv[1]->typePtr == &tclDoubleType) { 7510 Tcl_SetObjResult(interp, objv[1]); 7511 return TCL_OK; 7512 } 7513 #endif 7514 return TCL_ERROR; 7515 } 7516 Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); 7517 return TCL_OK; 7518 } 7519 7520 static int 7521 ExprEntierFunc( 7522 ClientData clientData, /* Ignored. */ 7523 Tcl_Interp *interp, /* The interpreter in which to execute the 7524 * function. */ 7525 int objc, /* Actual parameter count. */ 7526 Tcl_Obj *const *objv) /* Actual parameter vector. */ 7527 { 7528 double d; 7529 int type; 7530 ClientData ptr; 7531 7532 if (objc != 2) { 7533 MathFuncWrongNumArgs(interp, 2, objc, objv); 7534 return TCL_ERROR; 7535 } 7536 if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { 7537 return TCL_ERROR; 7538 } 7539 7540 if (type == TCL_NUMBER_DOUBLE) { 7541 d = *((const double *) ptr); 7542 if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) { 7543 mp_int big; 7544 7545 if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { 7546 /* Infinity */ 7547 return TCL_ERROR; 7548 } 7549 Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); 7550 return TCL_OK; 7551 } else { 7552 long result = (long) d; 7553 7554 Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); 7555 return TCL_OK; 7556 } 7557 } 7558 7559 if (type != TCL_NUMBER_NAN) { 7560 /* 7561 * All integers are already of integer type. 7562 */ 7563 7564 Tcl_SetObjResult(interp, objv[1]); 7565 return TCL_OK; 7566 } 7567 7568 /* 7569 * Get the error message for NaN. 7570 */ 7571 7572 Tcl_GetDoubleFromObj(interp, objv[1], &d); 7573 return TCL_ERROR; 7574 } 7575 7576 static int 7577 ExprIntFunc( 7578 ClientData clientData, /* Ignored. */ 7579 Tcl_Interp *interp, /* The interpreter in which to execute the 7580 * function. */ 7581 int objc, /* Actual parameter count. */ 7582 Tcl_Obj *const *objv) /* Actual parameter vector. */ 7583 { 7584 long iResult; 7585 Tcl_Obj *objPtr; 7586 if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { 7587 return TCL_ERROR; 7588 } 7589 objPtr = Tcl_GetObjResult(interp); 7590 if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) { 7591 /* 7592 * Truncate the bignum; keep only bits in long range. 7593 */ 7594 7595 mp_int big; 7596 7597 Tcl_GetBignumFromObj(NULL, objPtr, &big); 7598 mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); 7599 objPtr = Tcl_NewBignumObj(&big); 7600 Tcl_IncrRefCount(objPtr); 7601 TclGetLongFromObj(NULL, objPtr, &iResult); 7602 Tcl_DecrRefCount(objPtr); 7603 } 7604 Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); 7605 return TCL_OK; 7606 } 7607 7608 static int 7609 ExprWideFunc( 7610 ClientData clientData, /* Ignored. */ 7611 Tcl_Interp *interp, /* The interpreter in which to execute the 7612 * function. */ 7613 int objc, /* Actual parameter count. */ 7614 Tcl_Obj *const *objv) /* Actual parameter vector. */ 7615 { 7616 Tcl_WideInt wResult; 7617 Tcl_Obj *objPtr; 7618 7619 if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { 7620 return TCL_ERROR; 7621 } 7622 objPtr = Tcl_GetObjResult(interp); 7623 if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { 7624 /* 7625 * Truncate the bignum; keep only bits in wide int range. 7626 */ 7627 7628 mp_int big; 7629 7630 Tcl_GetBignumFromObj(NULL, objPtr, &big); 7631 mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); 7632 objPtr = Tcl_NewBignumObj(&big); 7633 Tcl_IncrRefCount(objPtr); 7634 Tcl_GetWideIntFromObj(NULL, objPtr, &wResult); 7635 Tcl_DecrRefCount(objPtr); 7636 } 7637 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); 7638 return TCL_OK; 7639 } 7640 7641 static int 7642 ExprRandFunc( 7643 ClientData clientData, /* Ignored. */ 7644 Tcl_Interp *interp, /* The interpreter in which to execute the 7645 * function. */ 7646 int objc, /* Actual parameter count. */ 7647 Tcl_Obj *const *objv) /* Actual parameter vector. */ 7648 { 7649 Interp *iPtr = (Interp *) interp; 7650 double dResult; 7651 long tmp; /* Algorithm assumes at least 32 bits. Only 7652 * long guarantees that. See below. */ 7653 Tcl_Obj *oResult; 7654 7655 if (objc != 1) { 7656 MathFuncWrongNumArgs(interp, 1, objc, objv); 7657 return TCL_ERROR; 7658 } 7659 7660 if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { 7661 iPtr->flags |= RAND_SEED_INITIALIZED; 7662 7663 /* 7664 * Take into consideration the thread this interp is running in order 7665 * to insure different seeds in different threads (bug #416643) 7666 */ 7667 7668 iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); 7669 7670 /* 7671 * Make sure 1 <= randSeed <= (2^31) - 2. See below. 7672 */ 7673 7674 iPtr->randSeed &= (unsigned long) 0x7fffffff; 7675 if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { 7676 iPtr->randSeed ^= 123459876; 7677 } 7678 } 7679 7680 /* 7681 * Generate the random number using the linear congruential generator 7682 * defined by the following recurrence: 7683 * seed = ( IA * seed ) mod IM 7684 * where IA is 16807 and IM is (2^31) - 1. The recurrence maps a seed in 7685 * the range [1, IM - 1] to a new seed in that same range. The recurrence 7686 * maps IM to 0, and maps 0 back to 0, so those two values must not be 7687 * allowed as initial values of seed. 7688 * 7689 * In order to avoid potential problems with integer overflow, the 7690 * recurrence is implemented in terms of additional constants IQ and IR 7691 * such that 7692 * IM = IA*IQ + IR 7693 * None of the operations in the implementation overflows a 32-bit signed 7694 * integer, and the C type long is guaranteed to be at least 32 bits wide. 7695 * 7696 * For more details on how this algorithm works, refer to the following 7697 * papers: 7698 * 7699 * S.K. Park & K.W. Miller, "Random number generators: good ones are hard 7700 * to find," Comm ACM 31(10):1192-1201, Oct 1988 7701 * 7702 * W.H. Press & S.A. Teukolsky, "Portable random number generators," 7703 * Computers in Physics 6(5):522-524, Sep/Oct 1992. 7704 */ 7705 7706 #define RAND_IA 16807 7707 #define RAND_IM 2147483647 7708 #define RAND_IQ 127773 7709 #define RAND_IR 2836 7710 #define RAND_MASK 123459876 7711 7712 tmp = iPtr->randSeed/RAND_IQ; 7713 iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; 7714 if (iPtr->randSeed < 0) { 7715 iPtr->randSeed += RAND_IM; 7716 } 7717 7718 /* 7719 * Since the recurrence keeps seed values in the range [1, RAND_IM - 1], 7720 * dividing by RAND_IM yields a double in the range (0, 1). 7721 */ 7722 7723 dResult = iPtr->randSeed * (1.0/RAND_IM); 7724 7725 /* 7726 * Push a Tcl object with the result. 7727 */ 7728 7729 TclNewDoubleObj(oResult, dResult); 7730 Tcl_SetObjResult(interp, oResult); 7731 return TCL_OK; 7732 } 7733 7734 static int 7735 ExprRoundFunc( 7736 ClientData clientData, /* Ignored. */ 7737 Tcl_Interp *interp, /* The interpreter in which to execute the 7738 * function. */ 7739 int objc, /* Actual parameter count. */ 7740 Tcl_Obj *const *objv) /* Parameter vector. */ 7741 { 7742 double d; 7743 ClientData ptr; 7744 int type; 7745 7746 if (objc != 2) { 7747 MathFuncWrongNumArgs(interp, 2, objc, objv); 7748 return TCL_ERROR; 7749 } 7750 7751 if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { 7752 return TCL_ERROR; 7753 } 7754 7755 if (type == TCL_NUMBER_DOUBLE) { 7756 double fractPart, intPart; 7757 long max = LONG_MAX, min = LONG_MIN; 7758 7759 fractPart = modf(*((const double *) ptr), &intPart); 7760 if (fractPart <= -0.5) { 7761 min++; 7762 } else if (fractPart >= 0.5) { 7763 max--; 7764 } 7765 if ((intPart >= (double)max) || (intPart <= (double)min)) { 7766 mp_int big; 7767 7768 if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) { 7769 /* Infinity */ 7770 return TCL_ERROR; 7771 } 7772 if (fractPart <= -0.5) { 7773 mp_sub_d(&big, 1, &big); 7774 } else if (fractPart >= 0.5) { 7775 mp_add_d(&big, 1, &big); 7776 } 7777 Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); 7778 return TCL_OK; 7779 } else { 7780 long result = (long)intPart; 7781 7782 if (fractPart <= -0.5) { 7783 result--; 7784 } else if (fractPart >= 0.5) { 7785 result++; 7786 } 7787 Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); 7788 return TCL_OK; 7789 } 7790 } 7791 7792 if (type != TCL_NUMBER_NAN) { 7793 /* 7794 * All integers are already rounded 7795 */ 7796 7797 Tcl_SetObjResult(interp, objv[1]); 7798 return TCL_OK; 7799 } 7800 7801 /* 7802 * Get the error message for NaN. 7803 */ 7804 7805 Tcl_GetDoubleFromObj(interp, objv[1], &d); 7806 return TCL_ERROR; 7807 } 7808 7809 static int 7810 ExprSrandFunc( 7811 ClientData clientData, /* Ignored. */ 7812 Tcl_Interp *interp, /* The interpreter in which to execute the 7813 * function. */ 7814 int objc, /* Actual parameter count. */ 7815 Tcl_Obj *const *objv) /* Parameter vector. */ 7816 { 7817 Interp *iPtr = (Interp *) interp; 7818 long i = 0; /* Initialized to avoid compiler warning. */ 7819 7820 /* 7821 * Convert argument and use it to reset the seed. 7822 */ 7823 7824 if (objc != 2) { 7825 MathFuncWrongNumArgs(interp, 2, objc, objv); 7826 return TCL_ERROR; 7827 } 7828 7829 if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) { 7830 Tcl_Obj *objPtr; 7831 mp_int big; 7832 7833 if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { 7834 /* TODO: more ::errorInfo here? or in caller? */ 7835 return TCL_ERROR; 7836 } 7837 7838 mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); 7839 objPtr = Tcl_NewBignumObj(&big); 7840 Tcl_IncrRefCount(objPtr); 7841 TclGetLongFromObj(NULL, objPtr, &i); 7842 Tcl_DecrRefCount(objPtr); 7843 } 7844 7845 /* 7846 * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in 7847 * ExprRandFunc for more details. 7848 */ 7849 7850 iPtr->flags |= RAND_SEED_INITIALIZED; 7851 iPtr->randSeed = i; 7852 iPtr->randSeed &= (unsigned long) 0x7fffffff; 7853 if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { 7854 iPtr->randSeed ^= 123459876; 7855 } 7856 7857 /* 7858 * To avoid duplicating the random number generation code we simply clean 7859 * up our state and call the real random number function. That function 7860 * will always succeed. 7861 */ 7862 7863 return ExprRandFunc(clientData, interp, 1, objv); 7864 } 7865 7866 /* 7867 *---------------------------------------------------------------------- 7868 * 7869 * MathFuncWrongNumArgs -- 7870 * 7871 * Generate an error message when a math function presents the wrong 7872 * number of arguments. 7873 * 7874 * Results: 7875 * None. 7876 * 7877 * Side effects: 7878 * An error message is stored in the interpreter result. 7879 * 7880 *---------------------------------------------------------------------- 7881 */ 7882 7883 static void 7884 MathFuncWrongNumArgs( 7885 Tcl_Interp *interp, /* Tcl interpreter */ 7886 int expected, /* Formal parameter count. */ 7887 int found, /* Actual parameter count. */ 7888 Tcl_Obj *const *objv) /* Actual parameter vector. */ 7889 { 7890 const char *name = Tcl_GetString(objv[0]); 7891 const char *tail = name + strlen(name); 7892 7893 while (tail > name+1) { 7894 tail--; 7895 if (*tail == ':' && tail[-1] == ':') { 7896 name = tail+1; 7897 break; 7898 } 7899 } 7900 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 7901 "too %s arguments for math function \"%s\"", 7902 (found < expected ? "few" : "many"), name)); 7903 Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); 7904 } 7905 7906 #ifdef USE_DTRACE 7907 /* 7908 *---------------------------------------------------------------------- 7909 * 7910 * DTraceObjCmd -- 7911 * 7912 * This function is invoked to process the "::tcl::dtrace" Tcl command. 7913 * 7914 * Results: 7915 * A standard Tcl object result. 7916 * 7917 * Side effects: 7918 * The 'tcl-probe' DTrace probe is triggered (if it is enabled). 7919 * 7920 *---------------------------------------------------------------------- 7921 */ 7922 7923 static int 7924 DTraceObjCmd( 7925 ClientData dummy, /* Not used. */ 7926 Tcl_Interp *interp, /* Current interpreter. */ 7927 int objc, /* Number of arguments. */ 7928 Tcl_Obj *const objv[]) /* Argument objects. */ 7929 { 7930 if (TCL_DTRACE_TCL_PROBE_ENABLED()) { 7931 char *a[10]; 7932 int i = 0; 7933 7934 while (i++ < 10) { 7935 a[i-1] = i < objc ? TclGetString(objv[i]) : NULL; 7936 } 7937 TCL_DTRACE_TCL_PROBE(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], 7938 a[8], a[9]); 7939 } 7940 return TCL_OK; 7941 } 7942 7943 /* 7944 *---------------------------------------------------------------------- 7945 * 7946 * TclDTraceInfo -- 7947 * 7948 * Extract information from a TIP280 dict for use by DTrace probes. 7949 * 7950 * Results: 7951 * None. 7952 * 7953 * Side effects: 7954 * None. 7955 * 7956 *---------------------------------------------------------------------- 7957 */ 7958 7959 void 7960 TclDTraceInfo( 7961 Tcl_Obj *info, 7962 const char **args, 7963 int *argsi) 7964 { 7965 static Tcl_Obj *keys[10] = { NULL }; 7966 Tcl_Obj **k = keys, *val; 7967 int i = 0; 7968 7969 if (!*k) { 7970 #define kini(s) TclNewLiteralStringObj(keys[i], s); i++ 7971 kini("cmd"); kini("type"); kini("proc"); kini("file"); 7972 kini("method"); kini("class"); kini("lambda"); kini("object"); 7973 kini("line"); kini("level"); 7974 #undef kini 7975 } 7976 for (i = 0; i < 6; i++) { 7977 Tcl_DictObjGet(NULL, info, *k++, &val); 7978 args[i] = val ? TclGetString(val) : NULL; 7979 } 7980 /* no "proc" -> use "lambda" */ 7981 if (!args[2]) { 7982 Tcl_DictObjGet(NULL, info, *k, &val); 7983 args[2] = val ? TclGetString(val) : NULL; 7984 } 7985 k++; 7986 /* no "class" -> use "object" */ 7987 if (!args[5]) { 7988 Tcl_DictObjGet(NULL, info, *k, &val); 7989 args[5] = val ? TclGetString(val) : NULL; 7990 } 7991 k++; 7992 for (i = 0; i < 2; i++) { 7993 Tcl_DictObjGet(NULL, info, *k++, &val); 7994 if (val) { 7995 TclGetIntFromObj(NULL, val, &argsi[i]); 7996 } else { 7997 argsi[i] = 0; 7998 } 7999 } 8000 } 8001 8002 /* 8003 *---------------------------------------------------------------------- 8004 * 8005 * DTraceCmdReturn -- 8006 * 8007 * NR callback for DTrace command return probes. 8008 * 8009 * Results: 8010 * None. 8011 * 8012 * Side effects: 8013 * None. 8014 * 8015 *---------------------------------------------------------------------- 8016 */ 8017 8018 static int 8019 DTraceCmdReturn( 8020 ClientData data[], 8021 Tcl_Interp *interp, 8022 int result) 8023 { 8024 char *cmdName = TclGetString((Tcl_Obj *) data[0]); 8025 8026 if (TCL_DTRACE_CMD_RETURN_ENABLED()) { 8027 TCL_DTRACE_CMD_RETURN(cmdName, result); 8028 } 8029 if (TCL_DTRACE_CMD_RESULT_ENABLED()) { 8030 Tcl_Obj *r = Tcl_GetObjResult(interp); 8031 8032 TCL_DTRACE_CMD_RESULT(cmdName, result, TclGetString(r), r); 8033 } 8034 return result; 8035 } 8036 8037 TCL_DTRACE_DEBUG_LOG() 8038 8039 #endif /* USE_DTRACE */ 8040 8041 /* 8042 *---------------------------------------------------------------------- 8043 * 8044 * Tcl_NRCallObjProc -- 8045 * 8046 * This function calls an objProc directly while managing things properly 8047 * if it happens to be an NR objProc. It is meant to be used by extenders 8048 * that provide an NR implementation of a command, as this function 8049 * permits a trivial coding of the non-NR objProc. 8050 * 8051 * Results: 8052 * The return value is a standard Tcl completion code such as TCL_OK or 8053 * TCL_ERROR. A result or error message is left in interp's result. 8054 * 8055 * Side effects: 8056 * Depends on the objProc. 8057 * 8058 *---------------------------------------------------------------------- 8059 */ 8060 8061 int 8062 Tcl_NRCallObjProc( 8063 Tcl_Interp *interp, 8064 Tcl_ObjCmdProc *objProc, 8065 ClientData clientData, 8066 int objc, 8067 Tcl_Obj *const objv[]) 8068 { 8069 NRE_callback *rootPtr = TOP_CB(interp); 8070 8071 TclNRAddCallback(interp, Dispatch, objProc, clientData, 8072 INT2PTR(objc), objv); 8073 return TclNRRunCallbacks(interp, TCL_OK, rootPtr); 8074 } 8075 8076 /* 8077 *---------------------------------------------------------------------- 8078 * 8079 * Tcl_NRCreateCommand -- 8080 * 8081 * Define a new NRE-enabled object-based command in a command table. 8082 * 8083 * Results: 8084 * The return value is a token for the command, which can be used in 8085 * future calls to Tcl_GetCommandName. 8086 * 8087 * Side effects: 8088 * If no command named "cmdName" already exists for interp, one is 8089 * created. Otherwise, if a command does exist, then if the object-based 8090 * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand 8091 * was called previously for the same command and just set its 8092 * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old 8093 * command. 8094 * 8095 * In the future, during bytecode evaluation when "cmdName" is seen as 8096 * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based 8097 * Tcl_ObjCmdProc proc will be called. When the command is deleted from 8098 * the table, deleteProc will be called. See the manual entry for details 8099 * on the calling sequence. 8100 * 8101 *---------------------------------------------------------------------- 8102 */ 8103 8104 Tcl_Command 8105 Tcl_NRCreateCommand( 8106 Tcl_Interp *interp, /* Token for command interpreter (returned by 8107 * previous call to Tcl_CreateInterp). */ 8108 const char *cmdName, /* Name of command. If it contains namespace 8109 * qualifiers, the new command is put in the 8110 * specified namespace; otherwise it is put in 8111 * the global namespace. */ 8112 Tcl_ObjCmdProc *proc, /* Object-based function to associate with 8113 * name, provides direct access for direct 8114 * calls. */ 8115 Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with 8116 * name, provides NR implementation */ 8117 ClientData clientData, /* Arbitrary value to pass to object 8118 * function. */ 8119 Tcl_CmdDeleteProc *deleteProc) 8120 /* If not NULL, gives a function to call when 8121 * this command is deleted. */ 8122 { 8123 Command *cmdPtr = (Command *) 8124 Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); 8125 8126 cmdPtr->nreProc = nreProc; 8127 return (Tcl_Command) cmdPtr; 8128 } 8129 8130 /**************************************************************************** 8131 * Stuff for the public api 8132 ****************************************************************************/ 8133 8134 int 8135 Tcl_NREvalObj( 8136 Tcl_Interp *interp, 8137 Tcl_Obj *objPtr, 8138 int flags) 8139 { 8140 return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN); 8141 } 8142 8143 int 8144 Tcl_NREvalObjv( 8145 Tcl_Interp *interp, /* Interpreter in which to evaluate the 8146 * command. Also used for error reporting. */ 8147 int objc, /* Number of words in command. */ 8148 Tcl_Obj *const objv[], /* An array of pointers to objects that are 8149 * the words that make up the command. */ 8150 int flags) /* Collection of OR-ed bits that control the 8151 * evaluation of the script. Only 8152 * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and 8153 * TCL_EVAL_NOERR are currently supported. */ 8154 { 8155 return TclNREvalObjv(interp, objc, objv, flags, NULL); 8156 } 8157 8158 int 8159 Tcl_NRCmdSwap( 8160 Tcl_Interp *interp, 8161 Tcl_Command cmd, 8162 int objc, 8163 Tcl_Obj *const objv[], 8164 int flags) 8165 { 8166 return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, 8167 (Command *) cmd); 8168 } 8169 8170 /***************************************************************************** 8171 * Stuff for tailcalls 8172 ***************************************************************************** 8173 * 8174 * Just to show that IT CAN BE DONE! The precise semantics are not simple, 8175 * require more thought. Possibly need a new Tcl return code to do it right? 8176 * Questions include: 8177 * (1) How is the objc/objv tailcall to be run? My current thinking is that 8178 * it should essentially be 8179 * [tailcall a b c] <=> [uplevel 1 [list a b c]] 8180 * with two caveats 8181 * (a) the current frame is dropped first, after running all pending 8182 * cleanup tasks and saving its namespace 8183 * (b) 'a' is looked up in the returning frame's namespace, but the 8184 * command is run in the context to which we are returning 8185 * Current implementation does this if [tailcall] is called from within 8186 * a proc, errors otherwise. 8187 * (2) Should a tailcall bypass [catch] in the returning frame? Current 8188 * implementation does not (or does it? Changed, test!) - it causes an 8189 * error. 8190 * 8191 * FIXME NRE! 8192 */ 8193 8194 void 8195 TclMarkTailcall( 8196 Tcl_Interp *interp) 8197 { 8198 Interp *iPtr = (Interp *) interp; 8199 8200 if (iPtr->deferredCallbacks == NULL) { 8201 TclNRAddCallback(interp, NRCommand, NULL, NULL, 8202 NULL, NULL); 8203 iPtr->deferredCallbacks = TOP_CB(interp); 8204 } 8205 } 8206 8207 void 8208 TclSkipTailcall( 8209 Tcl_Interp *interp) 8210 { 8211 Interp *iPtr = (Interp *) interp; 8212 8213 TclMarkTailcall(interp); 8214 iPtr->deferredCallbacks->data[1] = INT2PTR(1); 8215 } 8216 8217 void 8218 TclPushTailcallPoint( 8219 Tcl_Interp *interp) 8220 { 8221 TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); 8222 ((Interp *) interp)->numLevels++; 8223 } 8224 8225 void 8226 TclSetTailcall( 8227 Tcl_Interp *interp, 8228 Tcl_Obj *listPtr) 8229 { 8230 /* 8231 * Find the splicing spot: right before the NRCommand of the thing 8232 * being tailcalled. Note that we skip NRCommands marked by a 1 in data[1] 8233 * (used by command redirectors). 8234 */ 8235 8236 NRE_callback *runPtr; 8237 8238 for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { 8239 if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { 8240 break; 8241 } 8242 } 8243 if (!runPtr) { 8244 Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); 8245 } 8246 runPtr->data[1] = listPtr; 8247 } 8248 8249 int 8250 TclNRTailcallObjCmd( 8251 ClientData clientData, 8252 Tcl_Interp *interp, 8253 int objc, 8254 Tcl_Obj *const objv[]) 8255 { 8256 Interp *iPtr = (Interp *) interp; 8257 8258 if (objc < 1) { 8259 Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?"); 8260 return TCL_ERROR; 8261 } 8262 8263 if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { /* or is upleveled */ 8264 Tcl_SetObjResult(interp, Tcl_NewStringObj( 8265 "tailcall can only be called from a proc or lambda", -1)); 8266 Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); 8267 return TCL_ERROR; 8268 } 8269 8270 /* 8271 * Invocation without args just clears a scheduled tailcall; invocation 8272 * with an argument replaces any previously scheduled tailcall. 8273 */ 8274 8275 if (iPtr->varFramePtr->tailcallPtr) { 8276 Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); 8277 iPtr->varFramePtr->tailcallPtr = NULL; 8278 } 8279 8280 /* 8281 * Create the callback to actually evaluate the tailcalled 8282 * command, then set it in the varFrame so that PopCallFrame can use it 8283 * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to 8284 * build the callback. 8285 */ 8286 8287 if (objc > 1) { 8288 Tcl_Obj *listPtr, *nsObjPtr; 8289 Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; 8290 Tcl_Namespace *ns1Ptr; 8291 8292 /* The tailcall data is in a Tcl list: the first element is the 8293 * namespace, the rest the command to be tailcalled. */ 8294 8295 listPtr = Tcl_NewListObj(objc, objv); 8296 8297 nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); 8298 if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) 8299 || (nsPtr != ns1Ptr)) { 8300 Tcl_Panic("Tailcall failed to find the proper namespace"); 8301 } 8302 TclListObjSetElement(interp, listPtr, 0, nsObjPtr); 8303 8304 iPtr->varFramePtr->tailcallPtr = listPtr; 8305 } 8306 return TCL_RETURN; 8307 } 8308 8309 int 8310 TclNRTailcallEval( 8311 ClientData data[], 8312 Tcl_Interp *interp, 8313 int result) 8314 { 8315 Interp *iPtr = (Interp *) interp; 8316 Tcl_Obj *listPtr = data[0], *nsObjPtr; 8317 Tcl_Namespace *nsPtr; 8318 int objc; 8319 Tcl_Obj **objv; 8320 8321 Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); 8322 nsObjPtr = objv[0]; 8323 8324 if (result == TCL_OK) { 8325 result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); 8326 } 8327 8328 if (result != TCL_OK) { 8329 /* 8330 * Tailcall execution was preempted, eg by an intervening catch or by 8331 * a now-gone namespace: cleanup and return. 8332 */ 8333 8334 TailcallCleanup(data, interp, result); 8335 return result; 8336 } 8337 8338 /* 8339 * Perform the tailcall 8340 */ 8341 8342 TclMarkTailcall(interp); 8343 TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL); 8344 iPtr->lookupNsPtr = (Namespace *) nsPtr; 8345 return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); 8346 } 8347 8348 static int 8349 TailcallCleanup( 8350 ClientData data[], 8351 Tcl_Interp *interp, 8352 int result) 8353 { 8354 Tcl_DecrRefCount((Tcl_Obj *) data[0]); 8355 return result; 8356 } 8357 8358 8359 void 8360 Tcl_NRAddCallback( 8361 Tcl_Interp *interp, 8362 Tcl_NRPostProc *postProcPtr, 8363 ClientData data0, 8364 ClientData data1, 8365 ClientData data2, 8366 ClientData data3) 8367 { 8368 if (!(postProcPtr)) { 8369 Tcl_Panic("Adding a callback without an objProc?!"); 8370 } 8371 TclNRAddCallback(interp, postProcPtr, data0, data1, data2, data3); 8372 } 8373 8374 /* 8375 *---------------------------------------------------------------------- 8376 * 8377 * TclNRCoroutineObjCmd -- (and friends) 8378 * 8379 * This object-based function is invoked to process the "coroutine" Tcl 8380 * command. It is heavily based on "apply". 8381 * 8382 * Results: 8383 * A standard Tcl object result value. 8384 * 8385 * Side effects: 8386 * A new procedure gets created. 8387 * 8388 * ** FIRST EXPERIMENTAL IMPLEMENTATION ** 8389 * 8390 * It is fairly amateurish and not up to our standards - mainly in terms of 8391 * error messages and [info] interaction. Just to test the infrastructure in 8392 * teov and tebc. 8393 *---------------------------------------------------------------------- 8394 */ 8395 8396 #define iPtr ((Interp *) interp) 8397 8398 int 8399 TclNRYieldObjCmd( 8400 ClientData clientData, 8401 Tcl_Interp *interp, 8402 int objc, 8403 Tcl_Obj *const objv[]) 8404 { 8405 CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; 8406 8407 if (objc > 2) { 8408 Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?"); 8409 return TCL_ERROR; 8410 } 8411 8412 if (!corPtr) { 8413 Tcl_SetObjResult(interp, Tcl_NewStringObj( 8414 "yield can only be called in a coroutine", -1)); 8415 Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); 8416 return TCL_ERROR; 8417 } 8418 8419 if (objc == 2) { 8420 Tcl_SetObjResult(interp, objv[1]); 8421 } 8422 8423 NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); 8424 TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, 8425 clientData, NULL, NULL); 8426 return TCL_OK; 8427 } 8428 8429 int 8430 TclNRYieldToObjCmd( 8431 ClientData clientData, 8432 Tcl_Interp *interp, 8433 int objc, 8434 Tcl_Obj *const objv[]) 8435 { 8436 CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; 8437 Tcl_Obj *listPtr, *nsObjPtr; 8438 Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp); 8439 8440 if (objc < 2) { 8441 Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); 8442 return TCL_ERROR; 8443 } 8444 8445 if (!corPtr) { 8446 Tcl_SetObjResult(interp, Tcl_NewStringObj( 8447 "yieldto can only be called in a coroutine", -1)); 8448 Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); 8449 return TCL_ERROR; 8450 } 8451 8452 if (((Namespace *) nsPtr)->flags & NS_DYING) { 8453 Tcl_SetObjResult(interp, Tcl_NewStringObj( 8454 "yieldto called in deleted namespace", -1)); 8455 Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", 8456 NULL); 8457 return TCL_ERROR; 8458 } 8459 8460 /* 8461 * Add the tailcall in the caller env, then just yield. 8462 * 8463 * This is essentially code from TclNRTailcallObjCmd 8464 */ 8465 8466 listPtr = Tcl_NewListObj(objc, objv); 8467 nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); 8468 TclListObjSetElement(interp, listPtr, 0, nsObjPtr); 8469 8470 /* 8471 * Add the callback in the caller's env, then instruct TEBC to yield. 8472 */ 8473 8474 iPtr->execEnvPtr = corPtr->callerEEPtr; 8475 TclSetTailcall(interp, listPtr); 8476 iPtr->execEnvPtr = corPtr->eePtr; 8477 8478 return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); 8479 } 8480 8481 static int 8482 RewindCoroutineCallback( 8483 ClientData data[], 8484 Tcl_Interp *interp, 8485 int result) 8486 { 8487 return Tcl_RestoreInterpState(interp, data[0]); 8488 } 8489 8490 static int 8491 RewindCoroutine( 8492 CoroutineData *corPtr, 8493 int result) 8494 { 8495 Tcl_Interp *interp = corPtr->eePtr->interp; 8496 Tcl_InterpState state = Tcl_SaveInterpState(interp, result); 8497 8498 NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); 8499 NRE_ASSERT(corPtr->eePtr != NULL); 8500 NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr); 8501 8502 corPtr->eePtr->rewind = 1; 8503 TclNRAddCallback(interp, RewindCoroutineCallback, state, 8504 NULL, NULL, NULL); 8505 return TclNRInterpCoroutine(corPtr, interp, 0, NULL); 8506 } 8507 8508 static void 8509 DeleteCoroutine( 8510 ClientData clientData) 8511 { 8512 CoroutineData *corPtr = clientData; 8513 Tcl_Interp *interp = corPtr->eePtr->interp; 8514 NRE_callback *rootPtr = TOP_CB(interp); 8515 8516 if (COR_IS_SUSPENDED(corPtr)) { 8517 TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr); 8518 } 8519 } 8520 8521 static int 8522 NRCoroutineCallerCallback( 8523 ClientData data[], 8524 Tcl_Interp *interp, 8525 int result) 8526 { 8527 CoroutineData *corPtr = data[0]; 8528 Command *cmdPtr = corPtr->cmdPtr; 8529 8530 /* 8531 * This is the last callback in the caller execEnv, right before switching 8532 * to the coroutine's 8533 */ 8534 8535 NRE_ASSERT(iPtr->execEnvPtr == corPtr->callerEEPtr); 8536 8537 if (!corPtr->eePtr) { 8538 /* 8539 * The execEnv was wound down but not deleted for our sake. We finish 8540 * the job here. The caller context has already been restored. 8541 */ 8542 8543 NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr); 8544 NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); 8545 NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); 8546 ckfree(corPtr); 8547 return result; 8548 } 8549 8550 NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); 8551 SAVE_CONTEXT(corPtr->running); 8552 RESTORE_CONTEXT(corPtr->caller); 8553 8554 if (cmdPtr->flags & CMD_IS_DELETED) { 8555 /* 8556 * The command was deleted while it was running: wind down the 8557 * execEnv, this will do the complete cleanup. RewindCoroutine will 8558 * restore both the caller's context and interp state. 8559 */ 8560 8561 return RewindCoroutine(corPtr, result); 8562 } 8563 8564 return result; 8565 } 8566 8567 static int 8568 NRCoroutineExitCallback( 8569 ClientData data[], 8570 Tcl_Interp *interp, 8571 int result) 8572 { 8573 CoroutineData *corPtr = data[0]; 8574 Command *cmdPtr = corPtr->cmdPtr; 8575 8576 /* 8577 * This runs at the bottom of the Coroutine's execEnv: it will be executed 8578 * when the coroutine returns or is wound down, but not when it yields. It 8579 * deletes the coroutine and restores the caller's environment. 8580 */ 8581 8582 NRE_ASSERT(interp == corPtr->eePtr->interp); 8583 NRE_ASSERT(TOP_CB(interp) == NULL); 8584 NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); 8585 NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); 8586 NRE_ASSERT((corPtr->callerEEPtr->callbackPtr->procPtr == NRCoroutineCallerCallback)); 8587 8588 cmdPtr->deleteProc = NULL; 8589 Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); 8590 TclCleanupCommandMacro(cmdPtr); 8591 8592 corPtr->eePtr->corPtr = NULL; 8593 TclDeleteExecEnv(corPtr->eePtr); 8594 corPtr->eePtr = NULL; 8595 8596 corPtr->stackLevel = NULL; 8597 8598 /* 8599 * #280. 8600 * Drop the coroutine-owned copy of the lineLABCPtr hashtable for literal 8601 * command arguments in bytecode. 8602 */ 8603 8604 Tcl_DeleteHashTable(corPtr->lineLABCPtr); 8605 ckfree(corPtr->lineLABCPtr); 8606 corPtr->lineLABCPtr = NULL; 8607 8608 RESTORE_CONTEXT(corPtr->caller); 8609 iPtr->execEnvPtr = corPtr->callerEEPtr; 8610 iPtr->numLevels++; 8611 8612 return result; 8613 } 8614 8615 /* 8616 *---------------------------------------------------------------------- 8617 * 8618 * TclNRCoroutineActivateCallback -- 8619 * 8620 * This is the workhorse for coroutines: it implements both yield and 8621 * resume. 8622 * 8623 * It is important that both be implemented in the same callback: the 8624 * detection of the impossibility to suspend due to a busy C-stack relies 8625 * on the precise position of a local variable in the stack. We do not 8626 * want the compiler to play tricks on us, either by moving things around 8627 * or inlining. 8628 * 8629 *---------------------------------------------------------------------- 8630 */ 8631 8632 int 8633 TclNRCoroutineActivateCallback( 8634 ClientData data[], 8635 Tcl_Interp *interp, 8636 int result) 8637 { 8638 CoroutineData *corPtr = data[0]; 8639 int type = PTR2INT(data[1]); 8640 int numLevels, unused; 8641 int *stackLevel = &unused; 8642 8643 if (!corPtr->stackLevel) { 8644 /* 8645 * -- Coroutine is suspended -- 8646 * Push the callback to restore the caller's context on yield or 8647 * return. 8648 */ 8649 8650 TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, 8651 NULL, NULL, NULL); 8652 8653 /* 8654 * Record the stackLevel at which the resume is happening, then swap 8655 * the interp's environment to make it suitable to run this coroutine. 8656 */ 8657 8658 corPtr->stackLevel = stackLevel; 8659 numLevels = corPtr->auxNumLevels; 8660 corPtr->auxNumLevels = iPtr->numLevels; 8661 8662 SAVE_CONTEXT(corPtr->caller); 8663 corPtr->callerEEPtr = iPtr->execEnvPtr; 8664 RESTORE_CONTEXT(corPtr->running); 8665 iPtr->execEnvPtr = corPtr->eePtr; 8666 iPtr->numLevels += numLevels; 8667 } else { 8668 /* 8669 * Coroutine is active: yield 8670 */ 8671 8672 if (corPtr->stackLevel != stackLevel) { 8673 Tcl_SetObjResult(interp, Tcl_NewStringObj( 8674 "cannot yield: C stack busy", -1)); 8675 Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", 8676 NULL); 8677 return TCL_ERROR; 8678 } 8679 8680 if (type == CORO_ACTIVATE_YIELD) { 8681 corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; 8682 } else if (type == CORO_ACTIVATE_YIELDM) { 8683 corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; 8684 } else { 8685 Tcl_Panic("Yield received an option which is not implemented"); 8686 } 8687 8688 corPtr->stackLevel = NULL; 8689 8690 numLevels = iPtr->numLevels; 8691 iPtr->numLevels = corPtr->auxNumLevels; 8692 corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; 8693 8694 iPtr->execEnvPtr = corPtr->callerEEPtr; 8695 } 8696 8697 return TCL_OK; 8698 } 8699 8700 /* 8701 *---------------------------------------------------------------------- 8702 * 8703 * NRCoroInjectObjCmd -- 8704 * 8705 * Implementation of [::tcl::unsupported::inject] command. 8706 * 8707 *---------------------------------------------------------------------- 8708 */ 8709 8710 static int 8711 NRCoroInjectObjCmd( 8712 ClientData clientData, 8713 Tcl_Interp *interp, 8714 int objc, 8715 Tcl_Obj *const objv[]) 8716 { 8717 Command *cmdPtr; 8718 CoroutineData *corPtr; 8719 ExecEnv *savedEEPtr = iPtr->execEnvPtr; 8720 8721 /* 8722 * Usage more or less like tailcall: 8723 * inject coroName cmd ?arg1 arg2 ...? 8724 */ 8725 8726 if (objc < 3) { 8727 Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); 8728 return TCL_ERROR; 8729 } 8730 8731 cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); 8732 if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { 8733 Tcl_SetObjResult(interp, Tcl_NewStringObj( 8734 "can only inject a command into a coroutine", -1)); 8735 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", 8736 TclGetString(objv[1]), NULL); 8737 return TCL_ERROR; 8738 } 8739 8740 corPtr = cmdPtr->objClientData; 8741 if (!COR_IS_SUSPENDED(corPtr)) { 8742 Tcl_SetObjResult(interp, Tcl_NewStringObj( 8743 "can only inject a command into a suspended coroutine", -1)); 8744 Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); 8745 return TCL_ERROR; 8746 } 8747 8748 /* 8749 * Add the callback to the coro's execEnv, so that it is the first thing 8750 * to happen when the coro is resumed. 8751 */ 8752 8753 iPtr->execEnvPtr = corPtr->eePtr; 8754 TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN); 8755 iPtr->execEnvPtr = savedEEPtr; 8756 8757 return TCL_OK; 8758 } 8759 8760 int 8761 TclNRInterpCoroutine( 8762 ClientData clientData, 8763 Tcl_Interp *interp, /* Current interpreter. */ 8764 int objc, /* Number of arguments. */ 8765 Tcl_Obj *const objv[]) /* Argument objects. */ 8766 { 8767 CoroutineData *corPtr = clientData; 8768 8769 if (!COR_IS_SUSPENDED(corPtr)) { 8770 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 8771 "coroutine \"%s\" is already running", 8772 Tcl_GetString(objv[0]))); 8773 Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); 8774 return TCL_ERROR; 8775 } 8776 8777 /* 8778 * Parse all the arguments to work out what to feed as the result of the 8779 * [yield]. TRICKY POINT: objc==0 happens here! It occurs when a coroutine 8780 * is deleted! 8781 */ 8782 8783 switch (corPtr->nargs) { 8784 case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: 8785 if (objc == 2) { 8786 Tcl_SetObjResult(interp, objv[1]); 8787 } else if (objc > 2) { 8788 Tcl_WrongNumArgs(interp, 1, objv, "?arg?"); 8789 return TCL_ERROR; 8790 } 8791 break; 8792 default: 8793 if (corPtr->nargs != objc-1) { 8794 Tcl_SetObjResult(interp, 8795 Tcl_NewStringObj("wrong coro nargs; how did we get here? " 8796 "not implemented!", -1)); 8797 Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); 8798 return TCL_ERROR; 8799 } 8800 /* fallthrough */ 8801 case COROUTINE_ARGUMENTS_ARBITRARY: 8802 if (objc > 1) { 8803 Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, objv+1)); 8804 } 8805 break; 8806 } 8807 8808 TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, 8809 NULL, NULL, NULL); 8810 return TCL_OK; 8811 } 8812 8813 /* 8814 *---------------------------------------------------------------------- 8815 * 8816 * TclNRCoroutineObjCmd -- 8817 * 8818 * Implementation of [coroutine] command; see documentation for 8819 * description of what this does. 8820 * 8821 *---------------------------------------------------------------------- 8822 */ 8823 8824 int 8825 TclNRCoroutineObjCmd( 8826 ClientData dummy, /* Not used. */ 8827 Tcl_Interp *interp, /* Current interpreter. */ 8828 int objc, /* Number of arguments. */ 8829 Tcl_Obj *const objv[]) /* Argument objects. */ 8830 { 8831 Command *cmdPtr; 8832 CoroutineData *corPtr; 8833 const char *fullName, *procName; 8834 Namespace *nsPtr, *altNsPtr, *cxtNsPtr; 8835 Tcl_DString ds; 8836 Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; 8837 8838 if (objc < 3) { 8839 Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?"); 8840 return TCL_ERROR; 8841 } 8842 8843 /* 8844 * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have 8845 * something in tclUtil.c to find the FQ name. 8846 */ 8847 8848 fullName = TclGetString(objv[1]); 8849 TclGetNamespaceForQualName(interp, fullName, NULL, 0, 8850 &nsPtr, &altNsPtr, &cxtNsPtr, &procName); 8851 8852 if (nsPtr == NULL) { 8853 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 8854 "can't create procedure \"%s\": unknown namespace", 8855 fullName)); 8856 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); 8857 return TCL_ERROR; 8858 } 8859 if (procName == NULL) { 8860 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 8861 "can't create procedure \"%s\": bad procedure name", 8862 fullName)); 8863 Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); 8864 return TCL_ERROR; 8865 } 8866 if ((nsPtr != iPtr->globalNsPtr) 8867 && (procName != NULL) && (procName[0] == ':')) { 8868 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 8869 "can't create procedure \"%s\" in non-global namespace with" 8870 " name starting with \":\"", procName)); 8871 Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); 8872 return TCL_ERROR; 8873 } 8874 8875 /* 8876 * We ARE creating the coroutine command: allocate the corresponding 8877 * struct and create the corresponding command. 8878 */ 8879 8880 corPtr = ckalloc(sizeof(CoroutineData)); 8881 8882 Tcl_DStringInit(&ds); 8883 if (nsPtr != iPtr->globalNsPtr) { 8884 Tcl_DStringAppend(&ds, nsPtr->fullName, -1); 8885 TclDStringAppendLiteral(&ds, "::"); 8886 } 8887 Tcl_DStringAppend(&ds, procName, -1); 8888 8889 cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), 8890 /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); 8891 Tcl_DStringFree(&ds); 8892 8893 corPtr->cmdPtr = cmdPtr; 8894 cmdPtr->refCount++; 8895 8896 /* 8897 * #280. 8898 * Provide the new coroutine with its own copy of the lineLABCPtr 8899 * hashtable for literal command arguments in bytecode. Note that that 8900 * CFWordBC chains are not duplicated, only the entrypoints to them. This 8901 * means that in the presence of coroutines each chain is potentially a 8902 * tree. Like the chain -> tree conversion of the CmdFrame stack. 8903 */ 8904 8905 { 8906 Tcl_HashSearch hSearch; 8907 Tcl_HashEntry *hePtr; 8908 8909 corPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable)); 8910 Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); 8911 8912 for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch); 8913 hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) { 8914 int isNew; 8915 Tcl_HashEntry *newPtr = 8916 Tcl_CreateHashEntry(corPtr->lineLABCPtr, 8917 Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr), 8918 &isNew); 8919 8920 Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr)); 8921 } 8922 } 8923 8924 /* 8925 * Create the base context. 8926 */ 8927 8928 corPtr->running.framePtr = iPtr->rootFramePtr; 8929 corPtr->running.varFramePtr = iPtr->rootFramePtr; 8930 corPtr->running.cmdFramePtr = NULL; 8931 corPtr->running.lineLABCPtr = corPtr->lineLABCPtr; 8932 corPtr->stackLevel = NULL; 8933 corPtr->auxNumLevels = 0; 8934 8935 /* 8936 * Create the coro's execEnv, switch to it to push the exit and coro 8937 * command callbacks, then switch back. 8938 */ 8939 8940 corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE); 8941 corPtr->callerEEPtr = iPtr->execEnvPtr; 8942 corPtr->eePtr->corPtr = corPtr; 8943 8944 SAVE_CONTEXT(corPtr->caller); 8945 corPtr->callerEEPtr = iPtr->execEnvPtr; 8946 RESTORE_CONTEXT(corPtr->running); 8947 iPtr->execEnvPtr = corPtr->eePtr; 8948 8949 TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, 8950 NULL, NULL, NULL); 8951 8952 /* insure that the command is looked up in the correct namespace */ 8953 iPtr->lookupNsPtr = lookupNsPtr; 8954 Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); 8955 iPtr->numLevels--; 8956 8957 SAVE_CONTEXT(corPtr->running); 8958 RESTORE_CONTEXT(corPtr->caller); 8959 iPtr->execEnvPtr = corPtr->callerEEPtr; 8960 8961 /* 8962 * Now just resume the coroutine. 8963 */ 8964 8965 TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, 8966 NULL, NULL, NULL); 8967 return TCL_OK; 8968 } 8969 8970 /* 8971 * This is used in the [info] ensemble 8972 */ 8973 8974 int 8975 TclInfoCoroutineCmd( 8976 ClientData dummy, 8977 Tcl_Interp *interp, 8978 int objc, 8979 Tcl_Obj *const objv[]) 8980 { 8981 CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; 8982 8983 if (objc != 1) { 8984 Tcl_WrongNumArgs(interp, 1, objv, NULL); 8985 return TCL_ERROR; 8986 } 8987 8988 if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { 8989 Tcl_Obj *namePtr; 8990 8991 TclNewObj(namePtr); 8992 Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, namePtr); 8993 Tcl_SetObjResult(interp, namePtr); 8994 } 8995 return TCL_OK; 8996 } 8997 8998 #undef iPtr 8999 9000 /* 9001 * Local Variables: 9002 * mode: c 9003 * c-basic-offset: 4 9004 * fill-column: 78 9005 * tab-width: 8 9006 * indent-tabs-mode: nil 9007 * End: 9008 */