Tcl package Thread source code

Check-in [3d2f5a0b19]
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:merge compileTipCheck to trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 3d2f5a0b191cdb56a3fd742464e668c58d9f2c00
User & Date: jan.nijtmans 2012-11-13 23:23:58
Context
2012-11-13
23:36
comment fix check-in: 4b24fe1d2c user: jan.nijtmans tags: trunk
23:23
merge compileTipCheck to trunk check-in: 3d2f5a0b19 user: jan.nijtmans tags: trunk
23:15
simplify some things, and make it work against Tcl 8.4/8.5 again Closed-Leaf check-in: e187578bb3 user: jan.nijtmans 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.

11345
11346
11347
11348
11349
11350
11351

















11352
11353
11354
11355
11356
11357
11358
#--------------------------------------------------------------------


cat >>confdefs.h <<\_ACEOF
#define USE_TCL_STUBS 1
_ACEOF



















#--------------------------------------------------------------------
# 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.
#--------------------------------------------------------------------







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







11345
11346
11347
11348
11349
11350
11351
11352
11353
11354
11355
11356
11357
11358
11359
11360
11361
11362
11363
11364
11365
11366
11367
11368
11369
11370
11371
11372
11373
11374
11375
#--------------------------------------------------------------------


cat >>confdefs.h <<\_ACEOF
#define USE_TCL_STUBS 1
_ACEOF


#--------------------------------------------------------------------
# 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.
#--------------------------------------------------------------------


cat >>confdefs.h <<\_ACEOF
#define TCL_TIP143 1
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define TCL_TIP285 1
_ACEOF


#--------------------------------------------------------------------
# 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 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
412
...
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
....
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171

2172
2173
2174
2175
2176
2177
2178
....
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
2816
2817
2818
2819

2820
2821
2822
2823

2824
2825
2826
2827
2828
2829
2830
....
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"id",        ThreadIdObjCmd);
................................................................................
    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);
................................................................................
    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.
................................................................................
         * 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);
        canrun = (tsdPtr->flags & THREAD_FLAGS_STOPPED) == 0;
        Tcl_MutexUnlock(&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);
................................................................................
        	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
88
89
...
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
...
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
...
417
418
419
420
421
422
423
424
425
426
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
...
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
....
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
....
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
....
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
....
2187
2188
2189
2190
2191
2192
2193

2194
2195
2196
2197
2198
2199
2200
....
2211
2212
2213
2214
2215
2216
2217

2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
....
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
....
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
....
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
 * 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.
 */

#define haveInterpLimit (tclVersion>84)
#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.
 */

#define haveInterpCancel (tclVersion>85)
#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 *)"";

#if defined(TCL_TIP143) || defined(TCL_TIP285)
static int tclVersion = 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 */
{
    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
        return TCL_ERROR;
    }

#if defined(TCL_TIP143) || defined(TCL_TIP285)
    if (!tclVersion) {

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

	int major, minor;

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

    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"id",        ThreadIdObjCmd);
................................................................................
    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);
#ifdef TCL_TIP285
    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);
................................................................................
    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.
................................................................................
         * 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);
        canrun = (tsdPtr->flags & THREAD_FLAGS_STOPPED) == 0;
        Tcl_MutexUnlock(&threadMutex);
    }

#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) {
        char buf[THREAD_HNDLMAXLEN];
        const char *errorInfo;

        errorInfo = Tcl_GetVar(tsdPtr->interp, "errorInfo", TCL_GLOBAL_ONLY);
................................................................................
        	errorInfo = Tcl_GetStringResult(tsdPtr->interp);
        }

        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        Tcl_AppendResult(interp, "Error from thread ", buf, "\n",
                errorInfo, NULL);
    }
#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