Check-in [ec51e0603e]
Not logged in
Tcl 2014 Conference, Portland/OR, US, Nov 10-14
Browse the schedule online.

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

Overview
SHA1 Hash:ec51e0603e6e7adfae21ec62645616d24c77490c
Date: 2013-08-21 19:30:01
User: dgp
Comment:[8ff0cb9fe1] Make Tcl_NREvalObj() (and friends) behave as documented, by only scheduling evaluation and not doing any of it until the caller routine returns. This fixes some serious errors in [coroutine] too.
Tags And Properties
Changes

Changes to generic/tclBasic.c

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
...
154
155
156
157
158
159
160

161
162
163
164
165
166
167
....
4228
4229
4230
4231
4232
4233
4234
4235

4236
4237
4238
4239











4240
4241
4242
4243

4244
4245
4246
4247
4248
4249
4250
....
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
static Tcl_ObjCmdProc	ExprWideFunc;
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,
................................................................................
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_ObjCmdProc NRCoroInjectObjCmd;

MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
................................................................................
     * Fix the original callback to point to the now known cmdPtr. Insure that
     * the Command struct lives until the command returns.
     */

    *cmdPtrPtr = cmdPtr;
    cmdPtr->refCount++;

    /*

     * Find the objProc to call: nreProc if available, objProc otherwise. Push
     * a callback to do the actual running.
     */












    if (cmdPtr->nreProc) {
        TclNRAddCallback(interp, NRRunObjProc, cmdPtr,
                INT2PTR(objc), (ClientData) objv, NULL);
        return TCL_OK;

    } else {
	return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
    }
}

int
TclNRRunCallbacks(
................................................................................
    }
    if (result == TCL_OK && TclLimitReady(iPtr->limit)) {
	result = Tcl_LimitCheck(interp);
    }

    return result;
}

static int
NRRunObjProc(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    /* OPT: do not call? */

    Command* cmdPtr = data[0];
    int objc = PTR2INT(data[1]);
    Tcl_Obj **objv = data[2];

    return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv);
}

 
/*
 *----------------------------------------------------------------------
 *
 * TEOV_Exception	 -
 * TEOV_LookupCmdFromObj -
 * TEOV_RunEnterTraces	 -







<







 







>







 







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

<
<
<
>







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







129
130
131
132
133
134
135

136
137
138
139
140
141
142
...
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
....
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
....
4325
4326
4327
4328
4329
4330
4331
















4332
4333
4334
4335
4336
4337
4338
static Tcl_ObjCmdProc	ExprWideFunc;
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_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,
................................................................................
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	Dispatch;

static Tcl_ObjCmdProc NRCoroInjectObjCmd;

MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
................................................................................
     * Fix the original callback to point to the now known cmdPtr. Insure that
     * the Command struct lives until the command returns.
     */

    *cmdPtrPtr = cmdPtr;
    cmdPtr->refCount++;


    TclNRAddCallback(interp, Dispatch, cmdPtr, INT2PTR(objc), objv, NULL);
    return TCL_OK;


}

static int
Dispatch(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Command *cmdPtr = data[0];
    int objc = PTR2INT(data[1]);
    Tcl_Obj **objv = data[2];

    if (cmdPtr->nreProc) {



	return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv);
    } else {
	return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
    }
}

int
TclNRRunCallbacks(
................................................................................
    }
    if (result == TCL_OK && TclLimitReady(iPtr->limit)) {
	result = Tcl_LimitCheck(interp);
    }

    return result;
}
















 
/*
 *----------------------------------------------------------------------
 *
 * TEOV_Exception	 -
 * TEOV_LookupCmdFromObj -
 * TEOV_RunEnterTraces	 -

Changes to generic/tclOOBasic.c

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104

105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
...
127
128
129
130
131
132
133


134
135
136

137
138
139
140
141
142
143
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    Tcl_Obj *invoke[3];

    if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"?definitionScript?");
	return TCL_ERROR;
    } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
	return TCL_OK;
    }

    /*
     * Delegate to [oo::define] to do the work.
     */


    invoke[0] = oPtr->fPtr->defineName;
    invoke[1] = TclOOObjectName(interp, oPtr);
    invoke[2] = objv[objc-1];

    /*
     * Must add references or errors in configuration script will cause
     * trouble.
     */

    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    Tcl_IncrRefCount(invoke[2]);
    TclNRAddCallback(interp, DecrRefsPostClassConstructor,
	    invoke[0], invoke[1], invoke[2], NULL);

    /*
     * Tricky point: do not want the extra reported level in the Tcl stack
     * trace, so use TCL_EVAL_NOERR.
     */

    return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
................................................................................

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


    TclDecrRefCount((Tcl_Obj *) data[0]);
    TclDecrRefCount((Tcl_Obj *) data[1]);
    TclDecrRefCount((Tcl_Obj *) data[2]);

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







|













>













|







 







>
>
|
|
|
>







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
...
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    Tcl_Obj **invoke;

    if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"?definitionScript?");
	return TCL_ERROR;
    } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
	return TCL_OK;
    }

    /*
     * Delegate to [oo::define] to do the work.
     */

    invoke = ckalloc(3 * sizeof(Tcl_Obj *));
    invoke[0] = oPtr->fPtr->defineName;
    invoke[1] = TclOOObjectName(interp, oPtr);
    invoke[2] = objv[objc-1];

    /*
     * Must add references or errors in configuration script will cause
     * trouble.
     */

    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    Tcl_IncrRefCount(invoke[2]);
    TclNRAddCallback(interp, DecrRefsPostClassConstructor,
	    invoke, NULL, NULL, NULL);

    /*
     * Tricky point: do not want the extra reported level in the Tcl stack
     * trace, so use TCL_EVAL_NOERR.
     */

    return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
................................................................................

static int
DecrRefsPostClassConstructor(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj **invoke = data[0];

    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
    TclDecrRefCount(invoke[2]);
    ckfree(invoke);
    return result;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Create --

Changes to tests/coroutine.test

605
606
607
608
609
610
611









612
613
614
615
616
617
618
619
620
621
    set result ""
    coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\
	{a b c d e}
    list $result [info command j1] [info command j2] [info command j3]
} -cleanup {
    catch {rename juggler ""}
} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}









 
# cleanup
unset lambda
::tcltest::cleanupTests

return

# Local Variables:
# mode: tcl
# End:







>
>
>
>
>
>
>
>
>










605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
    set result ""
    coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\
	{a b c d e}
    list $result [info command j1] [info command j2] [info command j3]
} -cleanup {
    catch {rename juggler ""}
} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}

test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
    proc foo {a b} {catch yield; return 1}
} -cleanup {
    rename foo {}
} -body {
    coroutine demo lsort -command foo {a b}
} -result {b a}

 
# cleanup
unset lambda
::tcltest::cleanupTests

return

# Local Variables:
# mode: tcl
# End: