Tcl package Thread source code

Check-in [7e95d24385]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:Restore compile-time and runtime checks for TIP #143 and #285; by default, enable at compile-time and check availability at runtime.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | compileTipCheck
Files: files | file ages | folders
SHA1: 7e95d243853e6674e8e8355c0d68e0c54a8fd4c8
User & Date: mistachkin 2012-11-13 20:54:45
Context
2012-11-13
22:45
Restore [9cbfc3b299] bugfix. check-in: 8f5ee5bc0e user: jan.nijtmans tags: compileTipCheck
20:54
Restore compile-time and runtime checks for TIP #143 and #285; by default, enable at compile-time and check availability at runtime. check-in: 7e95d24385 user: mistachkin tags: compileTipCheck
11:00
AOL/Naviserver fix check-in: 7975acc2c4 user: jan.nijtmans tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to configure.in.

179
180
181
182
183
184
185









186
187
188
189
190
191
192
# Everyone should be linking against the Tcl stub library.  If you
# can't for some reason, remove this definition.  If you aren't using
# stubs, you also need to modify the SHLIB_LD_LIBS setting below to
# link against the non-stubbed Tcl library.  Add Tk too if necessary.
#--------------------------------------------------------------------

AC_DEFINE(USE_TCL_STUBS, 1, [Use Tcl stubs])










#--------------------------------------------------------------------
# This macro generates a line to use when building a library.  It
# depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS,
# and TEA_LOAD_TCLCONFIG macros above.
#--------------------------------------------------------------------







>
>
>
>
>
>
>
>
>







179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
# Everyone should be linking against the Tcl stub library.  If you
# can't for some reason, remove this definition.  If you aren't using
# stubs, you also need to modify the SHLIB_LD_LIBS setting below to
# link against the non-stubbed Tcl library.  Add Tk too if necessary.
#--------------------------------------------------------------------

AC_DEFINE(USE_TCL_STUBS, 1, [Use Tcl stubs])

#--------------------------------------------------------------------
# Enable compile-time support for TIP #143 and TIP #285.  When using
# a pre-Tcl 8.5 or 8.6 core, respectively, the actual functionality
# will not be available at runtime.
#--------------------------------------------------------------------

AC_DEFINE(TCL_TIP143, 1, [Enable TIP #143 support])
AC_DEFINE(TCL_TIP285, 1, [Enable TIP #285 support])

#--------------------------------------------------------------------
# This macro generates a line to use when building a library.  It
# depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS,
# and TEA_LOAD_TCLCONFIG macros above.
#--------------------------------------------------------------------

Changes to generic/threadCmd.c.

18
19
20
21
22
23
24
25
26
27
28
29

30













31
32



33
34
35
36
37
38
39
40


41













42
43
44
45
46



47
48
49
50
51
52
53
...
103
104
105
106
107
108
109





110









111
112
113
114
115
116
117
...
350
351
352
353
354
355
356

357
358
359
360
361

362
363
364
365
366
367
368
...
377
378
379
380
381
382
383


384

385
386
387
388
389




390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
...
417
418
419
420
421
422
423
























424



425
426
427
428
429
430
431
....
1442
1443
1444
1445
1446
1447
1448

1449
1450
1451
1452
1453
1454
1455
....
1497
1498
1499
1500
1501
1502
1503

1504
1505
1506
1507
1508
1509
1510
....
2112
2113
2114
2115
2116
2117
2118

2119
2120
2121
2122
2123
2124
2125
....
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171

2172
2173
2174
2175
2176
2177
2178
....
2748
2749
2750
2751
2752
2753
2754


2755













2756
2757
2758
2759
2760
2761
2762
....
2778
2779
2780
2781
2782
2783
2784

2785
2786
2787
2788
2789
2790
2791
....
2796
2797
2798
2799
2800
2801
2802


2803
2804
2805
2806
2807
2808

2809
2810
2811
2812
2813
2814
2815
....
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ----------------------------------------------------------------------------
 */

#include "tclThreadInt.h"

/*
 * Check if this is Tcl 8.5 or higher. In that case, we will have the TIP
 * #143 APIs (i.e. interpreter resource limiting) available.
 */

#define haveInterpLimit (tclVersion>84)

#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 5)













# define Tcl_LimitExceeded ((int (*)(Tcl_Interp *)) \
    ((&(tclStubsPtr->tcl_PkgProvideEx))[524]))



#endif

/*
 * Check if this is Tcl 8.6 or higher.  In that case, we will have the TIP
 * #285 APIs (i.e. asynchronous script cancellation) available.
 */

#define haveInterpCancel (tclVersion>85)


#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)













# define TCL_CANCEL_UNWIND 0x100000
# define Tcl_CancelEval ((int (*)(Tcl_Interp *, Tcl_Obj *, ClientData, int)) \
    ((&(tclStubsPtr->tcl_PkgProvideEx))[580]))
# define Tcl_Canceled ((int (*)(Tcl_Interp *, int)) \
    ((&(tclStubsPtr->tcl_PkgProvideEx))[581]))



#endif

/*
 * Access to the list of threads and to the thread send results
 * (defined below) is guarded by this mutex.
 */

................................................................................

/*
 * Used to represent the empty result.
 */

static char *threadEmptyResult = (char *)"";






static int tclVersion = 0;










/*
 * An instance of the following structure contains all information that is
 * passed into a new thread when the thread is created using either the
 * "thread create" Tcl command or the ThreadCreate() C function.
 */

................................................................................
static void
ErrorNoSuchThread(Tcl_Interp *interp,
                               Tcl_ThreadId thrId);
static void
ThreadCutChannel(Tcl_Interp *interp,
                               Tcl_Channel channel);


static int
ThreadCancel(Tcl_Interp *interp,
                               Tcl_ThreadId thrId,
                               const char *result,
                               int flags);


/*
 * Functions implementing Tcl commands
 */

static Tcl_ObjCmdProc ThreadCreateObjCmd;
static Tcl_ObjCmdProc ThreadReserveObjCmd;
................................................................................
static Tcl_ObjCmdProc ThreadExistsObjCmd;
static Tcl_ObjCmdProc ThreadConfigureObjCmd;
static Tcl_ObjCmdProc ThreadErrorProcObjCmd;
static Tcl_ObjCmdProc ThreadJoinObjCmd;
static Tcl_ObjCmdProc ThreadTransferObjCmd;
static Tcl_ObjCmdProc ThreadDetachObjCmd;
static Tcl_ObjCmdProc ThreadAttachObjCmd;


static Tcl_ObjCmdProc ThreadCancelObjCmd;


static int
ThreadInit(interp)
    Tcl_Interp *interp; /* The current Tcl interpreter */
{




    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
        return TCL_ERROR;
    }

    if (!tclVersion) {

        /*
         * Get the current core version to decide wether to use
         * some lately introduced core features or to back-off.
         */

        int major, minor;
        
        Tcl_GetVersion(&major, &minor, NULL, NULL);
        tclVersion = 10 * major + minor;
    }

    TCL_CMD(interp, THREAD_CMD_PREFIX"create",    ThreadCreateObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"send",      ThreadSendObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"broadcast", ThreadBroadcastObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"exit",      ThreadExitObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"unwind",    ThreadUnwindObjCmd);
................................................................................
    TCL_CMD(interp, THREAD_CMD_PREFIX"errorproc", ThreadErrorProcObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"preserve",  ThreadReserveObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"release",   ThreadReleaseObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"join",      ThreadJoinObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"transfer",  ThreadTransferObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"detach",    ThreadDetachObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"attach",    ThreadAttachObjCmd);
























    TCL_CMD(interp, THREAD_CMD_PREFIX"cancel",    ThreadCancelObjCmd);




    /*
     * Add shared variable commands
     */

    Sv_Init(interp);

................................................................................
            return TCL_ERROR;
        }
    }

    return TCL_OK;
}
 

/*
 *----------------------------------------------------------------------
 *
 * ThreadCancelObjCmd --
 *
 *  This procedure is invoked to process the "thread::cancel" Tcl
 *  command. See the user documentation for details on what it does.
................................................................................
        result = Tcl_GetString(objv[ii]);
    } else {
        result = NULL;
    }

    return ThreadCancel(interp, thrId, result, flags);
}

 
/*
 *----------------------------------------------------------------------
 *
 * ThreadSendEval --
 *
 *  Evaluates Tcl script passed from source to target thread.
................................................................................
            return tsdPtr;
        }
    }

    return NULL;
}
 

/*
 *----------------------------------------------------------------------
 *
 * ThreadCancel --
 *
 *    Cancels a script in another thread.
 *
................................................................................
    Tcl_Interp  *interp;        /* The current interpreter. */
    Tcl_ThreadId thrId;         /* Thread ID of other interpreter. */
    const char *result;         /* The error message or NULL for default. */
    int flags;                  /* Flags for Tcl_CancelEval. */
{
    int code;
    Tcl_Obj *resultObj = NULL;

    ThreadSpecificData *tsdPtr; /* ... of the target thread */

    Tcl_MutexLock(&threadMutex);

    tsdPtr = ThreadExistsInner(thrId);
    if (tsdPtr == (ThreadSpecificData*)NULL) {
        Tcl_MutexUnlock(&threadMutex);
        ErrorNoSuchThread(interp, thrId);
        return TCL_ERROR;
    }

    if (!haveInterpCancel) {
        Tcl_MutexUnlock(&threadMutex);
        Tcl_AppendResult(interp, "not supported with this Tcl version", NULL);
        return TCL_ERROR;
    }

    if (result != NULL) {
        resultObj = Tcl_NewStringObj(result, -1);
    }

    code = Tcl_CancelEval(tsdPtr->interp, resultObj, NULL, flags);

    Tcl_MutexUnlock(&threadMutex);

    return code;
}

 
/*
 *----------------------------------------------------------------------
 *
 * ThreadJoin --
 *
 *  Wait for the exit of a different thread.
................................................................................
 *----------------------------------------------------------------------
 */
static int
ThreadWait(Tcl_Interp *interp)
{
    int code = TCL_OK;
    int canrun = 1;


    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);














    /*
     * Process events until signaled to stop.
     */

    while (canrun) {

................................................................................
         * a script in progress to be canceled or exceed its limit;
         * therefore, check for these conditions if we are able to
         * (i.e. we are running in a high enough version of Tcl).
         */

        Tcl_DoOneEvent(TCL_ALL_EVENTS);


        if (haveInterpCancel) {

            /*
             * If the script has been unwound, bail out immediately. This does
             * not follow the recommended guidelines for how extensions should
             * handle the script cancellation functionality because this is
             * not a "normal" extension. Most extensions do not have a command
................................................................................

            if (Tcl_Canceled(tsdPtr->interp,
                    TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
                code = TCL_ERROR;
                break;
            }
        }


        if (haveInterpLimit) {
            if (Tcl_LimitExceeded(tsdPtr->interp)) {
                code = TCL_ERROR;
                break;
            }
        }


        /*
         * Test stop condition under mutex since
         * some other thread may flip our flags.
         */

        Tcl_MutexLock(&threadMutex);
................................................................................
    }

    /*
     * If the event processing loop above was terminated due to a
     * script in progress being canceled or exceeding its limits,
     * transfer the error to the current interpreter.
     */

    if (code != TCL_OK) {
        char buf[THREAD_HNDLMAXLEN];
        const char *errorInfo;

        errorInfo = Tcl_GetVar(tsdPtr->interp, "errorInfo", TCL_GLOBAL_ONLY);
        if (errorInfo == NULL) {
        	errorInfo = Tcl_GetStringResult(tsdPtr->interp);
        }

        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        Tcl_AppendResult(interp, "Error from thread ", buf, "\n",
                errorInfo, NULL);
    }

    /*
     * Remove from the list of active threads, so nobody can post
     * work to this thread, since it is just about to terminate.
     */

    ListRemove(tsdPtr);






|



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







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







 







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







 







>





>







 







>
>

>





>
>
>
>




|
|
|
|
|
|
|
|
<
<
<







 







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







 







>







 







>







 







>







 







<











|












<


>







 







>
>

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







 







>







 







>
>






>







 







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







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
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
85
86
87
...
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
...
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
...
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458



459
460
461
462
463
464
465
...
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
....
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
....
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
....
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
....
2221
2222
2223
2224
2225
2226
2227

2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251

2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
....
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
....
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
....
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
....
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939

2940
2941
2942
2943
2944
2945
2946
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ----------------------------------------------------------------------------
 */

#include "tclThreadInt.h"

/*
 * Check if this is Tcl 8.5 or higher.  In that case, we will have the TIP
 * #143 APIs (i.e. interpreter resource limiting) available.
 */

#ifndef TCL_TIP143
# if (TCL_MAJOR_VERSION > 8) || \
     ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 5))
#  define TCL_TIP143
# endif
#endif

/*
 * If TIP #143 support is enabled and we are compiling against a pre-Tcl 8.5
 * core, hard-wire the necessary APIs using the "well-known" offsets into the 
 * stubs table.
 */

#if defined(TCL_TIP143) && (TCL_MAJOR_VERSION == 8) && \
    (TCL_MINOR_VERSION < 5)
# if defined(USE_TCL_STUBS)
#  define Tcl_LimitExceeded ((int (*)(Tcl_Interp *)) \
     ((&(tclStubsPtr->tcl_PkgProvideEx))[524]))
# else
#  error "Supporting TIP #143 requires USE_TCL_STUBS before Tcl 8.5"
# endif
#endif

/*
 * Check if this is Tcl 8.6 or higher.  In that case, we will have the TIP
 * #285 APIs (i.e. asynchronous script cancellation) available.
 */


#ifndef TCL_TIP285
# if (TCL_MAJOR_VERSION > 8) || \
     ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 6))
#  define TCL_TIP285
# endif
#endif

/*
 * If TIP #285 support is enabled and we are compiling against a pre-Tcl 8.6
 * core, hard-wire the necessary APIs using the "well-known" offsets into the 
 * stubs table.
 */

#if defined(TCL_TIP285) && (TCL_MAJOR_VERSION == 8) && \
    (TCL_MINOR_VERSION < 6)
# if defined(USE_TCL_STUBS)
#  define TCL_CANCEL_UNWIND	0x100000
#  define Tcl_CancelEval ((int (*)(Tcl_Interp *, Tcl_Obj *, ClientData, int)) \
     ((&(tclStubsPtr->tcl_PkgProvideEx))[580]))
#  define Tcl_Canceled ((int (*)(Tcl_Interp *, int)) \
     ((&(tclStubsPtr->tcl_PkgProvideEx))[581]))
# else
#  error "Supporting TIP #285 requires USE_TCL_STUBS before Tcl 8.6"
# endif
#endif

/*
 * Access to the list of threads and to the thread send results
 * (defined below) is guarded by this mutex.
 */

................................................................................

/*
 * Used to represent the empty result.
 */

static char *threadEmptyResult = (char *)"";

/*
 * This will be set to non-zero if TIP #143 functionality is available.
 */

#ifdef TCL_TIP143
static int threadHaveInterpLimit = 0;
#endif

/*
 * This will be set to non-zero if TIP #285 functionality is available.
 */

#ifdef TCL_TIP285
static int threadHaveInterpCancel = 0;
#endif

/*
 * An instance of the following structure contains all information that is
 * passed into a new thread when the thread is created using either the
 * "thread create" Tcl command or the ThreadCreate() C function.
 */

................................................................................
static void
ErrorNoSuchThread(Tcl_Interp *interp,
                               Tcl_ThreadId thrId);
static void
ThreadCutChannel(Tcl_Interp *interp,
                               Tcl_Channel channel);

#ifdef TCL_TIP285
static int
ThreadCancel(Tcl_Interp *interp,
                               Tcl_ThreadId thrId,
                               const char *result,
                               int flags);
#endif

/*
 * Functions implementing Tcl commands
 */

static Tcl_ObjCmdProc ThreadCreateObjCmd;
static Tcl_ObjCmdProc ThreadReserveObjCmd;
................................................................................
static Tcl_ObjCmdProc ThreadExistsObjCmd;
static Tcl_ObjCmdProc ThreadConfigureObjCmd;
static Tcl_ObjCmdProc ThreadErrorProcObjCmd;
static Tcl_ObjCmdProc ThreadJoinObjCmd;
static Tcl_ObjCmdProc ThreadTransferObjCmd;
static Tcl_ObjCmdProc ThreadDetachObjCmd;
static Tcl_ObjCmdProc ThreadAttachObjCmd;

#ifdef TCL_TIP285
static Tcl_ObjCmdProc ThreadCancelObjCmd;
#endif

static int
ThreadInit(interp)
    Tcl_Interp *interp; /* The current Tcl interpreter */
{
    Tcl_Obj *boolObjPtr;
    const char *msg;
    int boolVar;

    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
        return TCL_ERROR;
    }

    boolObjPtr = Tcl_GetVar2Ex(interp, "::tcl_platform", "threaded", 0);

    if (boolObjPtr == NULL
	|| Tcl_GetBooleanFromObj(interp, boolObjPtr, &boolVar) != TCL_OK
	|| boolVar == 0) {
        msg = "Tcl core wasn't compiled for threading.";
        Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
        return TCL_ERROR;



    }

    TCL_CMD(interp, THREAD_CMD_PREFIX"create",    ThreadCreateObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"send",      ThreadSendObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"broadcast", ThreadBroadcastObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"exit",      ThreadExitObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"unwind",    ThreadUnwindObjCmd);
................................................................................
    TCL_CMD(interp, THREAD_CMD_PREFIX"errorproc", ThreadErrorProcObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"preserve",  ThreadReserveObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"release",   ThreadReleaseObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"join",      ThreadJoinObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"transfer",  ThreadTransferObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"detach",    ThreadDetachObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"attach",    ThreadAttachObjCmd);

#if defined(TCL_TIP143) || defined(TCL_TIP285)
    {
        /*
         * This package may have been compiled against Tcl 8.5 or higher;
         * however, what if it is being loaded by Tcl 8.4 or lower?  Perform
         * a version check now to stop using from trying to use the TIP #143
         * or TIP #285 functionality if they are not present.
         */

        int major, minor;

        Tcl_GetVersion(&major, &minor, NULL, NULL);

        Tcl_MutexLock(&threadMutex);
        if (major > 8 || (major == 8 && minor >= 5)) {
            threadHaveInterpLimit = 1;
        }
        if (major > 8 || (major == 8 && minor >= 6)) {
            threadHaveInterpCancel = 1;
        }
        Tcl_MutexUnlock(&threadMutex);

        if (major > 8 || (major == 8 && minor >= 6)) {
            TCL_CMD(interp, THREAD_CMD_PREFIX"cancel",    ThreadCancelObjCmd);
        }
    }
#endif

    /*
     * Add shared variable commands
     */

    Sv_Init(interp);

................................................................................
            return TCL_ERROR;
        }
    }

    return TCL_OK;
}
 
#ifdef TCL_TIP285
/*
 *----------------------------------------------------------------------
 *
 * ThreadCancelObjCmd --
 *
 *  This procedure is invoked to process the "thread::cancel" Tcl
 *  command. See the user documentation for details on what it does.
................................................................................
        result = Tcl_GetString(objv[ii]);
    } else {
        result = NULL;
    }

    return ThreadCancel(interp, thrId, result, flags);
}
#endif
 
/*
 *----------------------------------------------------------------------
 *
 * ThreadSendEval --
 *
 *  Evaluates Tcl script passed from source to target thread.
................................................................................
            return tsdPtr;
        }
    }

    return NULL;
}
 
#ifdef TCL_TIP285
/*
 *----------------------------------------------------------------------
 *
 * ThreadCancel --
 *
 *    Cancels a script in another thread.
 *
................................................................................
    Tcl_Interp  *interp;        /* The current interpreter. */
    Tcl_ThreadId thrId;         /* Thread ID of other interpreter. */
    const char *result;         /* The error message or NULL for default. */
    int flags;                  /* Flags for Tcl_CancelEval. */
{
    int code;
    Tcl_Obj *resultObj = NULL;

    ThreadSpecificData *tsdPtr; /* ... of the target thread */

    Tcl_MutexLock(&threadMutex);

    tsdPtr = ThreadExistsInner(thrId);
    if (tsdPtr == (ThreadSpecificData*)NULL) {
        Tcl_MutexUnlock(&threadMutex);
        ErrorNoSuchThread(interp, thrId);
        return TCL_ERROR;
    }

    if (!threadHaveInterpCancel) {
        Tcl_MutexUnlock(&threadMutex);
        Tcl_AppendResult(interp, "not supported with this Tcl version", NULL);
        return TCL_ERROR;
    }

    if (result != NULL) {
        resultObj = Tcl_NewStringObj(result, -1);
    }

    code = Tcl_CancelEval(tsdPtr->interp, resultObj, NULL, flags);

    Tcl_MutexUnlock(&threadMutex);

    return code;
}
#endif
 
/*
 *----------------------------------------------------------------------
 *
 * ThreadJoin --
 *
 *  Wait for the exit of a different thread.
................................................................................
 *----------------------------------------------------------------------
 */
static int
ThreadWait(Tcl_Interp *interp)
{
    int code = TCL_OK;
    int canrun = 1;
    int haveInterpLimit;
    int haveInterpCancel;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

#if defined(TCL_TIP143) || defined(TCL_TIP285)
    Tcl_MutexLock(&threadMutex);
#endif
#ifdef TCL_TIP143
    haveInterpLimit = threadHaveInterpLimit;
#endif
#ifdef TCL_TIP285
    haveInterpCancel = threadHaveInterpCancel;
#endif
#if defined(TCL_TIP143) || defined(TCL_TIP285)
    Tcl_MutexUnlock(&threadMutex);
#endif

    /*
     * Process events until signaled to stop.
     */

    while (canrun) {

................................................................................
         * a script in progress to be canceled or exceed its limit;
         * therefore, check for these conditions if we are able to
         * (i.e. we are running in a high enough version of Tcl).
         */

        Tcl_DoOneEvent(TCL_ALL_EVENTS);

#ifdef TCL_TIP285
        if (haveInterpCancel) {

            /*
             * If the script has been unwound, bail out immediately. This does
             * not follow the recommended guidelines for how extensions should
             * handle the script cancellation functionality because this is
             * not a "normal" extension. Most extensions do not have a command
................................................................................

            if (Tcl_Canceled(tsdPtr->interp,
                    TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
                code = TCL_ERROR;
                break;
            }
        }
#endif
#ifdef TCL_TIP143
        if (haveInterpLimit) {
            if (Tcl_LimitExceeded(tsdPtr->interp)) {
                code = TCL_ERROR;
                break;
            }
        }
#endif

        /*
         * Test stop condition under mutex since
         * some other thread may flip our flags.
         */

        Tcl_MutexLock(&threadMutex);
................................................................................
    }

    /*
     * If the event processing loop above was terminated due to a
     * script in progress being canceled or exceeding its limits,
     * transfer the error to the current interpreter.
     */

#if defined(TCL_TIP143) || defined(TCL_TIP285)
    /*
     * If the event processing loop above was terminated due to a
     * script in progress being canceled or exceeding its limits,
     * call the registered error processing script now, if there
     * is one.
     */

    if (code != TCL_OK) {
        ThreadErrorProc(tsdPtr->interp);
    }
#endif


    /*
     * Remove from the list of active threads, so nobody can post
     * work to this thread, since it is just about to terminate.
     */

    ListRemove(tsdPtr);

Changes to win/makefile.vc.

243
244
245
246
247
248
249

250
251
252
253
254
255
256
crt = -MTd
!else
crt = -MT
!endif
!endif

cflags = $(cflags) -DMODULE_SCOPE=extern


!if !$(STATIC_BUILD)
cflags = $(cflags) -DUSE_TCL_STUBS
!if defined(TKSTUBLIB)
cflags = $(cflags) -DUSE_TK_STUBS
!endif
!endif






>







243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
crt = -MTd
!else
crt = -MT
!endif
!endif

cflags = $(cflags) -DMODULE_SCOPE=extern
cflags = $(cflags) -DTCL_TIP143 -DTCL_TIP285

!if !$(STATIC_BUILD)
cflags = $(cflags) -DUSE_TCL_STUBS
!if defined(TKSTUBLIB)
cflags = $(cflags) -DUSE_TK_STUBS
!endif
!endif