diff options
author | jan.nijtmans <nijtmans@users.sourceforge.net> | 2016-04-07 09:37:21 (GMT) |
---|---|---|
committer | jan.nijtmans <nijtmans@users.sourceforge.net> | 2016-04-07 09:37:21 (GMT) |
commit | 2a2831d5de6f771f83a4ea641bcbd2916baa77a0 (patch) | |
tree | eee041139861eb7252c3e4d9ec5ee3243644b31f /generic | |
parent | 7bb07e3c726ce35eb760c2e102e78837b4158548 (diff) | |
download | tcl-2a2831d5de6f771f83a4ea641bcbd2916baa77a0.zip tcl-2a2831d5de6f771f83a4ea641bcbd2916baa77a0.tar.gz tcl-2a2831d5de6f771f83a4ea641bcbd2916baa77a0.tar.bz2 |
Selected harmless androwish changes, mostly backports from trunk (although the androwish branch is based on core-8-6-branch)
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tclExecute.c | 27 | ||||
-rw-r--r-- | generic/tclProc.c | 118 | ||||
-rw-r--r-- | generic/tclStringObj.c | 87 | ||||
-rw-r--r-- | generic/tclUtf.c | 22 | ||||
-rw-r--r-- | generic/tclVar.c | 72 |
5 files changed, 111 insertions, 215 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d4077f5..823f619 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -35,14 +35,14 @@ #endif /* - * A mask (should be 2**n-1) that is used to work out when the bytecode engine - * should call Tcl_AsyncReady() to see whether there is a signal that needs - * handling. + * A counter that is used to work out when the bytecode engine should call + * Tcl_AsyncReady() to see whether there is a signal that needs handling, and + * other expensive periodic operations. */ -#ifndef ASYNC_CHECK_COUNT_MASK -# define ASYNC_CHECK_COUNT_MASK 63 -#endif /* !ASYNC_CHECK_COUNT_MASK */ +#ifndef ASYNC_CHECK_COUNT +# define ASYNC_CHECK_COUNT 64 +#endif /* !ASYNC_CHECK_COUNT */ /* * Boolean flag indicating whether the Tcl bytecode interpreter has been @@ -2115,8 +2115,14 @@ TEBCresume( * sporadically: no special need for speed. */ - int instructionCount = 0; /* Counter that is used to work out when to - * call Tcl_AsyncReady() */ + unsigned interruptCounter = 1; + /* Counter that is used to work out when to + * call Tcl_AsyncReady(). This must be 1 + * initially so that we call the async-check + * stanza early, otherwise there are command + * sequences that can make the interpreter + * busy-loop without an opportunity to + * recognise an interrupt. */ const char *curInstName; #ifdef TCL_COMPILE_DEBUG int traceInstructions; /* Whether we are doing instruction-level @@ -2314,10 +2320,11 @@ TEBCresume( /* * Check for asynchronous handlers [Bug 746722]; we do the check every - * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). + * ASYNC_CHECK_COUNT instructions. */ - if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { + if ((--interruptCounter) == 0) { + interruptCounter = ASYNC_CHECK_COUNT; DECACHE_STACK_INFO(); if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); diff --git a/generic/tclProc.c b/generic/tclProc.c index 9770d26..ac65bde 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -808,68 +808,94 @@ TclObjGetFrame( register Interp *iPtr = (Interp *) interp; int curLevel, level, result; CallFrame *framePtr; - const char *name = NULL; + const char *name; /* * Parse object to figure out which level number to go to. */ - result = 0; + result = 1; curLevel = iPtr->varFramePtr->level; + if (objPtr == NULL) { + name = "1"; + goto haveLevel1; + } - /* - * Check for integer first, since that has potential to spare us - * a generation of a stringrep. - */ + name = TclGetString(objPtr); + if (objPtr->typePtr == &levelReferenceType) { + if (objPtr->internalRep.twoPtrValue.ptr1) { + level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); + } else { + level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); + } + if (level < 0) { + goto levelError; + } + /* TODO: Consider skipping the typePtr checks */ + } else if (objPtr->typePtr == &tclIntType +#ifndef TCL_WIDE_INT_IS_LONG + || objPtr->typePtr == &tclWideIntType +#endif + ) { + if (TclGetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { + goto levelError; + } + level = curLevel - level; + } else if (*name == '#') { + if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { + goto levelError; + } - if (objPtr == NULL) { - /* Do nothing */ - } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level) - && (level >= 0)) { + /* + * Cache for future reference. + */ + + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0; + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); + } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ + if (Tcl_GetInt(interp, name, &level) != TCL_OK) { + return -1; + } + + /* + * Cache for future reference. + */ + + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1; + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); level = curLevel - level; - result = 1; - } else if (objPtr->typePtr == &levelReferenceType) { - level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr1); - result = 1; } else { - name = TclGetString(objPtr); - if (name[0] == '#') { - if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(level); - result = 1; - } else { - result = -1; - } - } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */ - /* - * If this were an integer, we'd have succeeded already. - * Docs say we have to treat this as a 'bad level' error. - */ - result = -1; - } - } + /* + * Don't cache as the object *isn't* a level reference (might even be + * NULL...) + */ - if (result == 0) { + haveLevel1: level = curLevel - 1; - name = "1"; + result = 0; } - if (result != -1) { - if (level >= 0) { - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - *framePtrPtr = framePtr; - return result; - } - } - } - if (name == NULL) { - name = TclGetString(objPtr); + + /* + * Figure out which frame to use, and return it to the caller. + */ + + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; } } + if (framePtr == NULL) { + goto levelError; + } + *framePtrPtr = framePtr; + return result; + levelError: Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 11a57e9..b480735 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -39,15 +39,6 @@ #include "tclStringRep.h" /* - * Set COMPAT to 1 to restore the shimmering patterns to those of Tcl 8.5. - * This is an escape hatch in case the changes have some unexpected unwelcome - * impact on performance. If things go well, this mechanism can go away when - * post-8.6 development begins. - */ - -#define COMPAT 0 - -/* * Prototypes for functions defined later in this file: */ @@ -445,18 +436,6 @@ Tcl_GetCharLength( if (numChars == -1) { TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; - -#if COMPAT - if (numChars < objPtr->length) { - /* - * Since we've just computed the number of chars, and not all UTF - * chars are 1-byte long, go ahead and populate the unicode - * string. - */ - - FillUnicodeRep(objPtr); - } -#endif } return numChars; } @@ -1173,11 +1152,7 @@ Tcl_AppendUnicodeToObj( * objPtr's string rep. */ - if (stringPtr->hasUnicode -#if COMPAT - && stringPtr->numChars > 0 -#endif - ) { + if (stringPtr->hasUnicode) { AppendUnicodeToUnicodeRep(objPtr, unicode, length); } else { AppendUnicodeToUtfRep(objPtr, unicode, length); @@ -1281,11 +1256,7 @@ Tcl_AppendObjToObj( * appendObjPtr and append it. */ - if (stringPtr->hasUnicode -#if COMPAT - && stringPtr->numChars > 0 -#endif - ) { + if (stringPtr->hasUnicode) { /* * If appendObjPtr is not of the "String" type, don't convert it. */ @@ -1318,11 +1289,7 @@ Tcl_AppendObjToObj( AppendUtfToUtfRep(objPtr, bytes, length); - if (numChars >= 0 && appendNumChars >= 0 -#if COMPAT - && appendNumChars == length -#endif - ) { + if (numChars >= 0 && appendNumChars >= 0) { stringPtr->numChars = numChars + appendNumChars; } } @@ -1446,14 +1413,6 @@ AppendUnicodeToUtfRep( if (stringPtr->numChars != -1) { stringPtr->numChars += numChars; } - -#if COMPAT - /* - * Invalidate the unicode rep. - */ - - stringPtr->hasUnicode = 0; -#endif } /* @@ -2871,7 +2830,6 @@ DupStringInternalRep( String *srcStringPtr = GET_STRING(srcPtr); String *copyStringPtr = NULL; -#if COMPAT==0 if (srcStringPtr->numChars == -1) { /* * The String struct in the source value holds zero useful data. Don't @@ -2914,41 +2872,6 @@ DupStringInternalRep( */ copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0; -#else /* COMPAT!=0 */ - /* - * If the src obj is a string of 1-byte Utf chars, then copy the string - * rep of the source object and create an "empty" Unicode internal rep for - * the new object. Otherwise, copy Unicode internal rep, and invalidate - * the string rep of the new object. - */ - - if (srcStringPtr->hasUnicode && srcStringPtr->numChars > 0) { - /* - * Copy the full allocation for the Unicode buffer. - */ - - copyStringPtr = stringAlloc(srcStringPtr->maxChars); - copyStringPtr->maxChars = srcStringPtr->maxChars; - memcpy(copyStringPtr->unicode, srcStringPtr->unicode, - srcStringPtr->numChars * sizeof(Tcl_UniChar)); - copyStringPtr->unicode[srcStringPtr->numChars] = 0; - copyStringPtr->allocated = 0; - } else { - copyStringPtr = stringAlloc(0); - copyStringPtr->unicode[0] = 0; - copyStringPtr->maxChars = 0; - - /* - * Tricky point: the string value was copied by generic object - * management code, so it doesn't contain any extra bytes that might - * exist in the source object. - */ - - copyStringPtr->allocated = copyPtr->length; - } - copyStringPtr->numChars = srcStringPtr->numChars; - copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; -#endif /* COMPAT==0 */ SET_STRING(copyPtr, copyStringPtr); copyPtr->typePtr = &tclStringType; @@ -3044,7 +2967,7 @@ ExtendStringRepWithUnicode( */ int i, origLength, size = 0; - char *dst, buf[TCL_UTF_MAX]; + char *dst; String *stringPtr = GET_STRING(objPtr); if (numChars < 0) { @@ -3070,7 +2993,7 @@ ExtendStringRepWithUnicode( } for (i = 0; i < numChars && size >= 0; i++) { - size += Tcl_UniCharToUtf((int) unicode[i], buf); + size += TclUtfCount(unicode[i]); } if (size < 0) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); diff --git a/generic/tclUtf.c b/generic/tclUtf.c index b878149..6c4cb7f 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -84,17 +84,11 @@ static const unsigned char totalBytes[256] = { 1,1,1,1 #endif }; - -/* - * Functions used only in this module. - */ - -static int UtfCount(int ch); /* *--------------------------------------------------------------------------- * - * UtfCount -- + * TclUtfCount -- * * Find the number of bytes in the Utf character "ch". * @@ -107,8 +101,8 @@ static int UtfCount(int ch); *--------------------------------------------------------------------------- */ -INLINE static int -UtfCount( +int +TclUtfCount( int ch) /* The Tcl_UniChar whose size is returned. */ { if ((ch > 0) && (ch < UNICODE_SELF)) { @@ -143,7 +137,7 @@ UtfCount( *--------------------------------------------------------------------------- */ -INLINE int +int Tcl_UniCharToUtf( int ch, /* The Tcl_UniChar to be stored in the * buffer. */ @@ -829,7 +823,7 @@ Tcl_UtfToUpper( * char to dst if its size is <= the original char. */ - if (bytes < UtfCount(upChar)) { + if (bytes < TclUtfCount(upChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -882,7 +876,7 @@ Tcl_UtfToLower( * char to dst if its size is <= the original char. */ - if (bytes < UtfCount(lowChar)) { + if (bytes < TclUtfCount(lowChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -932,7 +926,7 @@ Tcl_UtfToTitle( bytes = TclUtfToUniChar(src, &ch); titleChar = Tcl_UniCharToTitle(ch); - if (bytes < UtfCount(titleChar)) { + if (bytes < TclUtfCount(titleChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -944,7 +938,7 @@ Tcl_UtfToTitle( bytes = TclUtfToUniChar(src, &ch); lowChar = Tcl_UniCharToLower(ch); - if (bytes < UtfCount(lowChar)) { + if (bytes < TclUtfCount(lowChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { diff --git a/generic/tclVar.c b/generic/tclVar.c index 5574f30..be035f7 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -206,7 +206,6 @@ static Tcl_UpdateStringProc PanicOnUpdateVarName; static Tcl_FreeInternalRepProc FreeParsedVarName; static Tcl_DupInternalRepProc DupParsedVarName; -static Tcl_UpdateStringProc UpdateParsedVarName; static Tcl_UpdateStringProc PanicOnUpdateVarName; static Tcl_SetFromAnyProc PanicOnSetVarName; @@ -237,7 +236,7 @@ static const Tcl_ObjType localVarNameType = { static const Tcl_ObjType tclParsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName + FreeParsedVarName, DupParsedVarName, PanicOnUpdateVarName, PanicOnSetVarName }; /* @@ -536,7 +535,6 @@ TclObjLookupVarEx( const char *errMsg = NULL; CallFrame *varFramePtr = iPtr->varFramePtr; const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL; - char *newPart2 = NULL; *arrayPtrPtr = NULL; if (typePtr == &localVarNameType) { @@ -583,9 +581,7 @@ TclObjLookupVarEx( } return NULL; } - part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; - if (newPart2) { - part2Ptr = Tcl_NewStringObj(newPart2, -1); + if ((part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2)) { if (createPart2) { Tcl_IncrRefCount(part2Ptr); } @@ -629,11 +625,7 @@ TclObjLookupVarEx( len2 = len1 - i - 2; len1 = i; - newPart2 = ckalloc(len2 + 1); - memcpy(newPart2, part2, (unsigned) len2); - *(newPart2+len2) = '\0'; - part2 = newPart2; - part2Ptr = Tcl_NewStringObj(newPart2, -1); + part2Ptr = Tcl_NewStringObj(part2, len2); if (createPart2) { Tcl_IncrRefCount(part2Ptr); } @@ -658,7 +650,8 @@ TclObjLookupVarEx( Tcl_IncrRefCount(part1Ptr); objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr; - objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2; + Tcl_IncrRefCount(part2Ptr); + objPtr->internalRep.twoPtrValue.ptr2 = part2Ptr; typePtr = part1Ptr->typePtr; part1 = TclGetString(part1Ptr); @@ -683,9 +676,6 @@ TclObjLookupVarEx( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(part1Ptr), NULL); } - if (newPart2) { - Tcl_DecrRefCount(part2Ptr); - } return NULL; } @@ -734,9 +724,6 @@ TclObjLookupVarEx( *arrayPtrPtr = varPtr; varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg, createPart1, createPart2, varPtr, -1); - if (newPart2) { - Tcl_DecrRefCount(part2Ptr); - } } return varPtr; } @@ -5592,11 +5579,11 @@ FreeParsedVarName( Tcl_Obj *objPtr) { register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - register char *elem = objPtr->internalRep.twoPtrValue.ptr2; + register Tcl_Obj *elem = objPtr->internalRep.twoPtrValue.ptr2; if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); - ckfree(elem); + TclDecrRefCount(elem); } objPtr->typePtr = NULL; } @@ -5607,58 +5594,17 @@ DupParsedVarName( Tcl_Obj *dupPtr) { register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; - register char *elem = srcPtr->internalRep.twoPtrValue.ptr2; - char *elemCopy; - unsigned elemLen; + register Tcl_Obj *elem = srcPtr->internalRep.twoPtrValue.ptr2; if (arrayPtr != NULL) { Tcl_IncrRefCount(arrayPtr); - elemLen = strlen(elem); - elemCopy = ckalloc(elemLen + 1); - memcpy(elemCopy, elem, elemLen); - *(elemCopy + elemLen) = '\0'; - elem = elemCopy; + Tcl_IncrRefCount(elem); } dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr; dupPtr->internalRep.twoPtrValue.ptr2 = elem; dupPtr->typePtr = &tclParsedVarNameType; } - -static void -UpdateParsedVarName( - Tcl_Obj *objPtr) -{ - Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - char *part2 = objPtr->internalRep.twoPtrValue.ptr2; - const char *part1; - char *p; - int len1, len2, totalLen; - - if (arrayPtr == NULL) { - /* - * This is a parsed scalar name: what is it doing here? - */ - - Tcl_Panic("scalar parsedVarName without a string rep"); - } - - part1 = TclGetStringFromObj(arrayPtr, &len1); - len2 = strlen(part2); - - totalLen = len1 + len2 + 2; - p = ckalloc(totalLen + 1); - objPtr->bytes = p; - objPtr->length = totalLen; - - memcpy(p, part1, (unsigned) len1); - p += len1; - *p++ = '('; - memcpy(p, part2, (unsigned) len2); - p += len2; - *p++ = ')'; - *p = '\0'; -} /* *---------------------------------------------------------------------- |