Tcl package Thread source code

Check-in [706fd2b4a3]
Login

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

Overview
Comment:Merge trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | novem
Files: files | file ages | folders
SHA3-256:706fd2b4a3be2d37071263b13a9209c4527511fc2d586190a811fc5249ac9298
User & Date: jan.nijtmans 2018-12-04 09:40:17
Context
2019-02-11
15:41
Merge trunk check-in: 5f5c0f4753 user: jan.nijtmans tags: novem
2018-12-04
09:40
Merge trunk check-in: 706fd2b4a3 user: jan.nijtmans tags: novem
2018-12-03
15:12
Integrate [bb825fdd0c129732]: add -command option to [thread::send] check-in: 2ac38ca6c1 user: jan.nijtmans tags: trunk
2018-11-24
09:08
Merge trunk check-in: 25c47ce840 user: jan.nijtmans tags: novem
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to configure.

5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
		{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING:
    Building ${PACKAGE_NAME} without threads enabled, but building against Tcl
    that IS thread-enabled.  It is recommended to use --enable-threads." >&5
$as_echo "$as_me: WARNING:
    Building ${PACKAGE_NAME} without threads enabled, but building against Tcl
    that IS thread-enabled.  It is recommended to use --enable-threads." >&2;}
	    fi
	    ;;
	*)
	    if test "${TCL_THREADS}" = "1"; then
		{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING:
    --enable-threads requested, but building against a Tcl that is NOT
    thread-enabled.  This is an OK configuration that will also run in
    a thread-enabled core." >&5
$as_echo "$as_me: WARNING:
    --enable-threads requested, but building against a Tcl that is NOT
    thread-enabled.  This is an OK configuration that will also run in
    a thread-enabled core." >&2;}
	    fi
	    ;;
    esac



#--------------------------------------------------------------------
# The statement below defines a collection of symbols related to







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







5618
5619
5620
5621
5622
5623
5624












5625
5626
5627
5628
5629
5630
5631
		{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING:
    Building ${PACKAGE_NAME} without threads enabled, but building against Tcl
    that IS thread-enabled.  It is recommended to use --enable-threads." >&5
$as_echo "$as_me: WARNING:
    Building ${PACKAGE_NAME} without threads enabled, but building against Tcl
    that IS thread-enabled.  It is recommended to use --enable-threads." >&2;}
	    fi












	    ;;
    esac



#--------------------------------------------------------------------
# The statement below defines a collection of symbols related to

Changes to generic/threadCmd.c.

16
17
18
19
20
21
22

23
24
25
26
27
28
29
...
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
...
144
145
146
147
148
149
150

151
152
153
154
155
156
157
...
850
851
852
853
854
855
856






857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
...
885
886
887
888
889
890
891



892
893
894
895
896
897
898
...
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
...
923
924
925
926
927
928
929



930

931
932
933
934

935
936
937
938
939
940
941
....
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612

1613

1614
1615
1616
1617
1618
























1619
1620
1621
1622
1623
1624
1625
....
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
....
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
....
3160
3161
3162
3163
3164
3165
3166

3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190

3191
3192
3193
3194
3195
3196
3197
....
3640
3641
3642
3643
3644
3645
3646
3647

3648
3649
3650
3651
3652
3653
3654
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ----------------------------------------------------------------------------
 */

#include "tclThreadInt.h"


/*
 * Provide package version in build contexts which do not provide
 * -DPACKAGE_VERSION, like building a shell with the Thread object
 * files built as part of that shell. Example: basekits.
 */
#ifndef PACKAGE_VERSION
................................................................................
/*
 * Structure holding result of the command executed in target thread.
 */

typedef struct ThreadEventResult {
    Tcl_Condition done;                   /* Set when the script completes */
    int code;                             /* Return value of the function */
    char *result;                         /* Result from the function */
    char *errorInfo;                      /* Copy of errorInfo variable */
    char *errorCode;                      /* Copy of errorCode variable */
    Tcl_ThreadId srcThreadId;             /* Id of sender, if it dies */
    Tcl_ThreadId dstThreadId;             /* Id of target, if it dies */
    struct ThreadEvent *eventPtr;         /* Back pointer */
    struct ThreadEventResult *nextPtr;    /* List for cleanup */
    struct ThreadEventResult *prevPtr;
................................................................................
} ThreadEvent;

typedef int  (ThreadSendProc) (Tcl_Interp*, void *);
typedef void (ThreadSendFree) (void *);

static ThreadSendProc ThreadSendEval;     /* Does a regular Tcl_Eval */
static ThreadSendProc ThreadClbkSetVar;   /* Sets the named variable */


/*
 * These structures are used to communicate commands between source and target
 * threads. The ThreadSendData is used for source->target command passing,
 * while the ThreadClbkData is used for doing asynchronous callbacks.
 *
 * Important: structures below must have first three elements identical!
................................................................................
 */

static void
threadSendFree(void *ptr)
{
    Tcl_Free(ptr);
}







static int
ThreadSendObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    size_t size;
    int ret, ii = 0, flags = 0;
    Tcl_ThreadId thrId;
    const char *script, *arg;
    Tcl_Obj *var = NULL;

    ThreadClbkData *clbkPtr = NULL;
    ThreadSendData *sendPtr = NULL;

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

    for (ii = 1; ii < objc; ii++) {
        arg = Tcl_GetString(objv[ii]);
        if (OPT_CMP(arg, "-async")) {
            flags &= ~THREAD_SEND_WAIT;
        } else if (OPT_CMP(arg, "-head")) {
            flags |= THREAD_SEND_HEAD;



        } else {
            break;
        }
    }
    if (ii >= objc) {
        goto usage;
    }
................................................................................

    script = Tcl_GetString(objv[ii]);
    size = objv[ii]->length+1;
    if (++ii < objc) {
        var = objv[ii];
    }
    if (var && (flags & THREAD_SEND_WAIT) == 0) {
        const char *varName = Tcl_GetString(var);
        size_t vsize = var->length + 1;

        if (thrId == Tcl_GetCurrentThread()) {
            /*
             * FIXME: Do something for callbacks to self
             */
            Tcl_SetObjResult(interp, Tcl_NewStringObj("can't notify self", TCL_AUTO_LENGTH));
            return TCL_ERROR;
................................................................................
        /*
         * Prepare record for the callback. This is asynchronously
         * posted back to us when the target thread finishes processing.
         * We should do a vwait on the "var" to get notified.
         */

        clbkPtr = Tcl_Alloc(sizeof(ThreadClbkData));



        clbkPtr->execProc   = ThreadClbkSetVar;

        clbkPtr->freeProc   = threadSendFree;
        clbkPtr->interp     = interp;
        clbkPtr->threadId   = Tcl_GetCurrentThread();
        clbkPtr->clientData = memcpy(Tcl_Alloc(vsize), varName, vsize);

    }

    /*
     * Prepare job record for the target thread
     */

    sendPtr = Tcl_Alloc(sizeof(ThreadSendData));
................................................................................
 */

static int
ThreadClbkSetVar(interp, clientData)
    Tcl_Interp *interp;
    void *clientData;
{
    ThreadClbkData *clbkPtr = clientData;
    const char *var = clbkPtr->clientData;
    Tcl_Obj *valObj;
    ThreadEventResult *resultPtr = &clbkPtr->result;
    int rc = TCL_OK;

    /*
     * Get the result of the posted command.
     * We will use it to fill-in the result variable.
     */

    valObj = Tcl_NewStringObj(resultPtr->result, TCL_AUTO_LENGTH);
    Tcl_IncrRefCount(valObj);

    if (resultPtr->result != threadEmptyResult) {
        Tcl_Free(resultPtr->result);
    }

    /*
     * Set the result variable
     */

    if (Tcl_SetVar2Ex(interp, var, NULL, valObj,
                      TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
        rc = TCL_ERROR;
        goto cleanup;
    }

    /*
     * In case of error, trigger the bgerror mechansim
     */

    if (resultPtr->code == TCL_ERROR) {
        if (resultPtr->errorCode) {
            var = "errorCode";
            Tcl_SetVar2Ex(interp, var, NULL, Tcl_NewStringObj(resultPtr->errorCode, TCL_AUTO_LENGTH), TCL_GLOBAL_ONLY);
            Tcl_Free(resultPtr->errorCode);
        }
        if (resultPtr->errorInfo) {
            var = "errorInfo";
            Tcl_SetVar2Ex(interp, var, NULL, Tcl_NewStringObj(resultPtr->errorInfo, TCL_AUTO_LENGTH), TCL_GLOBAL_ONLY);
            Tcl_Free(resultPtr->errorInfo);
        }
        Tcl_SetObjResult(interp, valObj);
        Tcl_BackgroundException(interp, TCL_ERROR);

    }


cleanup:
    Tcl_DecrRefCount(valObj);
    return rc;
}
























 
/*
 *----------------------------------------------------------------------
 *
 * ThreadCreate --
 *
 *  This procedure is invoked to create a thread containing an
................................................................................
        if (resultPtr->errorInfo) {
        	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(resultPtr->errorInfo, TCL_AUTO_LENGTH));
            Tcl_Free(resultPtr->errorInfo);
        }
    }

    code = resultPtr->code;
    Tcl_SetObjResult(interp, Tcl_NewStringObj(resultPtr->result, TCL_AUTO_LENGTH));

    /*
     * Cleanup
     */

    Tcl_ConditionFinalize(&resultPtr->done);
    if (resultPtr->result != threadEmptyResult) {
        Tcl_Free(resultPtr->result);
    }
    Tcl_Free(resultPtr);

    return code;
}
 
/*
 *----------------------------------------------------------------------
................................................................................

            if (dowait) {
                while (resultPtr->result == NULL) {
                    Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
                }
                SpliceOut(resultPtr, resultList);
                Tcl_ConditionFinalize(&resultPtr->done);
                if (resultPtr->result != threadEmptyResult) {
                    Tcl_Free(resultPtr->result); /* Will be ignored anyway */
                }
                Tcl_Free(resultPtr);
            }
        }
    }

    Tcl_MutexUnlock(&threadMutex);
    Tcl_SetIntObj(Tcl_GetObjResult(interp), (users > 0) ? users : 0);
................................................................................

static void
ThreadSetResult(interp, code, resultPtr)
    Tcl_Interp *interp;
    int code;
    ThreadEventResult *resultPtr;
{

    size_t size;
    const char *errorCode, *errorInfo, *result;

    if (interp == NULL) {
        code      = TCL_ERROR;
        errorInfo = "";
        errorCode = "THREAD";
        result    = "no target interp!";
        size    = strlen(result);
        resultPtr->result = (size) ?
            memcpy(Tcl_Alloc(1+size), result, 1+size) : threadEmptyResult;
    } else {
        result = Tcl_GetString(Tcl_GetObjResult(interp));
        size = Tcl_GetObjResult(interp)->length;
        resultPtr->result = (size) ?
            memcpy(Tcl_Alloc(1+size), result, 1+size) : threadEmptyResult;
        if (code == TCL_ERROR) {
            errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
            errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
        } else {
            errorCode = NULL;
            errorInfo = NULL;
        }
    }


    resultPtr->code = code;

    if (errorCode != NULL) {
        size = strlen(errorCode) + 1;
        resultPtr->errorCode = memcpy(Tcl_Alloc(size), errorCode, size);
    } else {
................................................................................

            /*
             * Dang. The target is going away. Unblock the caller.
             * The result string must be dynamically allocated
             * because the main thread is going to call free on it.
             */

            resultPtr->result = strcpy(Tcl_Alloc(1+strlen(diemsg)), diemsg);

            resultPtr->code = TCL_ERROR;
            resultPtr->errorCode = resultPtr->errorInfo = NULL;
            Tcl_ConditionNotify(&resultPtr->done);
        }
    }
    for (tResultPtr = transferList; tResultPtr; tResultPtr = tNextPtr) {
        tNextPtr = tResultPtr->nextPtr;







>







 







|







 







>







 







>
>
>
>
>
>









|







 







>
>
>







 







<
<







 







>
>
>
|
>
|


|
>







 







|
|









<
<
<
<
|
<





|











|
|



|
|




>

>





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







 







|






<
|
<







 







|
<
<







 







>

<





<
<
|
<

|
<
<
<








>







 







|
>







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
...
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
...
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
...
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
...
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
...
916
917
918
919
920
921
922


923
924
925
926
927
928
929
...
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
....
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592




1593

1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
....
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774

2775

2776
2777
2778
2779
2780
2781
2782
....
2995
2996
2997
2998
2999
3000
3001
3002


3003
3004
3005
3006
3007
3008
3009
....
3191
3192
3193
3194
3195
3196
3197
3198
3199

3200
3201
3202
3203
3204


3205

3206
3207



3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
....
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ----------------------------------------------------------------------------
 */

#include "tclThreadInt.h"
#include "threadSvCmd.h"

/*
 * Provide package version in build contexts which do not provide
 * -DPACKAGE_VERSION, like building a shell with the Thread object
 * files built as part of that shell. Example: basekits.
 */
#ifndef PACKAGE_VERSION
................................................................................
/*
 * Structure holding result of the command executed in target thread.
 */

typedef struct ThreadEventResult {
    Tcl_Condition done;                   /* Set when the script completes */
    int code;                             /* Return value of the function */
    Tcl_Obj *result;                      /* Result from the function */
    char *errorInfo;                      /* Copy of errorInfo variable */
    char *errorCode;                      /* Copy of errorCode variable */
    Tcl_ThreadId srcThreadId;             /* Id of sender, if it dies */
    Tcl_ThreadId dstThreadId;             /* Id of target, if it dies */
    struct ThreadEvent *eventPtr;         /* Back pointer */
    struct ThreadEventResult *nextPtr;    /* List for cleanup */
    struct ThreadEventResult *prevPtr;
................................................................................
} ThreadEvent;

typedef int  (ThreadSendProc) (Tcl_Interp*, void *);
typedef void (ThreadSendFree) (void *);

static ThreadSendProc ThreadSendEval;     /* Does a regular Tcl_Eval */
static ThreadSendProc ThreadClbkSetVar;   /* Sets the named variable */
static ThreadSendProc ThreadClbkCommand;   /* Sets the named variable */

/*
 * These structures are used to communicate commands between source and target
 * threads. The ThreadSendData is used for source->target command passing,
 * while the ThreadClbkData is used for doing asynchronous callbacks.
 *
 * Important: structures below must have first three elements identical!
................................................................................
 */

static void
threadSendFree(void *ptr)
{
    Tcl_Free(ptr);
}
 
static void
threadSendObjFree(ClientData ptr)
{
    Tcl_DecrRefCount((Tcl_Obj *)ptr);
}

static int
ThreadSendObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    size_t size;
    int cmd = 0, ret, ii = 0, flags = 0;
    Tcl_ThreadId thrId;
    const char *script, *arg;
    Tcl_Obj *var = NULL;

    ThreadClbkData *clbkPtr = NULL;
    ThreadSendData *sendPtr = NULL;

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

    for (ii = 1; ii < objc; ii++) {
        arg = Tcl_GetString(objv[ii]);
        if (OPT_CMP(arg, "-async")) {
            flags &= ~THREAD_SEND_WAIT;
        } else if (OPT_CMP(arg, "-head")) {
            flags |= THREAD_SEND_HEAD;
        } else if (OPT_CMP(arg, "-command")) {
            flags &= ~THREAD_SEND_WAIT;
            cmd = 1;
        } else {
            break;
        }
    }
    if (ii >= objc) {
        goto usage;
    }
................................................................................

    script = Tcl_GetString(objv[ii]);
    size = objv[ii]->length+1;
    if (++ii < objc) {
        var = objv[ii];
    }
    if (var && (flags & THREAD_SEND_WAIT) == 0) {



        if (thrId == Tcl_GetCurrentThread()) {
            /*
             * FIXME: Do something for callbacks to self
             */
            Tcl_SetObjResult(interp, Tcl_NewStringObj("can't notify self", TCL_AUTO_LENGTH));
            return TCL_ERROR;
................................................................................
        /*
         * Prepare record for the callback. This is asynchronously
         * posted back to us when the target thread finishes processing.
         * We should do a vwait on the "var" to get notified.
         */

        clbkPtr = Tcl_Alloc(sizeof(ThreadClbkData));
        if (cmd) {
            clbkPtr->execProc   = ThreadClbkCommand;
        } else {
            clbkPtr->execProc   = ThreadClbkSetVar;
        }
        clbkPtr->freeProc   = threadSendObjFree;
        clbkPtr->interp     = interp;
        clbkPtr->threadId   = Tcl_GetCurrentThread();
        clbkPtr->clientData = Sv_DuplicateObj(var);
        Tcl_IncrRefCount((Tcl_Obj *)clbkPtr->clientData);
    }

    /*
     * Prepare job record for the target thread
     */

    sendPtr = Tcl_Alloc(sizeof(ThreadSendData));
................................................................................
 */

static int
ThreadClbkSetVar(interp, clientData)
    Tcl_Interp *interp;
    void *clientData;
{
    ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
    Tcl_Obj *var = (Tcl_Obj *)clbkPtr->clientData;
    Tcl_Obj *valObj;
    ThreadEventResult *resultPtr = &clbkPtr->result;
    int rc = TCL_OK;

    /*
     * Get the result of the posted command.
     * We will use it to fill-in the result variable.
     */





    valObj = resultPtr->result;


    /*
     * Set the result variable
     */

    if (Tcl_ObjSetVar2(interp, var, NULL, valObj,
                      TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
        rc = TCL_ERROR;
        goto cleanup;
    }

    /*
     * In case of error, trigger the bgerror mechansim
     */

    if (resultPtr->code == TCL_ERROR) {
        if (resultPtr->errorCode) {
            Tcl_SetVar2Ex(interp, "errorCode", NULL,
                Tcl_NewStringObj(resultPtr->errorCode, -1), TCL_GLOBAL_ONLY);
            Tcl_Free(resultPtr->errorCode);
        }
        if (resultPtr->errorInfo) {
            Tcl_SetVar2Ex(interp, "errorInfo", NULL,
                Tcl_NewStringObj(resultPtr->errorInfo, -1), TCL_GLOBAL_ONLY);
            Tcl_Free(resultPtr->errorInfo);
        }
        Tcl_SetObjResult(interp, valObj);
        Tcl_BackgroundException(interp, TCL_ERROR);
        return TCL_ERROR;
    }
    return TCL_OK;

cleanup:
    Tcl_DecrRefCount(valObj);
    return rc;
}
 
static int ThreadClbkCommand(Tcl_Interp *interp, ClientData clientData)
{
    int status = TCL_OK;
    ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
    Tcl_Obj *script = (Tcl_Obj *)clbkPtr->clientData;
    ThreadEventResult *resultPtr = &clbkPtr->result;

    if (resultPtr->code == TCL_ERROR) {
        Tcl_SetObjResult(interp, resultPtr->result);
        Tcl_BackgroundError(interp);
        goto cleanup;
    }

    if ((status = Tcl_ListObjAppendElement(
        interp, script, resultPtr->result)) != TCL_OK) {
        goto cleanup;
    }
    status = Tcl_GlobalEvalObj(interp, script);

cleanup:
    Tcl_DecrRefCount(resultPtr->result);
    return status;
}
 
/*
 *----------------------------------------------------------------------
 *
 * ThreadCreate --
 *
 *  This procedure is invoked to create a thread containing an
................................................................................
        if (resultPtr->errorInfo) {
        	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(resultPtr->errorInfo, TCL_AUTO_LENGTH));
            Tcl_Free(resultPtr->errorInfo);
        }
    }

    code = resultPtr->code;
    Tcl_SetObjResult(interp, resultPtr->result);

    /*
     * Cleanup
     */

    Tcl_ConditionFinalize(&resultPtr->done);

    Tcl_DecrRefCount(resultPtr->result);

    Tcl_Free(resultPtr);

    return code;
}
 
/*
 *----------------------------------------------------------------------
................................................................................

            if (dowait) {
                while (resultPtr->result == NULL) {
                    Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
                }
                SpliceOut(resultPtr, resultList);
                Tcl_ConditionFinalize(&resultPtr->done);
                Tcl_DecrRefCount(resultPtr->result);


                Tcl_Free(resultPtr);
            }
        }
    }

    Tcl_MutexUnlock(&threadMutex);
    Tcl_SetIntObj(Tcl_GetObjResult(interp), (users > 0) ? users : 0);
................................................................................

static void
ThreadSetResult(interp, code, resultPtr)
    Tcl_Interp *interp;
    int code;
    ThreadEventResult *resultPtr;
{
    const char *errorCode, *errorInfo;
    size_t size;


    if (interp == NULL) {
        code      = TCL_ERROR;
        errorInfo = "";
        errorCode = "THREAD";


        resultPtr->result = Tcl_NewStringObj("no target interp", -1);

    } else {
        resultPtr->result = Sv_DuplicateObj(Tcl_GetObjResult(interp));



        if (code == TCL_ERROR) {
            errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
            errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
        } else {
            errorCode = NULL;
            errorInfo = NULL;
        }
    }
    Tcl_IncrRefCount(resultPtr->result);

    resultPtr->code = code;

    if (errorCode != NULL) {
        size = strlen(errorCode) + 1;
        resultPtr->errorCode = memcpy(Tcl_Alloc(size), errorCode, size);
    } else {
................................................................................

            /*
             * Dang. The target is going away. Unblock the caller.
             * The result string must be dynamically allocated
             * because the main thread is going to call free on it.
             */

            resultPtr->result = Tcl_NewStringObj(diemsg, -1);
            Tcl_IncrRefCount(resultPtr->result);
            resultPtr->code = TCL_ERROR;
            resultPtr->errorCode = resultPtr->errorInfo = NULL;
            Tcl_ConditionNotify(&resultPtr->done);
        }
    }
    for (tResultPtr = transferList; tResultPtr; tResultPtr = tNextPtr) {
        tNextPtr = tResultPtr->nextPtr;

Changes to tests/thread.test.

1192
1193
1194
1195
1196
1197
1198















1199
1200
1201
    thread::cond notify $cond
    after 1000
    set c2 [catch {thread::cond destroy $cond} r2]
    ThreadReap
    thread::mutex destroy $emutex
    list $c1 $c2 $r1 $r2
} {1 0 {condition variable is in use} {}}
















removeFile dummyForTransfer
::tcltest::cleanupTests







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



1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
    thread::cond notify $cond
    after 1000
    set c2 [catch {thread::cond destroy $cond} r2]
    ThreadReap
    thread::mutex destroy $emutex
    list $c1 $c2 $r1 $r2
} {1 0 {condition variable is in use} {}}

test thread-22.1  {thread::send -command} {
    ThreadReap
    after 0 [list ::apply [list {} {
        set tid [thread::create]
        thread::send -command $tid {lindex hello} [list ::apply [list args {
            variable result
            set result $args
        } [namespace current]]]
    } [namespace current]]]
    vwait [namespace current]::result
    ThreadReap
    set result
} hello 


removeFile dummyForTransfer
::tcltest::cleanupTests