Tcl Source Code

Check-in [1e66a5c9c0]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:[2486550] NR-enable same-interp invokehidden. Also, reroute all objProc invocation through the common routines of EvalObjvCore and Dispatch.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 1e66a5c9c0a33acecef484b1abce539bc51f99ca
User & Date: dgp 2013-08-29 19:19:32
Context
2013-08-30
21:57
Bump to tcltest 2.3.6 to account for changes since Tcl 8.6.0 release. check-in: 1fde5f0db3 user: dgp tags: trunk
2013-08-29
19:22
merge trunk check-in: 9d9256cf4a user: dgp tags: dgp-refactor
19:19
[2486550] NR-enable same-interp invokehidden. Also, reroute all objProc invocation through the comm... check-in: 1e66a5c9c0 user: dgp tags: trunk
17:59
New internal eval flag value so that all TclNREvalObjv() callers that pre-resolve command names can ... Closed-Leaf check-in: 9394415ab9 user: dgp tags: bug-2502002
2013-08-24
09:42
Unbreak doc; the apropos index entry *must* be one line. (This is an external constraint forced by ... check-in: 608930382f user: dkf tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclBasic.c.

143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
			    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, Tcl_Obj *commandPtr, 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;
static Tcl_NRPostProc	TEOV_NotFoundCallback;
static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	EvalObjvCore;
static Tcl_NRPostProc	Dispatch;

static Tcl_ObjCmdProc NRCoroInjectObjCmd;


MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
 */







|













>







143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
			    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, Tcl_Obj *commandPtr, int objc,
			    Tcl_Obj *const objv[]);
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;
static Tcl_NRPostProc	TEOV_NotFoundCallback;
static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	EvalObjvCore;
static Tcl_NRPostProc	Dispatch;

static Tcl_ObjCmdProc NRCoroInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;

MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
 */
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127

4128









4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149

4150
4151
4152
4153
4154
4155
4156
4157







4158
4159
4160
4161

4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175



4176


4177
4178
4179
4180



















4181
4182
4183
4184
4185
4186


4187
4188




4189

4190


4191
4192
4193

4194





4195
4196
4197
4198
4199
4200

4201
4202







4203





4204





4205



4206
4207
4208
4209
4210
4211
4212

static int
EvalObjvCore(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Command *cmdPtr = data[0];
    int flags = PTR2INT(data[1]);
    int objc = PTR2INT(data[2]);
    Tcl_Obj **objv = data[3];
    Interp *iPtr = (Interp *) interp;
    Namespace *lookupNsPtr = iPtr->lookupNsPtr;

    









    if (TCL_OK != TclInterpReady(interp)) {
	return TCL_ERROR;
    }

    if (objc == 0) {
	return TCL_OK;
    }

    if (TclLimitExceeded(iPtr->limit)) {
	return TCL_ERROR;
    }

    iPtr->lookupNsPtr = NULL;

    if (cmdPtr) {
	goto commandFound;
    }

    /*
     * Push records for task to be done on return, in INVERSE order. First, if
     * needed, the exception handlers (as they should happen last).

     */

    if (!(flags & TCL_EVAL_NOERR)) {
	TEOV_PushExceptionHandlers(interp, objc, objv, flags);
    }

    /*
     * Configure evaluation context to match the requested flags.







     */

    if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) {
	if (!lookupNsPtr) {

	    lookupNsPtr = iPtr->globalNsPtr;
	}
    } else {
	if (flags & TCL_EVAL_GLOBAL) {
	    TEOV_SwitchVarFrame(interp);
	    lookupNsPtr = iPtr->globalNsPtr;
	}

	/*
	 * TCL_EVAL_INVOKE was not set: clear rewrite rules
	 */

	iPtr->ensembleRewrite.sourceObjs = NULL;
    }






    /*
     * Lookup the command
     */




















    cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
    if (!cmdPtr) {
	return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
    }

    /*


     * Found a command! The real work begins now ...
     */






  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, TclGetSourceFromFrame(
		flags & TCL_EVAL_SOURCE_IN_FRAME ?  iPtr->cmdFramePtr : NULL,
		objc, objv), objc, objv, lookupNsPtr);
	if (result != TCL_OK) {

	    return result;
	}







	if (!cmdPtr) {





	    return TEOV_NotFound(interp, objc, objv, lookupNsPtr);





	}



    }

    TclNRAddCallback(interp, Dispatch,
	    cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc,
	    cmdPtr->objClientData, INT2PTR(objc), objv);
    return TCL_OK;
}







|




|
>

>
>
>
>
>
>
>
>
>












<
<
<
<
<
<

<
<
>


|
<
|
<
|
<
>
>
>
>
>
>
>
|

|
|
>
|
<

<
<
<
<






|
>
>
>
|
>
>

|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
>
>
|
<
>
>
>
>

>
|
>
>
|
|
<
>
|
>
>
>
>
>
|

<
<
<
|
>
|
|
>
>
>
>
>
>
>
|
>
>
>
>
>
|
>
>
>
>
>
|
>
>
>







4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151






4152


4153
4154
4155
4156

4157

4158

4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171

4172




4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217

4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228

4229
4230
4231
4232
4233
4234
4235
4236
4237



4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271

static int
EvalObjvCore(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Command *cmdPtr = NULL, *preCmdPtr = data[0];
    int flags = PTR2INT(data[1]);
    int objc = PTR2INT(data[2]);
    Tcl_Obj **objv = data[3];
    Interp *iPtr = (Interp *) interp;
    Namespace *lookupNsPtr = NULL;
    int enterTracesDone = 0;
    
    /*
     * Push records for task to be done on return, in INVERSE order. First, if
     * needed, the exception handlers (as they should happen last).
     */

    if (!(flags & TCL_EVAL_NOERR)) {
	TEOV_PushExceptionHandlers(interp, objc, objv, flags);
    }

    if (TCL_OK != TclInterpReady(interp)) {
	return TCL_ERROR;
    }

    if (objc == 0) {
	return TCL_OK;
    }

    if (TclLimitExceeded(iPtr->limit)) {
	return TCL_ERROR;
    }







    /*


     * Configure evaluation context to match the requested flags.
     */

    if (iPtr->lookupNsPtr) {



	/*

	 * Capture the namespace we should do command name resolution in, as
	 * instructed by our caller sneaking it in to us in a private interp
	 * field.  Clear that field right away so we cannot possibly have its
	 * use leak where it should not.  The sneaky message pass is done.
	 *
	 * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag.
	 * TODO: Is that a bug?
	 */

	lookupNsPtr = iPtr->lookupNsPtr;
	iPtr->lookupNsPtr = NULL;
    } else if (flags & TCL_EVAL_INVOKE) {
	lookupNsPtr = iPtr->globalNsPtr;

    } else {





	/*
	 * TCL_EVAL_INVOKE was not set: clear rewrite rules
	 */

	iPtr->ensembleRewrite.sourceObjs = NULL;

	if (flags & TCL_EVAL_GLOBAL) {
	    TEOV_SwitchVarFrame(interp);
	    lookupNsPtr = iPtr->globalNsPtr;
	}
    }

    /*
     * Lookup the Command to dispatch.
     */

    reresolve:
    assert(cmdPtr == NULL);
    if (preCmdPtr) {
	/* Caller gave it to us */
	if (!(preCmdPtr->flags & CMD_IS_DELETED)) {
	    /* So long as it exists, use it. */
	    cmdPtr = preCmdPtr;
	} else if (flags & TCL_EVAL_NORESOLVE) {
	    /*
	     * When it's been deleted, and we're told not to attempt
	     * resolving it ourselves, all we can do is raise an error.
	     */
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "attempt to invoke a deleted command"));
	    Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
	    return TCL_ERROR;
	}
    }
    if (cmdPtr == NULL) {
	cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
	if (!cmdPtr) {
	    return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
	}
    }

    if (enterTracesDone || iPtr->tracePtr
	    || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {


	Tcl_Obj *commandPtr = TclGetSourceFromFrame(
		flags & TCL_EVAL_SOURCE_IN_FRAME ?  iPtr->cmdFramePtr : NULL,
		objc, objv);
	Tcl_IncrRefCount(commandPtr);

	if (!enterTracesDone) {

	    int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
		    objc, objv);

	    /*

	     * Send any exception from enter traces back as an exception
	     * raised by the traced command.
	     * TODO: Is this a bug?  Letting an execution trace BREAK or
	     * CONTINUE or RETURN in the place of the traced command?
	     * Would either converting all exceptions to TCL_ERROR, or
	     * just swallowing them be better?  (Swallowing them has the
	     * problem of permanently hiding program errors.)
	     */




	    if (code != TCL_OK) {
		Tcl_DecrRefCount(commandPtr);
		return code;
	    }

	    /*
	     * If the enter traces made the resolved cmdPtr unusable, go
	     * back and resolve again, but next time don't run enter
	     * traces again.
	     */

	    if (cmdPtr == NULL) {
		enterTracesDone = 1;
		Tcl_DecrRefCount(commandPtr);
		goto reresolve;
	    }
	}

	/* 
	 * Schedule leave traces.  Raise the refCount on the resolved
	 * cmdPtr, so that when it passes to the leave traces we know
	 * it's still valid.
	 */

	cmdPtr->refCount++;
	TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc),
		    commandPtr, cmdPtr, objv);
    }

    TclNRAddCallback(interp, Dispatch,
	    cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc,
	    cmdPtr->objClientData, INT2PTR(objc), objv);
    return TCL_OK;
}
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657

static int
TEOV_RunEnterTraces(
    Tcl_Interp *interp,
    Command **cmdPtrPtr,
    Tcl_Obj *commandPtr,
    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_IncrRefCount(commandPtr);
    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.
     */

    cmdPtr->refCount++;
    if (iPtr->tracePtr) {
	traceCode = TclCheckInterpTraces(interp, command, length,
		cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv);
    }
    if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
	traceCode = TclCheckExecutionTraces(interp, command, length,
		cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv);
    }
    newEpoch = cmdPtr->cmdEpoch;
    TclCleanupCommandMacro(cmdPtr);

    /*
     * If the traces modified/deleted the command or any existing traces, they
     * will update the command's epoch. We need to lookup again, but do not
     * run enter traces on the newly found cmdPtr.
     */

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

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

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

static int
TEOV_RunLeaveTraces(
    ClientData data[],
    Tcl_Interp *interp,
    int result)







|
<



<
|
<
<
|
<
<
|




|
|














<
|
<
|
<
|

<
|

<
<
<
<
<
<
<
<
<
<
<
<
|







4647
4648
4649
4650
4651
4652
4653
4654

4655
4656
4657

4658


4659


4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680

4681

4682

4683
4684

4685
4686












4687
4688
4689
4690
4691
4692
4693
4694

static int
TEOV_RunEnterTraces(
    Tcl_Interp *interp,
    Command **cmdPtrPtr,
    Tcl_Obj *commandPtr,
    int objc,
    Tcl_Obj *const objv[])

{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr = *cmdPtrPtr;

    int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;


    int length, traceCode = TCL_OK;


    const char *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.
     */

    cmdPtr->refCount++;
    if (iPtr->tracePtr) {
	traceCode = TclCheckInterpTraces(interp, command, length,
		cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv);
    }
    if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
	traceCode = TclCheckExecutionTraces(interp, command, length,
		cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv);
    }
    newEpoch = cmdPtr->cmdEpoch;
    TclCleanupCommandMacro(cmdPtr);


    if (traceCode != TCL_OK) {

	return traceCode;

    }
    if (cmdEpoch != newEpoch) {

	*cmdPtrPtr = NULL;
    }












    return TCL_OK;
}

static int
TEOV_RunLeaveTraces(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr;
    Namespace *savedNsPtr = iPtr->varFramePtr->nsPtr;

    if (lookupNsPtr) {
	iPtr->varFramePtr->nsPtr = lookupNsPtr;
	iPtr->lookupNsPtr = NULL;
    }
    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr);
    iPtr->varFramePtr->nsPtr = savedNsPtr;
    return cmdPtr;
}

/*







<







4738
4739
4740
4741
4742
4743
4744

4745
4746
4747
4748
4749
4750
4751
{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr;
    Namespace *savedNsPtr = iPtr->varFramePtr->nsPtr;

    if (lookupNsPtr) {
	iPtr->varFramePtr->nsPtr = lookupNsPtr;

    }
    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr);
    iPtr->varFramePtr->nsPtr = savedNsPtr;
    return cmdPtr;
}

/*
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482

6483
6484
6485
6486












6487
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
6501




6502
6503


6504
6505
6506
6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521

6522
6523
6524
6525
6526
6527
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
    int objc,			/* Count of arguments. */
    Tcl_Obj *const objv[],	/* Argument objects; objv[0] points to the
				 * name of the command to invoke. */
    int flags)			/* Combination of flags controlling the call:
				 * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN,
				 * or TCL_INVOKE_NO_TRACEBACK. */
{
    register Interp *iPtr = (Interp *) interp;
    Tcl_HashTable *hTblPtr;	/* Table of hidden commands. */
    const char *cmdName;	/* Name of the command from objv[0]. */
    Tcl_HashEntry *hPtr = NULL;
    Command *cmdPtr;
    int result;

    if (interp == NULL) {
	return TCL_ERROR;
    }

    if ((objc < 1) || (objv == NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "illegal argument vector", -1));
	return TCL_ERROR;
    }

    if ((flags & TCL_INVOKE_HIDDEN) == 0) {
	Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
    }


    if (TclInterpReady(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }













    cmdName = TclGetString(objv[0]);
    hTblPtr = iPtr->hiddenCmdTablePtr;
    if (hTblPtr != NULL) {
	hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
    }
    if (hPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "invalid hidden command name \"%s\"", cmdName));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
                NULL);
	return TCL_ERROR;
    }
    cmdPtr = Tcl_GetHashValue(hPtr);





    /*
     * Invoke the command function.


     */

    iPtr->cmdCount++;
    if (cmdPtr->objProc != NULL) {
	result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
    } else {
	result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc,
		cmdPtr->objClientData, objc, objv);
    }

    /*
     * If an error occurred, record information about what was being executed
     * when the error occurred.
     */

    if ((result == TCL_ERROR)
	    && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
	    && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {

	int length;
	Tcl_Obj *command = Tcl_NewListObj(objc, objv);
	const char *cmdString;

	Tcl_IncrRefCount(command);
	cmdString = Tcl_GetStringFromObj(command, &length);
	Tcl_LogCommandInfo(interp, cmdString, cmdString, length);
	Tcl_DecrRefCount(command);
	iPtr->flags &= ~ERR_ALREADY_LOGGED;
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ExprString --







<
<
<
<
<
<
<



<





<



>
|
<
<
|
>
>
>
>
>
>
>
>
>
>
>
>















>
>
>
>

|
>
>


<
<
|
<
<
<
|

<
|
|
<
|
<
<
<
>
|
<
<
|
<
<
|
<
|
<







6492
6493
6494
6495
6496
6497
6498







6499
6500
6501

6502
6503
6504
6505
6506

6507
6508
6509
6510
6511


6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
6523
6524
6525
6526
6527
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
6546
6547
6548
6549


6550



6551
6552

6553
6554

6555



6556
6557


6558


6559

6560

6561
6562
6563
6564
6565
6566
6567
    int objc,			/* Count of arguments. */
    Tcl_Obj *const objv[],	/* Argument objects; objv[0] points to the
				 * name of the command to invoke. */
    int flags)			/* Combination of flags controlling the call:
				 * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN,
				 * or TCL_INVOKE_NO_TRACEBACK. */
{







    if (interp == NULL) {
	return TCL_ERROR;
    }

    if ((objc < 1) || (objv == NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "illegal argument vector", -1));
	return TCL_ERROR;
    }

    if ((flags & TCL_INVOKE_HIDDEN) == 0) {
	Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
    }
    return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}



int
TclNRInvoke(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    register Interp *iPtr = (Interp *) interp;
    Tcl_HashTable *hTblPtr;	/* Table of hidden commands. */
    const char *cmdName;	/* Name of the command from objv[0]. */
    Tcl_HashEntry *hPtr = NULL;
    Command *cmdPtr;

    cmdName = TclGetString(objv[0]);
    hTblPtr = iPtr->hiddenCmdTablePtr;
    if (hTblPtr != NULL) {
	hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
    }
    if (hPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "invalid hidden command name \"%s\"", cmdName));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
                NULL);
	return TCL_ERROR;
    }
    cmdPtr = Tcl_GetHashValue(hPtr);

    /* Avoid the exception-handling brain damage when numLevels == 0 . */
    iPtr->numLevels++;
    Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);

    /*
     * Normal command resolution of objv[0] isn't going to find cmdPtr.
     * That's the whole point of **hidden** commands.  So tell the
     * Eval core machinery not to even try (and risk finding something wrong).
     */



    return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);



}


static int
NRPostInvoke(

    ClientData clientData[],



    Tcl_Interp *interp,
    int result)


{


    Interp *iPtr = (Interp *)interp;

    iPtr->numLevels--;

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ExprString --
8072
8073
8074
8075
8076
8077
8078
8079

8080
8081
8082
8083
8084
8085
8086
Tcl_NRCmdSwap(
    Tcl_Interp *interp,
    Tcl_Command cmd,
    int objc,
    Tcl_Obj *const objv[],
    int flags)
{
    return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd);

}

/*****************************************************************************
 * Stuff for tailcalls
 *****************************************************************************
 *
 * Just to show that IT CAN BE DONE! The precise semantics are not simple,







|
>







8101
8102
8103
8104
8105
8106
8107
8108
8109
8110
8111
8112
8113
8114
8115
8116
Tcl_NRCmdSwap(
    Tcl_Interp *interp,
    Tcl_Command cmd,
    int objc,
    Tcl_Obj *const objv[],
    int flags)
{
    return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR,
	    (Command *) cmd);
}

/*****************************************************************************
 * Stuff for tailcalls
 *****************************************************************************
 *
 * Just to show that IT CAN BE DONE! The precise semantics are not simple,

Changes to generic/tclInt.h.

2197
2198
2199
2200
2201
2202
2203

2204
2205
2206
2207
2208
2209
2210
 *			code other than TCL_OK or TCL_ERROR; 0 means codes
 *			other than these should be turned into errors.
 */

#define TCL_ALLOW_EXCEPTIONS		0x04
#define TCL_EVAL_FILE			0x02
#define TCL_EVAL_SOURCE_IN_FRAME	0x10


/*
 * 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







>







2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
 *			code other than TCL_OK or TCL_ERROR; 0 means codes
 *			other than these should be turned into errors.
 */

#define TCL_ALLOW_EXCEPTIONS		0x04
#define TCL_EVAL_FILE			0x02
#define TCL_EVAL_SOURCE_IN_FRAME	0x10
#define TCL_EVAL_NORESOLVE		0x20

/*
 * 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
2721
2722
2723
2724
2725
2726
2727

2728
2729
2730
2731
2732
2733
2734
MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback;
MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;


MODULE_SCOPE void  TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
MODULE_SCOPE void  TclPushTailcallPoint(Tcl_Interp *interp);

/* These two can be considered for the public api */
MODULE_SCOPE void  TclMarkTailcall(Tcl_Interp *interp);
MODULE_SCOPE void  TclSkipTailcall(Tcl_Interp *interp);







>







2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback;
MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke;

MODULE_SCOPE void  TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
MODULE_SCOPE void  TclPushTailcallPoint(Tcl_Interp *interp);

/* These two can be considered for the public api */
MODULE_SCOPE void  TclMarkTailcall(Tcl_Interp *interp);
MODULE_SCOPE void  TclSkipTailcall(Tcl_Interp *interp);

Changes to generic/tclInterp.c.

275
276
277
278
279
280
281






282
283
284
285
286
287
288
			    Tcl_Interp *targetInterp, Tcl_Obj *scriptObj);
static void		CallScriptLimitCallback(ClientData clientData,
			    Tcl_Interp *interp);
static void		DeleteScriptLimitCallback(ClientData clientData);
static void		RunLimitHandlers(LimitHandler *handlerPtr,
			    Tcl_Interp *interp);
static void		TimeLimitCallback(ClientData clientData);







/*
 *----------------------------------------------------------------------
 *
 * TclSetPreInitScript --
 *
 *	This routine is used to change the value of the internal variable,







>
>
>
>
>
>







275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
			    Tcl_Interp *targetInterp, Tcl_Obj *scriptObj);
static void		CallScriptLimitCallback(ClientData clientData,
			    Tcl_Interp *interp);
static void		DeleteScriptLimitCallback(ClientData clientData);
static void		RunLimitHandlers(LimitHandler *handlerPtr,
			    Tcl_Interp *interp);
static void		TimeLimitCallback(ClientData clientData);

/* NRE enabling */
static Tcl_NRPostProc	NRPostInvokeHidden;
static Tcl_ObjCmdProc	NRInterpCmd;
static Tcl_ObjCmdProc	NRSlaveCmd;


/*
 *----------------------------------------------------------------------
 *
 * TclSetPreInitScript --
 *
 *	This routine is used to change the value of the internal variable,
477
478
479
480
481
482
483
484

485
486
487
488
489
490
491
    slavePtr = &interpInfoPtr->slave;
    slavePtr->masterInterp	= NULL;
    slavePtr->slaveEntryPtr	= NULL;
    slavePtr->slaveInterp	= interp;
    slavePtr->interpCmd		= NULL;
    Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);

    Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL);


    Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------







|
>







483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
    slavePtr = &interpInfoPtr->slave;
    slavePtr->masterInterp	= NULL;
    slavePtr->slaveEntryPtr	= NULL;
    slavePtr->slaveInterp	= interp;
    slavePtr->interpCmd		= NULL;
    Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);

    Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd,
	    NULL, NULL);

    Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
581
582
583
584
585
586
587










588
589
590
591
592
593
594
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
int
Tcl_InterpObjCmd(










    ClientData clientData,		/* Unused. */
    Tcl_Interp *interp,			/* Current interpreter. */
    int objc,				/* Number of arguments. */
    Tcl_Obj *const objv[])		/* Argument objects. */
{
    Tcl_Interp *slaveInterp;
    int index;







>
>
>
>
>
>
>
>
>
>







588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
int
Tcl_InterpObjCmd(
    ClientData clientData,		/* Unused. */
    Tcl_Interp *interp,			/* Current interpreter. */
    int objc,				/* Number of arguments. */
    Tcl_Obj *const objv[])		/* Argument objects. */
{
    return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv);
}

static int
NRInterpCmd(
    ClientData clientData,		/* Unused. */
    Tcl_Interp *interp,			/* Current interpreter. */
    int objc,				/* Number of arguments. */
    Tcl_Obj *const objv[])		/* Argument objects. */
{
    Tcl_Interp *slaveInterp;
    int index;
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
    }

    slaveInterp = Tcl_CreateInterp();
    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    slavePtr->masterInterp = masterInterp;
    slavePtr->slaveEntryPtr = hPtr;
    slavePtr->slaveInterp = slaveInterp;
    slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
	    SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc);
    Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
    Tcl_SetHashValue(hPtr, slavePtr);
    Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);

    /*
     * Inherit the recursion limit.
     */







|
|







2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
    }

    slaveInterp = Tcl_CreateInterp();
    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    slavePtr->masterInterp = masterInterp;
    slavePtr->slaveEntryPtr = hPtr;
    slavePtr->slaveInterp = slaveInterp;
    slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path,
	    SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
    Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
    Tcl_SetHashValue(hPtr, slavePtr);
    Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);

    /*
     * Inherit the recursion limit.
     */
2453
2454
2455
2456
2457
2458
2459










2460
2461
2462
2463
2464
2465
2466
 *	See user documentation for details.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveObjCmd(










    ClientData clientData,	/* Slave interpreter. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Interp *slaveInterp = clientData;
    int index;







>
>
>
>
>
>
>
>
>
>







2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
 *	See user documentation for details.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveObjCmd(
    ClientData clientData,	/* Slave interpreter. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv);
}

static int
NRSlaveCmd(
    ClientData clientData,	/* Slave interpreter. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Interp *slaveInterp = clientData;
    int index;
3048
3049
3050
3051
3052
3053
3054




3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070

















3071
3072
3073
3074
3075
3076
3077
	return TCL_ERROR;
    }

    Tcl_Preserve(slaveInterp);
    Tcl_AllowExceptions(slaveInterp);

    if (namespaceName == NULL) {




	result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
    } else {
	Namespace *nsPtr, *dummy1, *dummy2;
	const char *tail;

	result = TclGetNamespaceForQualName(slaveInterp, namespaceName, NULL,
		TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG
		| TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
	if (result == TCL_OK) {
	    result = TclObjInvokeNamespace(slaveInterp, objc, objv,
		    (Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN);
	}
    }

    Tcl_TransferResult(slaveInterp, result, interp);


















    Tcl_Release(slaveInterp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *







>
>
>
>
|















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
	return TCL_ERROR;
    }

    Tcl_Preserve(slaveInterp);
    Tcl_AllowExceptions(slaveInterp);

    if (namespaceName == NULL) {
	NRE_callback *rootPtr = TOP_CB(slaveInterp);

	Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp,
		rootPtr, NULL, NULL);
	return TclNRInvoke(NULL, slaveInterp, objc, objv);
    } else {
	Namespace *nsPtr, *dummy1, *dummy2;
	const char *tail;

	result = TclGetNamespaceForQualName(slaveInterp, namespaceName, NULL,
		TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG
		| TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
	if (result == TCL_OK) {
	    result = TclObjInvokeNamespace(slaveInterp, objc, objv,
		    (Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN);
	}
    }

    Tcl_TransferResult(slaveInterp, result, interp);

    Tcl_Release(slaveInterp);
    return result;
}

static int
NRPostInvokeHidden(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0];
    NRE_callback *rootPtr = (NRE_callback *)data[1];

    if (interp != slaveInterp) {
	result = TclNRRunCallbacks(slaveInterp, result, rootPtr);
	Tcl_TransferResult(slaveInterp, result, interp);
    }
    Tcl_Release(slaveInterp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *

Changes to generic/tclNamesp.c.

1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    ImportedCmdData *dataPtr = clientData;
    Command *realCmdPtr = dataPtr->realCmdPtr;

    TclSkipTailcall(interp);
    return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
}

static int
InvokeImportedCmd(
    ClientData clientData,	/* Points to the imported command's
				 * ImportedCmdData structure. */
    Tcl_Interp *interp,		/* Current interpreter. */







|







1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    ImportedCmdData *dataPtr = clientData;
    Command *realCmdPtr = dataPtr->realCmdPtr;

    TclSkipTailcall(interp);
    return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
}

static int
InvokeImportedCmd(
    ClientData clientData,	/* Points to the imported command's
				 * ImportedCmdData structure. */
    Tcl_Interp *interp,		/* Current interpreter. */

Changes to generic/tclOOMethod.c.

1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431

    Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
    argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
	    numPrefixes, prefixObjs, &len);
    Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
    ((Interp *)interp)->lookupNsPtr
	    = (Namespace *) contextPtr->oPtr->namespacePtr;
    return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, NULL);
}

static int
FinalizeForwardCall(
    ClientData data[],
    Tcl_Interp *interp,
    int result)







|







1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431

    Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
    argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
	    numPrefixes, prefixObjs, &len);
    Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
    ((Interp *)interp)->lookupNsPtr
	    = (Namespace *) contextPtr->oPtr->namespacePtr;
    return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL);
}

static int
FinalizeForwardCall(
    ClientData data[],
    Tcl_Interp *interp,
    int result)

Changes to tests/coroutine.test.

628
629
630
631
632
633
634









635
636
637
638
639
640
641

test coroutine-7.6 {Early yield crashes} {
    proc foo args {}
    trace add execution foo enter {catch yield}
    coroutine demo foo
    rename foo {}
} {}











# cleanup
unset lambda
::tcltest::cleanupTests

return







>
>
>
>
>
>
>
>
>







628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650

test coroutine-7.6 {Early yield crashes} {
    proc foo args {}
    trace add execution foo enter {catch yield}
    coroutine demo foo
    rename foo {}
} {}

test coroutine-7.7 {Bug 2486550} -setup {
    interp hide {} yield
} -body {
    coroutine demo interp invokehidden {} yield ok
} -cleanup {
    demo
    interp expose {} yield
} -result ok


# cleanup
unset lambda
::tcltest::cleanupTests

return