Index: configure ================================================================== --- configure +++ configure @@ -1,8 +1,8 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for itcl 4.1.2. +# Generated by GNU Autoconf 2.69 for itcl 4.2.0. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # @@ -575,12 +575,12 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='itcl' PACKAGE_TARNAME='itcl' -PACKAGE_VERSION='4.1.2' -PACKAGE_STRING='itcl 4.1.2' +PACKAGE_VERSION='4.2.0' +PACKAGE_STRING='itcl 4.2.0' PACKAGE_BUGREPORT='' PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ @@ -1303,11 +1303,11 @@ # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures itcl 4.1.2 to adapt to many kinds of systems. +\`configure' configures itcl 4.2.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. @@ -1364,11 +1364,11 @@ _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of itcl 4.1.2:";; + short | recursive ) echo "Configuration of itcl 4.2.0:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options @@ -1464,11 +1464,11 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -itcl configure 4.1.2 +itcl configure 4.2.0 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. @@ -1796,11 +1796,11 @@ } # ac_fn_c_check_type cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by itcl $as_me 4.1.2, which was +It was created by itcl $as_me 4.2.0, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF @@ -8828,11 +8828,11 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by itcl $as_me 4.1.2, which was +This file was extended by itcl $as_me 4.2.0, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS @@ -8881,11 +8881,11 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -itcl config.status 4.1.2 +itcl config.status 4.2.0 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation Index: configure.ac ================================================================== --- configure.ac +++ configure.ac @@ -17,11 +17,11 @@ # so you can encode the package version directly into the source files. # This will also define a special symbol for Windows (BUILD_ # so that we create the export library with the dll. #----------------------------------------------------------------------- -AC_INIT([itcl], [4.1.2]) +AC_INIT([itcl], [4.2.0]) #-------------------------------------------------------------------- # Call TEA_INIT as the first TEA_ macro to set up initial vars. # This will define a ${TEA_PLATFORM} variable == "unix" or "windows" # as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE. Index: doc/Preserve.3 ================================================================== --- doc/Preserve.3 +++ doc/Preserve.3 @@ -7,32 +7,76 @@ .TH Itcl_PreserveData 3 3.0 itcl "[incr\ Tcl] Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Itcl_PreserveData, Itcl_ReleaseData, Itcl_EventuallyFree \- Manipulate an Itcl list object. +Itcl_Alloc, Itcl_Free, Itcl_PreserveData, Itcl_ReleaseData, Itcl_EventuallyFree \- Manipulate an Itcl list object. .SH SYNOPSIS .nf \fB#include \fR +void * +\fBItcl_Alloc\fR(\fIsize\fR) + +void +\fBItcl_PreserveData\fR(\fIptr\fR) + void -\fBItcl_PreserveData\fR(\fIcdata\fR) +\fBItcl_ReleaseData\fR(\fIptr\fR) void -\fBItcl_ReleaseData\fR(\fIcdata\fR) +\fBItcl_EventuallyFree\fR(\fIptr, fproc\fR) void -\fBItcl_EventuallyFree\fR(\fIcdata, fproc\fR) +\fBItcl_Free\fR(\fIptr\fR) .fi .SH ARGUMENTS +.AP size_t size in +Number of bytes to allocate. +.AP void *ptr in +Pointer value allocated by \fBItcl_Alloc\fR. .AP Tcl_FreeProc *fproc in Address of function to call when the block is to be freed. -.AP ClientData clientData in -Arbitrary one-word value. .BE .SH DESCRIPTION .PP +These procedures are used to allocate and release memory, especially blocks +of memory that will be used by multiple independent modules. They are similar +in function to the routines in the public Tcl interface, \fBTcl_Alloc\fR, +\fBTcl_Free\fR, \fBTcl_Preserve\fR, \fBTcl_Release\fR, and +\fBTcl_EventuallyFree\fR. The Tcl routines suffer from issues with +performance scaling as the number of blocks managed grows large. The facilities +of Itcl encounter these performance scaling issues and require an +alternative that does not suffer from them. +.PP +\fBItcl_Alloc\fR returns an untyped pointer to an allocated block +of memory of at least \fIsize\fR bytes. +.PP +A module calls \fBItcl_PreserveData\fR on a pointer \fIptr\fR +allocated by \fBItcl_Alloc\fR to prevent deallocation of that memory while +the module remains interested in it. +.PP +A module calls \fBItcl_ReleaseData\fR on a pointer \fIptr\fR previously +preserved by \fBItcl_PreserveData\fR to indicate the module no longer has +an interest in the block of memory, and will not be disturbed by its +deallocation. +.PP +\fBItcl_EventuallyFree\fR is called on a pointer \fIptr\fR allocated by +\fBItcl_Alloc\fR to register a deallocation routine \fIfproc\fR to be +called when the number of calls to \fBItcl_ReleaseData\fR on \fIptr\fR +matches the number of calls to \fBItcl_PreserveData\fR on \fIptr\fR. This +condition indicates all modules have ended their interest in the block +of memory and a call to \fIfproc\ with argument \fIptr\fR will deallocate +the memory that no module needs anymore. +.PP +\fBItcl_Free\fR is a deallocation routine for a \fIptr\fR value allocated +by \fBItcl_Alloc\fR. It may be called on any \fIptr\fR with no history of +an \fBItcl_PreserveData\fR call unmatched by an \fBItcl_ReleaseData\fR +call. It is best used as an \fIfproc\fR argument to \fBItcl_EventuallyFree\fR +or as a routine called from within such an \fIfproc\fR routine. It can also +be used to deallocate a \fIptr\fR value when it can be assured that value +has never been passed to \fBItcl_PreserveData\fR or \fBItcl_EventuallyFree\fR. .SH KEYWORDS free, memory Index: generic/itcl.decls ================================================================== --- generic/itcl.decls +++ generic/itcl.decls @@ -87,10 +87,16 @@ int Itcl_RestoreInterpState(Tcl_Interp *interp, Itcl_InterpState state) } declare 25 { void Itcl_DiscardInterpState(Itcl_InterpState state) } +declare 26 { + void * Itcl_Alloc(size_t size) +} +declare 27 { + void Itcl_Free(void *ptr) +} # private API interface itclInt # Index: generic/itcl.h ================================================================== --- generic/itcl.h +++ generic/itcl.h @@ -78,16 +78,16 @@ #ifndef TCL_FINAL_RELEASE # define TCL_FINAL_RELEASE 2 #endif #define ITCL_MAJOR_VERSION 4 -#define ITCL_MINOR_VERSION 1 +#define ITCL_MINOR_VERSION 2 #define ITCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define ITCL_RELEASE_SERIAL 2 +#define ITCL_RELEASE_SERIAL 0 -#define ITCL_VERSION "4.1" -#define ITCL_PATCH_LEVEL "4.1.2" +#define ITCL_VERSION "4.2" +#define ITCL_PATCH_LEVEL "4.2.0" /* * A special definition used to allow this header file to be included from * windows resource files so that they can obtain version information. Index: generic/itclBase.c ================================================================== --- generic/itclBase.c +++ generic/itclBase.c @@ -192,32 +192,31 @@ Tcl_DecrRefCount(objPtr); return TCL_ERROR; } Tcl_DecrRefCount(objPtr); - infoPtr = (ItclObjectInfo*)ckalloc(sizeof(ItclObjectInfo)); + infoPtr = (ItclObjectInfo*)Itcl_Alloc(sizeof(ItclObjectInfo)); nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE, infoPtr, FreeItclObjectInfo); if (nsPtr == NULL) { - ckfree(infoPtr); + Itcl_Free(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); + Itcl_Free(infoPtr); Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n", ITCL_NAMESPACE); } /* * Create the top-level data structure for tracking objects. * Store this as "associated data" for easy access, but link * it to the itcl namespace for ownership. */ - memset(infoPtr, 0, sizeof(ItclObjectInfo)); infoPtr->interp = interp; infoPtr->class_meta_type = (Tcl_ObjectMetadataType *)ckalloc( sizeof(Tcl_ObjectMetadataType)); infoPtr->class_meta_type->version = TCL_OO_METADATA_VERSION_CURRENT; infoPtr->class_meta_type->name = "ItclClass"; Index: generic/itclClass.c ================================================================== --- generic/itclClass.c +++ generic/itclClass.c @@ -291,11 +291,11 @@ Itcl_InitList(&iclsPtr->bases); Itcl_InitList(&iclsPtr->derived); resolveInfoPtr = (ItclResolveInfo *) ckalloc(sizeof(ItclResolveInfo)); - memset (resolveInfoPtr, 0, sizeof(ItclResolveInfo)); + memset(resolveInfoPtr, 0, sizeof(ItclResolveInfo)); resolveInfoPtr->flags = ITCL_RESOLVE_CLASS; resolveInfoPtr->iclsPtr = iclsPtr; iclsPtr->resolvePtr = (Tcl_Resolve *)ckalloc(sizeof(Tcl_Resolve)); iclsPtr->resolvePtr->cmdProcPtr = Itcl_CmdAliasProc; iclsPtr->resolvePtr->varProcPtr = Itcl_VarAliasProc; @@ -902,14 +902,14 @@ while (hPtr) { ioPtr = (ItclObject*)Tcl_GetHashValue(hPtr); if (ioPtr->iclsPtr == iclsPtr) { if ((ioPtr->accessCmd != NULL) && (!(ioPtr->flags & (ITCL_OBJECT_IS_DESTRUCTED)))) { - ItclPreserveObject(ioPtr); + Itcl_PreserveData(ioPtr); Tcl_DeleteCommandFromToken(iclsPtr->interp, ioPtr->accessCmd); ioPtr->accessCmd = NULL; - ItclReleaseObject(ioPtr); + Itcl_ReleaseData(ioPtr); /* * Fix 227804: Whenever an object to delete was found we * have to reset the search to the beginning as the * current entry in the search was deleted and accessing it * is therefore not allowed anymore. @@ -1076,11 +1076,11 @@ /* * Delete all function definitions. */ FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { imPtr->iclsPtr = NULL; - ItclReleaseIMF(imPtr); + Itcl_ReleaseData(imPtr); } Tcl_DeleteHashTable(&iclsPtr->functions); /* * Delete all delegated options. @@ -1211,11 +1211,11 @@ if (iclsPtr->resolvePtr != NULL) { ckfree((char *)iclsPtr->resolvePtr->clientData); ckfree((char *)iclsPtr->resolvePtr); } - ckfree((char*)iclsPtr); + ckfree(iclsPtr); } /* * ------------------------------------------------------------------------ @@ -1956,21 +1956,20 @@ if (Itcl_CreateMemberCode(interp, iclsPtr, NULL, config, &mCodePtr) != TCL_OK) { Tcl_DeleteHashEntry(hPtr); return TCL_ERROR; } - ItclPreserveMemberCode(mCodePtr); + Itcl_PreserveData(mCodePtr); } else { mCodePtr = NULL; } /* * If everything looks good, create the variable definition. */ - ivPtr = (ItclVariable*)ckalloc(sizeof(ItclVariable)); - memset(ivPtr, 0, sizeof(ItclVariable)); + ivPtr = (ItclVariable*)Itcl_Alloc(sizeof(ItclVariable)); ivPtr->iclsPtr = iclsPtr; ivPtr->infoPtr = iclsPtr->infoPtr; ivPtr->protection = Itcl_Protection(interp, 0); ivPtr->codePtr = mCodePtr; ivPtr->namePtr = namePtr; @@ -2327,21 +2326,21 @@ if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } } if (ivPtr->codePtr != NULL) { - ItclReleaseMemberCode(ivPtr->codePtr); + Itcl_ReleaseData(ivPtr->codePtr); } Tcl_DecrRefCount(ivPtr->namePtr); Tcl_DecrRefCount(ivPtr->fullNamePtr); if (ivPtr->init) { Tcl_DecrRefCount(ivPtr->init); } if (ivPtr->arrayInitPtr) { Tcl_DecrRefCount(ivPtr->arrayInitPtr); } - ckfree((char*)ivPtr); + Itcl_Free(ivPtr); } /* * ------------------------------------------------------------------------ * ItclDeleteOption() @@ -2365,11 +2364,11 @@ if (ioptPtr->resourceNamePtr != NULL) { Tcl_DecrRefCount(ioptPtr->classNamePtr); } if (ioptPtr->codePtr) { - ItclReleaseMemberCode(ioptPtr->codePtr); + Itcl_ReleaseData(ioptPtr->codePtr); } if (ioptPtr->defaultValuePtr != NULL) { Tcl_DecrRefCount(ioptPtr->defaultValuePtr); } if (ioptPtr->cgetMethodPtr != NULL) { @@ -2389,11 +2388,11 @@ } if (ioptPtr->validateMethodVarPtr != NULL) { Tcl_DecrRefCount(ioptPtr->validateMethodVarPtr); } Itcl_ReleaseData(ioptPtr->idoPtr); - ckfree((char*)ioptPtr); + Itcl_Free(ioptPtr); } /* * ------------------------------------------------------------------------ * ItclDeleteFunction() @@ -2420,11 +2419,11 @@ if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } } if (imPtr->codePtr != NULL) { - ItclReleaseMemberCode(imPtr->codePtr); + Itcl_ReleaseData(imPtr->codePtr); } Tcl_DecrRefCount(imPtr->namePtr); Tcl_DecrRefCount(imPtr->fullNamePtr); if (imPtr->usagePtr != NULL) { Tcl_DecrRefCount(imPtr->usagePtr); @@ -2442,11 +2441,11 @@ Tcl_DecrRefCount(imPtr->bodyPtr); } if (imPtr->argListPtr != NULL) { ItclDeleteArgList(imPtr->argListPtr); } - ckfree((char*)imPtr); + Itcl_Free(imPtr); } /* * ------------------------------------------------------------------------ * ItclDeleteComponent() @@ -2503,11 +2502,11 @@ if (objPtr != NULL) { Tcl_DecrRefCount(objPtr); } } Tcl_DeleteHashTable(&idoPtr->exceptions); - ckfree((char *)idoPtr); + Itcl_Free(idoPtr); } /* * ------------------------------------------------------------------------ * ItclDeleteDelegatedFunction() Index: generic/itclDecls.h ================================================================== --- generic/itclDecls.h +++ generic/itclDecls.h @@ -17,11 +17,11 @@ /* !BEGIN!: Do not edit below this line. */ #define ITCL_STUBS_EPOCH 0 -#define ITCL_STUBS_REVISION 150 +#define ITCL_STUBS_REVISION 152 #ifdef __cplusplus extern "C" { #endif @@ -90,10 +90,14 @@ /* 24 */ ITCLAPI int Itcl_RestoreInterpState(Tcl_Interp *interp, Itcl_InterpState state); /* 25 */ ITCLAPI void Itcl_DiscardInterpState(Itcl_InterpState state); +/* 26 */ +ITCLAPI void * Itcl_Alloc(size_t size); +/* 27 */ +ITCLAPI void Itcl_Free(void *ptr); typedef struct { const struct ItclIntStubs *itclIntStubs; } ItclStubHooks; @@ -127,10 +131,12 @@ void (*itcl_PreserveData) (ClientData cdata); /* 21 */ void (*itcl_ReleaseData) (ClientData cdata); /* 22 */ Itcl_InterpState (*itcl_SaveInterpState) (Tcl_Interp *interp, int status); /* 23 */ int (*itcl_RestoreInterpState) (Tcl_Interp *interp, Itcl_InterpState state); /* 24 */ void (*itcl_DiscardInterpState) (Itcl_InterpState state); /* 25 */ + void * (*itcl_Alloc) (size_t size); /* 26 */ + void (*itcl_Free) (void *ptr); /* 27 */ } ItclStubs; extern const ItclStubs *itclStubsPtr; #ifdef __cplusplus @@ -191,11 +197,15 @@ (itclStubsPtr->itcl_SaveInterpState) /* 23 */ #define Itcl_RestoreInterpState \ (itclStubsPtr->itcl_RestoreInterpState) /* 24 */ #define Itcl_DiscardInterpState \ (itclStubsPtr->itcl_DiscardInterpState) /* 25 */ +#define Itcl_Alloc \ + (itclStubsPtr->itcl_Alloc) /* 26 */ +#define Itcl_Free \ + (itclStubsPtr->itcl_Free) /* 27 */ #endif /* defined(USE_ITCL_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* _ITCLDECLS */ Index: generic/itclInt.h ================================================================== --- generic/itclInt.h +++ generic/itclInt.h @@ -372,11 +372,10 @@ int destructorHasBeenCalled; /* is set when the destructor is called * to avoid callin destructor twice */ int noComponentTrace; /* don't call component traces if * setting components in DelegationInstall */ int hadConstructorError; /* needed for multiple calls of CallItclObjectCmd */ - int refCount; } ItclObject; #define ITCL_IGNORE_ERRS 0x002 /* useful for construction/destruction */ typedef struct ItclResolveInfo { @@ -402,11 +401,10 @@ union { Tcl_CmdProc *argCmd; /* (argc,argv) C implementation */ Tcl_ObjCmdProc *objCmd; /* (objc,objv) C implementation */ } cfunc; ClientData clientData; /* client data for C implementations */ - int refCount; } ItclMemberCode; /* * Flag bits for ItclMemberCode: */ @@ -504,11 +502,10 @@ ItclArgList *argListPtr; /* the parsed arguments */ ItclClass *declaringClassPtr; /* the class which declared the method/proc */ ClientData tmPtr; /* TclOO methodPtr */ ItclDelegatedFunction *idmPtr; /* if the function is delegated != NULL */ - int refCount; } ItclMemberFunc; /* * Instance variables. */ @@ -661,22 +658,13 @@ MODULE_SCOPE Tcl_ObjCmdProc ItclCallCCommand; MODULE_SCOPE Tcl_ObjCmdProc ItclObjectUnknownCommand; MODULE_SCOPE int ItclCheckCallProc(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext contextPtr, Tcl_CallFrame *framePtr, int *isFinished); -MODULE_SCOPE void ItclPreserveIMF(ItclMemberFunc *imPtr); -MODULE_SCOPE void ItclReleaseIMF(ClientData imPtr); - MODULE_SCOPE void ItclPreserveClass(ItclClass *iclsPtr); MODULE_SCOPE void ItclReleaseClass(ClientData iclsPtr); -MODULE_SCOPE void ItclPreserveMemberCode(ItclMemberCode *mcodePtr); -MODULE_SCOPE void ItclReleaseMemberCode(ItclMemberCode *mcodePtr); - -MODULE_SCOPE void ItclPreserveObject(ItclObject *ioPtr); -MODULE_SCOPE void ItclReleaseObject(ClientData ioPtr); - MODULE_SCOPE ItclFoundation *ItclGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc ItclClassCommandDispatcher; MODULE_SCOPE Tcl_Command Itcl_CmdAliasProc(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *cmdName, ClientData clientData); MODULE_SCOPE Tcl_Var Itcl_VarAliasProc(Tcl_Interp *interp, Index: generic/itclIntDecls.h ================================================================== --- generic/itclIntDecls.h +++ generic/itclIntDecls.h @@ -6,11 +6,11 @@ #define _ITCLINTDECLS /* !BEGIN!: Do not edit below this line. */ #define ITCLINT_STUBS_EPOCH 0 -#define ITCLINT_STUBS_REVISION 150 +#define ITCLINT_STUBS_REVISION 152 #ifdef __cplusplus extern "C" { #endif Index: generic/itclMethod.c ================================================================== --- generic/itclMethod.c +++ generic/itclMethod.c @@ -38,46 +38,12 @@ const char* arglist, const char* body, ItclMemberCode** mcodePtr, Tcl_Obj *namePtr, int flags); static int ItclCreateMemberFunc(Tcl_Interp* interp, ItclClass *iclsPtr, Tcl_Obj *namePtr, const char* arglist, const char* body, ItclMemberFunc** imPtrPtr, int flags); -void ItclFreeMemberCode (ItclMemberCode *mcodePtr); - -void -ItclPreserveIMF( - ItclMemberFunc *imPtr) -{ - imPtr->refCount++; -} - -void -ItclReleaseIMF( - ClientData clientData) -{ - ItclMemberFunc *imPtr = (ItclMemberFunc *)clientData; - - if (imPtr->refCount-- <= 1) { - Itcl_DeleteMemberFunc(clientData); - } -} - -void -ItclPreserveMemberCode( - ItclMemberCode *mcodePtr) -{ - mcodePtr->refCount++; -} - -void -ItclReleaseMemberCode( - ItclMemberCode *mcodePtr) -{ - if (mcodePtr->refCount-- <= 1) { - ItclFreeMemberCode(mcodePtr); - } -} - +static void FreeMemberCode(ItclMemberCode *mcodePtr); + /* * ------------------------------------------------------------------------ * Itcl_BodyCmd() * * Invoked by Tcl whenever the user issues an "itcl::body" command to @@ -308,14 +274,14 @@ &mcode) != TCL_OK) { status = TCL_ERROR; goto configBodyCmdDone; } - ItclPreserveMemberCode(mcode); + Itcl_PreserveData(mcode); if (ivPtr->codePtr) { - ItclReleaseMemberCode(ivPtr->codePtr); + Itcl_ReleaseData(ivPtr->codePtr); } ivPtr->codePtr = mcode; configBodyCmdDone: Tcl_DStringFree(&buffer); @@ -515,12 +481,12 @@ } /* * Allocate a member function definition and return. */ - imPtr = (ItclMemberFunc*)ckalloc(sizeof(ItclMemberFunc)); - memset(imPtr, 0, sizeof(ItclMemberFunc)); + imPtr = (ItclMemberFunc*)Itcl_Alloc(sizeof(ItclMemberFunc)); + Itcl_EventuallyFree(imPtr, (Tcl_FreeProc *)Itcl_DeleteMemberFunc); imPtr->iclsPtr = iclsPtr; imPtr->infoPtr = iclsPtr->infoPtr; imPtr->protection = Itcl_Protection(interp, 0); imPtr->namePtr = Tcl_NewStringObj(Tcl_GetString(namePtr), -1); Tcl_IncrRefCount(imPtr->namePtr); @@ -532,11 +498,11 @@ if (arglist != NULL) { imPtr->origArgsPtr = Tcl_NewStringObj(arglist, -1); Tcl_IncrRefCount(imPtr->origArgsPtr); } imPtr->codePtr = mcode; - ItclPreserveMemberCode(mcode); + Itcl_PreserveData(mcode); if (imPtr->protection == ITCL_DEFAULT_PROTECT) { imPtr->protection = ITCL_PUBLIC; } @@ -675,11 +641,11 @@ if (strcmp(name, "destructor") == 0) { imPtr->flags |= ITCL_DESTRUCTOR; } Tcl_SetHashValue(hPtr, imPtr); - imPtr->refCount = 1; + Itcl_PreserveData(imPtr); *imPtrPtr = imPtr; return TCL_OK; } @@ -765,11 +731,12 @@ "argument list changed for function \"", Tcl_GetString(imPtr->fullNamePtr), "\": should be \"", argsStr, "\"", NULL); - Itcl_DeleteMemberCode(mcode); + Itcl_PreserveData(mcode); + Itcl_ReleaseData(mcode); return TCL_ERROR; } if (imPtr->flags & ITCL_CONSTRUCTOR) { /* @@ -791,12 +758,12 @@ } /* * Free up the old implementation and install the new one. */ - ItclPreserveMemberCode(mcode); - ItclReleaseMemberCode(imPtr->codePtr); + Itcl_PreserveData(mcode); + Itcl_ReleaseData(imPtr->codePtr); imPtr->codePtr = mcode; if (mcode->flags & ITCL_IMPLEMENT_TCL) { ClientData pmPtr; imPtr->tmPtr = Itcl_NewProcClassMethod(interp, imPtr->iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod, @@ -858,17 +825,18 @@ int haveError; /* * Allocate some space to hold the implementation. */ - mcode = (ItclMemberCode*)ckalloc(sizeof(ItclMemberCode)); - memset(mcode, 0, sizeof(ItclMemberCode)); + mcode = (ItclMemberCode*)Itcl_Alloc(sizeof(ItclMemberCode)); + Itcl_EventuallyFree(mcode, (Tcl_FreeProc *)FreeMemberCode); if (arglist) { if (ItclCreateArgList(interp, arglist, &argc, &maxArgc, &usagePtr, &argListPtr, NULL, NULL) != TCL_OK) { - Itcl_DeleteMemberCode(mcode); + Itcl_PreserveData(mcode); + Itcl_ReleaseData(mcode); return TCL_ERROR; } mcode->argcount = argc; mcode->maxargcount = maxArgc; mcode->argListPtr = argListPtr; @@ -907,11 +875,12 @@ Tcl_AppendResult(interp, startStr, namePtr == NULL ? "??" : Tcl_GetString(namePtr), "'s arglist may not contain \"", *cPtrPtr, "\" explicitly", NULL); - Itcl_DeleteMemberCode(mcode); + Itcl_PreserveData(mcode); + Itcl_ReleaseData(mcode); return TCL_ERROR; } cPtrPtr++; } argListPtr = argListPtr->nextPtr; @@ -1024,11 +993,12 @@ if (!Itcl_FindC(interp, body+1, &argCmdProc, &objCmdProc, &cdata)) { Tcl_AppendResult(interp, "no registered C procedure with name \"", body+1, "\"", NULL); - Itcl_DeleteMemberCode(mcode); + Itcl_PreserveData(mcode); + Itcl_ReleaseData(mcode); return TCL_ERROR; } /* * WARNING! WARNING! WARNING! @@ -1078,11 +1048,11 @@ * class member function. This includes the argument list and the body * of the function. If the body is of the form "@name", then it is * treated as a label for a C procedure registered by Itcl_RegisterC(). * * A member function definition holds a handle for the implementation, and - * calls ItclReleaseMemberCode when finished with it. + * uses Itcl_PreserveData and Itcl_ReleaseData to manage its interest in it. * * If any errors are encountered, this procedure returns TCL_ERROR * along with an error message in the interpreter. Otherwise, it * returns TCL_OK, and stores a pointer to the new implementation in * "mcodePtr". @@ -1107,11 +1077,11 @@ * Destroys all data associated with the given command implementation. * Invoked automatically by ItclReleaseData() when the implementation * is no longer being used. * ------------------------------------------------------------------------ */ -void ItclFreeMemberCode ( +void FreeMemberCode ( ItclMemberCode* mCodePtr) { if (mCodePtr == NULL) { return; } @@ -1125,19 +1095,19 @@ Tcl_DecrRefCount(mCodePtr->argumentPtr); } if (mCodePtr->bodyPtr != NULL) { Tcl_DecrRefCount(mCodePtr->bodyPtr); } - ckfree((char*)mCodePtr); + Itcl_Free(mCodePtr); } void Itcl_DeleteMemberCode( void* cdata) /* pointer to member code definition */ { - ItclReleaseMemberCode((ItclMemberCode *)cdata); + Itcl_ReleaseData((ItclMemberCode *)cdata); } /* * ------------------------------------------------------------------------ @@ -1288,11 +1258,11 @@ /* * Bump the reference count on this code, in case it is * redefined or deleted during execution. */ - ItclPreserveMemberCode(mcode); + Itcl_PreserveData(mcode); if ((imPtr->flags & ITCL_DESTRUCTOR) && (contextIoPtr != NULL)) { contextIoPtr->destructorHasBeenCalled = 1; } @@ -1326,11 +1296,11 @@ INT2PTR(objc), (void *)objv); result = Itcl_NRRunCallbacks(interp, callbackPtr); } } - ItclReleaseMemberCode(mcode); + Itcl_ReleaseData(mcode); return result; } /* * ------------------------------------------------------------------------ @@ -1727,13 +1697,13 @@ /* * Execute the code for the method. Be careful to protect * the method in case it gets deleted during execution. */ - ItclPreserveIMF(imPtr); + Itcl_PreserveData(imPtr); result = Itcl_EvalMemberCode(interp, imPtr, ioPtr, objc, objv); - ItclReleaseIMF(imPtr); + Itcl_ReleaseData(imPtr); return result; } /* ARGSUSED */ int @@ -1813,15 +1783,15 @@ /* * Execute the code for the proc. Be careful to protect * the proc in case it gets deleted during execution. */ - ItclPreserveIMF(imPtr); + Itcl_PreserveData(imPtr); result = Itcl_EvalMemberCode(interp, imPtr, NULL, objc, objv); - ItclReleaseIMF(imPtr); + Itcl_ReleaseData(imPtr); return result; } /* ARGSUSED */ int @@ -2010,19 +1980,19 @@ ItclShowArgs(1, "EMC", cmdlinec, cmdlinev); /* * Execute the code for the method. Be careful to protect * the method in case it gets deleted during execution. */ - ItclPreserveIMF(imPtr); + Itcl_PreserveData(imPtr); if (contextObjectPtr->oPtr == NULL) { Tcl_DecrRefCount(cmdlinePtr); return TCL_ERROR; } result = Itcl_EvalMemberCode(interp, imPtr, contextObjectPtr, cmdlinec, cmdlinev); - ItclReleaseIMF(imPtr); + Itcl_ReleaseData(imPtr); Tcl_DecrRefCount(cmdlinePtr); } else { if (contextClassPtr->flags & (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { if (strcmp(name, "constructor") == 0) { @@ -2348,11 +2318,11 @@ ItclObjectInfo *infoPtr; oPtr = NULL; hPtr = NULL; imPtr = (ItclMemberFunc *)clientData; - ItclPreserveIMF(imPtr); + Itcl_PreserveData(imPtr); if (imPtr->flags & ITCL_CONSTRUCTOR) { ioPtr = imPtr->iclsPtr->infoPtr->currIoPtr; } else { if (contextPtr == NULL) { if ((imPtr->flags & ITCL_COMMON) || @@ -2485,11 +2455,11 @@ Itcl_PushStack(framePtr, stackPtr); if (ioPtr != NULL) { ioPtr->callRefCount++; - ItclPreserveObject(ioPtr); + Itcl_PreserveData(ioPtr); } imPtr->iclsPtr->callRefCount++; if (!imPtr->iclsPtr->infoPtr->useOldResolvers) { Itcl_SetCallFrameResolver(interp, ioPtr->resolvePtr); } @@ -2498,11 +2468,11 @@ if (isFinished != NULL) { *isFinished = 0; } return result; finishReturn: - ItclReleaseIMF(imPtr); + Itcl_ReleaseData(imPtr); return result; } /* * ------------------------------------------------------------------------ @@ -2599,18 +2569,18 @@ hPtr = Tcl_FindHashEntry(&callContextPtr->ioPtr->contextCache, (char *)callContextPtr->imPtr); if (hPtr == NULL) { ckfree((char *)callContextPtr); } - ItclReleaseObject(ioPtr); + Itcl_ReleaseData(ioPtr); } else { ckfree((char *)callContextPtr); } } result = call_result; finishReturn: - ItclReleaseIMF(imPtr); + Itcl_ReleaseData(imPtr); return result; } void ItclProcErrorProc( Index: generic/itclObject.c ================================================================== --- generic/itclObject.c +++ generic/itclObject.c @@ -51,11 +51,11 @@ const char *name1, const char *name2, int flags); static char* ItclTraceItclHullVar(ClientData cdata, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void ItclDestroyObject(ClientData clientData); -static void ItclFreeObject(char * clientData); +static Tcl_FreeProc FreeObject; static int ItclDestructBase(Tcl_Interp *interp, ItclObject *contextObj, ItclClass *contextClass, int flags); static int ItclInitObjectVariables(Tcl_Interp *interp, ItclObject *ioPtr, @@ -68,28 +68,10 @@ static const char * GetConstructorVar(Tcl_Interp *interp, ItclClass *iclsPtr, const char *varName); static ItclClass * GetClassFromClassName(Tcl_Interp *interp, const char *className, ItclClass *iclsPtr); -void -ItclPreserveObject( - ItclObject *ioPtr) -{ - ioPtr->refCount++; -} - -void -ItclReleaseObject( - ClientData clientData) -{ - ItclObject *ioPtr = (ItclObject *)clientData; - - if (ioPtr->refCount-- <= 1) { - ItclFreeObject((char *) clientData); - } -} - /* * ------------------------------------------------------------------------ * ItclDeleteObjectMetadata() * @@ -263,12 +245,12 @@ infoPtr->lastIoPtr = NULL; } /* * Create a new object and initialize it. */ - ioPtr = (ItclObject*)ckalloc(sizeof(ItclObject)); - memset(ioPtr, 0, sizeof(ItclObject)); + ioPtr = (ItclObject*)Itcl_Alloc(sizeof(ItclObject)); + Itcl_EventuallyFree(ioPtr, FreeObject); ioPtr->iclsPtr = iclsPtr; ioPtr->interp = interp; ioPtr->infoPtr = infoPtr; ItclPreserveClass(iclsPtr); @@ -276,20 +258,20 @@ Tcl_InitObjHashTable(ioPtr->constructed); ioPtr->oPtr = Tcl_NewObjectInstance(interp, iclsPtr->clsPtr, NULL, /* nsName */ NULL, /* objc */ -1, /* objv */ NULL, /* skip */ 0); if (ioPtr->oPtr == NULL) { - ckfree(ioPtr); + Itcl_Free(ioPtr); return TCL_ERROR; } /* * Add a command to the current namespace with the object name. * This is done before invoking the constructors so that the * command can be used during construction to query info. */ - ItclPreserveObject(ioPtr); + Itcl_PreserveData(ioPtr); ioPtr->namePtr = Tcl_NewStringObj(name, -1); Tcl_IncrRefCount(ioPtr->namePtr); nsName = Tcl_GetCurrentNamespace(interp)->fullName; ioPtr->origNamePtr = Tcl_NewStringObj("", -1); @@ -315,11 +297,11 @@ Tcl_InitObjHashTable(&ioPtr->objectDelegatedOptions); Tcl_InitObjHashTable(&ioPtr->objectDelegatedFunctions); Tcl_InitObjHashTable(&ioPtr->objectMethodVariables); Tcl_InitHashTable(&ioPtr->contextCache, TCL_ONE_WORD_KEYS); - ItclPreserveObject(ioPtr); + Itcl_PreserveData(ioPtr); /* * Install the class namespace and object context so that * the object's data members can be initialized via simple * "set" commands. @@ -510,11 +492,11 @@ ioPtr->accessCmd = NULL; } result = Itcl_RestoreInterpState(interp, istate); infoPtr->currIoPtr = saveCurrIoPtr; /* need this for 2 ReleaseData at errorReturn!! */ - ItclPreserveObject(ioPtr); + Itcl_PreserveData(ioPtr); goto errorReturn; } else { /* a constructor cannot return a result as the object name * is returned as result */ Tcl_ResetResult(interp); @@ -559,11 +541,11 @@ Tcl_DeleteCommandFromToken(interp, ioPtr->accessCmd); ioPtr->accessCmd = NULL; } result = Itcl_RestoreInterpState(interp, istate); /* need this for 2 ReleaseData at errorReturn!! */ - ItclPreserveObject(ioPtr); + Itcl_PreserveData(ioPtr); goto errorReturn; } if (iclsPtr->flags & ITCL_WIDGETADAPTOR) { @@ -611,11 +593,11 @@ Tcl_DeleteCommandFromToken(interp, ioPtr->accessCmd); ioPtr->accessCmd = NULL; } result = Itcl_RestoreInterpState(interp, istate); /* need this for 2 ReleaseData at errorReturn!! */ - ItclPreserveObject(ioPtr); + Itcl_PreserveData(ioPtr); goto errorReturn; } } /* @@ -703,11 +685,11 @@ infoPtr->lastIoPtr = ioPtr; Tcl_DeleteHashTable(ioPtr->constructed); ckfree((char*)ioPtr->constructed); ioPtr->constructed = NULL; ItclAddObjectsDictInfo(interp, ioPtr); - ItclReleaseObject(ioPtr); + Itcl_ReleaseData(ioPtr); return result; errorReturn: /* * At this point, the object is not constructed as there was an error. @@ -728,12 +710,12 @@ Tcl_DeleteHashTable(ioPtr->constructed); ckfree((char*)ioPtr->constructed); ioPtr->constructed = NULL; } ItclDeleteObjectVariablesNamespace(interp, ioPtr); - ItclReleaseObject(ioPtr); - ItclReleaseObject(ioPtr); + Itcl_ReleaseData(ioPtr); + Itcl_ReleaseData(ioPtr); return result; } /* * ------------------------------------------------------------------------ @@ -1223,17 +1205,17 @@ Tcl_GetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo); contextIoPtr->flags |= ITCL_OBJECT_IS_DELETED; - ItclPreserveObject(contextIoPtr); + Itcl_PreserveData(contextIoPtr); /* * Invoke the object's destructors. */ if (Itcl_DestructObject(interp, contextIoPtr, 0) != TCL_OK) { - ItclReleaseObject(contextIoPtr); + Itcl_ReleaseData(contextIoPtr); contextIoPtr->flags |= ITCL_TCLOO_OBJECT_IS_DELETED|ITCL_OBJECT_DESTRUCT_ERROR; return TCL_ERROR; } /* @@ -1253,20 +1235,20 @@ * the last use of the object data, the object will die here. */ if ((contextIoPtr->accessCmd != NULL) && (!(contextIoPtr->flags & (ITCL_OBJECT_IS_RENAMED)))) { if (Tcl_GetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo) == 1) { - cmdInfo.deleteProc = ItclReleaseObject; + cmdInfo.deleteProc = (Tcl_CmdDeleteProc *)Itcl_ReleaseData; Tcl_SetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo); Tcl_DeleteCommandFromToken(interp, contextIoPtr->accessCmd); } } contextIoPtr->oPtr = NULL; contextIoPtr->accessCmd = NULL; - ItclReleaseObject(contextIoPtr); + Itcl_ReleaseData(contextIoPtr); return TCL_OK; } /* @@ -2635,24 +2617,23 @@ if (hPtr) { Tcl_DeleteHashEntry(hPtr); } contextIoPtr->accessCmd = NULL; } - ItclReleaseObject(contextIoPtr); + Itcl_ReleaseData(contextIoPtr); } /* * ------------------------------------------------------------------------ - * ItclFreeObject() + * FreeObject() * * Deletes all instance variables and frees all memory associated with - * the given object instance. This is usually invoked automatically - * by ItclReleaseObject(), when an object's data is no longer being used. + * the given object instance. Called when releases match preserves. * ------------------------------------------------------------------------ */ static void -ItclFreeObject( +FreeObject( char * cdata) /* object instance data */ { FOREACH_HASH_DECLS; Tcl_HashSearch place; ItclCallContext *callContextPtr; @@ -2717,11 +2698,11 @@ Tcl_DecrRefCount(ioPtr->varNsNamePtr); if (ioPtr->resolvePtr != NULL) { ckfree((char *)ioPtr->resolvePtr->clientData); ckfree((char*)ioPtr->resolvePtr); } - ckfree((char*)ioPtr); + Itcl_Free(ioPtr); } /* * ------------------------------------------------------------------------ * ItclObjectCmd() Index: generic/itclParse.c ================================================================== --- generic/itclParse.c +++ generic/itclParse.c @@ -637,29 +637,29 @@ static const Tcl_MethodType itclObjMethodType = { TCL_OO_METHOD_VERSION_CURRENT, "itcl objv method", ObjCallProc, - ItclReleaseIMF, + Itcl_ReleaseData, CloneProc }; static const Tcl_MethodType itclArgMethodType = { TCL_OO_METHOD_VERSION_CURRENT, "itcl argv method", ArgCallProc, - ItclReleaseIMF, + Itcl_ReleaseData, CloneProc }; static int CloneProc( Tcl_Interp *interp, ClientData original, ClientData *copyPtr) { - ItclPreserveIMF((ItclMemberFunc *)original); + Itcl_PreserveData((ItclMemberFunc *)original); *copyPtr = original; return TCL_OK; } static int @@ -879,25 +879,25 @@ if (imPtr->codePtr->flags & ITCL_IMPLEMENT_OBJCMD) { /* Implementation of this member is coded in C expecting Tcl_Obj */ imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr, 1, &itclObjMethodType, imPtr); - ItclPreserveIMF(imPtr); + Itcl_PreserveData(imPtr); if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { imPtr->tmPtr = Tcl_NewInstanceMethod(interp, iclsPtr->oPtr, imPtr->namePtr, 1, &itclObjMethodType, imPtr); - ItclPreserveIMF(imPtr); + Itcl_PreserveData(imPtr); } } else if (imPtr->codePtr->flags & ITCL_IMPLEMENT_ARGCMD) { /* Implementation of this member is coded in C expecting (char *) */ imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr, 1, &itclArgMethodType, imPtr); - ItclPreserveIMF(imPtr); + Itcl_PreserveData(imPtr); } else { if (imPtr->codePtr->flags & ITCL_BUILTIN) { @@ -1086,17 +1086,17 @@ } } if ((imPtr->flags & ITCL_COMMON) == 0) { imPtr->accessCmd = Tcl_CreateObjCommand(interp, Tcl_GetString(imPtr->fullNamePtr), - Itcl_ExecMethod, imPtr, ItclReleaseIMF); - ItclPreserveIMF(imPtr); + Itcl_ExecMethod, imPtr, Itcl_ReleaseData); + Itcl_PreserveData(imPtr); } else { imPtr->accessCmd = Tcl_CreateObjCommand(interp, Tcl_GetString(imPtr->fullNamePtr), - Itcl_ExecProc, imPtr, ItclReleaseIMF); - ItclPreserveIMF(imPtr); + Itcl_ExecProc, imPtr, Itcl_ReleaseData); + Itcl_PreserveData(imPtr); } } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { /* initialize the typecomponents and typevariables */ if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr, @@ -2416,11 +2416,11 @@ } Tcl_DeleteHashTable(&infoPtr->objects); Tcl_DeleteHashTable(&infoPtr->frameContext); Itcl_DeleteStack(&infoPtr->clsStack); - ckfree((char*)infoPtr); + Itcl_Free(infoPtr); } /* * ------------------------------------------------------------------------ * Itcl_ClassFilterCmd() @@ -2829,12 +2829,11 @@ init = defaultValue; if ((newObjc > 1) && (init == NULL)) { init = Tcl_GetString(newObjv[1]); } - ioptPtr = (ItclOption*)ckalloc(sizeof(ItclOption)); - memset(ioptPtr, 0, sizeof(ItclOption)); + ioptPtr = (ItclOption*)Itcl_Alloc(sizeof(ItclOption)); ioptPtr->protection = Itcl_Protection(interp, 0); if (ioptPtr->protection == ITCL_DEFAULT_PROTECT) { ioptPtr->protection = ITCL_PROTECTED; } ioptPtr->namePtr = Tcl_NewStringObj(name, -1); @@ -3770,12 +3769,11 @@ "\" has been defined locally", NULL); goto errorOut1; return TCL_ERROR; } } - idoPtr = (ItclDelegatedOption *)ckalloc(sizeof(ItclDelegatedOption)); - memset(idoPtr, 0, sizeof(ItclDelegatedOption)); + idoPtr = (ItclDelegatedOption *)Itcl_Alloc(sizeof(ItclDelegatedOption)); Tcl_InitObjHashTable(&idoPtr->exceptions); if (*option != '*') { if (targetPtr == NULL) { targetPtr = optionNamePtr; } @@ -3822,11 +3820,11 @@ } ckfree((char *)argv); ItclAddDelegatedOptionDictInfo(interp, iclsPtr, idoPtr); return TCL_OK; errorOut2: - /* FIXME need to decr additional refCount's !! */ + Itcl_ReleaseData(idoPtr); errorOut1: Tcl_DecrRefCount(optionNamePtr); if (resourceNamePtr != NULL) { Tcl_DecrRefCount(resourceNamePtr); } Index: generic/itclStubInit.c ================================================================== --- generic/itclStubInit.c +++ generic/itclStubInit.c @@ -233,8 +233,10 @@ Itcl_PreserveData, /* 21 */ Itcl_ReleaseData, /* 22 */ Itcl_SaveInterpState, /* 23 */ Itcl_RestoreInterpState, /* 24 */ Itcl_DiscardInterpState, /* 25 */ + Itcl_Alloc, /* 26 */ + Itcl_Free, /* 27 */ }; /* !END!: Do not edit above this line. */ Index: generic/itclUtil.c ================================================================== --- generic/itclUtil.c +++ generic/itclUtil.c @@ -27,10 +27,11 @@ * ------------------------------------------------------------------------ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "itclInt.h" +#include /* * POOL OF LIST ELEMENTS FOR LINKED LIST */ static Itcl_ListElem *listPool = NULL; @@ -485,14 +486,12 @@ void Itcl_SetListValue( Itcl_ListElem *elemPtr, /* list element being modified */ ClientData val) /* new value associated with element */ { - Itcl_List *listPtr = elemPtr->owner; - assert(listPtr->validate == ITCL_VALID_LIST); assert(elemPtr != NULL); - + assert(elemPtr->owner->validate == ITCL_VALID_LIST); elemPtr->value = val; } /* @@ -524,40 +523,46 @@ * ======================================================================== * REFERENCE-COUNTED DATA * * The following procedures manage generic reference-counted data. * They are similar in spirit to the Tcl_Preserve/Tcl_Release - * procedures defined in the Tcl/Tk core. But these procedures use - * a hash table instead of a linked list to maintain the references, - * so they scale better. Also, the Tcl procedures have a bad behavior - * during the "exit" command. Their exit handler shuts them down - * when other data is still being reference-counted and cleaned up. - * + * procedures defined in the Tcl/Tk core. But these procedures attach a + * refcount directly to the allocated memory, and then use it to govern + * shared access and properly timed release. + */ + +typedef struct PresMemoryPrefix { + Tcl_FreeProc *freeProc; /* called by last Itcl_ReleaseData */ + size_t refCount; /* refernce (resp preserving) counter */ +} PresMemoryPrefix; + +/* * ------------------------------------------------------------------------ * Itcl_EventuallyFree() * - * Registers a piece of data so that it will be freed when no longer - * in use. The data is registered with an initial usage count of "0". - * Future calls to Itcl_PreserveData() increase this usage count, and - * calls to Itcl_ReleaseData() decrease the count until it reaches - * zero and the data is freed. + * Asscociates with cdata (allocated by Itcl_Alloc()) a routine to + * be called when cdata should be freed. This routine will be called + * when the number of Itcl_ReleaseData() calls on cdata matches the + * number of Itcl_PreserveData() calls on cdata. * ------------------------------------------------------------------------ */ void Itcl_EventuallyFree( ClientData cdata, /* data to be freed when not in use */ Tcl_FreeProc *fproc) /* procedure called to free data */ { - /* - * If the clientData value is NULL, do nothing. - */ + PresMemoryPrefix *blk; + if (cdata == NULL) { return; } - Tcl_EventuallyFree(cdata, fproc); - return; + + /* Itcl memory block to ckalloc block */ + blk = ((PresMemoryPrefix *)cdata)-1; + /* Set new free proc */ + blk->freeProc = fproc; } /* * ------------------------------------------------------------------------ * Itcl_PreserveData() @@ -572,19 +577,21 @@ */ void Itcl_PreserveData( ClientData cdata) /* data to be preserved */ { + PresMemoryPrefix *blk; - /* - * If the clientData value is NULL, do nothing. - */ if (cdata == NULL) { return; } - Tcl_Preserve(cdata); - return; + + /* Itcl memory block to ckalloc block */ + blk = ((PresMemoryPrefix *)cdata)-1; + + /* Increment preservation count */ + ++blk->refCount; } /* * ------------------------------------------------------------------------ * Itcl_ReleaseData() @@ -597,19 +604,88 @@ */ void Itcl_ReleaseData( ClientData cdata) /* data to be released */ { + PresMemoryPrefix *blk; + Tcl_FreeProc *freeProc; - /* - * If the clientData value is NULL, do nothing. - */ if (cdata == NULL) { return; } - Tcl_Release(cdata); - return; + + /* Itcl memory block to ckalloc block */ + blk = ((PresMemoryPrefix *)cdata)-1; + + /* Usage sanity check */ + assert(blk->refCount != 0); /* must call Itcl_PreserveData() first */ + assert(blk->freeProc); /* must call Itcl_EventuallyFree() first */ + + /* Decrement preservation count */ + if (--blk->refCount) { + return; + } + + /* Free cdata now */ + freeProc = blk->freeProc; + blk->freeProc = NULL; + freeProc(cdata); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_Alloc() + * + * Allocate preservable memory. In opposite to ckalloc the result can be + * supplied to preservation facilities of Itcl (Itcl_PreserveData). + * + * Results: + * Pointer to new allocated memory. + * ------------------------------------------------------------------------ + */ +void * Itcl_Alloc( + size_t size) /* Size of memory to allocate */ +{ + size_t numBytes; + PresMemoryPrefix *blk; + + /* The ckalloc() in Tcl 8 can alloc at most UINT_MAX bytes */ + assert (size <= UINT_MAX - sizeof(PresMemoryPrefix)); + numBytes = size + sizeof(PresMemoryPrefix); + + /* This will panic on allocation failure. No need to check return value. */ + blk = (PresMemoryPrefix *)ckalloc(numBytes); + + /* Itcl_Alloc defined to zero-init memory it allocates */ + memset(blk, 0, numBytes); + + /* ckalloc block to Itcl memory block */ + return blk+1; +} +/* + * ------------------------------------------------------------------------ + * ItclFree() + * + * Release memory allocated by Itcl_Alloc() that was never preserved. + * + * Results: + * None. + * + * ------------------------------------------------------------------------ + */ +void Itcl_Free(void *ptr) { + PresMemoryPrefix *blk; + + if (ptr == NULL) { + return; + } + /* Itcl memory block to ckalloc block */ + blk = ((PresMemoryPrefix *)ptr)-1; + + assert(blk->refCount == 0); /* it should be not preserved */ + assert(blk->freeProc == NULL); /* it should be released */ + ckfree(blk); } /* * ------------------------------------------------------------------------ * Itcl_SaveInterpState()