Itcl - the [incr Tcl] extension

Check-in [f95dd315b2]
Login
Core Home Timeline Branches Tags Tickets Wiki

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

Overview
Comment:merge trunk
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | sebres-memopt-perf-branch
Files: files | file ages | folders
SHA3-256: f95dd315b2d65bc2f085d5663d68209374057eaef604aa66a43adbde3bdd428d
User & Date: sebres 2019-02-09 20:23:53.135
Context
2019-02-10
01:48
merge fix from trunk check-in: fe7810c5f7 user: sebres tags: sebres-memopt-perf-branch
2019-02-09
20:23
merge trunk check-in: f95dd315b2 user: sebres tags: sebres-memopt-perf-branch
20:22
code review: revert clazzObjectPtr back to unused, remove increment workaround for OO 1.0.2 (thisPtr of clazz is removed with last ref to engine, no matter how many references still exist). check-in: b8e09f7f17 user: sebres tags: trunk
2019-02-08
23:59
merge trunk, no segfaults anymore (applied stashes, looks good, so WiP) check-in: 2b6eae425d user: sebres tags: sebres-memopt-perf-branch
Changes
Unified Diff Ignore Whitespace Patch
Changes to generic/itcl2TclOO.c.
︙︙
380
381
382
383
384
385
386
387
388
389
390
391
392
393

    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
        return 0;
    }
    return 1;
}

/* needed as work around for problem in Tcl 8.6.2 TclOO */
void
Itcl_IncrObjectRefCount(Tcl_Object ptr) {
  Object * oPtr = (Object *) ptr;
  oPtr->refCount++;
}








<
<
<
<
<
<
<

380
381
382
383
384
385
386








    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
        return 0;
    }
    return 1;
}
Changes to generic/itcl2TclOO.h.
︙︙
27
28
29
30
31
32
33
34

MODULE_SCOPE int Itcl_SelfCmd(ClientData clientData, Tcl_Interp *interp,
        int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int Itcl_IsMethodCallFrame(Tcl_Interp *interp);
MODULE_SCOPE int Itcl_InvokeEnsembleMethod(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
    Tcl_Obj *namePtr, Tcl_Proc *procPtr, int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int Itcl_InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp,
	int objc, Tcl_Obj *const *objv);
MODULE_SCOPE void Itcl_IncrObjectRefCount(Tcl_Object ptr);








<

27
28
29
30
31
32
33


MODULE_SCOPE int Itcl_SelfCmd(ClientData clientData, Tcl_Interp *interp,
        int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int Itcl_IsMethodCallFrame(Tcl_Interp *interp);
MODULE_SCOPE int Itcl_InvokeEnsembleMethod(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
    Tcl_Obj *namePtr, Tcl_Proc *procPtr, int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int Itcl_InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp,
	int objc, Tcl_Obj *const *objv);
Changes to generic/itclBase.c.
︙︙
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398

    if (clazzObjectPtr == NULL) {
        Tcl_AppendResult(interp,
                "ITCL: cannot get Object for ::itcl::clazz for class \"",
                "::itcl::clazz", "\"", NULL);
        return TCL_ERROR;
    }

    /* work around for SF bug #254 needed because of problem in TclOO 1.0.2 !! */
    if (Tcl_PkgPresent(interp, "TclOO", "1.0.2", 1) != NULL) {
	Itcl_IncrObjectRefCount(clazzObjectPtr);
    }

    infoPtr->clazzObjectPtr = clazzObjectPtr;
    infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(clazzObjectPtr);

    /*
     *  Initialize the ensemble package first, since we need this
     *  for other parts of [incr Tcl].
     */









<
<
<
<
<
<








379
380
381
382
383
384
385






386
387
388
389
390
391
392

    if (clazzObjectPtr == NULL) {
        Tcl_AppendResult(interp,
                "ITCL: cannot get Object for ::itcl::clazz for class \"",
                "::itcl::clazz", "\"", NULL);
        return TCL_ERROR;
    }







    infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(clazzObjectPtr);

    /*
     *  Initialize the ensemble package first, since we need this
     *  for other parts of [incr Tcl].
     */
︙︙
Changes to generic/itclClass.c.
︙︙
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259

    void *callbackPtr;
    int result;
    int newEntry;
    ItclResolveInfo *resolveInfoPtr;
    Tcl_Obj *cmdNamePtr;

    if (!infoPtr->clazzClassPtr
	|| Tcl_ObjectDeleted(infoPtr->clazzObjectPtr)
    ) {
	Tcl_AppendResult(interp, "oo-subsystem is deleted", NULL);
	return TCL_ERROR;
    }

    /*
     * check for an empty class name to avoid a crash








|








245
246
247
248
249
250
251
252
253
254
255
256
257
258
259

    void *callbackPtr;
    int result;
    int newEntry;
    ItclResolveInfo *resolveInfoPtr;
    Tcl_Obj *cmdNamePtr;

    if (!infoPtr->clazzClassPtr
	|| Tcl_ObjectDeleted(Tcl_GetClassAsObject(infoPtr->clazzClassPtr))
    ) {
	Tcl_AppendResult(interp, "oo-subsystem is deleted", NULL);
	return TCL_ERROR;
    }

    /*
     * check for an empty class name to avoid a crash
︙︙
Changes to generic/itclInt.h.
︙︙
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

				     * otherwise NULL */
    Tcl_ObjectMetadataType *class_meta_type;
                                    /* type for getting the Itcl class info
                                     * from a TclOO Tcl_Object */
    const Tcl_ObjectMetadataType *object_meta_type;
                                    /* type for getting the Itcl object info
                                     * from a TclOO Tcl_Object */
    Tcl_Object clazzObjectPtr;      /* the root object of Itcl */
    Tcl_Class clazzClassPtr;        /* the root class of Itcl */
    struct EnsembleInfo *ensembleInfo;
    struct ItclClass *currContextIclsPtr;
                                    /* context class for delegated option
                                     * handling */
    int currClassFlags;             /* flags for the class just in creation */
    int buildingWidget;             /* set if in construction of a widget */








|








165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

				     * otherwise NULL */
    Tcl_ObjectMetadataType *class_meta_type;
                                    /* type for getting the Itcl class info
                                     * from a TclOO Tcl_Object */
    const Tcl_ObjectMetadataType *object_meta_type;
                                    /* type for getting the Itcl object info
                                     * from a TclOO Tcl_Object */
    Tcl_Object unused1;             /* the root object of Itcl */
    Tcl_Class clazzClassPtr;        /* the root class of Itcl */
    struct EnsembleInfo *ensembleInfo;
    struct ItclClass *currContextIclsPtr;
                                    /* context class for delegated option
                                     * handling */
    int currClassFlags;             /* flags for the class just in creation */
    int buildingWidget;             /* set if in construction of a widget */
︙︙
This page was generated in about 0.016s by Fossil 2.26 [1205ec86cb] 2025-04-30 16:57:32