Tcl Source Code

Check-in [60d629e262]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

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

Overview
Comment:Import of TIP 530 implementation, and update to follow Tcl Engineering Manual style.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-530
Files: files | file ages | folders
SHA3-256:60d629e26202cf2d11c414e82935645e704ec45bcbbefec7cce46de7143c218d
User & Date: dkf 2019-05-18 09:08:30
Context
2019-05-18
10:42
Surface TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS as configure --enable-line-continuations Leaf check-in: 68d2b424fb user: dkf tags: tip-530
09:08
Import of TIP 530 implementation, and update to follow Tcl Engineering Manual style. check-in: 60d629e262 user: dkf tags: tip-530
2019-05-16
18:19
merge 8.5 check-in: 594a6ef663 user: sebres tags: core-8-6-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclObj.c.

14
15
16
17
18
19
20









21
22
23
24
25
26
27
..
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
...
507
508
509
510
511
512
513


















































514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532






533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
...
569
570
571
572
573
574
575
576
577
578

579
580





581
582
583
584
585
586
587
...
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
...
680
681
682
683
684
685
686
687

688
689

690
691
692
693
694
695
696
697
698
699
700

701
702
703
704
705
706
707
...
724
725
726
727
728
729
730
731


732
733
734
735
736
737
738

739
740
741
742
743
744
745
...
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772


773
774
775
776
777
778
779
...
794
795
796
797
798
799
800
801
802
803
804

805
806
807
808
809
810
811
812

813
814
815
816
817
818
819
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

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










/*
 * 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);

/*
 * 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);
}
 
/*
 *----------------------------------------------------------------------
 *


















































 * 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.
 *
 * Side effects:
 *	May allocate memory for the thread-data.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

static ThreadSpecificData *
TclGetContLineTable(void)
{






    /*
     * 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);

    if (!tsdPtr->lineCLPtr) {
	tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
	Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
    }
    return tsdPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclContinuationsEnter --
 *
................................................................................
ContLineLoc *
TclContinuationsEnter(
    Tcl_Obj *objPtr,
    int num,
    int *loc)
{
    int newEntry;
    ThreadSpecificData *tsdPtr = TclGetContLineTable();
    Tcl_HashEntry *hPtr =
	    Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);

    ContLineLoc *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));
    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.

	 */


	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.
	     */

	    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_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);

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

	TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);

    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclContinuationsGet --
................................................................................
 *----------------------------------------------------------------------
 */

ContLineLoc *
TclContinuationsGet(
    Tcl_Obj *objPtr)
{
    ThreadSpecificData *tsdPtr = TclGetContLineTable();
    Tcl_HashEntry *hPtr =
            Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);

    if (!hPtr) {
        return NULL;
    }
    return Tcl_GetHashValue(hPtr);


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

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


    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 --
 *







>
>
>
>
>
>
>
>
>







 







|







 







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







|








|


>
>
>
>
>
>








|
<





|







 







<
|
<
>
|

>
>
>
>
>







 







|







 







|
>


>
|
|

|
|
|
|
|

|
|
>







 







|
>
>
|
<

|
|

|
>







 







|
|
|
|
|
|
|
|
>
>







 







|



>
|
|
|
|
|
|
|
|
>







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
...
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606

607
608
609
610
611
612
613
614
615
616
617
618
619
...
633
634
635
636
637
638
639

640

641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
...
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
...
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
...
795
796
797
798
799
800
801
802
803
804
805

806
807
808
809
810
811
812
813
814
815
816
817
818
...
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
...
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
 * 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 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 hash table that is stored in thread-data.
 *
 * Side effects:
 *	May allocate memory for the thread-data.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

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.
     */

    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->lineCLPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclContinuationsEnter --
 *
................................................................................
ContLineLoc *
TclContinuationsEnter(
    Tcl_Obj *objPtr,
    int num,
    int *loc)
{
    int newEntry;

    Tcl_HashEntry *hPtr;

    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));
    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. 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;

                /*
                 * 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");
                }
	    }
	}
    }
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 */

void
TclContinuationsCopy(
    Tcl_Obj *objPtr,
    Tcl_Obj *originObjPtr)
{
    Tcl_HashTable *contLineTable = TclGetContLineTable();

    if (contLineTable) {
        Tcl_HashEntry *hPtr = Tcl_FindHashEntry(contLineTable, originObjPtr);


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

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

ContLineLoc *
TclContinuationsGet(
    Tcl_Obj *objPtr)
{
    Tcl_HashTable *contLineTable = TclGetContLineTable();

    if (contLineTable) {
        Tcl_HashEntry *hPtr = Tcl_FindHashEntry(contLineTable, objPtr);

        if (hPtr) {
            return Tcl_GetHashValue(hPtr);
        }
    }
    return NULL;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclThreadFinalizeContLines --
 *
................................................................................
TclThreadFinalizeContLines(
    ClientData clientData)
{
    /*
     * Release the hashtable tracking invisible continuation lines.
     */

    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;
    }
}
 
/*
 *--------------------------------------------------------------
 *
 * Tcl_RegisterObjType --
 *