diff options
| -rw-r--r-- | generic/tclIOUtil.c | 8 | ||||
| -rw-r--r-- | generic/tclInt.h | 91 | ||||
| -rw-r--r-- | generic/tclObj.c | 114 | ||||
| -rw-r--r-- | generic/tclParse.c | 37 |
4 files changed, 173 insertions, 77 deletions
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 9f9969a..65dca78 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.8 1999/04/21 21:50:26 rjohnson Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.9 1999/11/10 02:51:56 hobbs Exp $ */ #include "tclInt.h" @@ -593,7 +593,7 @@ TclStatInsertProc (proc) if (proc != NULL) { StatProc *newStatProcPtr; - newStatProcPtr = (StatProc *)Tcl_Alloc(sizeof(StatProc));; + newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); if (newStatProcPtr != NULL) { newStatProcPtr->proc = proc; @@ -696,7 +696,7 @@ TclAccessInsertProc(proc) if (proc != NULL) { AccessProc *newAccessProcPtr; - newAccessProcPtr = (AccessProc *)Tcl_Alloc(sizeof(AccessProc));; + newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc)); if (newAccessProcPtr != NULL) { newAccessProcPtr->proc = proc; @@ -801,7 +801,7 @@ TclOpenFileChannelInsertProc(proc) OpenFileChannelProc *newOpenFileChannelProcPtr; newOpenFileChannelProcPtr = - (OpenFileChannelProc *)Tcl_Alloc(sizeof(OpenFileChannelProc));; + (OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc)); if (newOpenFileChannelProcPtr != NULL) { newOpenFileChannelProcPtr->proc = proc; diff --git a/generic/tclInt.h b/generic/tclInt.h index 6cf719b..0be91e1 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.36 1999/10/30 00:27:26 welch Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.37 1999/11/10 02:51:56 hobbs Exp $ */ #ifndef _TCLINT @@ -2025,33 +2025,14 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, * * EXTERN void TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr)); * EXTERN void TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); - * - * There are three variations on these routines for: - * TCL_MEM_DEBUG - * TCL_THREADS - * the normal case *---------------------------------------------------------------- */ -/* - * TclDecrRefCount is the same for all cases. The three cases - * are handled inside TclFreeObj. - */ - -#define TclDecrRefCount(objPtr) \ - if (--(objPtr)->refCount <= 0) { \ - TclFreeObj(objPtr); \ - } - #ifdef TCL_COMPILE_STATS # define TclIncrObjsAllocated() \ - Tcl_MutexLock(&tclCompStatsMutex); \ - tclObjsAlloced++; - Tcl_MutexUnLock(&tclCompStatsMutex) + tclObjsAlloced++ # define TclIncrObjsFreed() \ - Tcl_MutexLock(&tclCompStatsMutex); \ - tclObjsFreed++; \ - Tcl_MutexUnLock(&tclCompStatsMutex) + tclObjsFreed++ #else # define TclIncrObjsAllocated() # define TclIncrObjsFreed() @@ -2059,40 +2040,47 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, #ifdef TCL_MEM_DEBUG # define TclNewObj(objPtr) \ - TclDbNewObj(objPtr, __FILE__, __LINE__) - -# define TclDbNewObj(objPtr, file, line) \ - (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ + (objPtr) = (Tcl_Obj *) \ + Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TclIncrObjsAllocated() -#else /* not TCL_MEM_DEBUG */ - -#ifdef TCL_THREADS - -/* - * The TclAllocateFreeObjects is a source of lock contention, - * so we just don't use it and rely on a good threaded memory allocator. - */ - -# define TclNewObj(objPtr) \ - (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); \ +# define TclDbNewObj(objPtr, file, line) \ + (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TclIncrObjsAllocated() + +# define TclDecrRefCount(objPtr) \ + if (--(objPtr)->refCount <= 0) { \ + if ((objPtr)->refCount < -1) \ + panic("Reference count for %lx was negative: %s line %d", \ + (objPtr), __FILE__, __LINE__); \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ + ckfree((char *) (objPtr)->bytes); \ + } \ + if (((objPtr)->typePtr != NULL) \ + && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ + (objPtr)->typePtr->freeIntRepProc(objPtr); \ + } \ + ckfree((char *) (objPtr)); \ + TclIncrObjsFreed(); \ + } -#else +#else /* not TCL_MEM_DEBUG */ -/* - * Unthreaded case uses a special allocator. - */ +#ifdef TCL_THREADS +extern Tcl_Mutex tclObjMutex; +#endif # define TclNewObj(objPtr) \ + Tcl_MutexLock(&tclObjMutex); \ if (tclFreeObjList == NULL) { \ TclAllocateFreeObjects(); \ } \ @@ -2103,10 +2091,25 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ - TclIncrObjsAllocated() - -#endif /* TCL_THREADS */ + TclIncrObjsAllocated(); \ + Tcl_MutexUnlock(&tclObjMutex) +# define TclDecrRefCount(objPtr) \ + if (--(objPtr)->refCount <= 0) { \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ + ckfree((char *) (objPtr)->bytes); \ + } \ + if (((objPtr)->typePtr != NULL) \ + && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ + (objPtr)->typePtr->freeIntRepProc(objPtr); \ + } \ + Tcl_MutexLock(&tclObjMutex); \ + (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ + tclFreeObjList = (objPtr); \ + TclIncrObjsFreed(); \ + Tcl_MutexUnlock(&tclObjMutex); \ + } #endif /* TCL_MEM_DEBUG */ /* diff --git a/generic/tclObj.c b/generic/tclObj.c index 900a861..e83d70a 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.10 1999/10/30 00:27:26 welch Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.11 1999/11/10 02:51:57 hobbs Exp $ */ #include "tclInt.h" @@ -26,12 +26,20 @@ TCL_DECLARE_MUTEX(tableMutex) /* * Head of the list of free Tcl_Obj structs we maintain. - * This is not used in the threaded case, so no lock is declared. */ Tcl_Obj *tclFreeObjList = NULL; /* + * The object allocator is single threaded. This mutex is referenced + * by the TclNewObj macro, however, so must be visible. + */ + +#ifdef TCL_THREADS +Tcl_Mutex tclObjMutex; +#endif + +/* * Pointer to a heap-allocated string of length zero that the Tcl core uses * as the value of an empty string representation for an object. This value * is shared by all new objects allocated by Tcl_NewObj. @@ -48,7 +56,6 @@ char *tclEmptyStringRep = &emptyString; #ifdef TCL_COMPILE_STATS long tclObjsAlloced = 0; long tclObjsFreed = 0; -TCL_DECLARE_MUTEX(tclCompStatsMutex) #endif /* TCL_COMPILE_STATS */ /* @@ -133,10 +140,10 @@ TclInitObjSubsystem() Tcl_RegisterObjType(&tclProcBodyType); #ifdef TCL_COMPILE_STATS - Tcl_MutexLock(&tclCompStatsMutex); + Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; tclObjsFreed = 0; - Tcl_MutexUnlock(&tclCompStatsMutex); + Tcl_MutexUnlock(&tclObjMutex); #endif } @@ -167,12 +174,9 @@ TclFinalizeCompExecEnv() typeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); -#ifndef TCL_THREADS - /* - * This would a source of lock contention, so we don't use it. - */ + Tcl_MutexLock(&tclObjMutex); tclFreeObjList = NULL; -#endif + Tcl_MutexUnlock(&tclObjMutex); TclFinalizeCompilation(); TclFinalizeExecution(); @@ -385,16 +389,43 @@ Tcl_ConvertToType(interp, objPtr, typePtr) #ifdef TCL_MEM_DEBUG #undef Tcl_NewObj -#endif Tcl_Obj * Tcl_NewObj() { - Tcl_Obj *objPtr; - TclNewObj(objPtr); - return objPtr; + return Tcl_DbNewObj("unknown", 0); } +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewObj() +{ + register Tcl_Obj *objPtr; + + /* + * Allocate the object using the list of free Tcl_Obj structs + * we maintain. + */ + + Tcl_MutexLock(&tclObjMutex); + if (tclFreeObjList == NULL) { + TclAllocateFreeObjects(); + } + objPtr = tclFreeObjList; + tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr; + + objPtr->refCount = 0; + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; + objPtr->typePtr = NULL; +#ifdef TCL_COMPILE_STATS + tclObjsAlloced++; +#endif /* TCL_COMPILE_STATS */ + Tcl_MutexUnlock(&tclObjMutex); + return objPtr; +} +#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -410,7 +441,7 @@ Tcl_NewObj() * number when reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the - * result of calling TclNewObj. + * result of calling Tcl_NewObj. * * Results: * The result is a newly allocated that represents the empty string. @@ -423,6 +454,7 @@ Tcl_NewObj() *---------------------------------------------------------------------- */ +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewObj(file, line) @@ -432,13 +464,38 @@ Tcl_DbNewObj(file, line) * for debugging. */ { register Tcl_Obj *objPtr; -#ifdef TCL_MEM_DEBUG - TclDbNewObj(objPtr, file, line); -#else - TclNewObj(objPtr); -#endif + + /* + * If debugging Tcl's memory usage, allocate the object using ckalloc. + * Otherwise, allocate it using the list of free Tcl_Obj structs we + * maintain. + */ + + objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line); + objPtr->refCount = 0; + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; + objPtr->typePtr = NULL; +#ifdef TCL_COMPILE_STATS + Tcl_MutexLock(&tclObjMutex); + tclObjsAlloced++; + Tcl_MutexUnlock(&tclObjMutex); +#endif /* TCL_COMPILE_STATS */ return objPtr; } + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewObj(file, line) + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return Tcl_NewObj(); +} +#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -448,7 +505,7 @@ Tcl_DbNewObj(file, line) * Procedure to allocate a number of free Tcl_Objs. This is done using * a single ckalloc to reduce the overhead for Tcl_Obj allocation. * - * NOTE: This memory is not freed. + * Assumes mutex is held. * * Results: * None. @@ -531,22 +588,23 @@ TclFreeObj(objPtr) Tcl_InvalidateStringRep(objPtr); /* - * There are three cases, TCL_MEM_DEBUG and TCL_THREADS just use - * ckfree. The normal case uses the special object freelist. + * If debugging Tcl's memory usage, deallocate the object using ckfree. + * Otherwise, deallocate it by adding it onto the list of free + * Tcl_Obj structs we maintain. */ + Tcl_MutexLock(&tclObjMutex); #ifdef TCL_MEM_DEBUG ckfree((char *) objPtr); #else -#ifdef TCL_THREADS - ckfree((char *) objPtr); -#else objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList; tclFreeObjList = objPtr; -#endif /* TCL_THREADS */ #endif /* TCL_MEM_DEBUG */ - TclIncrObjsFreed(); +#ifdef TCL_COMPILE_STATS + tclObjsFreed++; +#endif /* TCL_COMPILE_STATS */ + Tcl_MutexUnlock(&tclObjMutex); } /* diff --git a/generic/tclParse.c b/generic/tclParse.c index 56b0a05..ab50ac4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParse.c,v 1.12 1999/08/12 23:14:42 stanton Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.13 1999/11/10 02:51:57 hobbs Exp $ */ #include "tclInt.h" @@ -1973,9 +1973,44 @@ Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr) src += length; } } else if (src == end) { + int openBrace; + if (interp != NULL) { Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); } + /* + * Search the source string for a possible open + * brace within the context of a comment. Since we + * aren't performing a full Tcl parse, just look for + * an open brace preceeded by a '<whitspace>#' on + * the same line. + */ + openBrace = 0; + while (src > string ) { + switch (*src) { + case '{': + openBrace = 1; + break; + case '\n': + openBrace = 0; + break; + case '#': + if ((openBrace == 1) && (isspace(UCHAR(src[-1])))) { + if (interp != NULL) { + Tcl_AppendResult(interp, + ": possible unbalanced brace in comment", + (char *) NULL); + } + openBrace = -1; + break; + } + break; + } + if (openBrace == -1) { + break; + } + src--; + } parsePtr->errorType = TCL_PARSE_MISSING_BRACE; parsePtr->term = string; parsePtr->incomplete = 1; |