Tcl package Thread source code

#include <string.h> /* For memset and friends */

/*
 * MSVC 8.0 started to mark many standard C library functions depreciated
 * including the *printf family and others. Tell it to shut up.
 * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0)
 */
#if defined(_MSC_VER) && (_MSC_VER >= 1400)
#   pragma warning(disable:4244)

#   pragma warning(disable:4267)
#   pragma warning(disable:4996)

#endif

/*
 * Used to tag functions that are only to be visible within the module being
 * built and not outside it (where this is supported by the linker).
 */

/*
 * Implementation of most standard Tcl list processing commands
 * suitable for operation on thread shared (list) variables.
 *
 * Copyright (c) 2002 by Zoran Vasiljevic.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ----------------------------------------------------------------------------
 */

#include "threadSvCmd.h"
#include "threadSvListCmd.h"


























/*
 * Implementation of list commands for shared variables.
 * Most of the standard Tcl list commands are implemented.
 * There are also two new commands: "lpop" and "lpush".
 * Those are very convenient for simple stack operations.
 *

static Tcl_ObjCmdProc SvLlengthObjCmd;   /* llength     */
static Tcl_ObjCmdProc SvLindexObjCmd;    /* lindex      */
static Tcl_ObjCmdProc SvLinsertObjCmd;   /* linsert     */
static Tcl_ObjCmdProc SvLrangeObjCmd;    /* lrange      */
static Tcl_ObjCmdProc SvLsearchObjCmd;   /* lsearch     */
static Tcl_ObjCmdProc SvLsetObjCmd;      /* lset        */

/*
 * These two are copied verbatim from the tclUtil.c
 * since not found in the public stubs table.
 * I was just too lazy to rewrite them from scratch.
 */

static int SvCheckBadOctal(Tcl_Interp*, const char *);
static int SvGetIntForIndex(Tcl_Interp*,  Tcl_Obj *, int, int*);

/*
 * Inefficient list duplicator function which,
 * however, produces deep list copies, unlike
 * the original, which just makes shallow copies.
 */

static void DupListObjShared(Tcl_Obj*, Tcl_Obj*);

static int
SvLpopObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int ret, off, llen, index = 0, iarg = 0;

    Tcl_Obj *elPtr = NULL;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lpop array key ?index?
     *          $list lpop ?index?

        iarg = off;
    }
    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if (iarg) {
        ret = SvGetIntForIndex(interp, objv[iarg], llen-1, &index);
        if (ret != TCL_OK) {
            goto cmd_err;
        }
    }
    if (index < 0 || index >= llen) {
        goto cmd_ok; /* Ignore out-of bounds, like Tcl does */
    }

static int
SvLpushObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int off, ret, flg, llen, index = 0;

    Tcl_Obj *args[1];
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lpush array key element ?index?
     *          $list lpush element ?index?

        goto cmd_err;
    }
    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if ((objc - off) == 2) {
        ret = SvGetIntForIndex(interp, objv[off+1], llen, &index);
        if (ret != TCL_OK) {
            goto cmd_err;
        }
        if (index < 0) {
            index = 0;
        } else if (index > llen) {
            index = llen;

    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    const char *firstArg;
    size_t argLen;
    int ret, off, llen, first, last, ndel, nargs, i, j;

    Tcl_Obj **args = NULL;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lreplace array key first last ?element ...?
     *          $list lreplace first last ?element ...?

        Tcl_WrongNumArgs(interp, off, objv, "first last ?element ...?");
        goto cmd_err;
    }
    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off], llen-1, &first);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off+1], llen-1, &last);
    if (ret != TCL_OK) {
        goto cmd_err;
    }

    firstArg = Tcl_GetString(objv[off]);
    argLen = objv[off]->length;
    if (first < 0)  {

static int
SvLrangeObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int ret, off, llen, first, last, nargs, i, j;

    Tcl_Obj **elPtrs, **args;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lrange array key first last
     *          $list lrange first last

        Tcl_WrongNumArgs(interp, off, objv, "first last");
        goto cmd_err;
    }
    ret = Tcl_ListObjGetElements(interp, svObj->tclObj, &llen, &elPtrs);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off], llen-1, &first);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off+1], llen-1, &last);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if (first < 0)  {
        first = 0;
    }
    if (last >= llen) {

static int
SvLinsertObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int off, ret, flg, llen, nargs, index = 0, i, j;

    Tcl_Obj **args;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::linsert array key index element ?element ...?
     *          $list linsert element ?element ...?

        Tcl_WrongNumArgs(interp, off, objv, "index element ?element ...?");
        goto cmd_err;
    }
    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off], llen, &index);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if (index < 0) {
        index = 0;
    } else if (index > llen) {
        index = llen;

SvLindexObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    Tcl_Obj **elPtrs;
    int ret, off, llen, index;

    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lindex array key index
     *          $list lindex index
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }
    if ((objc - off) != 1) {
        Tcl_WrongNumArgs(interp, off, objv, "index");
        goto cmd_err;
    }
    ret = Tcl_ListObjGetElements(interp, svObj->tclObj, &llen, &elPtrs);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off], llen-1, &index);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if (index >= 0 && index < llen) {
        Tcl_SetObjResult(interp, Sv_DuplicateObj(elPtrs[index]));
    }

        newObjList[i] = Sv_DuplicateObj(elObj);
    }

    Tcl_SetListObj(copyPtr, llen, newObjList);

    ckfree((char*)newObjList);
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvCheckBadOctal --
 *
 *  Exact copy from the TclCheckBadOctal found in tclUtil.c
 *  since this is not in the stubs table.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvCheckBadOctal(interp, value)
    Tcl_Interp *interp;     /* Interpreter to use for error reporting.
                             * If NULL, then no error message is left
                             * after errors. */
    const char *value;      /* String to check. */
{
    register const char *p = value;

    /*
     * A frequent mistake is invalid octal values due to an unwanted
     * leading zero. Try to generate a meaningful error message.
     */

    while (isspace((unsigned char)(*p))) { /* INTL: ISO space. */
        p++;
    }
    if (*p == '+' || *p == '-') {
        p++;
    }
    if (*p == '0') {
        while (isdigit((unsigned char)(*p))) { /* INTL: digit. */
            p++;
        }
        while (isspace((unsigned char)(*p))) { /* INTL: ISO space. */
            p++;
        }
        if (*p == '\0') {
            /* Reached end of string */
            if (interp != NULL) {
                Tcl_AppendResult(interp, " (looks like invalid octal number)",
                        (char *) NULL);
            }
            return 1;
        }
    }
    return 0;
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvGetIntForIndex --
 *
 *  Exact copy from the TclGetIntForIndex found in tclUtil.c
 *  since this is not in the stubs table.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvGetIntForIndex(interp, objPtr, endValue, indexPtr)
    Tcl_Interp *interp;     /* Interpreter to use for error reporting.
                             * If NULL, then no error message is left
                             * after errors. */
    Tcl_Obj *objPtr;        /* Points to an object containing either
                             * "end" or an integer. */
    int endValue;           /* The value to be stored at "indexPtr" if
                             * "objPtr" holds "end". */
    int *indexPtr;          /* Location filled in with an integer
                             * representing an index. */
{
    const char *bytes;
    size_t length;
    int offset;

    bytes = Tcl_GetString(objPtr);
    length = objPtr->length;

    if ((*bytes != 'e')
        || (strncmp(bytes, "end",((length > 3) ? 3 : length)) != 0)) {
        if (Tcl_GetIntFromObj(NULL, objPtr, &offset) != TCL_OK) {
            goto intforindex_error;
        }
        *indexPtr = offset;
        return TCL_OK;
    }
    if (length <= 3) {
        *indexPtr = endValue;
    } else if (bytes[3] == '-') {
        /*
         * This is our limited string expression evaluator
         */
        if (Tcl_GetInt(interp, bytes+3, &offset) != TCL_OK) {
            return TCL_ERROR;
        }
        *indexPtr = endValue + offset;
    } else {
  intforindex_error:
        if (interp != NULL) {
            Tcl_ResetResult(interp);
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad index \"",
                    bytes, "\": must be integer or end?-integer?",(char*)NULL);
            SvCheckBadOctal(interp, bytes);
        }
        return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SvLsetFlat --
 *
 *  Almost exact copy from the TclLsetFlat found in tclListObj.c.

SvLsetFlat(interp, listPtr, indexCount, indexArray, valuePtr)
     Tcl_Interp *interp;     /* Tcl interpreter */
     Tcl_Obj *listPtr;       /* Pointer to the list being modified */
     int indexCount;         /* Number of index args */
     Tcl_Obj **indexArray;
     Tcl_Obj *valuePtr;      /* Value arg to 'lset' */
{
    int elemCount, index, result, i;

    Tcl_Obj **elemPtrs, *chainPtr, *subListPtr;

    /*
     * Determine whether the index arg designates a list
     * or a single index.
     */

        listPtr->internalRep.twoPtrValue.ptr2 = (void*)chainPtr;

        /*
         * Determine the index of the requested element.
         */

        result = SvGetIntForIndex(interp, indexArray[i], elemCount-1, &index);
        if (result != TCL_OK) {
            break;
        }

        /*
         * Check that the index is in range.
         */