Tcl Source Code

 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tommath.h"
#include <math.h>

/*
 * Allow disabling (by default) of the performance cost of [info frame] as a
 * compile-time option.
 */

#ifndef TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS
#define TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS 1
#endif

/*
 * Table of all object types.
 */

static Tcl_HashTable typeTable;
static int typeTableInitialized = 0;	/* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(tableMutex)

                                 * other thread. */
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

static void             TclThreadFinalizeContLines(ClientData clientData);
static ThreadSpecificData *TclGetContLineTable(void);
static Tcl_HashTable *  TclGetContLineTable(void);

/*
 * Nested Tcl_Obj deletion management support
 *
 * All context references used in the object freeing code are pointers to this
 * structure; every thread will have its own structure instance. The purpose
 * of this structure is to allow deeply nested collections of Tcl_Objs to be

    tclFreeObjList = NULL;
    Tcl_MutexUnlock(&tclObjMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * LineContinuationsMustBeTracked --
 *
 *      Bookkeeping of line continuation (backslash+newline) sequences with
 *      the purpose of reporting correct line numbers in the result of [info
 *      frame level] introduces noticeable overhead in TclFreeObj().
 *      Therefore that functionality can be turned on or off via the
 *      environment variable TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS
 *      (setting it to 0 results in improved performance at the cost of worse
 *      debuggability of Tcl scripts, while any other value has an opposite
 *      effect). During compilation, defining a macro with the same name sets
 *      the default value for that setting.
 *
 * Returns:
 *      A true value if we want detailed tracking, a false one if we don't.
 *
 * TIP #530
 *----------------------------------------------------------------------
 */

#define TRACK_CONTINUATIONS_NEEDS_INIT  (-1)

static int
LineContinuationsMustBeTracked(void)
{
    static int trackContinuations = TRACK_CONTINUATIONS_NEEDS_INIT;

    /*
     * Not technically thread safe, but two threads will assign the same
     * value.
     */

    if (trackContinuations == TRACK_CONTINUATIONS_NEEDS_INIT) {
        Tcl_DString buffer;
        const char *valuePtr = TclGetEnv(
                "TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS", &buffer);

        if (valuePtr == NULL) {
            trackContinuations =
                    (TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS != 0);
        } else {
            trackContinuations = (strcmp(valuePtr, "0") != 0);
            Tcl_DStringFree(&buffer);
        }
    }
    return trackContinuations;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetContLineTable --
 *
 *	This procedure is a helper which returns the thread-specific
 *	hash-table used to track continuation line information associated with
 *	Tcl_Obj*, and the objThreadMap, etc.
 *
 * Results:
 *	A reference to the thread-data.
 *	A reference to the hash table that is stored in thread-data.
 *
 * Side effects:
 *	May allocate memory for the thread-data.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

static ThreadSpecificData *
static Tcl_HashTable *
TclGetContLineTable(void)
{
    ThreadSpecificData *tsdPtr;

    if (!LineContinuationsMustBeTracked()) {
        return NULL;
    }

    /*
     * Initialize the hashtable tracking invisible continuation lines.  For
     * the release we use a thread exit handler to ensure that this is done
     * before TSD blocks are made invalid. The TclFinalizeObjects() which
     * would be the natural place for this is invoked afterwards, meaning that
     * we try to operate on a data structure already gone.
     */

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->lineCLPtr) {
	tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
	Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
    }
    return tsdPtr;
    return tsdPtr->lineCLPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclContinuationsEnter --
 *

ContLineLoc *
TclContinuationsEnter(
    Tcl_Obj *objPtr,
    int num,
    int *loc)
{
    int newEntry;
    ThreadSpecificData *tsdPtr = TclGetContLineTable();
    Tcl_HashEntry *hPtr =
    Tcl_HashEntry *hPtr;
	    Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
    ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int));
    Tcl_HashTable *contLineTable = TclGetContLineTable();
    ContLineLoc *clLocPtr;

    if (!contLineTable) {
        return NULL;
    }
    hPtr = Tcl_CreateHashEntry(contLineTable, objPtr, &newEntry);
    clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int));
    if (!newEntry) {
	/*
	 * We're entering ContLineLoc data for the same value more than one
	 * time. Taking care not to leak the old entry.
	 *
	 * This can happen when literals in a proc body are shared. See for
	 * example test info-30.19 where the action (code) for all branches of

	 * doing.
	 */

	ckfree(Tcl_GetHashValue(hPtr));
    }

    clLocPtr->num = num;
    memcpy(&clLocPtr->loc, loc, num*sizeof(int));
    memcpy(&clLocPtr->loc, loc, num * sizeof(int));
    clLocPtr->loc[num] = CLL_END;       /* Sentinel */
    Tcl_SetHashValue(hPtr, clLocPtr);

    return clLocPtr;
}

/*

    num = wordCLLast - clNext;
    if (num) {
	int i;
	ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext);

	/*
	 * Re-base the locations.
	 * Re-base the locations. Note that TclContinuationsEnter() may return
	 * NULL if user policy has disabled continuation line tracking.
	 */

        if (clLocPtr != NULL) {
	for (i=0 ; i<num ; i++) {
	    clLocPtr->loc[i] -= start;
            for (i=0 ; i<num ; i++) {
                clLocPtr->loc[i] -= start;

	    /*
	     * Continuation lines coming before the string and affecting us
	     * should not happen, due to the proper maintenance of clNext
	     * during compilation.
	     */
                /*
                 * Continuation lines coming before the string and affecting
                 * us should not happen, due to the proper maintenance of
                 * clNext during compilation.
                 */

	    if (clLocPtr->loc[i] < 0) {
		Tcl_Panic("Derived ICL data for object using offsets from before the script");
                if (clLocPtr->loc[i] < 0) {
                    Tcl_Panic("Derived ICL data for object using offsets from before the script");
                }
	    }
	}
    }
}

/*
 *----------------------------------------------------------------------

 */

void
TclContinuationsCopy(
    Tcl_Obj *objPtr,
    Tcl_Obj *originObjPtr)
{
    ThreadSpecificData *tsdPtr = TclGetContLineTable();
    Tcl_HashEntry *hPtr =
    Tcl_HashTable *contLineTable = TclGetContLineTable();

    if (contLineTable) {
        Tcl_HashEntry *hPtr = Tcl_FindHashEntry(contLineTable, originObjPtr);
            Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);

    if (hPtr) {
	ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr);
        if (hPtr) {
            ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr);

	TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
            TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
        }
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclContinuationsGet --

 *----------------------------------------------------------------------
 */

ContLineLoc *
TclContinuationsGet(
    Tcl_Obj *objPtr)
{
    ThreadSpecificData *tsdPtr = TclGetContLineTable();
    Tcl_HashEntry *hPtr =
    Tcl_HashTable *contLineTable = TclGetContLineTable();

    if (contLineTable) {
        Tcl_HashEntry *hPtr = Tcl_FindHashEntry(contLineTable, objPtr);
            Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);

    if (!hPtr) {
        return NULL;
    }
    return Tcl_GetHashValue(hPtr);
        if (hPtr) {
            return Tcl_GetHashValue(hPtr);
        }
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclThreadFinalizeContLines --
 *

TclThreadFinalizeContLines(
    ClientData clientData)
{
    /*
     * Release the hashtable tracking invisible continuation lines.
     */

    ThreadSpecificData *tsdPtr = TclGetContLineTable();
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch hSearch;

    if (tsdPtr->lineCLPtr != NULL) {
    for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
	    hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
	ckfree(Tcl_GetHashValue(hPtr));
	Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
    ckfree(tsdPtr->lineCLPtr);
    tsdPtr->lineCLPtr = NULL;
        for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
                hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
            ckfree(Tcl_GetHashValue(hPtr));
            Tcl_DeleteHashEntry(hPtr);
        }
        Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
        ckfree(tsdPtr->lineCLPtr);
        tsdPtr->lineCLPtr = NULL;
    }
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_RegisterObjType --
 *

    AC_HELP_STRING([--enable-dll-unloading],
	[enable the 'unload' command (default: on)]),
    [tcl_ok=$enableval], [tcl_ok=yes])
if test $tcl_ok = yes; then
    AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?])
fi
AC_MSG_RESULT([$tcl_ok])

#------------------------------------------------------------------------

AC_MSG_CHECKING([whether to track line continuation])
AC_ARG_ENABLE(line-continuations,
    AC_HELP_STRING([--enable-line-continuations],
	[enable the tracking of line continuations for [info frame] (default: on)]),
    [tcl_ok=$enableval], [tcl_ok=yes])
if test $tcl_ok = yes; then
    AC_DEFINE(TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS, 1, [Do we source code line numbers accurately?])
fi
AC_MSG_RESULT([$tcl_ok])

#------------------------------------------------------------------------
#	Check whether the timezone data is supplied by the OS or has
#	to be installed by Tcl. The default is autodetection, but can
#	be overriden on the configure command line either way.
#------------------------------------------------------------------------