Tcl Source Code

Changes On Branch tip-383
Login
Bounty program for improvements to Tcl and certain Tcl packages.

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

Changes In Branch tip-383 Excluding Merge-Ins

This is equivalent to a diff from ec114b14ff to de44589e23

2019-05-25
08:06
TIP 383: [coroinject] and [coroprobe] check-in: 7bcb41aa5e user: dkf tags: core-8-branch
08:01
Add to error info when passing an error out of [coroprobe] Closed-Leaf check-in: de44589e23 user: dkf tags: tip-383
2019-05-01
10:44
merge bug-de232b49f2 check-in: f51188e305 user: pooryorick tags: core-8-branch
2019-04-30
07:44
Starting to implement a temporary directory creator. check-in: ca92b413f2 user: dkf tags: tip-431
2019-04-28
16:17
Advanced feature tests check-in: 4d84822cda user: dkf tags: tip-383
2019-04-27
17:56
Implement 383 as two commands for two scenarios: injection and probing check-in: 8aa55737df user: dkf tags: tip-383
2019-04-24
19:29
Track memory lifetimes in the zip mount/unmount. check-in: 8811378a89 user: dgp tags: dgp-wip
14:29
Plug memleak in [lpop] due to mishandling the unconventional recounting practices of TclLsetFlat(). check-in: ec114b14ff user: dgp tags: core-8-branch
04:52
merge bug-67a5eabbd3d1 check-in: 9bcec7cd88 user: pooryorick tags: core-8-branch

Changes to doc/coroutine.n.

10
11
12
13
14
15
16
17
18
19

20



21
22
23
24
25
26
27
..
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
..
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77













































78
79
80
81
82
83
84
...
134
135
136
137
138
139
140
141
142
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
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
coroutine, yield, yieldto \- Create and produce values from coroutines
.SH SYNOPSIS
.nf
\fBcoroutine \fIname command\fR ?\fIarg...\fR?
\fByield\fR ?\fIvalue\fR?
.VS TIP396
\fByieldto\fR \fIcommand\fR ?\fIarg...\fR?
\fIname\fR ?\fIvalue...\fR?

.VE TIP396



.fi
.BE
.SH DESCRIPTION
.PP
The \fBcoroutine\fR command creates a new coroutine context (with associated
command) named \fIname\fR and executes that context by calling \fIcommand\fR,
passing in the other remaining arguments without further interpretation. Once
................................................................................
of the context can then be resumed by calling the context command, optionally
passing in the \fIsingle\fR value to use as the result of the \fByield\fR call
that caused
the context to be suspended. If the coroutine context never yields and instead
returns conventionally, the result of the \fBcoroutine\fR command will be the
result of the evaluation of the context.
.PP
.VS TIP396
The coroutine may also suspend its execution by use of the \fByieldto\fR
command, which instead of returning, cedes execution to some command called
\fIcommand\fR (resolved in the context of the coroutine) and to which \fIany
number\fR of arguments may be passed. Since every coroutine has a context
command, \fByieldto\fR can be used to transfer control directly from one
coroutine to another (this is only advisable if the two coroutines are
expecting this to happen) but \fIany\fR command may be the target. If a
................................................................................
decide what to do with those values.
.PP
The recommended way of writing a version of \fByield\fR that allows resumption
with multiple arguments is by using \fByieldto\fR and the \fBreturn\fR
command, like this:
.PP
.CS
proc yieldm {value} {
    \fByieldto\fR return -level 0 $value
}
.CE
.VE TIP396
.PP
The coroutine can also be deleted by destroying the command \fIname\fR, and
the name of the current coroutine can be retrieved by using
\fBinfo coroutine\fR.
If there are deletion traces on variables in the coroutine's
implementation, they will fire at the point when the coroutine is explicitly
deleted (or, naturally, if the command returns conventionally).
.PP
At the point when \fIcommand\fR is called, the current namespace will be the
global namespace and there will be no stack frames above it (in the sense of
\fBupvar\fR and \fBuplevel\fR). However, which command to call will be
determined in the namespace that the \fBcoroutine\fR command was called from.













































.SH EXAMPLES
.PP
This example shows a coroutine that will produce an infinite sequence of
even values, and a loop that consumes the first ten of them.
.PP
.CS
proc allNumbers {} {
................................................................................
    }
}} allNumbers
for {set i 1} {$i <= 20} {incr i} {
    puts "prime#$i = [\fIeratosthenes\fR]"
}
.CE
.PP
.VS TIP396
This example shows how a value can be passed around a group of three
coroutines that yield to each other:
.PP
.CS
proc juggler {name target {value ""}} {
    if {$value eq ""} {
        set value [\fByield\fR [info coroutine]]
    }
    while {$value ne ""} {
        puts "$name : $value"
        set value [string range $value 0 end-1]
        lassign [\fByieldto\fR $target $value] value
    }
}
\fBcoroutine\fR j1 juggler Larry [
    \fBcoroutine\fR j2 juggler Curly [
        \fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!"
.CE
.VE TIP396











































.SS "DETAILED SEMANTICS"
.PP
This example demonstrates that coroutines start from the global namespace, and
that \fIcommand\fR resolution happens before the coroutine stack is created.
.PP
.CS
proc report {where level} {






<


>
|
>
>
>







 







<







 







|
|


<












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







 







<











|






|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







10
11
12
13
14
15
16

17
18
19
20
21
22
23
24
25
26
27
28
29
30
..
38
39
40
41
42
43
44

45
46
47
48
49
50
51
..
56
57
58
59
60
61
62
63
64
65
66

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
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
127
128
129
130
...
180
181
182
183
184
185
186

187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
coroutine, yield, yieldto \- Create and produce values from coroutines
.SH SYNOPSIS
.nf
\fBcoroutine \fIname command\fR ?\fIarg...\fR?
\fByield\fR ?\fIvalue\fR?

\fByieldto\fR \fIcommand\fR ?\fIarg...\fR?
\fIname\fR ?\fIvalue...\fR?
.sp
.VS "8.7, TIP383"
\fBcoroinject \fIcoroName command\fR ?\fIarg...\fR?
\fBcoroprobe \fIcoroName command\fR ?\fIarg...\fR?
.VE "8.7, TIP383"
.fi
.BE
.SH DESCRIPTION
.PP
The \fBcoroutine\fR command creates a new coroutine context (with associated
command) named \fIname\fR and executes that context by calling \fIcommand\fR,
passing in the other remaining arguments without further interpretation. Once
................................................................................
of the context can then be resumed by calling the context command, optionally
passing in the \fIsingle\fR value to use as the result of the \fByield\fR call
that caused
the context to be suspended. If the coroutine context never yields and instead
returns conventionally, the result of the \fBcoroutine\fR command will be the
result of the evaluation of the context.
.PP

The coroutine may also suspend its execution by use of the \fByieldto\fR
command, which instead of returning, cedes execution to some command called
\fIcommand\fR (resolved in the context of the coroutine) and to which \fIany
number\fR of arguments may be passed. Since every coroutine has a context
command, \fByieldto\fR can be used to transfer control directly from one
coroutine to another (this is only advisable if the two coroutines are
expecting this to happen) but \fIany\fR command may be the target. If a
................................................................................
decide what to do with those values.
.PP
The recommended way of writing a version of \fByield\fR that allows resumption
with multiple arguments is by using \fByieldto\fR and the \fBreturn\fR
command, like this:
.PP
.CS
proc yieldMultiple {value} {
    tailcall \fByieldto\fR string cat $value
}
.CE

.PP
The coroutine can also be deleted by destroying the command \fIname\fR, and
the name of the current coroutine can be retrieved by using
\fBinfo coroutine\fR.
If there are deletion traces on variables in the coroutine's
implementation, they will fire at the point when the coroutine is explicitly
deleted (or, naturally, if the command returns conventionally).
.PP
At the point when \fIcommand\fR is called, the current namespace will be the
global namespace and there will be no stack frames above it (in the sense of
\fBupvar\fR and \fBuplevel\fR). However, which command to call will be
determined in the namespace that the \fBcoroutine\fR command was called from.
.PP
.VS "8.7, TIP383"
A suspended coroutine (i.e., one that has \fByield\fRed or \fByieldto\fR-d)
may have its state inspected (or modified) at that point by using
\fBcoroprobe\fR to run a command at the point where the coroutine is at. The
command takes the name of the coroutine to run the command in, \fIcoroName\fR,
and the name of a command (any any arguments it requires) to immediately run
at that point. The result of that command is the result of the \fBcoroprobe\fR
command, and the gross state of the coroutine remains the same afterwards
(i.e., the coroutine is still expecting the results of a \fByield\fR or
\fByieldto\fR as before) though variables may have been changed.
.PP
Similarly, the \fBcoroinject\fR command may be used to place a command to be
run inside a suspended coroutine (when it is resumed) to process arguments,
with quite a bit of similarity to \fBcoroprobe\fR. However, with
\fBcoroinject\fR there are several key differences:
.VE "8.7, TIP383"
.IP \(bu
.VS "8.7, TIP383"
The coroutine is not immediately resumed after the injection has been done.  A
consequence of this is that multiple injections may be done before the
coroutine is resumed. There injected commands are performed in \fIreverse
order of definition\fR (that is, they are internally stored on a stack).
.VE "8.7, TIP383"
.IP \(bu
.VS "8.7, TIP383"
An additional two arguments are appended to the list of arguments to be run
(that is, the \fIcommand\fR and its \fIargs\fR are extended by two elements).
The first is the name of the command that suspended the coroutine (\fByield\fR
or \fByieldto\fR), and the second is the argument (or list of arguments, in
the case of \fByieldto\fR) that is the current resumption value.
.VE "8.7, TIP383"
.IP \(bu
.VS "8.7, TIP383"
The result of the injected command is used as the result of the \fByield\fR or
\fByieldto\fR that caused the coroutine to become suspended. Where there are
multiple injected commands, the result of one becomes the resumption value
processed by the next.
.PP
The injection is a one-off. It is not retained once it has been executed. It
may \fByield\fR or \fByieldto\fR as part of its execution.
.PP
Note that running coroutines may be neither probed nor injected; the
operations may only be applied to 
.VE "8.7, TIP383"
.SH EXAMPLES
.PP
This example shows a coroutine that will produce an infinite sequence of
even values, and a loop that consumes the first ten of them.
.PP
.CS
proc allNumbers {} {
................................................................................
    }
}} allNumbers
for {set i 1} {$i <= 20} {incr i} {
    puts "prime#$i = [\fIeratosthenes\fR]"
}
.CE
.PP

This example shows how a value can be passed around a group of three
coroutines that yield to each other:
.PP
.CS
proc juggler {name target {value ""}} {
    if {$value eq ""} {
        set value [\fByield\fR [info coroutine]]
    }
    while {$value ne ""} {
        puts "$name : $value"
        set value [string range $value 0 end-1]
        lassign [\fByieldto\fR \fI$target\fR $value] value
    }
}
\fBcoroutine\fR j1 juggler Larry [
    \fBcoroutine\fR j2 juggler Curly [
        \fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!"
.CE
.PP
.VS "8.7, TIP383"
This example shows a simple coroutine that collects non-empty values and
returns a list of them when not given an argument. It also shows how we can
look inside the coroutine to find out what it is doing, and how we can modify
the input on a one-off basis.
.PP
.CS
proc collectorImpl {} {
    set me [info coroutine]
    set accumulator {}
    for {set val [\fByield\fR $me]} {$val ne ""} {set val [\fByield\fR]} {
        lappend accumulator $val
    }
    return $accumulator
}

\fBcoroutine\fR collect collectorImpl
\fIcollect\fR 123
\fIcollect\fR "abc def"
\fIcollect\fR 456

puts [\fBcoroprobe \fIcollect\fR set accumulator]
# ==> 123 {abc def} 456

\fIcollect\fR "pqr"

\fBcoroinject \fIcollect\fR apply {{type value} {
    puts "Received '$value' at a $type in [info coroutine]"
    return [string toupper $value]
}}

\fIcollect\fR rst
# ==> Received 'rst' at a yield in ::collect
\fIcollect\fR xyz

puts [\fIcollect\fR]
# ==> 123 {abc def} 456 pqr RST xyz
.CE
.PP
This example shows a simple coroutine that collects non-empty values and
returns a list of them when not given an argument. It also shows how we can
look inside the coroutine to find out what it is doing.
.VE "8.7, TIP383"
.SS "DETAILED SEMANTICS"
.PP
This example demonstrates that coroutines start from the global namespace, and
that \fIcommand\fR resolution happens before the coroutine stack is created.
.PP
.CS
proc report {where level} {

Changes to generic/tclBasic.c.

167
168
169
170
171
172
173
174
175





176
177
178
179
180
181
182
...
238
239
240
241
242
243
244


245
246
247
248
249
250
251
...
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
....
9182
9183
9184
9185
9186
9187
9188





























9189







9190































































































































































































































9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222

9223
9224
9225
9226
9227
9228
9229
9230
9231
9232
9233
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].
 */
................................................................................
    {"break",		Tcl_BreakObjCmd,	TclCompileBreakCmd,	NULL,	CMD_IS_SAFE},
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
    {"case",		Tcl_CaseObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
#endif
    {"catch",		Tcl_CatchObjCmd,	TclCompileCatchCmd,	TclNRCatchObjCmd,	CMD_IS_SAFE},
    {"concat",		Tcl_ConcatObjCmd,	TclCompileConcatCmd,	NULL,	CMD_IS_SAFE},
    {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	NULL,	CMD_IS_SAFE},


    {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	CMD_IS_SAFE},
    {"error",		Tcl_ErrorObjCmd,	TclCompileErrorCmd,	NULL,	CMD_IS_SAFE},
    {"eval",		Tcl_EvalObjCmd,		NULL,			TclNREvalObjCmd,	CMD_IS_SAFE},
    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	CMD_IS_SAFE},
    {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	CMD_IS_SAFE},
    {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	CMD_IS_SAFE},
    {"format",		Tcl_FormatObjCmd,	TclCompileFormatCmd,	NULL,	CMD_IS_SAFE},
................................................................................
    /* Adding the bytecode assembler command */
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

    Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
	    NRCoroInjectObjCmd, NULL, NULL);

    /* Export unsupported commands */
    nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
    if (nsPtr) {
	Tcl_Export(interp, nsPtr, "*", 1);
    }

................................................................................
    TclListObjGetElements(NULL, listPtr, &objc, &objv);
    return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
 
/*
 *----------------------------------------------------------------------
 *





























 * NRCoroInjectObjCmd --







 *































































































































































































































 *      Implementation of [::tcl::unsupported::inject] command.
 *
 *----------------------------------------------------------------------
 */

static int
NRCoroInjectObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Command *cmdPtr;
    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;

    /*
     * Usage more or less like tailcall:
     *   inject coroName cmd ?arg1 arg2 ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
	return TCL_ERROR;
    }

    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only inject a command into a coroutine", -1));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
                TclGetString(objv[1]), NULL);

        return TCL_ERROR;
    }

    corPtr = cmdPtr->objClientData;
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only inject a command into a suspended coroutine", -1));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
        return TCL_ERROR;
    }







|

>
>
>
>
>







 







>
>







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|





<













|
<
<
|
<
<
>


<
<







167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
...
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
...
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
....
9189
9190
9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222
9223
9224
9225
9226
9227
9228
9229
9230
9231
9232
9233
9234
9235
9236
9237
9238
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
9260
9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
9272
9273
9274
9275
9276
9277
9278
9279
9280
9281
9282
9283
9284
9285
9286
9287
9288
9289
9290
9291
9292
9293
9294
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
9310
9311
9312
9313
9314
9315
9316
9317
9318
9319
9320
9321
9322
9323
9324
9325
9326
9327
9328
9329
9330
9331
9332
9333
9334
9335
9336
9337
9338
9339
9340
9341
9342
9343
9344
9345
9346
9347
9348
9349
9350
9351
9352
9353
9354
9355
9356
9357
9358
9359
9360
9361
9362
9363
9364
9365
9366
9367
9368
9369
9370
9371
9372
9373
9374
9375
9376
9377
9378
9379
9380
9381
9382
9383
9384
9385
9386
9387
9388
9389
9390
9391
9392
9393
9394
9395
9396
9397
9398
9399
9400
9401
9402
9403
9404
9405
9406
9407
9408
9409
9410
9411
9412
9413
9414
9415
9416
9417
9418
9419
9420
9421
9422
9423
9424
9425
9426
9427
9428
9429
9430
9431
9432
9433
9434
9435
9436
9437
9438
9439
9440
9441
9442
9443
9444
9445
9446
9447
9448
9449
9450
9451
9452
9453
9454
9455
9456
9457
9458
9459
9460
9461
9462
9463
9464
9465
9466
9467
9468

9469
9470
9471
9472
9473
9474
9475
9476
9477
9478
9479
9480
9481
9482


9483


9484
9485
9486


9487
9488
9489
9490
9491
9492
9493
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 NRInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;

static Tcl_ObjCmdProc TclNRCoroInjectObjCmd;
static Tcl_ObjCmdProc TclNRCoroProbeObjCmd;
static Tcl_NRPostProc InjectHandler;
static Tcl_NRPostProc InjectHandlerPostCall;

MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
 */
................................................................................
    {"break",		Tcl_BreakObjCmd,	TclCompileBreakCmd,	NULL,	CMD_IS_SAFE},
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
    {"case",		Tcl_CaseObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
#endif
    {"catch",		Tcl_CatchObjCmd,	TclCompileCatchCmd,	TclNRCatchObjCmd,	CMD_IS_SAFE},
    {"concat",		Tcl_ConcatObjCmd,	TclCompileConcatCmd,	NULL,	CMD_IS_SAFE},
    {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	NULL,	CMD_IS_SAFE},
    {"coroinject",	NULL,			NULL,                   TclNRCoroInjectObjCmd,	CMD_IS_SAFE},
    {"coroprobe",	NULL,			NULL,                   TclNRCoroProbeObjCmd,	CMD_IS_SAFE},
    {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	CMD_IS_SAFE},
    {"error",		Tcl_ErrorObjCmd,	TclCompileErrorCmd,	NULL,	CMD_IS_SAFE},
    {"eval",		Tcl_EvalObjCmd,		NULL,			TclNREvalObjCmd,	CMD_IS_SAFE},
    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	CMD_IS_SAFE},
    {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	CMD_IS_SAFE},
    {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	CMD_IS_SAFE},
    {"format",		Tcl_FormatObjCmd,	TclCompileFormatCmd,	NULL,	CMD_IS_SAFE},
................................................................................
    /* Adding the bytecode assembler command */
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

    Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
	    NRInjectObjCmd, NULL, NULL);

    /* Export unsupported commands */
    nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
    if (nsPtr) {
	Tcl_Export(interp, nsPtr, "*", 1);
    }

................................................................................
    TclListObjGetElements(NULL, listPtr, &objc, &objv);
    return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd --
 *
 *      Implementation of [coroinject] and [coroprobe] commands.
 *
 *----------------------------------------------------------------------
 */

static inline CoroutineData *
GetCoroutineFromObj(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    const char *errMsg)
{
    /*
     * How to get a coroutine from its handle.
     */

    Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);

    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
                TclGetString(objPtr), NULL);
        return NULL;
    }
    return cmdPtr->objClientData;
}

static int
TclNRCoroInjectObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;

    /*
     * Usage more or less like tailcall:
     *   coroinject coroName cmd ?arg1 arg2 ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
	return TCL_ERROR;
    }

    corPtr = GetCoroutineFromObj(interp, objv[1],
            "can only inject a command into a coroutine");
    if (!corPtr) {
        return TCL_ERROR;
    }
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only inject a command into a suspended coroutine", -1));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
        return TCL_ERROR;
    }

    /*
     * Add the callback to the coro's execEnv, so that it is the first thing
     * to happen when the coro is resumed.
     */

    iPtr->execEnvPtr = corPtr->eePtr;
    TclNRAddCallback(interp, InjectHandler, corPtr,
            Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL);
    iPtr->execEnvPtr = savedEEPtr;

    return TCL_OK;
}

static int
TclNRCoroProbeObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;
    int numLevels, unused;
    int *stackLevel = &unused;

    /*
     * Usage more or less like tailcall:
     *   coroprobe coroName cmd ?arg1 arg2 ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
	return TCL_ERROR;
    }

    corPtr = GetCoroutineFromObj(interp, objv[1],
            "can only inject a probe command into a coroutine");
    if (!corPtr) {
        return TCL_ERROR;
    }
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only inject a probe command into a suspended coroutine",
                -1));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
        return TCL_ERROR;
    }

    /*
     * Add the callback to the coro's execEnv, so that it is the first thing
     * to happen when the coro is resumed.
     */

    iPtr->execEnvPtr = corPtr->eePtr;
    TclNRAddCallback(interp, InjectHandler, corPtr,
            Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr);
    iPtr->execEnvPtr = savedEEPtr;

    /*
     * Now we immediately transfer control to the coroutine to run our probe.
     * TRICKY STUFF copied from the [yield] implementation.
     *
     * Push the callback to restore the caller's context on yield back.
     */

    TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr,
            NULL, NULL, NULL);

    /*
     * Record the stackLevel at which the resume is happening, then swap
     * the interp's environment to make it suitable to run this coroutine.
     */

    corPtr->stackLevel = stackLevel;
    numLevels = corPtr->auxNumLevels;
    corPtr->auxNumLevels = iPtr->numLevels;

    /*
     * Do the actual stack swap.
     */

    SAVE_CONTEXT(corPtr->caller);
    corPtr->callerEEPtr = iPtr->execEnvPtr;
    RESTORE_CONTEXT(corPtr->running);
    iPtr->execEnvPtr = corPtr->eePtr;
    iPtr->numLevels += numLevels;
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * InjectHandler, InjectHandlerPostProc --
 *
 *      Part of the implementation of [coroinject] and [coroprobe]. These are
 *      run inside the context of the coroutine being injected/probed into.
 *
 *      InjectHandler runs a script (possibly adding arguments) in the context
 *      of the coroutine. The script is specified as a one-shot list (with
 *      reference count equal to 1) in data[1]. This function also arranges
 *      for InjectHandlerPostProc to be the part that runs after the script
 *      completes.
 *
 *      InjectHandlerPostProc cleans up after InjectHandler (deleting the
 *      list) and, for the [coroprobe] command *only*, yields back to the
 *      caller context (i.e., where [coroprobe] was run).
 *s
 *----------------------------------------------------------------------
 */

static int
InjectHandler(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CoroutineData *corPtr = data[0];
    Tcl_Obj *listPtr = data[1];
    int nargs = PTR2INT(data[2]);
    ClientData isProbe = data[3];
    int objc;
    Tcl_Obj **objv;

    if (!isProbe) {
        /*
         * If this is [coroinject], add the extra arguments now.
         */

        if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) {
            Tcl_ListObjAppendElement(NULL, listPtr,
                    Tcl_NewStringObj("yield", -1));
        } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) {
            Tcl_ListObjAppendElement(NULL, listPtr,
                    Tcl_NewStringObj("yieldto", -1));
        } else {
            /*
             * I don't think this is reachable...
             */

            Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs));
        }
        Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp));
    }

    /*
     * Call the user's script; we're in the right place.
     */

    Tcl_IncrRefCount(listPtr);
    TclMarkTailcall(interp);
    TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr,
            INT2PTR(nargs), isProbe);
    TclListObjGetElements(NULL, listPtr, &objc, &objv);
    return TclNREvalObjv(interp, objc, objv, 0, NULL);
}

static int
InjectHandlerPostCall(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CoroutineData *corPtr = data[0];
    Tcl_Obj *listPtr = data[1];
    int nargs = PTR2INT(data[2]);
    ClientData isProbe = data[3];
    int numLevels;

    /*
     * Delete the command words for what we just executed.
     */

    Tcl_DecrRefCount(listPtr);

    /*
     * If we were doing a probe, splice ourselves back out of the stack
     * cleanly here. General injection should instead just look after itself.
     *
     * Code from guts of [yield] implementation.
     */

    if (isProbe) {
        if (result == TCL_ERROR) {
            Tcl_AddErrorInfo(interp,
                    "\n    (injected coroutine probe command)");
        }
        corPtr->nargs = nargs;
        corPtr->stackLevel = NULL;
        numLevels = iPtr->numLevels;
        iPtr->numLevels = corPtr->auxNumLevels;
        corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
        iPtr->execEnvPtr = corPtr->callerEEPtr;
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NRInjectObjCmd --
 *
 *      Implementation of [::tcl::unsupported::inject] command.
 *
 *----------------------------------------------------------------------
 */

static int
NRInjectObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{

    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;

    /*
     * Usage more or less like tailcall:
     *   inject coroName cmd ?arg1 arg2 ...?
     */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
	return TCL_ERROR;
    }

    corPtr = GetCoroutineFromObj(interp, objv[1],


            "can only inject a command into a coroutine");


    if (!corPtr) {
        return TCL_ERROR;
    }


    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only inject a command into a suspended coroutine", -1));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
        return TCL_ERROR;
    }

Changes to tests/coroutine.test.

788
789
790
791
792
793
794
795

















































































































































796
797
798
799
800
801
802
803
804
    }
    slave eval demo
    set result [slave eval {set ::result}]

    interp delete slave
    set result
} -result {inject-executed}
 

















































































































































# cleanup
unset lambda
::tcltest::cleanupTests

return

# Local Variables:
# mode: tcl
# End:






|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
    }
    slave eval demo
    set result [slave eval {set ::result}]

    interp delete slave
    set result
} -result {inject-executed}

test coroutine-9.1 {coroprobe with yield} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo]
} -cleanup {
    catch {rename demo {}}
} -result {1 {} 2 {}}
test coroutine-9.2 {coroprobe with yieldto} -body {
    coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }}
    list [coroprobe demo set i] [demo a b] [coroprobe demo set i] [demo c d]
} -cleanup {
    catch {rename demo {}}
} -result {1 {} 2 {{a b} {c d}}}
test coroutine-9.3 {coroprobe errors} -setup {
    catch {rename demo {}}
} -body {
    coroprobe demo set i
} -returnCodes error -result {can only inject a probe command into a coroutine}
test coroutine-9.4 {coroprobe errors} -body {
    proc demo {} { foreach i {1 2} yield }
    coroprobe demo set i
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {can only inject a probe command into a coroutine}
test coroutine-9.5 {coroprobe errors} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroprobe
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"}
test coroutine-9.6 {coroprobe errors} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroprobe demo
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"}
test coroutine-9.7 {coroprobe errors in probe command} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroprobe demo set
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {wrong # args: should be "set varName ?newValue?"}
test coroutine-9.8 {coroprobe errors in probe command} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    list [catch {coroprobe demo set}] [demo] [coroprobe demo set i]
} -cleanup {
    catch {rename demo {}}
} -result {1 {} 2}
test coroutine-9.9 {coroprobe: advanced features} -setup {
    set i [interp create]
} -body {
    $i eval {
	coroutine demo apply {{} {
	    set f [info level],[info frame]
	    foreach i {1 2} yield
	}}
	coroprobe demo apply {{} {
	    upvar 1 f f
	    list [info coroutine] [info level] [info frame] $f
	}}
    }
} -cleanup {
    interp delete $i
} -result {::demo 2 3 1,2}

test coroutine-10.1 {coroinject with yield} -setup {
    set result {}
} -body {
    coroutine demo apply {{} { lmap i {1 2} yield }}
    coroinject demo apply {{op val} {lappend ::result $op $val}}
    list $result [demo x] [demo y] $result
} -cleanup {
    catch {rename demo {}}
} -result {{} {} {{yield x} y} {yield x}}
test coroutine-10.2 {coroinject stacking} -setup {
    set result {}
} -body {
    coroutine demo apply {{} { lmap i {1 2} yield }}
    coroinject demo apply {{op val} {lappend ::result $op $val A;return $val}}
    coroinject demo apply {{op val} {lappend ::result $op $val B;return $val}}
    list $result [demo x] [demo y] $result
} -cleanup {
    catch {rename demo {}}
} -result {{} {} {x y} {yield x B yield x A}}
test coroutine-10.3 {coroinject with yieldto} -setup {
    set result {}
} -body {
    coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }}
    coroinject demo apply {{op val} {lappend ::result $op $val;return $val}}
    list $result [demo x mp] [demo y le] $result
} -cleanup {
    catch {rename demo {}}
} -result {{} {} {{x mp} {y le}} {yieldto {x mp}}}
test coroutine-10.4 {coroinject errors} -setup {
    catch {rename demo {}}
} -body {
    coroinject demo set i
} -returnCodes error -result {can only inject a command into a coroutine}
test coroutine-10.5 {coroinject errors} -body {
    proc demo {} { foreach i {1 2} yield }
    coroinject demo set i
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {can only inject a command into a coroutine}
test coroutine-10.6 {coroinject errors} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroinject
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"}
test coroutine-10.7 {coroinject errors} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroinject demo
} -returnCodes error -cleanup {
    catch {rename demo {}}
} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"}
test coroutine-10.8 {coroinject errors in injected command} -body {
    coroutine demo apply {{} { foreach i {1 2} yield }}
    coroinject demo apply {args {error "ERR: $args"}}
    list [catch demo msg] $msg [catch demo msg] $msg
} -cleanup {
    catch {rename demo {}}
} -result {1 {ERR: yield {}} 1 {invalid command name "demo"}}
test coroutine-10.9 {coroinject: advanced features} -setup {
    set i [interp create]
} -body {
    $i eval {
	coroutine demo apply {{} {
	    set l [info level]
	    set f [info frame]
	    lmap i {1 2} yield
	}}
	coroinject demo apply {{arg op val} {
	    global result
	    upvar 1 f f l l
	    lappend result [info coroutine] $arg $op $val
	    lappend result [info level] $l [info frame] $f
	    lappend result [yield $arg]
	    return [string toupper $val]
	}} grill
	list [demo ABC] [demo pqr] [demo def] $result
    }
} -cleanup {
    interp delete $i
} -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}}
 
# cleanup
unset lambda
::tcltest::cleanupTests

return

# Local Variables:
# mode: tcl
# End: