Itcl - the [incr Tcl] extension

Check-in [d46639da5b]
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:move bypass-logic of internal dicts into and simplify Itcl_ParseVarResolver
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | sebres-on-dmnd-resolver-perf-branch
Files: files | file ages | folders
SHA3-256: d46639da5bd26deb4441439e50186cc22cc097f808d4c18e0f38b7784b18ddce
User & Date: sebres 2019-04-17 20:45:19
Context
2019-04-17
20:46
add performance test-suite check-in: b8ab55a29e user: sebres tags: sebres-on-dmnd-resolver-perf-branch
20:45
move bypass-logic of internal dicts into and simplify Itcl_ParseVarResolver check-in: d46639da5b user: sebres tags: sebres-on-dmnd-resolver-perf-branch
20:44
some clean-ups / review check-in: 7b37e1c98b user: sebres tags: sebres-on-dmnd-resolver-perf-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/itclBase.c.

225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
    nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE, infoPtr, FreeItclObjectInfo);
    if (nsPtr == NULL) {
	ckfree(infoPtr);
        Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", ITCL_NAMESPACE);
    }

    nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE"::internal::dicts",
            NULL, NULL);
    if (nsPtr == NULL) {
	ckfree(infoPtr);
        Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n",
	        ITCL_NAMESPACE);
    }







|







225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
    nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE, infoPtr, FreeItclObjectInfo);
    if (nsPtr == NULL) {
	ckfree(infoPtr);
        Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", ITCL_NAMESPACE);
    }

    nsPtr = Tcl_CreateNamespace(interp, ITCL_INTDICTS_NAMESPACE,
            NULL, NULL);
    if (nsPtr == NULL) {
	ckfree(infoPtr);
        Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n",
	        ITCL_NAMESPACE);
    }

Changes to generic/itclClass.c.

1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
    ItclClass* iclsPtr2;
    ItclVarLookup *vlookup;
    ItclVariable *ivPtr;
    Tcl_Namespace* nsPtr;
    Tcl_Obj *vnObjPtr;
    int newEntry, processAncestors;
    size_t varLen;

    /* simple speedup: avoid lookup for ::itcl::internal's - not resolvable in a class */
    if (strncmp(lookupName, ITCL_NAMESPACE, sizeof(ITCL_NAMESPACE)-1) == 0) {
	return NULL;
    }
    
    /* (de)qualify to simple name */
    varName = simpleName = lookupName;
    while(*varName) {
        if (*varName++ == ':') {
            if (*varName++ == ':') { simpleName = varName; }
        };
    }






|
<
<
<
<
<







1720
1721
1722
1723
1724
1725
1726
1727





1728
1729
1730
1731
1732
1733
1734
    ItclClass* iclsPtr2;
    ItclVarLookup *vlookup;
    ItclVariable *ivPtr;
    Tcl_Namespace* nsPtr;
    Tcl_Obj *vnObjPtr;
    int newEntry, processAncestors;
    size_t varLen;
  





    /* (de)qualify to simple name */
    varName = simpleName = lookupName;
    while(*varName) {
        if (*varName++ == ':') {
            if (*varName++ == ':') { simpleName = varName; }
        };
    }

Changes to generic/itclInt.h.

82
83
84
85
86
87
88


89
90
91
92
93
94
95
96
97
/*
 * What sort of size of things we like to allocate.
 */

#define ALLOC_CHUNK 8



#define ITCL_VARIABLES_NAMESPACE "::itcl::internal::variables"
#define ITCL_COMMANDS_NAMESPACE "::itcl::internal::commands"

#ifdef ITCL_PRESERVE_DEBUG
#define ITCL_PRESERVE_BUCKET_SIZE 50
#define ITCL_PRESERVE_INCR 1
#define ITCL_PRESERVE_DECR -1
#define ITCL_PRESERVE_DELETED 0







>
>
|
|







82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
/*
 * What sort of size of things we like to allocate.
 */

#define ALLOC_CHUNK 8

#define ITCL_INT_NAMESPACE	    ITCL_NAMESPACE"::internal"
#define ITCL_INTDICTS_NAMESPACE	    ITCL_INT_NAMESPACE"::dicts"
#define ITCL_VARIABLES_NAMESPACE    ITCL_INT_NAMESPACE"::variables"
#define ITCL_COMMANDS_NAMESPACE	    ITCL_INT_NAMESPACE"::commands"

#ifdef ITCL_PRESERVE_DEBUG
#define ITCL_PRESERVE_BUCKET_SIZE 50
#define ITCL_PRESERVE_INCR 1
#define ITCL_PRESERVE_DECR -1
#define ITCL_PRESERVE_DELETED 0

Changes to generic/itclResolve.c.

645
646
647
648
649
650
651





652
653
654
655
656
657
658



659
660
661


662
663
664
665
666
667
668
669
670
671
672
673

674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
    Tcl_Var* rPtr)             /* returns: Tcl_Var for desired variable */
{
    ItclObjectInfo *infoPtr = (ItclObjectInfo*)contextNs->clientData;
    ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);

    Tcl_HashEntry *hPtr;
    ItclVarLookup *vlookup;






    /*
     *  See if the requested variable is a recognized "common" member.
     *  If it is, make sure that access is allowed.
     */
    hPtr = ItclResolveVarEntry(iclsPtr, name);
    if (hPtr) {



        vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);

        if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) {


            if (!vlookup->accessible) {
                Tcl_AppendResult(interp,
                    "can't access \"", name, "\": ",
                    Itcl_ProtectionStr(vlookup->ivPtr->protection),
                    " variable",
                    (char*)NULL);
                return TCL_ERROR;
            }
	    hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons,
	        (char *)vlookup->ivPtr);
	    if (hPtr != NULL) {
                *rPtr = Tcl_GetHashValue(hPtr);

                return TCL_OK;
	    }
        }
    }

    /*
     *  If the variable is not recognized, return TCL_CONTINUE and
     *  let lookup continue via the normal name resolution rules.
     *  This is important for variables like "errorInfo"
     *  that might get set while the parser namespace is active.
     */
    return TCL_CONTINUE;
}



int
ItclSetParserResolver(
    Tcl_Namespace *nsPtr)
{
    Itcl_SetNamespaceResolvers(nsPtr, (Tcl_ResolveCmdProc*)NULL,
            Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL);
    return TCL_OK;
}






>
>
>
>
>






|
>
>
>
|

|
>
>
|
|
|
|
|
|
|
|
|
|
<
<
>
|
|
<
<
<
<
|
<
<
<
<
|












645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681


682
683
684




685




686
687
688
689
690
691
692
693
694
695
696
697
698
    Tcl_Var* rPtr)             /* returns: Tcl_Var for desired variable */
{
    ItclObjectInfo *infoPtr = (ItclObjectInfo*)contextNs->clientData;
    ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);

    Tcl_HashEntry *hPtr;
    ItclVarLookup *vlookup;

    /* simple speedup: avoid lookup for ::itcl::internal's - not resolvable in a class */
    if (strncmp(name, ITCL_INTDICTS_NAMESPACE, sizeof(ITCL_INTDICTS_NAMESPACE)-1) == 0) {
	return TCL_CONTINUE;
    }

    /*
     *  See if the requested variable is a recognized "common" member.
     *  If it is, make sure that access is allowed.
     */
    hPtr = ItclResolveVarEntry(iclsPtr, name);
    if (!hPtr) {
	return TCL_CONTINUE;
    }

    vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);

    if ((vlookup->ivPtr->flags & ITCL_COMMON) == 0) {
	return TCL_CONTINUE;
    }
    if (!vlookup->accessible) {
        Tcl_AppendResult(interp,
            "can't access \"", name, "\": ",
            Itcl_ProtectionStr(vlookup->ivPtr->protection),
            " variable",
            (char*)NULL);
        return TCL_ERROR;
    }
    hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons,
        (char *)vlookup->ivPtr);


    if (!hPtr) {
	return TCL_CONTINUE;
    }




    *rPtr = Tcl_GetHashValue(hPtr);




    return TCL_OK;
}



int
ItclSetParserResolver(
    Tcl_Namespace *nsPtr)
{
    Itcl_SetNamespaceResolvers(nsPtr, (Tcl_ResolveCmdProc*)NULL,
            Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL);
    return TCL_OK;
}