Tcl Source Code

static Tcl_ObjCmdProc	ExprIsqrtFunc;
static Tcl_ObjCmdProc	ExprRandFunc;
static Tcl_ObjCmdProc	ExprRoundFunc;
static Tcl_ObjCmdProc	ExprSqrtFunc;
static Tcl_ObjCmdProc	ExprSrandFunc;
static Tcl_ObjCmdProc	ExprUnaryFunc;
static Tcl_ObjCmdProc	ExprWideFunc;
static Tcl_Obj *	GetCommandSource(Interp *iPtr, int objc,
			    Tcl_Obj *const objv[]);
static void		MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
			    int actual, Tcl_Obj *const *objv);
static Tcl_NRPostProc	NRCoroutineCallerCallback;
static Tcl_NRPostProc	NRCoroutineExitCallback;
static int NRCommand(ClientData data[], Tcl_Interp *interp, int result);

static Tcl_NRPostProc	NRRunObjProc;
static Tcl_ObjCmdProc	OldMathFuncProc;
static void		OldMathFuncDeleteProc(ClientData clientData);
static void		ProcessUnexpectedResult(Tcl_Interp *interp,
			    int returnCode);
static int		RewindCoroutine(CoroutineData *corPtr, int result);
static void		TEOV_SwitchVarFrame(Tcl_Interp *interp);
static void		TEOV_PushExceptionHandlers(Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[], int flags);
static inline Command *	TEOV_LookupCmdFromObj(Tcl_Interp *interp,
			    Tcl_Obj *namePtr, Namespace *lookupNsPtr);
static int		TEOV_NotFound(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[], Namespace *lookupNsPtr);
static int		TEOV_RunEnterTraces(Tcl_Interp *interp,
			    Command **cmdPtrPtr, int objc,
			    Tcl_Obj *const objv[], Namespace *lookupNsPtr);
static Tcl_NRPostProc	RewindCoroutineCallback;
static Tcl_NRPostProc	TailcallCleanup;
static Tcl_NRPostProc	TEOEx_ByteCodeCallback;
static Tcl_NRPostProc	TEOEx_ListCallback;
static Tcl_NRPostProc	TEOV_Error;
static Tcl_NRPostProc	TEOV_Exception;

    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * GetCommandSource --
 *
 *	This function returns a Tcl_Obj with the full source string for the
 *	command. This insures that traces get a correct NUL-terminated command
 *	string. The Tcl_Obj has refCount==1.
 *
 *	*** MAINTAINER WARNING ***
 *	The returned Tcl_Obj is all wrong for any purpose but getting the
 *	source string for an objc/objv command line in the stringRep (no
 *	stringRep if no source is available) and the corresponding substituted
 *	version in the List intrep.
 *	This means that the intRep and stringRep DO NOT COINCIDE! Using these
 *	Tcl_Objs normally is likely to break things.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
GetCommandSource(
    Interp *iPtr,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *objPtr, *obj2Ptr;
    CmdFrame *cfPtr = iPtr->cmdFramePtr;
    const char *command = NULL;
    int numChars;

    objPtr = Tcl_NewListObj(objc, objv);
    if (cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) {
	switch (cfPtr->type) {
	case TCL_LOCATION_EVAL:
	case TCL_LOCATION_SOURCE:
	    command = cfPtr->cmd;
	    numChars = cfPtr->len;
	    break;
	case TCL_LOCATION_BC:
	case TCL_LOCATION_PREBC:
	    command = TclGetSrcInfoForCmd(iPtr, &numChars);
	    break;
	}
	if (command) {
	    obj2Ptr = Tcl_NewStringObj(command, numChars);
	    objPtr->bytes = obj2Ptr->bytes;
	    objPtr->length = numChars;
	    obj2Ptr->bytes = NULL;
	    Tcl_DecrRefCount(obj2Ptr);
	}
    }
    Tcl_IncrRefCount(objPtr);
    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupCommand --
 *
 *	This function frees up a Command structure unless it is still
 *	referenced from an interpreter's command hashtable or from a CmdName
 *	Tcl object representing the name of a command in a ByteCode
 *	instruction sequence.
 *

  commandFound:
    if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
	/*
	 * Call enter traces. They will schedule a call to the leave traces if
	 * necessary.
	 */

	result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr);


	if (!cmdPtr) {
	    return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
	}
	if (result != TCL_OK) {
	    return result;
	}
    }

    return result;
}

static int
TEOV_RunEnterTraces(
    Tcl_Interp *interp,
    Command **cmdPtrPtr,

    int objc,
    Tcl_Obj *const objv[],
    Namespace *lookupNsPtr)
{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr = *cmdPtrPtr;
    int traceCode = TCL_OK;
    int cmdEpoch = cmdPtr->cmdEpoch;
    int newEpoch;
    const char *command;
    int length;
    Tcl_Obj *commandPtr;

    commandPtr = GetCommandSource(iPtr, objc, objv);
    command = Tcl_GetStringFromObj(commandPtr, &length);

    /*
     * Call trace functions.
     * Execute any command or execution traces. Note that we bump up the
     * command's reference count for the duration of the calling of the traces
     * so that the structure doesn't go away underneath our feet.

     */

    if (cmdEpoch != newEpoch) {
	cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
	*cmdPtrPtr = cmdPtr;
    }

    if (cmdPtr) {
	/*
	 * Command was found: push a record to schedule the leave traces.
	 */

	TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode),
		commandPtr, cmdPtr, NULL);
	cmdPtr->refCount++;
    } else {
	Tcl_DecrRefCount(commandPtr);
    }
    return traceCode;
}

static int
TEOV_RunLeaveTraces(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    const char *command;
    int length, objc;
    Tcl_Obj **objv;
    int traceCode = PTR2INT(data[0]);

    Tcl_Obj *commandPtr = data[1];
    Command *cmdPtr = data[2];

    command = Tcl_GetStringFromObj(commandPtr, &length);
    if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) {
	Tcl_Panic("Who messed with commandPtr?");
    }

    if (!(cmdPtr->flags & CMD_IS_DELETED)) {



	if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){
	    traceCode = TclCheckExecutionTraces(interp, command, length,
		    cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
	}
	if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
	    traceCode = TclCheckInterpTraces(interp, command, length,
		    cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
	}

     * For sourced files we always have a path object, even if nothing was
     * specified in the interp itself. That makes code using it simpler as
     * NULL checks can be left out. Sourced file without path in the
     * 'scriptFile' is possible during Tcl initialization.
     */

    eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1;
    eeFramePtr->numLevels = iPtr->numLevels;
    eeFramePtr->framePtr = iPtr->framePtr;
    eeFramePtr->nextPtr = iPtr->cmdFramePtr;
    eeFramePtr->nline = 0;
    eeFramePtr->line = NULL;


    iPtr->cmdFramePtr = eeFramePtr;
    if (iPtr->evalFlags & TCL_EVAL_FILE) {
	/*
	 * Set up for a sourced file.
	 */

		eeFramePtr->len--;
	    }

	    eeFramePtr->nline = objectsUsed;
	    eeFramePtr->line = lines;

	    TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr);
	    code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR);

	    TclArgumentRelease(interp, objv, objectsUsed);

	    eeFramePtr->line = NULL;
	    eeFramePtr->nline = 0;





	    if (code != TCL_OK) {
		goto error;
	    }
	    for (i = 0; i < objectsUsed; i++) {
		Tcl_DecrRefCount(objv[i]);
	    }

	 * TODO: Create a test to demo this need, or eliminate it.
	 * FIXME OPT: preserve just the internal rep?
	 */

	Tcl_IncrRefCount(objPtr);
	listPtr = TclListObjCopy(interp, objPtr);
	Tcl_IncrRefCount(listPtr);
	TclDecrRefCount(objPtr);

	if (word != INT_MIN) {
	    /*
	     * TIP #280 Structures for tracking lines. As we know that this is
	     * dynamic execution we ignore the invoker, even if known.
	     *
	     * TIP #280. We do _not_ compute all the line numbers for the

	    eoFramePtr = TclStackAlloc(interp, sizeof(CmdFrame));
	    eoFramePtr->nline = 0;
	    eoFramePtr->line = NULL;

	    eoFramePtr->type = TCL_LOCATION_EVAL;
	    eoFramePtr->level = (iPtr->cmdFramePtr == NULL?
		    1 : iPtr->cmdFramePtr->level + 1);
	    eoFramePtr->numLevels = iPtr->numLevels;
	    eoFramePtr->framePtr = iPtr->framePtr;
	    eoFramePtr->nextPtr = iPtr->cmdFramePtr;


	    eoFramePtr->cmd = Tcl_GetStringFromObj(listPtr, &(eoFramePtr->len));

	    eoFramePtr->data.eval.path = NULL;

	    iPtr->cmdFramePtr = eoFramePtr;


	}

	TclMarkTailcall(interp);
        TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
		NULL, NULL);

	ListObjGetElements(listPtr, objc, objv);
	return TclNREvalObjv(interp, objc, objv, flags, NULL);
    }

    if (!(flags & TCL_EVAL_DIRECT)) {
	/*

    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *listPtr = data[0];
    CmdFrame *eoFramePtr = data[1];


    /*
     * Remove the cmdFrame
     */

    if (eoFramePtr) {
	iPtr->cmdFramePtr = eoFramePtr->nextPtr;
	TclStackFree(interp, eoFramePtr);
    }

    TclDecrRefCount(listPtr);

    return result;
}

/*
 *----------------------------------------------------------------------

	ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
	if (framePtr->line) {
	    ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
	} else {
	    ADD_PAIR("line", Tcl_NewIntObj(1));
	}
	ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd, framePtr->len));
	break;

    case TCL_LOCATION_PREBC:
	/*
	 * Precompiled. Result contains the type as signal, nothing else.
	 */

	    /*
	     * Death of reference by TclGetSrcInfoForPc.
	     */

	    Tcl_DecrRefCount(fPtr->data.eval.path);
	}

	ADD_PAIR("cmd", Tcl_NewStringObj(fPtr->cmd, fPtr->len));
	TclStackFree(interp, fPtr);
	break;
    }

    case TCL_LOCATION_SOURCE:
	/*
	 * Evaluation of a script file.
	 */

	ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
	ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
	ADD_PAIR("file", framePtr->data.eval.path);

	/*
	 * Refcount framePtr->data.eval.path goes up when lv is converted into
	 * the result list object.
	 */

	ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd, framePtr->len));
	break;

    case TCL_LOCATION_PROC:
	Tcl_Panic("TCL_LOCATION_PROC found in standard frame");
	break;
    }

     * TIP #280: Initialize the frame. Do not push it yet: it will be pushed
     * every time that we call out from this TD, popped when we return to it.
     */

    bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
	    ? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
    bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
    bcFramePtr->numLevels = iPtr->numLevels;
    bcFramePtr->framePtr = iPtr->framePtr;
    bcFramePtr->nextPtr = iPtr->cmdFramePtr;
    bcFramePtr->nline = 0;
    bcFramePtr->line = NULL;
    bcFramePtr->litarg = NULL;
    bcFramePtr->data.tebc.codePtr = codePtr;
    bcFramePtr->data.tebc.pc = NULL;

    bcFramePtr->cmd = NULL;
    bcFramePtr->len = 0;

#ifdef TCL_COMPILE_STATS
    iPtr->stats.numExecutions++;
#endif

#endif

    if (data[1] /* resume from invocation */) {
	if (iPtr->execEnvPtr->rewind) {
	    result = TCL_ERROR;
	}
	NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);





	iPtr->cmdFramePtr = bcFramePtr->nextPtr;
	if (iPtr->flags & INTERP_DEBUG_FRAME) {
	    TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
	}
	if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
	    iPtr->flags |= ERR_ALREADY_LOGGED;
	    codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;

	}

	DECACHE_STACK_INFO();

	pc += pcAdjustment;
	TEBC_YIELD();
	return TclNREvalObjv(interp, objc, objv,
		TCL_EVAL_NOERR, NULL);

#if TCL_SUPPORT_84_BYTECODE
    case INST_CALL_BUILTIN_FUNC1:
	/*
	 * Call one of the built-in pre-8.5 Tcl math functions. This
	 * translates to INST_INVOKE_STK1 with the first argument of
	 * ::tcl::mathfunc::$objv[0]. We need to insert the named math

	    "can't use %s as operand of \"%s\"", description, operator));
    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd --
 *
 *	Given a program counter value, finds the closest command in the
 *	bytecode code unit's CmdLocation array and returns information about
 *	that command's source: a pointer to its first byte and the number of
 *	characters.
 *
 * Results:
 *	If a command is found that encloses the program counter value, a
 *	pointer to the command's source is returned and the length of the
 *	source is stored at *lengthPtr. If multiple commands resulted in code
 *	at pc, information about the closest enclosing command is returned. If
 *	no matching command is found, NULL is returned and *lengthPtr is
 *	unchanged.
 *
 * Side effects:
 *	The CmdFrame at *cfPtr is updated.
 *
 *----------------------------------------------------------------------
 */

const char *
TclGetSrcInfoForCmd(
    Interp *iPtr,
    int *lenPtr)

{




    CmdFrame *cfPtr = iPtr->cmdFramePtr;
    ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;

    return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc,
	    codePtr, lenPtr, NULL, NULL);





}

void
TclGetSrcInfoForPc(
    CmdFrame *cfPtr)
{
    ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;

    assert(cfPtr->type == TCL_LOCATION_BC);

    assert(cfPtr->cmd == NULL);

	cfPtr->cmd = GetSrcInfoForPc(
		(unsigned char *) cfPtr->data.tebc.pc, codePtr,
		&cfPtr->len, NULL, NULL);


    assert(cfPtr->cmd != NULL);
    {
	/*
	 * We now have the command. We can get the srcOffset back and from
	 * there find the list of word locations for this command.
	 */

				 * in. */
	} eval;
	struct {
	    const void *codePtr;/* Byte code currently executed... */
	    const char *pc;	/* ... and instruction pointer. */
	} tebc;
    } data;

    const char *cmd;		/* The executed command, if possible... */
    int len;			/* ... and its length. */
    int numLevels;		/* Value of interp's numLevels when the frame
				 * was pushed. */
    const struct CFWordBC *litarg;
				/* Link to set of literal arguments which have
				 * ben pushed on the lineLABCPtr stack by
				 * TclArgumentBCEnter(). These will be removed
				 * by TclArgumentBCRelease. */
} CmdFrame;

 * EvalFlag bits for Interp structures:
 *
 * TCL_ALLOW_EXCEPTIONS	1 means it's OK for the script to terminate with a
 *			code other than TCL_OK or TCL_ERROR; 0 means codes
 *			other than these should be turned into errors.
 */

#define TCL_ALLOW_EXCEPTIONS	4
#define TCL_EVAL_FILE		2


/*
 * Flag bits for Interp structures:
 *
 * DELETED:		Non-zero means the interpreter has been deleted:
 *			don't process any more commands for it, and destroy
 *			the structure as soon as all nested invocations of

MODULE_SCOPE int	TclGetNumberFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, ClientData *clientDataPtr,
			    int *typePtr);
MODULE_SCOPE int	TclGetOpenModeEx(Tcl_Interp *interp,
			    const char *modeString, int *seekFlagPtr,
			    int *binaryPtr);
MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE const char *TclGetSrcInfoForCmd(Interp *iPtr, int *lenPtr);

MODULE_SCOPE int	TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *unquotedPrefix, int globFlags,
			    Tcl_GlobTypeData *types);
MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);